Wolfram Cloud Document

NeighborsPictureSL[g_,init_]:=Module[{connectedNodes,selfLoopNodeQ,toLines,toCircles,toSelfLoopCircles,nodePosition,g1,allNodes,graphicsBag,activeNodes,xCoord,usedNodes,nextNodes,nextNodes1},selfLoopNodeQ[n_]:=MemberQ[g,n->_List?(Count[#,n]===2&)];connectedNodes[l_]:=First/@Cases[ap=Apply[{{##},MemberQ[#1/.g,#2]&&MemberQ[#2/.g,#1]}&,so=(Sort/@Flatten[Table[{l[[i]],l[[j]]},{i,Length[l]},{j,i+1,Length[l]}],1]),{1}],{_,True}];toLines[{startNode_,endNodes_}]:=Line[{nodePosition[startNode],nodePosition[#]}]&/@endNodes;toSelfLoopCircles[node_]:=With[{mp=nodePosition[node]},{Circle[mp+{0,1/8},{1/4,1/8},{-Pi/2,Pi/2}],Circle[mp+{0,0},{1/4,1/4},{Pi/2,3Pi/2}],Circle[mp+{0,-1/8},{1/4,1/8},{-Pi/2,Pi/2}]}];toCircles[{node1_,node2_}]:=With[{mp1=nodePosition[node1],mp2=nodePosition[node2]},Circle[(mp1+mp2)/2,{1/2,Abs[mp1[[2]]-mp2[[2]]]/2},{-Pi/2,Pi/2}]];g1=Flatten/@Apply[List,g,{1}];allNodes=First/@g;graphicsBag={};activeNodes={allNodes[[init[[1]]]]};nodePosition[init[[1]]]={0,0};xCoord=1;usedNodes=activeNodes;If[selfLoopNodeQ[init[[1]]],AppendTo[graphicsBag,toSelfLoopCircles[init[[1]]]]];While[Union[(nextNodes=DeleteCases[activeNodes/.g,Alternatives@@usedNodes,{2}])]=!={{}},(*useeverynewnodeonlyonce*)nextNodes1=Delete[nextNodes,Last/@Select[Position[nextNodes,#]&/@Sort[Flatten[nextNodes]],{_,_}]];(*positionsofthenewnodes*)Apply[(nodePosition[#1]={xCoord,#2})&,First@Fold[{Append[#[[1]],Take[#[[2]],#2]],Drop[#[[2]],#2]}&,{{},MapIndexed[{#,#2[[1]]-1}&,Flatten[nextNodes1]]},Length/@nextNodes1],{-2}];(*thenewnodeconnections*)AppendTo[graphicsBag,{toLines/@Transpose[{activeNodes,nextNodes1}],toCircles/@connectedNodes[Flatten[nextNodes1]],toSelfLoopCircles/@Select[Flatten[nextNodes1],selfLoopNodeQ]}];usedNodes=Join[usedNodes,Flatten[nextNodes1]];activeNodes=Flatten[nextNodes1];xCoord=xCoord+1];Graphics[{graphicsBag,Text[FontForm[ToString[#],{"Courier-Bold",14}],nodePosition[#]-{1/8,0}]&/@allNodes}]]

RandomNetwork[20]

{1{11,12,15},2{12,16,20},3{8,11,18},4{6,7,12},5{7,13,18},6{4,15,19},7{4,5,19},8{3,14,20},9{14,17,18},10{16,17,20},11{1,3,14},12{1,2,4},13{5,13,13},14{8,9,11},15{1,6,17},16{2,10,19},17{9,10,15},18{3,5,9},19{6,7,16},20{2,8,10}}

Show[NeighborsPictureSL[%164,{1}]]

⁃Graphics⁃

NeighborLists[%164]

{{1},{11,12,15},{1,2,3,4,6,14,17},{4,6,7,8,9,10,11,12,15,16,18,19,20},{1,2,3,4,5,6,7,8,9,10,12,14,15,16,17,18,19,20},{1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20},{1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20}}

Last[%]

{1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20}

Length[%]

20

ConnectedPart[%164]

{1{11,12,15},2{12,16,20},3{8,11,18},4{6,7,12},5{7,13,18},6{4,15,19},7{4,5,19},8{3,14,20},9{14,17,18},10{16,17,20},11{1,3,14},12{1,2,4},13{5,13,13},14{8,9,11},15{1,6,17},16{2,10,19},17{9,10,15},18{3,5,9},19{6,7,16},20{2,8,10}}

RandomNetwork[50]

{1{20,36,40},2{39,46,49},3{26,27,45},4{6,8,9},5{10,27,35},6{4,32,42},7{25,29,42},8{4,12,13},9{4,10,48},10{5,9,23},11{18,24,43},12{8,19,41},13{8,25,49},14{15,24,38},15{14,44,44},16{28,48,50},17{28,38,41},18{11,41,45},19{12,31,39},20{1,33,43},21{36,37,50},22{32,36,39},23{10,29,46},24{11,14,30},25{7,13,30},26{3,27,35},27{3,5,26},28{16,17,47},29{7,23,47},30{24,25,33},31{19,35,49},32{6,22,37},33{20,30,45},34{38,42,48},35{5,26,31},36{1,21,22},37{21,32,40},38{14,17,34},39{2,19,22},40{1,37,44},41{12,17,18},42{6,7,34},43{11,20,46},44{15,15,40},45{3,18,33},46{2,23,43},47{28,29,50},48{9,16,34},49{2,13,31},50{16,21,47}}

Show[NeighborsPictureR[%175]];

Show[NeighborsPictureSL[%175,{1}]];

ConnectedPart[%175]

{1{20,36,40},2{39,46,49},3{26,27,45},4{6,8,9},5{10,27,35},6{4,32,42},7{25,29,42},8{4,12,13},9{4,10,48},10{5,9,23},11{18,24,43},12{8,19,41},13{8,25,49},14{15,24,38},15{14,44,44},16{28,48,50},17{28,38,41},18{11,41,45},19{12,31,39},20{1,33,43},21{36,37,50},22{32,36,39},23{10,29,46},24{11,14,30},25{7,13,30},26{3,27,35},27{3,5,26},28{16,17,47},29{7,23,47},30{24,25,33},31{19,35,49},32{6,22,37},33{20,30,45},34{38,42,48},35{5,26,31},36{1,21,22},37{21,32,40},38{14,17,34},39{2,19,22},40{1,37,44},41{12,17,18},42{6,7,34},43{11,20,46},44{15,15,40},45{3,18,33},46{2,23,43},47{28,29,50},48{9,16,34},49{2,13,31},50{16,21,47}}

Show[CirclePicture[%175]];