lamp={{1,0}{1,1},{1,1}{2,0},{2,1}{1,1},{2,0}{2,0}};
FAStep
FAStep
FAStep::usage="FAStep[rule, init, list] applies the finite automaton represented by rule to list, starting with state init.";
FAStep[rule_,init_,list_]:=FoldList[{First[#1],#2}/.rule&,{init},list]
FAMap::usage="FAMap[rule, init, n] generates the mapping corresponding to finite automaton rule for sequences of length n.";
FAMap[rule_,init_,n_]:=With[{k=1+Max[#[[1,2]]&/@rule]},Table[{i,FromDigits[Last/@Rest[FAStep[rule,init,IntegerDigits[i,k,n]]],k]},{i,0,k^n-1}]]
FAApply[rule_,s0_,list_]:=FoldList[{First[#1],#2}/.rule&,{s0},list]
The following should really be equivalent to the above FAStep[ ]....
XFAStep[rule_,s0_,list_]:=Map[Last,Rest[FoldList[{First[#1],#2}/.rule&,{s0},list]]]
XFAEvolveList[rule_,s0_,init_,t_]:=NestList[XFAStep[rule,s0,#]&,init,t]
GFAEvolveList[rule_,seq_,init_]:=FoldList[XFAStep[rule,#2,#]&,init,seq]
GFAEvolve[rule_,seq_,init_]:=Fold[XFAStep[rule,#2,#]&,init,seq]
FA enumeration
FA enumeration
Tuples[list_,n_]:=Flatten[Outer[List,##,1]&@@Table[list,{n}],n-1]
AllFAs[s_,k_]:=With[{lhs=Flatten[Outer[List,Range[s],Range[0,k-1],1],1]},Thread[lhs#]&/@(Partition[#,2]&/@Flatten[Outer[List,##,1]&@@Flatten[Table[{Range[s],Range[0,k-1]},{sk}],1],2sk-1])]
ToFARule[n_Integer,{s_Integer,k_Integer}]:=Flatten[MapIndexed[{1,-1}#2+{0,k}Mod[Quotient[#1,{k,1}],{s,k}]+{1,0}&,Partition[IntegerDigits[n,sk,sk],k],{2}]]
Group functions
Group functions
GroupFAQ[fa_]:=Apply[And,Apply[UnsameQ,Table[Cases[fa,({i,_}{_,y_})y],{i,Min[#[[1,1]]&/@fa],Max[#[[1,1]]&/@fa]}],{1}]]
SimplifyWord::usage="SimplifyWord[{,,...}] contracts consecutive entries when one is the GroupInverse of the other.";
a
1
a
2
SimplifyWord[word_List]:=First[SimplifyWord0[word]]
SimplifyWord0[{a___,b_,GroupInverse[b_],c___}]:=SimplifyWord0[{a,c}]
SimplifyWord0[{a___,GroupInverse[b_],b_,c___}]:=SimplifyWord0[{a,c}]
GroupInverse[GroupInverse[a_]]:=a
redundQ::usage="redundQ[u,v] gives True if word u is contained with word v.";
redundQ[{a__},{___,a__,___}]:=True
redundQ[_,_]:=False
redUnion::usage="redUnion[{,,...}] eliminates identities in later lists which contain an identity in a previous list.";
id
1
id
2
redUnion[ls_]:=Union[Flatten[Table[DeleteCases[ls[[i]],w_/;Select[Flatten[Take[ls,i-1],1],redundQ[#,w]&,1]≠{}],{i,Length[ls]}],1]]
Finite Automata groups
Finite Automata groups
InvertRule::usage="InvertRule[fa] inverts the finite automaton. A finite automaton is the result when the fa is invertible.";
InvertRule[fa_]:={#[[1,1]],#[[2,2]]}{#[[2,1]],#[[1,2]]}&/@fa
idQ::usage="idQ[fa,word,n,k] gives True if word acts as the Identity map on all list of symbols of length n with k colors. idQ[fa,word,n] assumes the number of colors is equal to 2.";
idQ[fa_,word_,n_,k_:2]:=Select[Tuples[Range[0,k-1],n],Fold[FAact[fa,#2,#1]&,#,word]=!=#&,1]==={}
FAact::usage="FAact[fa, letter, list] gives the action of the letter on the list of symbols. The letter may be either an integer or GroupInverse[letter].";
FAact[fa_,letter_Integer,list_]:=Last/@Rest[FAStep[fa,letter,list]]
FAact[fa_,GroupInverse[letter_Integer],list_]:=Last/@Rest[FAStep[InvertRule[fa],letter,list]]
FAact0[fa_,letter_Integer,list_]:=Rest[FAStep[fa,letter,list]]
FAact0[fa_,GroupInverse[letter_Integer],list_]:=Rest[FAStep[InvertRule[fa],letter,list]]
FAinduced::usage="FAinduced[rule, word, list] gives the final states reached for each letter, while applying word to the list. Effectively, list gives a homomorphism on word.";
FAinduced[rule_,word_,list_]:=MapThread[#1[#2]&,{(Head/@word)/.(IntegerIdentity),#[[-1,1]]&/@Rest[FoldList[FAact0[rule,#2,Last/@#1]&,List/@list,word]]}]
relations::usage="relations[fa, n, k] gives the words of length k which act by the Identity map on the symbol lists of length n.";
relations[fa_,symblen_,wordlen_]:=Select[Union[SimplifyWord/@Tuples[Flatten[Table[{i,GroupInverse[i]},{i,Min[#[[1,1]]&/@fa],Max[#[[1,1]]&/@fa]}]],wordlen]],idQ[fa,#,symblen]&]
FilterRelations::usage="FilterRelations[fa,n,k] gives the words of length k which act by the identity on symbol lists of length k.";
FilterRelations0[fa_,symblen_,wordls_]:=Select[Union[SimplifyWord/@wordls],idQ[fa,#,symblen]&]
FilterRelations[fa_,symblen_,wordlen_]:=Fold[FilterRelations0[fa,#2,#1]&,Tuples[Flatten[Table[{i,GroupInverse[i]},{i,Min[#[[1,1]]&/@fa],Max[#[[1,1]]&/@fa]}]],wordlen],Range[symblen]]
WordFilter::usage="WordFilter[fa,n,k] gives the identities up to length k on the symbol lists of length n. Words containing smaller identities are removed.";
WordFilter0[fa_,symblen_,wordlen_,rels_]:=Fold[FilterRelations0[fa,#2,#1]&,Select[Union[SimplifyWord/@Tuples[Flatten[Table[{i,GroupInverse[i]},{i,Min[#[[1,1]]&/@fa],Max[#[[1,1]]&/@fa]}]],wordlen]],Length[#]wordlen&&Select[rels,Function[prevrel,redundQ[prevrel,#]],1]{}&],Range[symblen]]
WordFilter[fa_,symblen_,wordlen_]:=Fold[Join[#1,WordFilter0[fa,symblen,#2,#1]]&,{},Range[wordlen]]
Graphic functions
Graphic functions
FAEvoGraphic[rule_,k_,l_]:=Graphics[Raster[Reverse[1-NestList[Last/@Rest[FAStep[rule,1,#]]&,Table[0,{l}],k]]]]
FAEvoGraphic[rule_,k_,l_,initstate_,initsymbs_]:=Graphics[Raster[Reverse[1-NestList[Last/@Rest[FAStep[rule,initstate,#]]&,Reverse[IntegerDigits[initsymbs,2,l]],k]]]]
FAEvoGraphic2[rule_,k_,l_,num_]:=Graphics[Raster[Reverse[1-NestList[Last/@Rest[FAStep[rule,1,#]]&,Table[0,{l}],k]]],PlotLabelnum]
FAEvoArray[rulelist_,k_,l_,wid_]:=GraphicsArray[Partition[FAEvoGraphic[#,k,l]&/@rulelist,wid,wid,1,Graphics[]]]
FAEvoArray2[rulelist_,k_,l_,wid_]:=GraphicsArray[Partition[MapIndexed[FAEvoGraphic2[#,k,l,#2[[1]]]&,rulelist],wid,wid,1,Graphics[]]]