(***********************************************************************
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}]]]]