(*********************************************************************** This file was generated automatically by the Mathematica front end. It contains Initialization cells from a Notebook file, which typically will have the same name as this file except ending in ".nb" instead of ".m". This file is intended to be loaded into the Mathematica kernel using the package loading commands Get or Needs. Doing so is equivalent to using the Evaluate Initialization Cells menu command in the front end. DO NOT EDIT THIS FILE. This entire file is regenerated automatically each time the parent Notebook file is saved in the Mathematica front end. Any changes you make to this file will be overwritten. ***********************************************************************) tetra={1\[Rule]{2,3,4},2\[Rule]{1,3,4},3\[Rule]{1,2,4},4\[Rule]{1,2,3}}; asym={1\[Rule]{2,8,7},2\[Rule]{3,11,1},3\[Rule]{2,11,4},4\[Rule]{3,12,5}, 5\[Rule]{4,12,6},6\[Rule]{5,9,7},7\[Rule]{6,8,1},8\[Rule]{1,7,9}, 9\[Rule]{6,8,10},10\[Rule]{9,11,12},11\[Rule]{2,3,10}, 12\[Rule]{4,5,10}}; dumbbell={1\[Rule]{1,1,2},2\[Rule]{1,2,2}}; tribar={1\[Rule]{2,2,2},2\[Rule]{1,1,1}}; tribell={1\[Rule]{3,3,4},2\[Rule]{2,2,3},3\[Rule]{1,1,2},4\[Rule]{1,4,4}}; loops3={1\[Rule]{2,3,4},2\[Rule]{1,2,2},3\[Rule]{1,3,3},4\[Rule]{1,4,4}}; tetra={1\[Rule]{2,3,4},2\[Rule]{1,3,4},3\[Rule]{1,2,4},4\[Rule]{1,2,3}}; square={1\[Rule]{2,2,3},2\[Rule]{1,1,4},3\[Rule]{1,4,4},4\[Rule]{2,3,3}}; cowbell={1\[Rule]{1,1,4},2\[Rule]{3,3,4},3\[Rule]{2,2,4},4\[Rule]{1,2,3}}; prism={1\[Rule]{2,3,6},2\[Rule]{1,4,6},3\[Rule]{1,4,5},4\[Rule]{2,3,5}, 5\[Rule]{3,4,6},6\[Rule]{1,2,5}}; k33={1\[Rule]{4,5,6},2\[Rule]{4,5,6},3\[Rule]{4,5,6},4\[Rule]{1,2,3}, 5\[Rule]{1,2,3},6\[Rule]{1,2,3}}; treecell={1\[Rule]{20,21,22},2\[Rule]{3,13,16},3\[Rule]{2,4,16}, 4\[Rule]{3,5,15},5\[Rule]{4,6,15},6\[Rule]{5,7,14},7\[Rule]{6,8,14}, 8\[Rule]{7,9,19},9\[Rule]{8,10,19},10\[Rule]{9,11,18}, 11\[Rule]{10,12,18},12\[Rule]{11,13,17},13\[Rule]{2,12,17}, 14\[Rule]{6,7,20},15\[Rule]{4,5,20},16\[Rule]{2,3,21}, 17\[Rule]{12,13,21},18\[Rule]{10,11,22},19\[Rule]{8,9,22}, 20\[Rule]{1,14,15},21\[Rule]{1,16,17},22\[Rule]{1,18,19}}; dodec1={1\[Rule]{2,5,10},2\[Rule]{1,3,9},3\[Rule]{2,4,8},4\[Rule]{3,5,6}, 5\[Rule]{1,4,7},6\[Rule]{4,16,20},7\[Rule]{5,16,17},8\[Rule]{3,19,20}, 9\[Rule]{2,18,19},10\[Rule]{1,17,18},11\[Rule]{12,15,16}, 12\[Rule]{11,13,17},13\[Rule]{12,14,18},14\[Rule]{13,15,19}, 15\[Rule]{11,14,20},16\[Rule]{6,7,11},17\[Rule]{7,10,12}, 18\[Rule]{9,10,13},19\[Rule]{8,9,14},20\[Rule]{6,8,15}}; asym12a={1\[Rule]{2,5,11},2\[Rule]{1,3,11},3\[Rule]{2,4,10},4\[Rule]{3,7,10}, 5\[Rule]{1,6,9},6\[Rule]{5,7,12},7\[Rule]{4,6,12},8\[Rule]{9,10,11}, 9\[Rule]{5,8,12},10\[Rule]{3,4,8},11\[Rule]{1,2,8},12\[Rule]{6,7,9}}; asym12b={1\[Rule]{5,7,8},2\[Rule]{3,10,11},3\[Rule]{2,4,12},4\[Rule]{3,5,6}, 5\[Rule]{1,4,9},6\[Rule]{4,7,12},7\[Rule]{1,6,8},8\[Rule]{1,7,9}, 9\[Rule]{5,8,10},10\[Rule]{2,9,11},11\[Rule]{2,10,12}, 12\[Rule]{3,6,11}}; cube={1\[Rule]{2,4,8},2\[Rule]{1,3,5},3\[Rule]{2,4,6},4\[Rule]{1,3,7}, 5\[Rule]{2,6,8},6\[Rule]{3,5,7},7\[Rule]{4,6,8},8\[Rule]{1,5,7}}; pete1={1\[Rule]{4,7,10},2\[Rule]{3,6,10},3\[Rule]{2,4,8},4\[Rule]{1,3,5}, 5\[Rule]{4,6,9},6\[Rule]{2,5,7},7\[Rule]{1,6,8},8\[Rule]{3,7,9}, 9\[Rule]{5,8,10},10\[Rule]{1,2,9}}; pete2={1\[Rule]{2,3,8},2\[Rule]{1,5,9},3\[Rule]{1,4,10},4\[Rule]{3,5,7}, 5\[Rule]{2,4,6},6\[Rule]{5,8,10},7\[Rule]{4,8,9},8\[Rule]{1,6,7}, 9\[Rule]{2,7,10},10\[Rule]{3,6,9}}; pete3={1\[Rule]{2,5,8},2\[Rule]{1,3,9},3\[Rule]{2,4,7},4\[Rule]{3,5,10}, 5\[Rule]{1,4,6},6\[Rule]{5,7,9},7\[Rule]{3,6,8},8\[Rule]{1,7,10}, 9\[Rule]{2,6,10},10\[Rule]{4,8,9}}; pete4={1\[Rule]{4,6,9},2\[Rule]{5,7,9},3\[Rule]{4,5,10},4\[Rule]{1,3,7}, 5\[Rule]{2,3,6},6\[Rule]{1,5,8},7\[Rule]{2,4,8},8\[Rule]{6,7,10}, 9\[Rule]{1,2,10},10\[Rule]{3,8,9}}; pete5={1\[Rule]{4,6,10},2\[Rule]{5,7,10},3\[Rule]{4,5,9},4\[Rule]{1,3,7}, 5\[Rule]{2,3,6},6\[Rule]{1,5,8},7\[Rule]{2,4,8},8\[Rule]{6,7,9}, 9\[Rule]{3,8,10},10\[Rule]{1,2,9}}; pete6={1\[Rule]{2,4,10},2\[Rule]{1,3,6},3\[Rule]{2,5,8},4\[Rule]{1,5,9}, 5\[Rule]{3,4,7},6\[Rule]{2,7,9},7\[Rule]{5,6,10},8\[Rule]{3,9,10}, 9\[Rule]{4,6,8},10\[Rule]{1,7,8}}; pete7={1\[Rule]{8,9,10},2\[Rule]{3,5,9},3\[Rule]{2,4,8},4\[Rule]{3,6,10}, 5\[Rule]{2,7,10},6\[Rule]{4,7,9},7\[Rule]{5,6,8},8\[Rule]{1,3,7}, 9\[Rule]{1,2,6},10\[Rule]{1,4,5}}; pete8={1\[Rule]{2,4,5},2\[Rule]{1,3,7},3\[Rule]{2,9,10},4\[Rule]{1,8,10}, 5\[Rule]{1,6,9},6\[Rule]{5,7,10},7\[Rule]{2,6,8},8\[Rule]{4,7,9}, 9\[Rule]{3,5,8},10\[Rule]{3,4,6}}; pete9={1\[Rule]{4,8,10},2\[Rule]{3,6,10},3\[Rule]{2,4,7},4\[Rule]{1,3,5}, 5\[Rule]{4,6,9},6\[Rule]{2,5,8},7\[Rule]{3,8,9},8\[Rule]{1,6,7}, 9\[Rule]{5,7,10},10\[Rule]{1,2,9}}; NetworkToList[g_]:= Module[{nodes},nodes=First/@g; Map[Position[nodes,#][[1,1]]&,Apply[List,Last[#]]&/@Apply[List,g],{2}]] NodesToEdges[g_]:= Flatten[Partition[Sort[Sort/@(Flatten[Thread/@g]/.Rule->List)],1,2],1] EdgesToNodes[g_]:= #[[1,1]]->#[[2]]&/@Transpose/@Partition[Sort[Join[g,Reverse/@g]],3] AllNodes[g_]:=First/@g NetworkToMatrix[g_]:= ReplacePart[Table[0,{Length[g]},{Length[g]}],1, Join[NodesToEdges[g],Reverse/@NodesToEdges[g]]] ReverseEngineer[g_]:= Module[{gp,nn}, gp=Union[Sort/@ Flatten[Cases[g,Line[x_]:>Partition[x,2,1],\[Infinity]],1]]; nn=Union[Flatten[gp,1]]; EdgesToNodes[Map[First[Flatten[Position[nn,#]]]&,gp,{2}]]] ReverseEngineerNodes[g_]:= Module[{gp}, gp=Union[Sort/@ Flatten[Cases[g,Line[x_]:>Partition[x,2,1],\[Infinity]],1]]; Union[Flatten[gp,1]]] AddRim2D[g_]:= Graphics[Line/@ Module[{gp,nnf,nnc,mid,ang}, gp=Union[ Sort/@Flatten[Cases[g,Line[x_]:>Partition[x,2,1],\[Infinity]],1], SameTest->Equal];nnf=Flatten[gp,1];nn=Union[nnf,SameTest->Equal]; nnc=Select[nn,(Count[nnf,#]<3) &];mid=Apply[Plus,nnc]/Length[nnc]; ang=Apply[ArcTan,(#-mid)&/@nnc,{1}]; nnc=Last/@Sort[Transpose[{ang,nnc}]];nnc=Append[nnc,First[nnc]]; gp=Join[gp,Partition[nnc,2,1]]],AspectRatio->Automatic] RimNodes2D[g_]:= Module[{gp,nnf,nnc,mid,ang}, gp=Union[Sort/@Flatten[Cases[g,Line[x_]:>Partition[x,2,1],\[Infinity]],1], SameTest->Equal];nnf=Flatten[gp,1];nn=Union[nnf,SameTest->Equal]; Flatten[Position[nn,x_/;(Count[nnf,x]<3),1,Heads->False]]] RandomlyPermute[l_List] := Fold[Insert[#1, #2, Random[Integer, Length[#1]]+1]&,{},l] RandomNetwork[(n_?EvenQ)?Positive] := EdgesToNodes[Partition[RandomlyPermute[Floor[Range[1,n+2/3,1/3]]], 2]] ConnectedPart[g_,i_:1]:=g[[FixedPoint[Union[Flatten[#/.g]]&,{i}]]] OneD[n_]:=Map[(#+1)&, Table[i\[Rule]{Mod[i+2,n],Mod[i-2,n],Mod[If[EvenQ[i],i+1,i-1],n]}, {i,0,n-1}],{-1}] TwoD[n_]:=TwoD[{n,n}] TwoD[{n_,m_}]:= Map[(#+1)&, Flatten[Table[ {i,j}\[Rule]{{i,Mod[j+1,n]},{i,Mod[j-1,n]}, {Mod[If[EvenQ[i+j],i+1,i-1],m],j}},{i,0, m-1},{j,0,n-1}]/. {i_,j_}\[Rule]i+m j],{-1}] ThreeD[n_]:=ThreeD[{n,n,n}] ThreeD[{xm_,ym_,zm_}]:= Map[(#+1)&, Flatten[Table[ {x,y,z}\[Rule]{{x,y,Mod[z+1,zm]},{x,y,Mod[z-1,zm]}, If[EvenQ[z],{Mod[If[EvenQ[z/2+x+y],x+1,x-1],xm],y,z}, {x,Mod[If[EvenQ[Floor[z/2+x+y]],y+1,y-1],ym],z}]}, {x,0,xm-1},{y,0,ym-1},{z,0,zm-1}]]/. {x_Integer,y_Integer,z_Integer}->x+xm(y+ym z),{-1}]/; (IntegerQ[zm/4]&&IntegerQ[ym/2]&&IntegerQ[xm/2]) icoverts=With[{signs=2 Table[IntegerDigits[i,2,3],{i,8}]-1}, Union[Flatten[ Function[perm,(perm #1&)/@signs]/@ NestList[RotateRight,{0,1,GoldenRatio},2],1]]]; \!\(norm[vec_] := \@\(vec . vec\)\) icoedges=Flatten[ Table[If[norm[ icoverts\[LeftDoubleBracket]i\[RightDoubleBracket]- icoverts\[LeftDoubleBracket]j\[RightDoubleBracket]]<3,{{i,j}}, {}],{i,12},{j,i+1,12}],2]; icofaces=Flatten[ Table[If[MemberQ[icoedges,{a,b}]&&MemberQ[icoedges,{b,c}]&& MemberQ[icoedges,{a,c}],{{a,b,c}},{}],{a,12},{b,a+1,12}, {c,b+1,12}],3]; icoadjacent= Flatten[Table[ If[Length[ (icofaces\[LeftDoubleBracket] i\[RightDoubleBracket])\[Intersection](icofaces\ \[LeftDoubleBracket]j\[RightDoubleBracket])]==2,{{i,j}},{}],{i,20}, {j,i+1,20}],2]; SphereLayout[ord_]:= Flatten[{(insideedges[#1,ord]&)/@icofaces, (edgeedges[#1,ord]&)/@icoadjacent},2] insideedges[face_,order_]:= Map[findpoint[face,#1]&, Flatten[Function[pt,({pt,pt+#1}&)/@Permutations[{2,-1,-1}]]/@ (3 Flatten[Table[{i,j,order+2-i-j},{i,order},{j,order+1-i}],1]-1),1], {2}] edgeedges[{faceind1_,faceind2_},order_]:= Module[{face1=icofaces\[LeftDoubleBracket]faceind1\[RightDoubleBracket], face2=icofaces\[LeftDoubleBracket]faceind2\[RightDoubleBracket], ourface1,ourface2}, ourface1=Join[face1\[Intersection]face2,Complement[face1,face2]]; ourface2=Join[face2\[Intersection]face1,Complement[face2,face1]]; Table[(findpoint[#1,{3 k+1,3 (order-k)+1,1}]&)/@{ourface1,ourface2}, {k,0,order}]] \!\(findpoint[face_, coords_] := \((N[#1\/norm[#1]] &)\)[ Plus @@ \(\(\((icoverts\[LeftDoubleBracket]#1\[RightDoubleBracket] &)\) /@ face\ coords\)\/Plus @@ coords\)]\) SphereNetwork[ord_]:= Module[{d=SphereLayout[ord],nn},nn=Union[Flatten[d,1]]; EdgesToNodes[Map[First[Flatten[Position[nn,#]]]&,d,{2}]]] TreeNetwork[ord_Integer]:= Map[(#-1)&,With[{sz=3*2^ord}, Join[{2\[Rule]{3,4,5},3\[Rule]{2,6,7}}, Table[i\[Rule]{Floor[i/2],2i,2i+1},{i,4,sz-1}], Table[i\[Rule]{Floor[i/2],Mod[i-1,sz]+sz,Mod[i+1,sz]+sz},{i,sz,2sz-1}]]],{-1}] TrivalentQ[g_]:= Module[{nodes},nodes=Sort[Apply[List,First/@g]]; Sort[Flatten[Apply[List,Last/@g,{0,1}]]]=== Sort[Flatten[{nodes,nodes,nodes}]]] NeighborCounts[g_,i0_,n_]:= Map[Length, Module[{gp=Dispatch[g]},NestList[Union[Flatten[{#,#/.gp}]]&,{i0},n]]] NeighborCounts[g_,i0_:1]:= Map[Length, Module[{gp=Dispatch[g]},FixedPointList[Union[Flatten[{#,#/.gp}]]&,{i0}]]] NeighborLists[g_,i0_,n_]:=NestList[Union[Flatten[#/.g]]&,{i0},n] NeighborLists[g_,i0_:1]:=FixedPointList[Union[Flatten[#/.g]]&,{i0}] ShellNeighborLists[args__]:= Module[{r},r=NeighborLists[args]; MapThread[Complement,{r,Drop[FoldList[Union,{},r],-1]}]] ShellNeighborCounts[args__]:=Length/@ShellNeighborLists[args] ShortestPath[g_,{i0_,i1_}]:= Module[{gp=Dispatch[g],d=0,nn={i0}}, While[!MemberQ[nn,i1],nn=Union[Flatten[nn/.gp]];d++];d] ShortestPath2[g_,{i_,j_}]:= Module[{s=0}, Catch[Nest[If[MemberQ[#,j],Throw[s],s++;Union[Flatten[#/.g]]]&,{i}, Length[g]]]] ShortestPath[g_,{i0_,i1_},ex_List]:= Module[{gp=Dispatch[g],d=0,nn={i0},exx},exx=Complement[ex,{i0}]; While[!MemberQ[nn,i1],nn=Complement[nn,exx];nn=Union[Flatten[nn/.gp]]; d++];d] DistanceMatrix[g_]:=Table[ShortestPath[g,{i,j}],{i,Length[g]},{j,Length[g]}] DistanceMatrix[g_,ex_List]:= Table[ShortestPath[g,{i,j},ex],{i,Length[g]},{j,Length[g]}] NeighborWeightedLists[g_,i0_,n_]:=NestList[NW0[g,#]&,{{i0,1}},n] NW0[g_,list_]:= With[{gp=Dispatch[g]}, ({#[[1,1]],Apply[Plus,Last[#]]}&[Transpose[#]])&/@ Split[Sort[ Flatten[(Function[u,{u,Last[#]}]/@Replace[First[#],gp])&/@list,1]], First[#1]==First[#2]&]] NeighborWeights[g_,i0_,n_]:=Map[Sort[Last/@#]&,NeighborWeightedLists[g,i0,n]] ShellNeighborWeightedLists[g_,i0_,n_]:= Module[{nw},nw=NeighborWeightedLists[g,i0,n]; sf=Drop[FoldList[Union,{},Map[First,nw,{2}]],-1]; MapThread[Function[{a,b},Select[a,!MemberQ[b,First[#]]&]],{nw,sf}]] ShellNeighborWeights[g_,i0_,n_]:= Map[Sort[Last/@#]&,ShellNeighborWeightedLists[g,i0,n]] Cycles[g_,n_]:= First/@Select[{#,Nest[Union[Flatten[#/.g]]&,{#},n]}&/@AllNodes[g], MemberQ[Last[#],First[#]]&] (* Needs["DiscreteMath`Combinatorica`"] *) ToCombinatorica[g_]:= FromUnorderedPairs[Union[DeleteCases[NodesToEdges[g],{x_,x_}]]] NetworkGirth[g_]:=Girth[ToCombinatorica[g]] NetworkCycles[g_]:=ExtractCycles[ToCombinatorica[g]] LinesPicture[gx_,opts___]:= Module[{g=Last/@gx,p,n},n=Length[g]; p=Table[N[{Sin[2Pi i/n],Cos[2Pi i/n]}],{i,n}]; Graphics[{AbsolutePointSize[1],Point/@p,AbsoluteThickness[.25], Table[Line[{p[[i]],p[[g[[i,j]]]]}],{i,Length[g]},{j,3}]},opts, AspectRatio->Automatic,PlotRange->All]] CirclePicture[gx_,opts___]:= With[{g=Last/@gx}, Graphics[{{GrayLevel[.5],AbsoluteThickness[1], Line[{{1,0},{Length[g],0}}]},AbsoluteThickness[.25], {AbsolutePointSize[.5],Table[Point[{i,0}],{i,Length[g]}]}, Table[Circle[{(i+g[[i,j]])/2,0},Abs[g[[i,j]]-i]/2,{0,\[Pi]}], {i,Length[g]},{j,3}]},opts,AspectRatio->Automatic, PlotRange->All]] Clear[NeighborsPicture] Options[NeighborsPicture]= {Reordered->False,Symmetrized->False,DoubleEdges->True,Dotted->False, AspectRatio->Automatic,LightCone->False}; \!\(NeighborsPicture[g_, init_, opts___?OptionQ] := Module[{already = init, next, nextp, xv = 0, gbag = {}, last, lastp, wts, reord, sym, dbl, pf, ar, cone, rot}, {reord, sym, dbl, ar, cone} = \({Reordered, Symmetrized, DoubleEdges, AspectRatio, LightCone} /. {opts}\) /. Options[NeighborsPicture]; \n\t\tlast = init; \n\t\tWhile[ \((nextp = last /. g; next = Complement[Flatten[nextp], already])\) =!= {}, \n\t\t\t\ \ \ \ \ If[reord, wts = \(\((First /@ Position[nextp, #])\) &\) /@ next; \n\t\t\t\t\ \ \ \ \ \ \ \ \ \ \ wts = \(\((Apply[Plus, #]/Length[#])\) &\) /@ wts; wts = Transpose[{wts, next}]; next = Last /@ Sort[wts]]; \n\t\t\t\ \ \ \ \ \ If[sym, pf = \((#1 - #2/2)\) &, pf = \((#1)\) &]; \n\t\t\t\ \ \ \ \ If[ cone, rot = {#\[LeftDoubleBracket]2\[RightDoubleBracket], \(-#\[LeftDoubleBracket]1\[RightDoubleBracket]\)} &, rot = # &]; \n\t\t\t\ \ \ \ \ AppendTo[gbag, Table[If[ MemberQ[next, nextp\[LeftDoubleBracket]i, j\[RightDoubleBracket]], Line[{rot[{xv, pf[i, Length[last]]}], \n\t\t\t\t\t\t\t\trot[ {xv + 1, pf[\(Position[next, nextp\[LeftDoubleBracket]i, j\[RightDoubleBracket]]\)\[LeftDoubleBracket]1, 1\[RightDoubleBracket], Length[next]]}]}], {}], {i, Length[last]}, {j, Length[ nextp\[LeftDoubleBracket] i\[RightDoubleBracket]]}]]; \n\t\t\t\ \ \ \ \ \ already = Flatten[{already, next}]; nextp = next /. g; \n\t\t\t\ \ \ \ \ AppendTo[gbag, Table[If[ MemberQ[next, nextp\[LeftDoubleBracket]i, j\[RightDoubleBracket]], p = \(Position[next, nextp\[LeftDoubleBracket]i, j\[RightDoubleBracket]]\)\[LeftDoubleBracket]1, 1\[RightDoubleBracket]; \n\t\t\t\t\t\t\ \ \ \ \ Circle[ rot[{xv + 1, pf[\((i + p)\)\/2, Length[next]]}], \(N[If[cone, {#, ArcTan[#]\/2}, {ArcTan[#]\/2, #}]] &\)[ Abs[p - i]\/2], If[cone, {\(-\[Pi]\), 0}, {\(-\[Pi]\)\/2, \[Pi]\/2}]], {}], {i, Length[next]}, {j, Length[ nextp\[LeftDoubleBracket] i\[RightDoubleBracket]]}]]; \n\t\t\t\ \ \ \ \ \ \(xv++\); last = next]; \n\t\tGraphics[ Flatten[{AbsoluteThickness[ .25], gbag}], PlotRange \[Rule] All, AspectRatio -> ar]]\) NeighborsPicture[g_,opts___?OptionQ]:=NeighborsPicture[g,{Min[First/@g]},opts] NeighborsPictureR[args___]:=NeighborsPicture[args,Reordered->True] 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}])]=!={{}}, (* use every new node only once *) nextNodes1=Delete[nextNodes, Last/@Select[Position[nextNodes,#]& /@ Sort[Flatten[nextNodes]],{_,_}]]; (* positions of the new nodes *) Apply[(nodePosition[#1]={xCoord,#2})&, First@Fold[{Append[#[[1]],Take[#[[2]],#2]],Drop[#[[2]],#2]}&, {{},MapIndexed[{#,#2[[1]]-1}&,Flatten[nextNodes1]]},Length/@nextNodes1], {-2}]; (* the new node connections *) 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}]] \!\(TrialMatrix[n_, d_] := Table[Sum[\((x[i, k] - x[j, k])\)\^2, {k, d}], {i, n}, {j, n}]\) FindEmbedding[g_,d_:2,wf_:(1&),s_:1234,opts___]:= Module[{n=Length[g],m=DistanceMatrix[g],c,vars,con,ans,ans2,ans3}, c=Apply[Plus, Flatten[Map[wf,m,{2}](TrialMatrix[n,d]-m^2)]^2]; vars=Flatten[Table[x[i,j],{i,2,n},{j,d}]];con=Table[x[1,i]->0,{i,d}]; SeedRandom[s]; ans=FindMinimum[Evaluate[c/.con],##,opts]&@@({#,Random[]}&/@vars); ans2=Prepend[Partition[vars/.Last[ans],d],Table[0,{d}]]; ans3=Map[ans2[[#]]&,NodesToEdges[g],{-1}]; {ans2,If[d==2,Graphics,Graphics3D][Line/@ans3,AspectRatio->Automatic]}] EmbeddedMatrix[data_]:=Sqrt[Outer[Apply[Plus,(#1-#2)^2]&,data,data,1]] EmbeddedDistances[g_,data_]:= Module[{gp},gp=NodesToEdges[g]; Sqrt[Map[Apply[Plus,#^2]&,Apply[data[[#1]]-data[[#2]]&,gp,{1}]]]]