[NKS book material:]
Multiway system operator equivalences {mwos-1.eps, mwos-2.eps}
[NKS book material:]
Multiway system operator equivalences {mwos-1.eps, mwos-2.eps}
Multiway system operator equivalences {mwos-1.eps, mwos-2.eps}
mwos-1.eps
mwos-1.eps
CCheckAxiom[{f[f[a,b],c]==f[a,f[b,c]],f[a,b]f[b,a]},2,2000]
{{{0,1,1,0},{1,0,0,0},{1,0,0,1},{1,1,1,0},{1,1,1,1},{0,0,0,0}},6}
CCheckAxiom[{f[f[a,b],c]==f[a,f[b,c]],f[a,b]f[b,a]},3,2000]
{{{0,0,0,0,1,0,0,0,0},{0,0,0,0,2,0,0,0,0},{0,0,1,0,0,1,1,1,0},{0,0,2,0,0,2,2,2,0},{0,1,0,1,0,1,0,1,0},{0,1,0,1,1,1,0,1,0},{0,1,1,1,1,1,1,1,1},{0,1,2,1,1,1,2,1,0},{0,2,0,2,1,0,0,0,0},{0,2,1,2,1,0,1,0,2},{0,2,2,2,0,0,2,0,0},{0,2,2,2,1,0,2,0,0},{1,0,0,0,0,0,0,0,0},{1,0,1,0,1,0,1,0,1},{1,0,2,0,2,1,2,1,0},{1,1,0,1,1,0,0,0,0},{1,1,0,1,1,0,0,0,1},{1,1,1,1,1,1,1,1,0},{1,1,1,1,1,1,1,1,1},{1,1,1,1,1,1,1,1,2},{1,1,2,1,1,1,2,1,0},{1,2,0,2,1,0,0,0,0},{1,2,1,2,1,2,1,2,1},{1,2,2,2,1,1,2,1,0},{1,2,2,2,1,1,2,1,1},{2,0,0,0,0,0,0,0,0},{2,0,0,0,1,0,0,0,0},{2,0,0,0,2,2,0,2,2},{2,1,0,1,0,0,0,0,0},{2,1,0,1,0,1,0,1,0},{2,1,0,1,0,2,0,2,1},{2,1,0,1,1,0,0,0,0},{2,1,0,1,1,0,0,0,1},{2,1,0,1,1,1,0,1,0},{2,1,0,1,1,1,0,1,1},{2,1,0,1,1,1,0,1,2},{2,1,0,1,2,0,0,0,0},{2,1,1,1,1,1,1,1,0},{2,1,1,1,1,1,1,1,1},{2,1,1,1,2,2,1,2,2},{2,1,2,1,1,1,2,1,0},{2,1,2,1,1,1,2,1,2},{2,1,2,1,2,1,2,1,0},{2,1,2,1,2,1,2,1,2},{2,2,0,2,1,0,0,0,0},{2,2,0,2,1,0,0,0,2},{2,2,0,2,2,0,0,0,0},{2,2,0,2,2,0,0,0,2},{2,2,2,2,0,0,2,0,0},{2,2,2,2,0,1,2,1,0},{2,2,2,2,0,2,2,2,2},{2,2,2,2,1,0,2,0,0},{2,2,2,2,1,0,2,0,1},{2,2,2,2,1,0,2,0,2},{2,2,2,2,1,1,2,1,0},{2,2,2,2,1,1,2,1,1},{2,2,2,2,1,2,2,2,0},{2,2,2,2,1,2,2,2,2},{2,2,2,2,2,1,2,1,0},{2,2,2,2,2,2,2,2,0},{2,2,2,2,2,2,2,2,1},{2,2,2,2,2,2,2,2,2},{0,0,0,0,0,0,0,0,0}},63}
CodePictureLabelled[c_,k_:2]:=Module{d=.3,dm,do=.1},dm=1-d;GraphicsRaster[.85(1-(Reverse[Partition[IntegerDigits[c,k,k^2],k]])/(k-1))],GrayGrid[{0,0},{k,k}],TableEdgedRectangle{do-dm,i+d},{do-d,i+dm},GrayLevel0.851-,{i,0,k-1},TableEdgedRectangle{d+i,k+d-do},{i+dm,k+dm-do},GrayLevel0.851-,{i,0,k-1},AspectRatioAutomatic
i
k-1
k-1-i
k-1
opss={{0,2},{8,2},{9,2},{81,3},{162,3},{2460,3},{19539,3},{2100224,4},{800768,4}};
Show[GraphicsRow[ListLabelWrapper[CodePictureLabelled@@@opss],0.02]];
PSWrite["mwos-1.eps",%,1.083NoteColumn];
mwos-2.eps
mwos-2.eps
allstr::usage="allstr[n] makes the first n-1 strings starting from A, as allstr[1] returns an empty list.";
EquivClasses::usage="EquivClasses[matrix, strings] finds the equivalence classes of strings using the matrix, returning a list of lists of strings. Two strings are related if the word they give, gives the same operator. For example, AB is the pattern A_B_, and the matrix gives an operation which takes two elements and makes another element. Hence a rank two tensor, and in this case retrieves the original matrix.";
opss::usage="opss are some interesting operators, of the form, {key, dimension}.";
StringValue::usage="StringValue[matrix,string] gives the operator value of the string, given the original binary matrix operator. It is only functional with strings of A's and B's.";
blackorder::usage="blackorder puts B's before A's, and for lists of strings, arranges them in terms of their smallest strings, again listing B's before A's. It assumes that the lists are disjoint, as is the case in Equivalence Classes.";
blacksort::usage="Sorts lists of lists of strings using blackorder.";
OppsEquivGraphic::usage="OppsEquivGraphic[i, scale] makes the ith graphic from opss where scale determines how much data goes into the picture.";
eqc2::usage=" The function eqc2[i, k] puts the first k strings, from allstr, into equivalence classes using operator i, from opss. When more data is needed, k is increased is 2^length -1.";
eqlens::usage="The data in eqlens are the number of strings in each equivalence class for each operator. Note that each operator has at least one equivalence class that has an infinite number of elements because each operator has a finite number of equivalence classes.";
mnl::usage="Returns {max, number}, the maximum number of strings in each equivalence class, and how many equivalence classes will be shown.";
allstr[j_]:=Rest[Table[StringJoin[Rest[IntegerDigits[i,2]]/.{1"B",0"A"}],{i,j}]]
EquivClasses[m_,strings_]:=(Last/@#)&/@Split[Sort[#],First[#1]First[#2]&]&[{StringValue[m,#],#}&/@strings]
StringValue[mm_,str_String]:=Module[{m=mm+1,l,len=Length[mm]},Table[l=Characters[str]/.{"A"i,"B"j};Fold[m[[#1,#2]]&,First[l],Rest[l]],{i,len},{j,len}]]
blackorder[str1_String,str2_String]:=OrderedQ[Map[(Characters[#]/.{"B"0,"A"1})&,{str1,str2}]]
blackorder[a_List,b_List]:=OrderedQ[First/@Sort/@Map[(Characters[#]/.{"B"0,"A"1})&,{a,b}]]
blacksort[a_List]:=Sort[#,blackorder]&/@Sort[a,blackorder]
othermat2[o_]:=Module[{m=Partition[IntegerDigits[o[[1]],o[[2]],o[[2]]^2],o[[2]]]},Reverse[Reverse/@m]]
eqc[n_]:=Module[{m=othermat2[opss[[n]]]},blacksort[EquivClasses[m,allstr[60]]]]
eqc2[n_,k_Integer]:=Module[{m=othermat2[opss[[n]]]},blacksort[EquivClasses[m,allstr[k]]]]
mnl[a_List][n_Integer]:=Module[{cnt=0,tmp=0,tmplist,mx,lo},While[tmp≤n&&cnt<100,tmp+=Count[a,x_/;x>cnt,1];cnt++];mx=If[cnt>3,cnt-2,2];tmplist=FoldList[Plus,0,a/.y_/;y>mxmx+1];lo=If[FreeQ[tmplist,y_/;y>n,1],Length[a],Position[tmplist,y_/;y>n,1,1][[1,1]]-2];{mx,lo}]
enoughQ[data_List,a_List,{mx_Integer,lo_Integer}]:=Module[{dl=Length/@Take[data,lo],aa=Take[a,lo]/.y_/;y>mxmx+1},Apply[And,Map[NonNegative,dl-aa]]]
eqlens={{1,1,Infinity},{Infinity,Infinity,Infinity},{Infinity,Infinity,Infinity,Infinity},{1,1,Infinity,Infinity,Infinity},{1,1,1,2,1,Infinity},{1,1,Infinity,Infinity,Infinity,Infinity},{Infinity,Infinity,Infinity},{1,1,1,2,1,Infinity,Infinity,Infinity},{1,1,1,2,1,1,6,1,Infinity}};
makedata[ind_Integer,{mx_,lo_}]:=Module[{data=blacksort[eqc2[ind,63]],cnt=6},While[Not[enoughQ[data,eqlens[[ind]],{mx,lo}]],cnt++;data=blacksort[eqc2[ind,2^cnt-1]]];data]
GraphicsRowX[list_List,spacing_:0.1,opts___]:=Module[{as},as=(1/FullOptions[#1,AspectRatio]&)/@list;as=Partition[FoldList[Plus,0,as],2,1];Graphics[Table[Rectangle[{as[[i,1]]+(i-1)*spacing,0},{as[[i,2]]+(i-1)*spacing,1},list[[i]]],{i,Length[list]}],opts,AspectRatioAutomatic,PlotRange{{0,as[[Length[list],2]]+(Length[list]-1)*spacing},{0,1}}]]
EquivGraphic[data_]:=Module[{mx=3,allbut,noc=7,δ=.2},If[Length[data]>3,mx=2];allbut=Plus@@Length/@Take[data,Length[data]-1];If[allbut<7,mx=9-allbut];If[Count[data,x_/;Length[x]>2,1]>3,noc=5];If[Length[#]>noc,GraphicsRowX[{FramedGraphicsRow[Take[#,noc],PlotRangeTight],Graphics[Text[NKSStringForm["… (``)",Length[#]],{0,0}],AspectRatio.5]}],FramedGraphicsRow[#,PlotRangeTight]]&[GraphicsRowX[If[Length[#]>mx,Append[Take[#,mx],Graphics[Text[NKSStringForm["…"],{0,0}],AspectRatio1]],#]]&[Show[GridGraphics[{Characters[#]/.{"A".15,"B"1}}],DisplayFunctionIdentity,PlotRange{{-δ,δ+StringLength[#]},{-δ,1+δ}}]&/@#,-.02]&/@blacksort[data]]]
NOTE: aa==a is a kludge....
(blank line at end is necessary...)