(* 
Basic data structure:
{{a1, a2}, {b1, b2}, .....}
i.e. list of directed arcs


NOTE: hypergraph simply involves more than 2 nodes in each edge list
*)


Tetrahedron = {{1, 2}, {1, 3}, {2, 3}, {1, 4}, {2, 4}, {3, 4}}



ToAdjacency[g_] := MapAt[(# + 1)&,
	Array[0&, {1, 1} Length[Union[Flatten[g]]]], g]

FromAdjacency[m_] := Sort[Flatten[MapIndexed[If[# != 0, Table[#2, {#}], {}]&,
	m, {2}], 2]]

(* must be perm of 3n elements, where n is number of nodes *)
PermToGraph[perm_List /; (Mod[Length[perm], 3] == 0)] := 
	Sort[Partition[Flatten[Table[i, {i, Length[perm]/3}, {3}]][[perm]], 2]]

RealUnion[l_, func_]:=
Fold[Function[{u,v},If[Select[u,func[#1,v]&,1]==={},
                       Flatten[{u,{v}},1],u]],
    {First[#]},Rest[#]]&[Union[l]]

Needs["DiscreteMath`Combinatorica`"]

UniqueGraphs[list_] := RealUnion[list, IsomorphismQ[Graph[ToAdjacency[#1]],
	Graph[ToAdjacency[#2]]]&]

Valences[g_] := Map[Length, Split[Sort[Flatten[g]]]]

Nodes[g_] := Union[Flatten[g]]



(* set up G objects;  use G[{a_, b_}, {b_, a_}] etc. rules to 
make transformations on subgraphs *)
(** Use ReplaceList[ ]  to check for overlapping rules **)
(* Wrap Block[{node}, .... :> node++] for adding new nodes *)

SetAttributes[G, {Flat, Orderless}]

SetAttributes[Gp, {Orderless}]

(*
G[{a_, o_}, {b_, o_}, {c_, o_}] :> With[{{n1, n2, n3} = Table[New[], {3}]},
	G[{a, n1}, {b, n2}, ......]
*)


(** Random3Graph[n_] := PermToGraph[RandomPermutation[3n]] **)

Random3Graph[n_] :=
	Sort[
Partition[Last /@ Sort[{Random[], #}& /@ Join[#, #, #]&[Range[n]]], 2]]


nextlayer[g_, nlist_] := Union[Flatten[{nlist, 
					Cases[g, {#, x_}->x]& /@ nlist}]]

(* find all knobs *)
KnobFind[g_] := Complement[Union[FixedPoint[nextlayer[g, #]&, #]& /@ 
	Select[Union[Flatten[g]], IntegerQ]], {Union[Flatten[g]]}]


SubsetQ[big_, small_] := Intersection[big, small] === small && big =!= small


FindIrreducible[list_] := Module[{c},
	c = list;
	For[i=1, i<=Length[c], i++, c = Select[c, !SubsetQ[#, c[[i]]]&]] ;
	c ]

GetSubgraph[g_, nodes_] :=
	Module[{a},
		a = Apply[Alternatives, nodes];
		Cases[g, {a, _} | {_, a}]
	]

RenumberGraph[g_] :=
	Module[{t},  t = Union[Flatten[g]];
		Sort[ g /. MapThread[Rule, {t, Range[Length[t]]}] ] ]

IrreducibleKnobs[g_] :=
	GetSubgraph[g, #]& /@ FindIrreducible[KnobFind[g]]

CanonicalGraph[g_] := 
	Module[{t},  t = Union[Flatten[g]] ;
		First[Sort[
	Function[p, Sort[Map[Part[p, #]&, g, {2}]]] /@ Permutations[t]]]
]

GraphKnobs[g_] := CanonicalGraph /@ RenumberGraph /@ IrreducibleKnobs[g]
	

(* Use UniqueGraphs[Union[ RenumberGraph /@ IrreducibleKnobs[ xxxx ] ]] *)
	

testknob = {{1, 6}, {1, 2}, {2, 3}, {2, 5},
	{3, 4}, {3, 1}, {4, 5}, {5, 6}, {6, 4}}
 
BicycleGraph[n_] := Join[Table[{i, i+1}, {i, n-1}], {{n, 1}},
	Table[{i, i+1}, {i, n+1, 2n-1}], {{2n, n+1}}, 
	Table[{i + n, i}, {i, n}]]



GraphToPattern[g_] := G[Map[Apply[Pattern, 
	{ToExpression[StringJoin["x", ToString[#]]], _}]&, g, {2}]]


(** can specify knobs by incomplete subgraphs: i.e. graphs where 
some nodes have valence < 3; their other arcs come in from outside the
knob **)


(* constructing new potential knobs *)

AddNodes[glist_] := Union[Flatten[AddNodes0 /@ glist, 1]]

AddNodes0[g_] := Module[{t}, t = Length[Nodes[g]] + 1;
	Table[Append[ReplacePart[g, t, {i, 2}], {t, g[[i, 2]]}],
		{i, Length[g]}]]

AddArcs[glist_] := Select[Union[Flatten[AddArcs0 /@ glist, 1]],
	Max[Valences[#]] <= 3 &]

AddArcs0[g_] := Module[{t}, 
	t = First /@ Select[Split[Sort[Flatten[g]]], Length[#] < 3&] ;
	Map[Append[g, #]&, Flatten[Outer[List, t, t], 1] ] ]


mingraphA = {{1, 2}, {1, 2}, {1, 2}}

mingraphB = {{1, 1}, {1, 2}, {2, 2}}

knobruleA = G[{a_, o_}, {b_, o_}, {c_, o_}] :>
	With[{n = Table[++tot, {4}]},
		G[{n[[1]], a}, {n[[1]], o}, n[[{1, 4}]], 
			{n[[3]], c}, {n[[3]], o}, n[[{3, 4}]],
			{n[[2]], b}, {n[[2]], o}, n[[{2, 4}]]]]

knobruleAp = Gp[{a_, o_}, {b_, o_}, {c_, o_}] :>
	With[{n = Table[++tot, {4}]},
		Gp[{n[[1]], a}, {n[[1]], o}, n[[{1, 4}]], 
			{n[[3]], c}, {n[[3]], o}, n[[{3, 4}]],
			{n[[2]], b}, {n[[2]], o}, n[[{2, 4}]]]]

knobruleAx = {{2, 1}, {3, 1}, {4, 1}} ->
	{{-1, 2}, {-1, 1}, {-1, -4}, {-3, 4}, {-3, 1}, {-3, -4},
		{-2, 3}, {-2, 1}, {-2, -4}}


knobruleB = G[{a_, b_}, {b_, c_}, {c_, a_}, {d_, a_}, {e_, b_}, {f_, c_}] :>
	With[{n = ++tot}, G[{d, n}, {e, n}, {f, n}]]

knobruleBp = Gp[{a_, b_}, {b_, c_}, {c_, a_}, {d_, a_}, {e_, b_}, {f_, c_}] :>
	With[{n = ++tot}, Gp[{d, n}, {e, n}, {f, n}]]

knobruleBx = {{1, 2}, {2, 3}, {3, 1}, {4, 1}, {5, 2}, {6, 3}} ->
	{{4, -1}, {5, -1}, {6, -1}}

kr1 = {{2, 1}, {3, 1}, {4, 1}} ->
	{{-1, 2}, {1, -1}, {-4, -1}, {-3, 4}, {1, -3}, {-4, -3},
		{-2, 3}, {1, -2}, {-4, -2}}

kr2 = {{1, 2}, {2, 3}, {3, 1}, {4, 1}, {5, 2}, {6, 3}} ->
	{{4, -1}, {5, -1}, {6, -1}}

tetragraph = {{1, 4}, {1, 2}, {2, 4}, {2, 3}, {3, 4}, {3, 1}}


GraphStep[rules_, g_] := 
	RenumberGraph[
		List @@ Block[{tot = Length[Nodes[g]]}, (G @@ g) /. rules]]

GraphEvolveList[rules_, g_, t_] := NestList[GraphStep[rules, #]&, g, t]

DeleteOne[list_, elem_] :=
	Delete[list, Position[list, elem, 1, 1]]
		
GraphStepComplete[rules_, g_] := 
	RenumberGraph [ Block[{tot = Length[Nodes[g]]},
	   Module[{ }, t = IrreducibleKnobs[g];
		u = Apply[List, Apply[Gp, t, {1}] /. rules, {1}] ;
		Join[Fold[DeleteOne[#1, #2]&, g, Flatten[t,1]], 
			Flatten[u,1]]
	] ]] 
	
GraphEvolveCompleteList[rules_, g_, t_] := NestList[
	GraphStepComplete[rules, #]&, g, t]


XGCEvolveList[rules_, init_, t_] := NestList[XGCStep[rules, #]&, init, t]



ToPhred[g_] := Network[Flatten[{Node /@ Union[Flatten[g]], Arc /@ g}]]

AddOuterNodes[g_] :=
	Module[{nn = Max[Flatten[g]], n},  n = nn+1;
		Join[g, Flatten[
		Table[Table[{n++, i}, {3-Count[Flatten[g], i]}], {i, nn}], 1]]]

		



bkr[1, 1] = {{2, 1}, {3, 1}, {4, 1}} -> {{-1, 2}, {-1, 3}, {-1, 4}}

bkr[1, 2] = {{2, 1}, {3, 1}, {4, 1}} -> 
	{{-4, -1}, {-4, -2}, {-4, -3}, {-5, -1}, {-5, -2}, {-5, -3}, 
				{-1, 2}, {-2, 3}, {-3, 4}} 

bkr[1, 3] = {{2, 1}, {3, 1}, {4, 1}} -> 
	{{-1, -2}, {-1, -3}, {-1, -4}, {-2, -5}, {-5, -2}, {-3, -6},
		{-6, -3}, {-4, -7}, {-7, -4}, {-5, 2}, {-6, 3}, {-7, 4}}

bkr[1, 4] = {{2, 1}, {3, 1}, {4, 1}} -> 
	{{-1, -2}, {-1, -3}, {-1, -4}, {-2, -5}, {-2, -5}, {-3, -6},
		{-3, -6}, {-4, -7}, {-4, -7}, {-5, 2}, {-6, 3}, {-7, 4}}

bkr[1, 5] = {{2, 1}, {3, 1}, {4, 1}} -> 
	{{-1, -2}, {-1, -3}, {-1, -4}, {-2, -5}, {-2, -7}, {-3, -5},
		{-3, -6}, {-4, -6}, {-4, -7}, {-5, 2}, {-6, 3}, {-7, 4}}

bkr[2, 1] = {{1, 2}, {2, 1}, {3, 1}, {4, 2}} ->
			{{-1, -2}, {-2, -1}, {-1, 3}, {-2, 4}}

bkr[2, 2] = {{1, 2}, {2, 1}, {3, 1}, {4, 2}} ->
		{{-1, -2}, {-2, -3}, {-2, -4}, {-3, -1}, {-4, -1},
			{-3, 3}, {-4, 4}}

bkr[2, 3] = {{1, 2}, {2, 1}, {3, 1}, {4, 2}} ->
		{{-1, -2}, {-2, -3}, {-2, -4}, {-1, -3}, {-1, -4},
			{-3, 3}, {-4, 4}}

bkr[3, 1] = {{1, 2}, {2, 3}, {3, 1}, {4, 1}, {5, 2}, {6, 3}} ->
		{{-1, -2}, {-2, -3}, {-3, -1}, {-1, 4}, {-2, 5}, {-3, 6}}

bkr[3, 2] = {{1, 2}, {2, 3}, {3, 1}, {4, 1}, {5, 2}, {6, 3}} ->
		{{-1, -3}, {-3, -2}, {-2, -1}, {-1, 4}, {-2, 5}, {-3, 6}}

bkr[3, 3] = {{1, 2}, {2, 3}, {3, 1}, {4, 1}, {5, 2}, {6, 3}} ->
		{{-1, 4}, {-1, 5}, {-1, 6}}

bkr[3, 4] = {{1, 2}, {2, 3}, {3, 1}, {4, 1}, {5, 2}, {6, 3}} ->
		{{-4, -1}, {-4, -2}, {-4, -3}, {-5, -1}, {-5, -2}, {-5, -3}, 
				{-1, 4}, {-2, 5}, {-3, 6}} 


Null

alltetragraphs = 
{{{1, 2}, {1, 3}, {1, 4}, {2, 3}, {2, 4}, {3, 4}}, 
 
  {{1, 2}, {1, 3}, {1, 4}, {2, 3}, {3, 4}, {4, 2}}, 
 
  {{1, 2}, {1, 3}, {2, 3}, {2, 4}, {3, 4}, {4, 1}}, 
 
  {{1, 2}, {1, 3}, {2, 3}, {2, 4}, {4, 1}, {4, 3}}} ;

allbaseballs =
{{{1, 2}, {1, 2}, {1, 3}, {2, 4}, {3, 4}, {3, 4}}, 
 
  {{1, 2}, {1, 2}, {1, 3}, {2, 4}, {3, 4}, {4, 3}}, 
 
  {{1, 2}, {1, 2}, {1, 3}, {2, 4}, {4, 3}, {4, 3}}, 
 
  {{1, 2}, {1, 2}, {1, 3}, {3, 4}, {3, 4}, {4, 2}}, 
 
  {{1, 2}, {1, 2}, {1, 3}, {3, 4}, {4, 2}, {4, 3}}, 
 
  {{1, 2}, {1, 2}, {1, 3}, {4, 2}, {4, 3}, {4, 3}}, 
 
  {{1, 2}, {1, 2}, {2, 3}, {3, 4}, {3, 4}, {4, 1}}, 
 
  {{1, 2}, {1, 2}, {2, 3}, {3, 4}, {4, 1}, {4, 3}}, 
 
  {{1, 2}, {1, 2}, {3, 1}, {3, 4}, {4, 2}, {4, 3}}, 
 
  {{1, 2}, {1, 3}, {2, 1}, {2, 4}, {3, 4}, {4, 3}}, 
 
  {{1, 2}, {1, 3}, {2, 1}, {3, 4}, {4, 2}, {4, 3}}} ;



ladderer = {{1, 1}, {1, 2}, {3, 3}, {3, 2}, {2, 4}, {5, 4},
	{5, 5}, {6, 4}, {6, 6}}  ;