(* :Name: Grammatica` *)

(* :Context: Grammatica` *)

(* :Author: Gabriel Valiente
Technical University of Catalonia
Department of Software
E-08034 Barcelona, Catalonia, Spain
http://www.lsi.upc.es/~valiente/
mailto://valiente@lsi.upc.es
*)

(* :Mathematica Version: 3.0 *)

(* :Package Version: 1.1 *)

(* :Copyright: Copyright 1998, 1999, Gabriel Valiente *)

(* :Summary:
This package implements algebraic graph transformation, as an extension to
the functions for graph theory provided in DiscreteMath`Combinatorica`.
*)

BeginPackage["Grammatica`"]

Needs["LinearAlgebra`MatrixManipulation`"]
Needs["DiscreteMath`Combinatorica`"]

RandomMorphism::usage =
	"RandomMorphism[L, G] returns a random homomorphism m from graph L to graph 
G. Returns False if no homomorphism is found."
AllMorphisms::usage =
	"AllMorphisms[L, G] returns a list of all (random) homomorphisms from graph 
L to graph G. Returns the empty list if no homomorphism is found."
IsMorphism::usage =
	"IsMorphism[m, L, G] returns True if m is a homomorphism from graph L to 
graph G. Returns False otherwise."
IsMonomorphism::usage =
	"IsMonomorphism[m, L, G] returns True if m is a monomorphism from graph L to 
graph G. Returns False otherwise."
RandomMonomorphism::usage =
	"RandomMonomorphism[L, G] returns a random monomorphism m from graph L to 
graph G. Returns False if nomonomorphism is found."
AllMonomorphisms::usage =
	"AllMonomorphisms[L, G] returns a list of all monomorphisms from 
graph L to graph G. Returns the empty list if no monomorphism is found."
RandomRedex::usage =
	"RandomRedex[p, G] returns a random redex for production p and graph G. 
Returns False if no redex is found."
AllRedexes::usage =
	"AllRedexes[p, G] returns a list of all (random) redexes for production p 
and graph G. Returns the empty list if no redex is found."
InverseProduction::usage =
	"InverseProduction[p] returns the production inverse to production p."
RewriteProductionGraphRedex::usage =
	"RewriteProductionGraphRedex[p, G, m] returns the result of applying 
production p to graph G at redex m."
RewriteProductionGraphRandomRedex::usage =
	"RewriteProductionGraphRandomRedex[p, G] finds a random redex m for 
production p and graph G, and returns the result of applying production p 
to graph G at redex m.  Returns False if no redex is found."
RewriteProductionGraphAllRedexes::usage =
	"RewriteProductionGraphAllRedexes[p, G] finds all (random) redexes m for 
production p and graph G, and returns a list of the results of applying 
production p to graph G at each of the redexes m.  Returns the empty list 
if no redex is found."
RewriteGraph::usage =
	"RewriteGraph[{p_1, ..., p_n}, G] returns the result of applying a production 
chosen at random out of p_1, ..., p_n to graph G at a random redex.  Returns 
False if no redex is found for any of the productions."
ReduceGraph::usage =
	"ReduceGraph[{p_1, ..., p_n}, G] takes a production at random from p_1, ..., p_n 
and applies it to graph G at a random redex, displaying the resulting graph 
H. It repeats the process until no redex for any of the productions is 
found."
MinCrossEmbedding::usage =
	"MinCrossEmbedding[G] returns an embedding for graph G that shows the 
minimum number of arc crossings, among the graph layout algorithms encoded 
in Combinatorica : circular, ranked, radial, rooted, and spring embedding."
AllEmbeddings::usage =
	"AllEmbeddings[G] shows different embeddings (circular, ranked, radial, 
rooted, and spring embedding) for graph G, together with the number of arc 
crossings produced by each of them."
ShowMatrixProduction::usage =
	"ShowMatrixProduction[p] shows production p in the form of a diagram.  
Graphs and graph homomorphisms are visualized as Boolean matrices."
ShowProduction::usage =
	"ShowProduction[p] shows production p in the form of a diagram.  Graph 
homomorphisms are visualized as Boolean matrices, and graphs are drawn."
ShowMatrixRewriteStep::usage =
	"ShowMatrixRewriteStep[p, G, m] shows a double-pushout diagram for the 
application of production p to graph G at redex m.  Graphs and graph 
homomorphisms are visualized as Boolean matrices."
ShowRewriteStep::usage =
	"ShowRewriteStep[p, G, m] shows a double-pushout diagram for the application 
of production p to graph G at redex m.  Graph homomorphisms are visualized 
as Boolean matrices, and graphs are drawn."

Begin["`Private`"]

Off[General::spell1]
Off[Solve::svars]
Off[RowReduce::luc]

BoolQ[expr_Integer] := expr == 0 || expr == 1

RelationQ[expr_] := VectorQ[expr, BoolQ] || MatrixQ[expr, BoolQ]

II[a_] := IdentityMatrix[Length[a]]

LL[a_] := Table[1, {Length[a]}]

OO[a_] := Table[0, {Length[a]}]

MakeBoolean[m_List /; VectorQ[m]] := Function[x, If[x == 0, 0, 1]] /@ m
MakeBoolean[m_List /; MatrixQ[m]] := Function[x, Function[x, If[x == 0, 0, 1]] /@ x] /@ m

Prod[r_List /; RelationQ[r], s_List /; RelationQ[s]] := MakeBoolean[r . s]

Uni[r_List /; RelationQ[r], s_List /; RelationQ[s]] := MakeBoolean[r + s]

Int[r_List /; RelationQ[r], s_List /; RelationQ[s]] :=
	MapThread[Times, {r, s}, Length[Dimensions[r]]]

Neg[r_List /; VectorQ[r]] := Function[x, If[x == 0, 1, 0]] /@ r
Neg[r_List /; MatrixQ[r]] := Function[x, Function[x, If[x == 0, 1, 0]] /@ x] /@ r

Incl[r_List /; RelationQ[r], s_List /; RelationQ[s]] :=
	And @@ (First[#1] <= Last[#1] & ) /@ Transpose[{Flatten[r], Flatten[s]}]

Tr[r_List /; RelationQ[r]] := Transpose[r]

Diff[r_List, s_List] := Int[r, Neg[s]]

LogicSum[a_, b_] := If[a == 1 || b == 1, Return[1], Return[0]]

TransClosure[R_] :=
	Module[{copy, i, j, k},
		copy = R;
		For[i = 1, i <= Length[copy], i++,
			For[j = 1, j <= Length[copy], j++,
				If[copy[[j,i]] == 1,
					For[k = 1, k <= Length[copy], k++,
						copy[[j,k]] = LogicSum[copy[[j,k]], copy[[i,k]]]
					]
				]
			]
		];
		Return[copy]
	]

LogicMatrixSum[a_, b_] := ((If[#1 == 0, 0, 1] & ) /@ #1 & ) /@ (a + b)

SymmClosure[R_] := LogicMatrixSum[R, Transpose[R]]

LogicVectorSum[a_, b_] := (If[#1 == 0, 0, 1] & ) /@ (a + b)

RowAdd[matrix_, row1_, row2_] :=
	Block[{temp = matrix},
		temp[[row1]] = LogicVectorSum[matrix[[row1]], matrix[[row2]]];
		temp
	]

ColAdd[matrix_, col1_, col2_] :=
	Block[{temp = Transpose[matrix]},
		temp[[col1]] = LogicVectorSum[Transpose[matrix][[col1]], Transpose[matrix][[col2]]];
		Transpose[temp]
	]

ColSwap[matrix_, col1_, col2_] :=
	Block[{temp = Transpose[matrix]},
		temp[[col1]] = Transpose[matrix][[col2]];
		temp[[col2]] = Transpose[matrix][[col1]];
		Transpose[temp]
	]

LeafNumberToMatrix[n_, rows_, cols_] :=
	If[cols == 1, Return[Table[{1}, {rows}]],
		If[rows == 1, Module[{t = Table[0, {cols}]}, t[[cols - n]] = 1; Return[{t}]],
			Module[{dd = IntegerDigits[n, cols, rows]},
				Return[IntegerDigits[rows^dd, rows, cols]]
			]
		]
	]

IsMorphism[m_, L_Graph, G_Graph] := Incl[Prod[Edges[L],m], Prod[m, Edges[G]]]

RandomMorphism[L_Graph, G_Graph] :=
	Module[{rows = V[L], cols = V[G], found = False, mat},
		For[i = 1, i < cols^rows, i++,
			mat = LeafNumberToMatrix[i, rows, cols];
			If[IsMorphism[mat, L, G], Return[mat]]
		];
		Return[False]
	]

AllMorphisms[L_Graph, G_Graph] :=
	Module[{rows = Length[Edges[L]], cols = Length[Edges[G]], mat, i, res = {}},
		Do[
			mat = LeafNumberToMatrix[i, rows, cols];
			If[IsMorphism[mat, L, G], AppendTo[res, mat]],
			{i, 1, cols^rows}
		];
		Return[res]
	]

IsMonomorphism[m_, L_Graph, G_Graph] := IsMorphism[m, L, G] && Max[Plus @@ m] <= 1

RandomMonomorphism[L_Graph, G_Graph] :=
	Module[{rows = V[L], cols = V[G], found = False, mat},
		For[i = 1, i < cols^rows, i++,
			mat = LeafNumberToMatrix[i, rows, cols];
			If[IsMonomorphism[mat, L, G], Return[mat]]
		];
		Return[False]
	]

(*
AllMonomorphisms[L_Graph, G_Graph] :=
	Module[{rows = Length[Edges[L]], cols = Length[Edges[G]], mat, i, res = {}},
		Do[
			mat = LeafNumberToMatrix[i, rows, cols];
			If[IsMonomorphism[mat, L, G], AppendTo[res, mat]],
			{i, 1, cols^rows}
		];
		Return[res]
	]
*)

(* Current version of function 'AllMonoMorphisms' implements the graph monomorphism algorithm by J. R. Ullman, "An algorithm for subgraph isomorphism" (Journal of the ACM, 23(1):31-42, 1976). *)

Degrees[Graph[g_,_]]:=
	Map[(Apply[Plus,#])&,g]

NegativeDegrees[Graph[g_,_]]:=
	Map[(Apply[Plus,#])&,Transpose[g]]

AllMonomorphisms[Graph[G_,_],Graph[H_,_]]:=
	Module[{rows=Length[G],
			cols=Length[H],
			P,
			F,
			M={},
			DegG=Degrees[Graph[G,_]],
			NegDegG=NegativeDegrees[Graph[G,_]],
			DegH=Degrees[Graph[H,_]],
			NegDegH=NegativeDegrees[Graph[H,_]]},
		P=Table[0,{i,rows},{j,cols}];
		F=Table[0,{i,rows}];
		Do[
			If[G[[i,i]]<=H[[j,j]],P[[i,j]]=1]
			,{j,cols},{i,rows}];
		Search[G,H,DegG,NegDegG,DegH,NegDegH,P,1,F,M];
		Return[M] ]

SetAttributes[Search,HoldAll] 
Search[G_,H_,DegG_,NegDegG_,DegH_,NegDegH_,P_,i_,F_,M_]:=
	Module[{rows=Length[P],cols=Length[First[P]]},
		If[i>rows,
			AppendTo[M,F],
			Do[
					If[P\[LeftDoubleBracket]i,j\[RightDoubleBracket]==1&&
            DegG\[LeftDoubleBracket]i\[RightDoubleBracket]<=
              DegH\[LeftDoubleBracket]j\[RightDoubleBracket]&&
            NegDegG\[LeftDoubleBracket]i\[RightDoubleBracket]<=
              NegDegH\[LeftDoubleBracket]j\[RightDoubleBracket],
						F\[LeftDoubleBracket]i\[RightDoubleBracket]=j; (* 
            map vertex i to vertex j *)
						Do[P\[LeftDoubleBracket]k,j\[RightDoubleBracket]=0,{k,i+1,rows}];
						If[Consistent[G,H,P,i,F],
						Search[G,H,DegG,NegDegG,DegH,NegDegH,P,i+1,F,M]
					];
						Do[P\[LeftDoubleBracket]k,j\[RightDoubleBracket]=1,{k,i+1,rows}];
						F\[LeftDoubleBracket]i\[RightDoubleBracket]=0] (* 
          unmap vertex i to vertex j *)
				,{j,cols}]] ]

Consistent[G_,H_,P_,i_,F_]:=
	Module[{rows=Length[P],cols=Length[First[P]]},
		Do[
			Do[
				If[P\[LeftDoubleBracket]k,j\[RightDoubleBracket]\[Equal]1,
					Do[If[F\[LeftDoubleBracket]u\[RightDoubleBracket]\[Equal]1\[And]
								((
                      G\[LeftDoubleBracket]k,u\[RightDoubleBracket]\[Equal]1
                          \[And]H\[LeftDoubleBracket]j,
                            F\[LeftDoubleBracket]u
                              \[RightDoubleBracket]\[RightDoubleBracket]\
\[Equal]0)\[Or](G\[LeftDoubleBracket]u,k\[RightDoubleBracket]\[Equal]1
                          \[And]H
                            \[LeftDoubleBracket]F\[LeftDoubleBracket]u
                              \[RightDoubleBracket],j
                            \[RightDoubleBracket]\[Equal]0)),
							P\[LeftDoubleBracket]k,j\[RightDoubleBracket]=0]
						,{u,1,i-1}]]
				,{j,1,cols}]
			,{k,i+1,rows}];
		Not[Apply[Or,Map[FreeQ[#,1]&,P]]] ]

CoproductGraph[R_Graph, D_Graph] :=
	BlockMatrix[
		{{Edges[R], ZeroMatrix[Length[Edges[R]], Length[First[Edges[D]]]]},
		{ZeroMatrix[Length[Edges[D]], Length[First[Edges[R]]]], Edges[D]}}
	]

GluingRelation[r_, d_] := 
  BlockMatrix[{{II[Tr[r]], Prod[Tr[r], d]}, 
    {ZeroMatrix[Length[Tr[d]], Length[Tr[r]]], II[Tr[d]]}}]

IdentificationPoints[K_Graph, L_Graph, G_Graph, l_, m_] :=
	Prod[Int[Prod[m, Tr[m]], Neg[II[Edges[L]]]], LL[Edges[L]]]

DanglingPoints[K_Graph, L_Graph, G_Graph, l_, m_] :=
	Module[{i=Diff[Edges[G],Prod[Prod[Tr[m],Edges[L]],m]]},
		Prod[m,Uni[Prod[i,LL[Edges[G]]],Prod[LL[Edges[G]],i]]]
	]

GluingPoints[K_Graph, L_Graph, G_Graph, l_, m_] := Prod[Prod[Tr[l], l], LL[Edges[L]]]

GluingCondition[K_Graph, L_Graph, G_Graph, l_, m_] :=
	Module[{ident, dangl, gluing},
		ident = IdentificationPoints[K, L, G, l, m];
		dangl = DanglingPoints[K, L, G, l, m];
		gluing = GluingPoints[K, L, G, l, m];
		Incl[ident, gluing] && Incl[dangl, gluing]
	]

LLLL[x_] := Table[Table[1, {Length[x]}], {Length[x]}]

UniversalQ[R_] :=
	!MemberQ[Flatten[R], 0]*LogicMatrixDiff[a_, b_] :=
	((If[#1 == -1, 0, #1] & ) /@ #1 & ) /@ (a - b)

PushoutComplement[K_Graph, L_Graph, G_Graph, l_, m_] :=
	Module[{D, ll, d, nonzero,E},
		D = Neg[Prod[Prod[Prod[Tr[m], Neg[Prod[Prod[Tr[l], l], LLLL[Edges[L]]]]], m], LL[Edges[G]]]];
		nonzero = Flatten[Position[D, 1]]; (* nodes to be preserved *)
		E=Diff[Edges[G],Prod[Prod[Tr[m],Edges[L]],m]]; (* edges to be preserved *)
		D=E[[nonzero,nonzero]];
		d = (l . m)[[Range[Length[Edges[K]]],nonzero]];
		ll = II[Edges[G]][[nonzero,Range[Length[Edges[G]]]]];
		Return[{CircularVertices[Graph[D, _]], d, ll}]
	]

Pushout[K_Graph, R_Graph, D_Graph, r_, d_] :=
	Module[{RD, theta, H, mm, rr, rowscols},
		RD = CoproductGraph[R, D]; rowscols = Range[Length[RD]];
		theta = TransClosure[SymmClosure[GluingRelation[r, d]]];
		Do[
			Do[
				If[theta[[i,j]] == 1,
					RD = RowAdd[RD, i, j];
					RD = ColAdd[RD, i, j];
					rowscols = Complement[rowscols, {j}]
				], {j, i + 1, Length[theta]}
			], {i, 1, Length[theta]}
		];
		H = RD[[rowscols,rowscols]];
		mm = BlockMatrix[
			{{IdentityMatrix[Length[Edges[R]]], ZeroMatrix[Length[Edges[R]], Length[Edges[D]]]}}
		];
		mm = mm[[Range[Length[Edges[R]]],rowscols]];
		rr = BlockMatrix[
			{{ZeroMatrix[Length[Edges[D]], Length[Edges[R]]], IdentityMatrix[Length[Edges[D]]]}}
		];
		Do[
			Do[
				If[theta[[i,j]] == 1, rr = ColSwap[rr, i, j]
				], {j, i + 1, Length[theta]}
			], {i, 1, Length[theta]}
		];
		rr = rr[[Range[Length[Edges[D]]],rowscols]];
		Return[{CircularVertices[Graph[H, _]], mm, rr}]
	]

RewriteProductionGraphRandomRedex[{L_Graph, K_Graph, R_Graph, l_, r_}, G_Graph] :=
	Module[{m, D, d, ll, H, mm, rr},
		m = RandomRedex[{L, K, R, l, r}, G];
		{D, d, ll} = PushoutComplement[K, L, G, l, m];
		{H, mm, rr} = Pushout[K, R, D, r, d];
		Return[{D, d, ll, H, mm, rr}]
	]

RewriteProductionGraphAllRedexes[p_, G_Graph] :=
	Function[redex, RewriteProductionGraphRedex[p, G, redex]] /@ AllRedexes[p, G]

RewriteProductionGraphRedex[{L_Graph, K_Graph, R_Graph, l_, r_}, G_Graph, m_] :=
	Module[{D, d, ll, H, mm, rr},
		{D, d, ll} = PushoutComplement[K, L, G, l, m];
		{H, mm, rr} = Pushout[K, R, D, r, d];
		Return[{D, d, ll, H, mm, rr}]
]

RandomRedex[{L_Graph, K_Graph, R_Graph, l_, r_}, G_Graph] :=
	Module[{rows = Length[Edges[L]], cols = Length[Edges[G]], found = False, leaf, mat, i},
		leaf = RandomPermutation[cols^rows] - 1;
		Do[
			mat = LeafNumberToMatrix[leaf[[i]], rows, cols];
			If[IsMorphism[mat, L, G] && GluingCondition[K, L, G, l, mat],
				found = True;
				Break[]
			], {i, 1, Length[leaf]}
		];
		If[found, Return[mat], Return[False]]
	]

AllRedexes[{L_Graph, K_Graph, R_Graph, l_, r_}, G_Graph] :=
	Module[{rows = Length[Edges[L]], cols = Length[Edges[G]], leaf, mat, i, res = {}},
		leaf = RandomPermutation[cols^rows] - 1;
		Do[
			mat = LeafNumberToMatrix[leaf[[i]], rows, cols];
			If[IsMorphism[mat, L, G] && GluingCondition[K, L, G, l, mat],
				AppendTo[res, mat]
			], {i, 1, Length[leaf]}
		];
    Return[res]
	]

RewriteGraph[p_List, G_Graph] :=
	Module[{i, j, L, K, R, l, r, m, H, found = False},
		i = RandomPermutation[Length[p]];
		Do[
			{L, K, R, l, r} = p[[i[[j]]]];
			m = RandomRedex[{L, K, R, l, r}, G];
			If[MatrixQ[m],
				H = RewriteProductionGraphRedex[{L, K, R, l, r}, G, m];
				found = True;
				Break[]
			], {j, 1, Length[p]}
		];
		If[found, Return[H], Return[False]]
	]

GraphQ[Graph[_, _]] := True

EmptyGraphQ[Graph[e_, _]] := Not[MemberQ[Flatten[e],1]]

ReduceGraph[p_List, G_Graph] :=
	Module[{H = G},
		While[Not[EmptyGraphQ[H]],
			H = RewriteGraph[p, H][[4]];
			If[GraphQ[H], Print[MatrixForm[Edges[H]]]]
		]
	]

InverseProduction[{L_Graph, K_Graph, R_Graph, l_, r_}] := {R, K, L, r, l}

MatrixToGraphics[m_List] := 
  Graphics[Text[MatrixForm[m], {0, 0}], Frame -> False, 
   FrameTicks -> None]
GraphLabels[v_List, l_List] := 
  Module[{i}, Table[Text[l[[i]], v[[i]] - {0.03, 0.03}, 
     {0, 1}], {i, Length[v]}]]
GraphLabels[v_List, l_List] := 
  Module[{i}, Table[Text[l[[i]], v[[i]], {0, 1}], 
    {i, Length[v]}]]
FindPlotRange[v_List] := 
  Module[{xmin = Min[First /@ v], xmax = Max[First /@ v], 
    ymin = Min[Last /@ v], ymax = Max[Last /@ v]}, 
   {{xmin - 0.05*Max[1, xmax - xmin], 
     xmax + 0.05*Max[1, xmax - xmin]}, 
    {ymin - 0.05*Max[1, ymax - ymin], 
     ymax + 0.05*Max[1, ymax - ymin]}}]
GraphToGraphics[g_Graph] := GraphToGraphics[g, Range[V[g]]]
GraphToGraphics[g1_Graph, labels_List] := 
  Module[{pairs = ToOrderedPairs[g1], 
    g = NormalizeVertices[g1], v}, 
   v = Vertices[g]; Graphics[Join[PointsAndLines[g], 
      (Line[Chop[v[[#1]]]] & ) /@ pairs, 
      GraphLabels[v, labels]]]]
UndirectedGraphToGraphics[g1_Graph] := 
  Module[{pairs = ToOrderedPairs[g1], 
    g = NormalizeVertices[g1], v}, 
   v = Vertices[g]; Graphics[Join[PointsAndLines[g], 
      (Line[Chop[v[[#1]]]] & ) /@ pairs]]]

ShowMatrixProduction[{L_Graph, K_Graph, R_Graph, l_, r_}] :=
	DisplayForm[
		GridBox[
			{{"", GridBox[l], "", GridBox[r], ""},
			{FrameBox[GridBox[Edges[L]]],
			"\[LeftArrow]",
			FrameBox[GridBox[Edges[K]]],
			"\[RightArrow]",
			FrameBox[GridBox[Edges[R]]]}}
		]
	]

ShowProduction[{L_Graph, K_Graph, R_Graph, l_, r_}] :=
	Module[{e = Graphics[Text["", {0, 0}]]},
		Show[
			GraphicsArray[
				{{GraphToGraphics[L],
				Graphics[Text["\[LeftArrow]", {0, 0}]],
				MatrixToGraphics[l],
				Graphics[Text["\[LeftArrow]", {0, 0}]],
				GraphToGraphics[K],
				Graphics[Text["\[RightArrow]", {0, 0}]],
				MatrixToGraphics[r],
				Graphics[Text["\[RightArrow]", {0, 0}]],
				GraphToGraphics[R]}}
			]
		]
	]

ShowMatrixRewriteStep[{L_Graph, K_Graph, R_Graph, l_, r_}, G_Graph, m_] :=
	DisplayForm[
		Module[{D, d, ll, H, mm, rr},
			{D, d, ll, H, mm, rr} = RewriteProductionGraphRedex[{L, K, R, l, r}, G, m];
			GridBox[
				{{"", "", GridBox[l], "", GridBox[r], "", ""},
				{"", FrameBox[GridBox[Edges[L]]], "\[LeftArrow]",
				FrameBox[GridBox[Edges[K]]], "\[RightArrow]",
				FrameBox[GridBox[Edges[R]]], ""},
				{GridBox[m], "\[DownArrow]", "", GridBox[d], "", "\[DownArrow]", GridBox[mm]},
				{"", FrameBox[GridBox[Edges[G]]], "\[LeftArrow]",
				FrameBox[GridBox[Edges[D]]], "\[RightArrow]",
				FrameBox[GridBox[Edges[H]]], ""},
				{"", "", GridBox[ll], "", GridBox[rr], "", ""}}
			]
		]
	]

ShowRewriteStep[{L_Graph, K_Graph, R_Graph, l_, r_}, G_Graph, m_] :=
	Module[{D, d, ll, H, mm, rr, e = Graphics[Text["", {0, 0}]]},
		{D, d, ll, H, mm, rr} = RewriteProductionGraphRedex[{L, K, R, l, r}, G, m];
		Show[
			GraphicsArray[
				{{GraphToGraphics[L],
					Graphics[Text["\[LeftArrow]", {0, 0}]],
					MatrixToGraphics[l],
					Graphics[Text["\[LeftArrow]", {0, 0}]],
					GraphToGraphics[K],
					Graphics[Text["\[RightArrow]", {0, 0}]],
					MatrixToGraphics[r],
					Graphics[Text["\[RightArrow]", {0, 0}]],
					GraphToGraphics[R]},
				{Graphics[Text["\[DownArrow]", {0, 0}]], e, e, e,
					Graphics[Text["\[DownArrow]", {0, 0}]], e, e, e,
					Graphics[Text["\[DownArrow]", {0, 0}]]},
				{MatrixToGraphics[m],
					Graphics[Text["\[LeftArrow]", {0, 0}]], e,
					Graphics[Text["\[LeftArrow]", {0, 0}]],
					MatrixToGraphics[d],
					Graphics[Text["\[LeftArrow]", {0, 0}]], e,
					Graphics[Text["\[LeftArrow]", {0, 0}]],
					MatrixToGraphics[mm]},
				{Graphics[Text["\[DownArrow]", {0, 0}]], e, e, e,
					Graphics[Text["\[DownArrow]", {0, 0}]], e, e, e,
					Graphics[Text["\[DownArrow]", {0, 0}]]},
				{GraphToGraphics[G],
					Graphics[Text["\[LeftArrow]", {0, 0}]],
					MatrixToGraphics[ll],
					Graphics[Text["\[LeftArrow]", {0, 0}]],
					GraphToGraphics[D],
					Graphics[Text["\[RightArrow]", {0, 0}]],
					MatrixToGraphics[rr],
					Graphics[Text["\[RightArrow]", {0, 0}]],
					GraphToGraphics[H]}}
			]
		]
	]

CrossQ[{x1_, y1_}, {x2_, y2_}, {x3_, y3_}, {x4_, y4_}] :=
	Module[{lambda1, lambda2, res},
		res = Solve[{x1, y1} + lambda1*({x2, y2} - {x1, y1}) == 
			{x3, y3} + lambda2*({x4, y4} - {x3, y3}), {lambda1, lambda2}];
		TrueQ[Length[res] == 1 && Length[res[[1]]] == 2 && 
			0 < res[[1,1,2]] && 0 < res[[1,2,2]] && 
			res[[1,1,2]] < 1 && res[[1,2,2]] < 1]
	]

NumberCrossing[g_Graph] :=
	Module[{h, e, v, count = 0, edges = {}, pairs = {}},
		h = MakeUndirected[g]; e = Edges[h]; v = Vertices[h];
		For[i = 1, i <= Length[e], i++,
			For[j = i + 1, j <= Length[e], j++,
				If[e[[i,j]] == 1, AppendTo[edges, {i, j}]]
			]
		];
		For[i = 1, i <= Length[edges], i++,
			For[j = i + 1, j <= Length[edges], j++,
				If[Length[Join[edges[[i]], edges[[j]]]] == Length[Union[edges[[i]], edges[[j]]]],
					AppendTo[pairs, Join[edges[[i]], edges[[j]]]]
				]
			]
		];
		For[i = 1, i <= Length[pairs], i++,
			If[TrueQ[CrossQ[v[[pairs[[i,1]]]], v[[pairs[[i,2]]]], v[[pairs[[i,3]]]], v[[pairs[[i,4]]]]]],
				count = count + 1
			]
		];
		Return[count]
	]

MinCrossEmbedding[g_Graph] :=
	Module[{g1, g2, g3, g4, g5, n1, n2, n3, n4, n5, n},
		n1 = NumberCrossing[g1 = ChangeVertices[g, CircularVertices[V[g]]]];
		n2 = NumberCrossing[g2 = RankedEmbedding[g, {1}]];
		n3 = NumberCrossing[g3 = RadialEmbedding[g]];
		n4 = NumberCrossing[g4 = RootedEmbedding[g, 1]];
		n5 = NumberCrossing[g5 = SpringEmbedding[g]];
		n = Min[{n1, n2, n3, n4, n5}]; If[n1 == n, Return[g1]];
		If[n2 == n, Return[g2]];
		If[n3 == n, Return[g3]];
		If[n4 == n, Return[g4]];
		If[n5 == n, Return[g5]]
	]

AllEmbeddings[g_Graph] :=
	Module[{g1, g2, g3, g4, g5, n1, n2, n3, n4, n5},
		n1 = NumberCrossing[g1 = ChangeVertices[g, CircularVertices[V[g]]]];
		n2 = NumberCrossing[g2 = RankedEmbedding[g, {1}]];
		n3 = NumberCrossing[g3 = RadialEmbedding[g]];
		n4 = NumberCrossing[g4 = RootedEmbedding[g, 1]];
		n5 = NumberCrossing[g5 = SpringEmbedding[g]];
		Show[
			GraphicsArray[
				{{UndirectedGraphToGraphics[g1],
					Graphics[Text[n1, {0, 0}]], 
					Graphics[Text["Circular", {0, 0}]]}, 
				{UndirectedGraphToGraphics[g2], 
					Graphics[Text[n2, {0, 0}]], 
					Graphics[Text["Ranked", {0, 0}]]}, 
				{UndirectedGraphToGraphics[g3], 
					Graphics[Text[n3, {0, 0}]], 
					Graphics[Text["Radial", {0, 0}]]}, 
				{UndirectedGraphToGraphics[g4], 
					Graphics[Text[n4, {0, 0}]], 
					Graphics[Text["Rooted", {0, 0}]]}, 
				{UndirectedGraphToGraphics[g5], 
					Graphics[Text[n5, {0, 0}]], 
					Graphics[Text["Spring", {0, 0}]]}}
			]
		]
	]

End[ ]

EndPackage[ ]