(* ::Package:: *)

(*Author:       Klaus Sutner*)
(*Affiliation:  Carnegie Mellon University*)
(*email:        sutner@cs.cmu.edu*)
(*url:          http://www.cs.cmu.edu/~sutner*)
(*version:      1.0*)

(* this file is generated by TanglePaclet, do not edit *)

BeginPackage["KlausSutner`Automata`Cellaut`",{"KlausSutner`Automata`Utils`","KlausSutner`Automata`Fsm`"}];




CA::usage = "CA[w,k,r] represents a cellular automaton of width w, alphabet k and rule number r.";
ECA::usage = "ECA[r] represents elementary cellular automaton with rule number r. Converts to CA[3,2,r].";
WidthCA::usage = "WidthCA[C] returns the width of a cellular automaton.";
AlphabetCountCA::usage = "AlphabetCountCA[C] returns the size of the alphabet of a cellular automaton.";
RuleCA::usage = "RuleCA[C] returns the rule numbew of a cellular automaton.";
LocalMapCA::usage = "LocalMapCA[f,C] assigns to f the local map of cellular automaton C.";
DomCodomCA::usage = "DomCodomCA[C] returns the domain and codomain of the local map of cellular automaton C.";
GlobalMapCA::usage = "GlobalMapCA[f,C] assigns to f the global map of cellular automaton C.";
ConvertToCA::usage = "ConvertToCA[f,w,k] returns the cellular automaton defined by local map f.";
ToFredkinCA::usage = "ToFredkinCA[C] returns the Fredkin automaton associated with cellular automaton C.";
ToWidthTwoCA::usage = "ToWidthTwoCA[C] returns the width-2 cellular automaton corresponding to C.";
ComposeCA::usage = "ComposeCA[C1,C2] composes the cellular automata C1 and C2.";
SeedConfiguration::usage = "SeedConfiguration[args] produces a seed configuration for a cellular automaton.";
OrbitCA::usage = "OrbitCA[C,X,t] returns the t-step orbit of configuration X under cellular automaton C.";
PrintCA::usage = "PrintCA[C] prints the rule table of cellular automata C.";
ToSemiautomatonCA::usage = "ToSemiautomatonCA[C] converts cellular automaton C into a semi-automaton.";
BalancedQCA::usage = "BalancedQCA[C] checks if cellular automaton C is balanced.";
ClassifyCA::usage = "ClassifyCA[C] tests whether a cellular automaton C is surjective, open or injective.";
ToWelchAutomatonCA::usage = "ToWelchAutomatonCA[C] converts cellular automaton C into the corresponding Welch automata.";
InverseCA::usage = "InverseCA[C] constructs the inverse cellular automaton.";
ShrinkCA::usage = "ShrinkCA[C] removes useless variables at either end of the local map of cellular automaton C.";
ShiftOrbit::usage = "ShiftOrbit[orb,k] right-shifts an orbit by k places.";
Begin["`Private`"];
SyntaxInformation[CA] = {"ArgumentsPattern"->{_,_,_}};
SyntaxInformation[ECA] = {"ArgumentsPattern"->{_}};
ECA[r_Integer?NonNegative] := CA[3,2,r];
SyntaxInformation[WidthCA] = {"ArgumentsPattern"->{_}};
Attributes[WidthCA]={Listable};
WidthCA[CA[w_,k_,r_]] := w;
SyntaxInformation[AlphabetCountCA] = {"ArgumentsPattern"->{_}};
Attributes[AlphabetCountCA]={Listable};
AlphabetCountCA[CA[w_,k_,r_]] := k;
SyntaxInformation[RuleCA] = {"ArgumentsPattern"->{_}};
Attributes[RuleCA]={Listable};
RuleCA[CA[w_,k_,r_]] := r;
Attributes[LocalMapCA] = {HoldFirst};
Options[LocalMapCA] = {"KAdic"->True};
LocalMapCA[ ff_, ca_CA, opts : OptionsPattern[] ] := 
(
	ClearAll[ff];
	AssignFunction[ ff, Sequence@@DomCodomCA[ca], "KAdic"->OptionValue["KAdic"] ]
);
SyntaxInformation[DomCodomCA] = {"ArgumentsPattern"->{_,OptionsPattern[]}};
Options[DomCodomCA]={Full->True};
DomCodomCA[ca_CA,OptionsPattern[]] := 
With[ {r = RuleCA[ca], w = WidthCA[ca], k = AlphabetCountCA[ca]},
	With[ {res = { IntegerDigits[Range[0, k^w - 1], k, w],
				Reverse[IntegerDigits[r, k, k^w]] } },
		If[OptionValue[Full], res, Rule@@@Pairs@@res ] ] ];
SyntaxInformation[GlobalMapCA] = {"ArgumentsPattern"->{_,_,OptionsPattern[]}};
Options[GlobalMapCA]={"Boundary"->"Cyclic","BoundaryZero"->0};
Attributes[GlobalMapCA]={HoldFirst};
GlobalMapCA[ ff_, ca_CA, opts:OptionsPattern[] ] := 
Module[ {w,w2,loc},
    ClearAll[ff];
    w  = WidthCA[ca];
    w2 = Ceiling[w/2];
    LocalMapCA[loc,ca,"KAdic"->False];
    ff = Switch[ OptionValue["Boundary"],
     	    "Cyclic", loc /@ Partition[#,w,1,w2]&,
     	    "Fixed"|"Periodic",  loc /@ Partition[#,w,1,w2,OptionValue["BoundaryZero"]]&,
     	    None,     loc /@ Partition[#,w,1]&
         ];
];
SyntaxInformation[ConvertToCA] = {"ArgumentsPattern"->{_,_,_,OptionsPattern[]}};
Options[ConvertToCA]={Type->Function};
ConvertToCA[ ff_, w_Integer?Positive, k_Integer?Positive, opts:OptionsPattern[] ] := 
Module[ {A,r},
	A = Tuples[ Range[0,k-1], w ];
	r = Switch[ OptionValue[Type],
			Function, ff@@@A,
			Rule,     A /. ff,
			Boole,    Boole[ ff@@@UnBoole[A] ]
		];
	CA[ w, k, FromDigits[Reverse[r],k] ]
];
SyntaxInformation[ToFredkinCA] = {"ArgumentsPattern"->{_,OptionsPattern[]}};
ToFredkinCA[ ca_CA ] := 
Module[ {f, ff, k = AlphabetCountCA[ca], w = WidthCA[ca]},
    	LocalMapCA[ f, ca ];
    	ff[xx__] := With[ { zz = Mod[{xx}, k ], ci = Ceiling[w/2] },
			  k zz[[ci]] + Mod[ f @@ zz + Quotient[{xx}[[ci]], k], k] ];
    	ConvertToCA[ff, w, k^2]
];
SyntaxInformation[ToWidthTwoCA] = {"ArgumentsPattern"->{_,OptionsPattern[]}};
ToWidthTwoCA[ca_CA] := 
Module[ {w, k, ff},
	w = WidthCA[ca];
	k = AlphabetCountCA[ca];
	GlobalMapCA[ff, ca, "Boundary" -> None];
	CA[ 2, k^(w - 1), 
	    FromDigits[ Reverse[FromDigits[#,k]& /@ (ff /@ Tuples[Range[0,k-1],2w-2]) ], 
		       k^(w - 1)] ]
];
SyntaxInformation[ComposeCA] = {"ArgumentsPattern"->{_,_,OptionsPattern[]}};
ComposeCA[ C1_CA, C2_CA, opts:OptionsPattern[] ] :=
Module[ {k,alph,w,f1,f2,B,norm},
	w = WidthCA[C1] + WidthCA[C2] - 1;
	k = AlphabetCountCA[C1];
	GlobalMapCA[ f1, C1, "Boundary"->None];
	LocalMapCA[ f2, C2, "KAdic"->False];
	B = f2[f1[#]]& /@ Reverse[Tuples[Range[0,k-1],w]];
	CA[ w, k, FromDigits[B,k] ]
]  /;  AlphabetCountCA[C1]===AlphabetCountCA[C2];

ComposeCA[C1_CA,C2_CA,ca__CA,opts:OptionsPattern[]] := 
         ComposeCA[ComposeCA[C1,C2,opts],ca,opts];
ComposeCA[ca_CA,opts:OptionsPattern[]] := ca;
SyntaxInformation[SeedConfiguration] = {"ArgumentsPattern"->{_,_.,OptionsPattern[]}};
Options[SeedConfiguration]={Alignment->Center,Padding->0,"RandomDigits"->0};
SeedConfiguration[n_Integer?Positive,opts:OptionsPattern[]]:=
	SeedConfiguration[{1},n,opts];
SeedConfiguration[s_Integer?NonNegative,n_Integer?Positive,opts:OptionsPattern[]]:=
	SeedConfiguration[{s},n,opts];
SeedConfiguration[s_List,n_Integer?Positive,opts:OptionsPattern[]]:=
Module[{rnd,whr,pad,typ},
	If[0<(rnd=OptionValue["RandomDigits"]),
		Return[RandomInteger[{0,rnd-1},n]]];
	whr=OptionValue[Alignment];
	pad=OptionValue[Padding];
	Flatten[Switch[whr,
			Center,PadLeft[s,n,pad,Floor[1/2 (n-Length[s])]],
			Right,PadLeft[s,n,pad],
			_,PadRight[s,n,pad]]
	]
];
SyntaxInformation[OrbitCA] = {"ArgumentsPattern"->{_,_,_.,OptionsPattern[]}};
Options[OrbitCA]={"Boundary"->"Cyclic","BoundaryZero"->0};
OrbitCA[ ca_CA, pat_List, t_Integer:40, opts:OptionsPattern[] ] := 
Module[ {rho},
	GlobalMapCA[ rho, ca, SelectOptions[GlobalMapCA,opts] ];
	NestList[ rho, pat, t ]
];
SyntaxInformation[PrintCA] = {"ArgumentsPattern"->{_,OptionsPattern[]}};
PrintCA[ca_CA] :=
Module[ {rules,k,A,res},
	rules = DomCodomCA[ca,Full->False];
	k = AlphabetCountCA[ca];
	Assert[ k<8, "Alphabet too large."];
	A = AlphabetList[Alpha[k,<|"AlphabetType"->"Digit"|>]];
	rules = MapAt[StringJoin[A[[#+1]]]&, rules,{All,1}];
	res = Switch[ WidthCA[ca],
		1,    {rules},
		2|3,  Partition[ rules, AlphabetCountCA[ca]^(WidthCA[ca]-1) ],
		_,    Partition[ rules, AlphabetCountCA[ca]^(WidthCA[ca]-2) ]
	];
	TableForm[Thread[res],TableSpacing->{1,2}]
];
SyntaxInformation[ToSemiautomatonCA] = {"ArgumentsPattern"->{_,OptionsPattern[]}};
Options[ToSemiautomatonCA]={StateType->"Indexed"};
ToSemiautomatonCA[ca_CA,opts:OptionsPattern[]]:=
Module[{w,k,n,A,lb,tr,G},
	w = WidthCA[ca];
	k = AlphabetCountCA[ca];
	n = k^(w-1);
	A = Alpha[k, <|"AlphabetType"->"Digit", "AlphabetOffset"->0|> ];
	lb = Reverse@IntegerDigits[RuleCA[ca],k,k^w]+1;
	tr = DirectedEdge@@@Pairs[Flatten@Thread@Table[Range[n],{k}],Flatten@Table[i,{k},{i,n}],lb];
	G = Graph[ tr ];
	Switch[ OptionValue[StateType],
		"Indexed", None,
		"Shallow", V = CartesianProduct@@Table[Range[k],{w-1}];
				G = VertexReplace[ G, Thread[VertexList[G]->V] ],
		"Words", V = Words[{w-1},A];
				G = VertexReplace[ G, Thread[VertexList[G]->V] ]
	];
	FA[ TSys[ n, k, G, 
		Alpha[k, <|"AlphabetType"->"Digit", "AlphabetOffset"->0|> ], 
		<| "TransType"->TransitionType[n,k,G] |>], 
		<| "AccCond"->Existential[All, All],"Special"->"MultiEntry" |> ]
];
SyntaxInformation[BalancedQCA] = {"ArgumentsPattern"->{_,OptionsPattern[]}};
Options[BalancedQCA] = {Full->False};
BalancedQCA[ ca_CA, opts : OptionsPattern[] ] := 
With[ {cod = Last@DomCodomCA[ca],cnt = AlphabetCountCA[ca]^(WidthCA[ca]-1)},
	If[ OptionValue[Full], 
		Frequencies[cod],
		Union[Last/@Tally[cod]] === {cnt}
	]
];
SyntaxInformation[ClassifyCA] = {"ArgumentsPattern"->{_,OptionsPattern[]}};
Options[ClassifyCA]={Full->False};
ClassifyCA[ca_CA,opts:OptionsPattern[]]:=
Module[{n,T,G,scc,ntscc,sccind,ed,H,HH,diag,res},
	If[ !BalancedQCA[ca], Return[0] ];
	n = AlphabetCountCA[ca]^(WidthCA[ca]-1);
	T = TransitionSystem@ToSemiautomatonCA[ca];
	G = TransitionSystemGraph[ProductTransitionSystem[T,StateType->"Shallow"]];
	{scc,ntscc,sccind} = StronglyConnectedComponents[G];
	{H,scc,ntscc} = Most@CondensationGraph[G,Full->True,Type->"Shallow"];
	diag = First@Select[scc,MemberQ[#,{1,1}]&];
	HH = Subgraph[H,Intersection[
		FlattenOne[VertexOutComponent[H,#]& /@ ntscc],
		FlattenOne[VertexOutComponent[ReverseGraph@H,#]& /@ ntscc]
		]];

	res = Which[ 
			Length[diag] != n,        0, 
			Length[ntscc]==1,         3,
			VertexDegree[HH,diag]==0, 2,
			True,                     1 ];
	If[ OptionValue[Full], Sow[{res,H,HH,scc,ntscc}] ];
	res
];
SyntaxInformation[ToWelchAutomatonCA] = {"ArgumentsPattern"->{_,OptionsPattern[]}};
Options[ToWelchAutomatonCA]={Full->True};
ToWelchAutomatonCA[ca_CA,opts:OptionsPattern[]]:=
Module[{sa,mr,mxr,pos,Wr,ml,mxl,Wl,nwm},
	sa = ToSemiautomatonCA[ca];
(* right Welsh *)
	mr  = ToKernelFA[ sa, {1}, Full->True ];
	mxr = Max[ Length/@ StateList[mr] ];
	pos = Select[StateList[mr],Length[#]==mxr&];
	Wr  = CloneFA[ SubAutomatonFA[mr, pos, StateType->"Deep"], 
			"InitialStates"->{1}, "FinalStates"->All ];
(* left Welsh *)
	ml  = ToKernelFA[ ReverseFA[sa],{1},Full->True];
	mxl = Max[ Length/@ StateList[ml] ];
	pos = Select[StateList[ml],Length[#]==mxl&];
	Wl  = CloneFA[ SubAutomatonFA[ ml, pos,  StateType->"Deep" ], 
			"InitialStates"->{1}, "FinalStates"->All ];
	nwm = AlphabetCountCA[ca]^(WidthCA[ca]-1)/(mxl mxr);
	If[ OptionValue[Full],
		{{mxl,nwm,mxr},{Wl,Wr}},
		{mxl,nwm,mxr}
	]
];
SyntaxInformation[InverseCA] = {"ArgumentsPattern"->{_,OptionsPattern[]}};
Options[InverseCA]={};
InverseCA[CA[1,k_Integer,r_Integer]]:=
Module[{lab},
	LocalMapCA[lab, CA[1,k,r], Full->True ];
	Assert[PermutationListQ[lab+1]];
	CA[ 1, k, FromDigits[ Reverse[InversePermutation[lab+1]-1], k ] ]
];
InverseCA[ca_CA,opts:OptionsPattern[]]:=
Module[{k,ll,wi,Wl,Wr,dql,defl,dqr,defr,ww,sa,Ll,Lr,rule,rk},
	k = AlphabetCountCA[ca];
	ll = k^(WidthCA[ca]-1);
	{wi,{Wl,Wr}} = ToWelchAutomatonCA[ca];
	{dql,defl} = PropertyQFA[Wl,"Definite",Full->True];
	{dqr,defr} = PropertyQFA[Wr,"Definite",Full->True];
	ww = defl + defr;
	sa = ToSemiautomatonCA[ca];
	Lr = auxFullanguage[sa,defl];
	Ll = auxFullanguage[ReverseFA[sa],defr];
	Lr = (#[[2]]&/@#)& /@ GatherBy[ Lr, First ];
	Ll = Map[ Reverse,(#[[2]]&/@#)& /@ GatherBy[ Ll, First ],{2} ];
	rule = Last /@ Sort@FlattenOne@MapIndexed[ 
		(Flatten/@CartesianProduct@@Join[#1,{#2}])&,Pairs[Ll,Lr]];
	rk = Thread[Range[ll]->Flatten[Thread[Table[Range[k]-1,{ll/k}]]]];
	CA[ ww, k, FromDigits[ Reverse[rule/.rk], k ] ]
];
auxFullanguage[M_FA,r_Integer]:=
Module[{n,tr,targ,extend},
	n = StateCount[M];
	tr = List@@@TransitionList[M];
	targ[p_Integer] := targ[p] = Reverse /@ Rest /@ Cases[tr,{p,_,_} ] ;
	extend[{p_Integer,L_List,q_Integer}] := 
		Table[ {p,Append[L,x[[1]]],x[[2]]}, {x,targ[q]} ];
	Union[Most /@ Nest[ FlattenOne[extend/@#]&, Table[ {p,{},p}, {p,n} ], r ]]
];
SyntaxInformation[ShrinkCA] = {"ArgumentsPattern"->{_,OptionsPattern[]}};
ShrinkCA[ CA[w_Integer, k_Integer, r_Integer ] ]:= 
	ShrinkCA[ IntegerDigits[r,k,k^w], k ];
ShrinkCA[ rr_List,k_Integer]:= 
Module[ {red},
	red = FixedPoint[ auxDepFirst[#,k]&,rr,10 ];
	red = FixedPoint[ auxDepLast[#,k]&,red,10 ];
	CA[ PadicOrder[Length[red],k], k, FromDigits[red,k] ]
];

auxDepFirst[L_List, k_Integer] := 
  With[{part =  Partition[L, Length[L]/k]},
   If[ SameQ@@part, First@part, L]];

auxDepLast[L_List, k_Integer] := 
With[{part = Partition[L, k]}, 
   If[AllTrue[part, SameQ @@ #1 & ], First /@ part, L]];
SyntaxInformation[ShiftOrbit] = {"ArgumentsPattern"->{_,_.}};
ShiftOrbit[orb_?MatrixQ,k_Integer:1] := 
	MapIndexed[RotateRight[ #1, k #2 ]&, orb];
WidthCA::args = "Wrong argument(s), try WidthCA[C]";
WidthCA[__] := $Failed /; Message[WidthCA::args];
AlphabetCountCA::args = "Wrong argument(s), try AlphabetCountCA[C]";
AlphabetCountCA[__] := $Failed /; Message[AlphabetCountCA::args];
RuleCA::args = "Wrong argument(s), try RuleCA[C]";
RuleCA[__] := $Failed /; Message[RuleCA::args];
LocalMapCA::args = "Wrong argument(s), try LocalMapCA[f,C]";
LocalMapCA[__] := $Failed /; Message[LocalMapCA::args];
DomCodomCA::args = "Wrong argument(s), try DomCodomCA[C]";
DomCodomCA[__] := $Failed /; Message[DomCodomCA::args];
GlobalMapCA::args = "Wrong argument(s), try GlobalMapCA[f,C]";
GlobalMapCA[__] := $Failed /; Message[GlobalMapCA::args];
ConvertToCA::args = "Wrong argument(s), try ConvertToCA[f,w,k]";
ConvertToCA[__] := $Failed /; Message[ConvertToCA::args];
ToFredkinCA::args = "Wrong argument(s), try ToFredkinCA[C]";
ToFredkinCA[__] := $Failed /; Message[ToFredkinCA::args];
ToWidthTwoCA::args = "Wrong argument(s), try ToWidthTwoCA[C]";
ToWidthTwoCA[__] := $Failed /; Message[ToWidthTwoCA::args];
ComposeCA::args = "Wrong argument(s), try ComposeCA[C1,C2]";
ComposeCA[__] := $Failed /; Message[ComposeCA::args];
SeedConfiguration::args = "Wrong argument(s), try SeedConfiguration[args]";
SeedConfiguration[__] := $Failed /; Message[SeedConfiguration::args];
OrbitCA::args = "Wrong argument(s), try OrbitCA[C,X,t]";
OrbitCA[__] := $Failed /; Message[OrbitCA::args];
PrintCA::args = "Wrong argument(s), try PrintCA[C]";
PrintCA[__] := $Failed /; Message[PrintCA::args];
ToSemiautomatonCA::args = "Wrong argument(s), try ToSemiautomatonCA[C]";
ToSemiautomatonCA[__] := $Failed /; Message[ToSemiautomatonCA::args];
BalancedQCA::args = "Wrong argument(s), try BalancedQCA[C]";
BalancedQCA[__] := $Failed /; Message[BalancedQCA::args];
ClassifyCA::args = "Wrong argument(s), try ClassifyCA[C]";
ClassifyCA[__] := $Failed /; Message[ClassifyCA::args];
ToWelchAutomatonCA::args = "Wrong argument(s), try ToWelchAutomatonCA[C]";
ToWelchAutomatonCA[__] := $Failed /; Message[ToWelchAutomatonCA::args];
InverseCA::args = "Wrong argument(s), try InverseCA[C]";
InverseCA[__] := $Failed /; Message[InverseCA::args];
ShrinkCA::args = "Wrong argument(s), try ShrinkCA[C]";
ShrinkCA[__] := $Failed /; Message[ShrinkCA::args];
ShiftOrbit::args = "Wrong argument(s), try ShiftOrbit[orb,k]";
ShiftOrbit[__] := $Failed /; Message[ShiftOrbit::args];
Protect[{
WidthCA,AlphabetCountCA,RuleCA,LocalMapCA,DomCodomCA,GlobalMapCA,ConvertToCA,ToFredkinCA,ToWidthTwoCA,ComposeCA,SeedConfiguration,OrbitCA,PrintCA,ToSemiautomatonCA,BalancedQCA,ClassifyCA,ToWelchAutomatonCA,InverseCA,ShrinkCA,ShiftOrbit}];
End[];
EndPackage[];
