Code 1 - SW’s
Code 1 - SW’s
In[]:=
mincase[rule_,s_Integer]:=First[Sort[Map[Sort,(rule/.#)&/@(Thread[Range[s]#]&/@Permutations[Range[s]]),{2}]]]
Code 2 - EdP’s
Code 2 - EdP’s
In[]:=
PutInStandardOrder[rule_Rule]:=Module[{alphabet,s,t,convertedrule,parts},alphabet=Union[Flatten[Table[rule[[n]],{n,1,Length[rule]}]]];s=Length[alphabet];convertedrule=rule/.Thread[alphabetRange[s]];parts=Table[SortBy[convertedrule[[n]],{-Length[#],-PadRight[Length/@Split[#],Length[#]],#}&],{n,1,2}];convertedrule=convertedrule/.Thread[DeleteDuplicates[Flatten[parts]]Range[s]];parts=Table[SortBy[convertedrule[[n]],{-Length[#],#}&],{n,1,2}];Rule@@parts]
In[]:=
CanonRule[rule_Rule]:=Module[{standard,r,s,partR,orderstart,ordering,parts},standard=PutInStandardOrder[rule];{r,s}=Table[Max[Flatten[standard[[n]]]],{n,1,Length[standard]}];If[s<r,s=r];partR=First[Sort[{SortBy[(standard[[1]]/.#),{-Length[#],#}&],Last/@#}&/@(Thread[Range[r]#]&/@Permutations[Range[r]])]];orderstart=partR[[2]];ordering=Switch[s-r,0,orderstart,1,Append[orderstart,s],_,Last[First[Sort[{SortBy[(standard[[2]]/.#),{-Length[#],#}&],Last/@#}&/@(Thread[Range[s]Join[orderstart,#]]&/@Permutations[Range[r+1,s]])]]]];parts=Table[SortBy[standard[[n]]/.Thread[Range[s]ordering],{-Length[#],#}&],{n,1,2}];Rule@@parts];
Code 3 - SushmaK’s merger
Code 3 - SushmaK’s merger
In[]:=
FindCanonicalWolframModel[rule_Rule]:=Module[{alphabet,s,t,convertedrule,parts},alphabet=Union[Flatten[Table[rule[[n]],{n,1,Length[rule]}]]];s=Length[alphabet];convertedrule=rule/.Thread[alphabetRange[s]];First[Sort[Map[SortBy[#,{-Length[#],#}&]&,(convertedrule/.#)&/@(Thread[Range[s]#]&/@Permutations[Range[s]]),{2}]]]]
Code 4 - EdP’s update
Code 4 - EdP’s update
In[]:=
NewPutInStandardOrder[rule_Rule]:=Module[{alphabet,s,t,convertedrule,convertedrule2,tally,parts,parts2},alphabet=Union[Flatten[Table[rule[[n]],{n,1,Length[rule]}]]];s=Length[alphabet];convertedrule=rule/.Thread[alphabetRange[s]];parts=Table[SortBy[convertedrule[[n]],{-Length[#],-PadRight[Length/@Split[#],Length[#]],#}&],{n,1,2}];convertedrule=convertedrule/.Thread[DeleteDuplicates[Flatten[parts]]Range[s]];parts=Table[SortBy[convertedrule[[n]],{-Length[#],#}&],{n,1,2}];tally=First/@SortBy[Tally[First[DeleteDuplicates[#]]&/@Select[Flatten[Join[parts],1],Length[#]>0&]],-Last[#]&];convertedrule2=convertedrule/.Thread[tallySort[tally]];parts2=Table[SortBy[convertedrule2[[n]],{-Length[#],#}&],{n,1,2}];First[Sort[{Rule@@parts,Rule@@parts2}]]]
In[]:=
NewCanonRule[rule_Rule]:=Module[{standard,r,s,partR,partS,orderstart,ordering,parts},standard=NewPutInStandardOrder[rule];{r,s}=Table[Max[Flatten[standard[[n]]]],{n,1,Length[standard]}];If[s<r,s=r];partR=First[Sort[{SortBy[(standard[[1]]/.#),{-Length[#],#}&],Last/@#}&/@(Thread[Range[r]#]&/@Permutations[Range[r]])]];partS=First[Sort[{SortBy[(standard[[2]]/.#),{-Length[#],#}&],Last/@#}&/@(Thread[Range[r]Prepend[#,1]]&/@Permutations[Range[2,r]])]];orderstart={partR[[2]],partS[[2]]};ordering=Switch[s-r,0,{orderstart[[1]],orderstart[[1]]},1,{Append[orderstart[[1]],s],Append[orderstart[[1]],s]},_,Table[Last[First[Sort[{SortBy[(standard[[2]]/.#),{-Length[#],#}&],Last/@#}&/@(Thread[Range[s]Join[orderstart[[k]],#]]&/@Permutations[Range[r+1,s]])]]],{k,1,2}]];parts=First[Sort[Table[Table[SortBy[standard[[n]]/.Thread[Range[s]ordering[[k]]],{-Length[#],#}&],{n,1,2}],{k,1,2}]]];Rule@@parts];
In[]:=
NewFindCanonicalWolframModel[rule_Rule]:=NewCanonRule[rule]
Tests
Tests
Example 1
Example 1
In[]:=
mincase[{{2,3,3}}{{3,2,2},{2,1,1}},3]//AbsoluteTiming
Out[]=
{0.000179,{{1,2,2}}{{1,3,3},{2,1,1}}}
In[]:=
CanonRule[{{2,3,3}}{{3,2,2},{2,1,1}}]//AbsoluteTiming
Out[]=
{0.000427,{{1,2,2}}{{1,3,3},{2,1,1}}}
In[]:=
FindCanonicalWolframModel[{{2,3,3}}{{3,2,2},{2,1,1}}]//AbsoluteTiming
Out[]=
{0.000328,{{1,2,2}}{{1,3,3},{2,1,1}}}
In[]:=
NewFindCanonicalWolframModel[{{2,3,3}}{{3,2,2},{2,1,1}}]//AbsoluteTiming
Out[]=
{0.000485,{{1,2,2}}{{1,3,3},{2,1,1}}}
Example 2
Example 2
In[]:=
mincase[{{a,e,d},{d,c},{c,b},{b,a}}{{}},5]//AbsoluteTiming
Out[]=
{0.003884,{{b,a},{c,b},{d,c},{a,e,d}}{{}}}
In[]:=
CanonRule[{{a,e,d},{d,c},{c,b},{b,a}}{{}}]//AbsoluteTiming
Out[]=
{0.003471,{{1,2,3},{3,4},{4,5},{5,1}}{{}}}
In[]:=
FindCanonicalWolframModel[{{a,e,d},{d,c},{c,b},{b,a}}{{}}]//AbsoluteTiming
Out[]=
{0.004121,{{1,2,3},{3,4},{4,5},{5,1}}{{}}}
In[]:=
NewFindCanonicalWolframModel[{{a,e,d},{d,c},{c,b},{b,a}}{{}}]//AbsoluteTiming
Out[]=
{0.003293,{{1,2,3},{3,4},{4,5},{5,1}}{{}}}
Example 3
Example 3
In[]:=
mincase[{{2,5},{5,2},{2,3,1},{5,0,4},{4,9,4,8}}{{7,11},{8,9},{9,8},{10,14},{11,7},{12,13},{13,12},{14,10},{1,8,7},{4,12,11},{9,10,3},{13,14,6},{9,8,7,2}},14]//AbsoluteTiming
In[]:=
CanonRule[{{2,5},{5,2},{2,3,1},{5,0,4},{4,9,4,8}}{{7,11},{8,9},{9,8},{10,14},{11,7},{12,13},{13,12},{14,10},{1,8,7},{4,12,11},{9,10,3},{13,14,6},{9,8,7,2}}]//AbsoluteTiming
Out[]=
FindCanonicalWolframModel[{{2,5},{5,2},{2,3,1},{5,0,4},{4,9,4,8}}{{7,11},{8,9},{9,8},{10,14},{11,7},{12,13},{13,12},{14,10},{1,8,7},{4,12,11},{9,10,3},{13,14,6},{9,8,7,2}}]//AbsoluteTiming
SystemException[MemoryAllocationFailure]
In[]:=
NewFindCanonicalWolframModel[{{2,5},{5,2},{2,3,1},{5,0,4},{4,9,4,8}}{{7,11},{8,9},{9,8},{10,14},{11,7},{12,13},{13,12},{14,10},{1,8,7},{4,12,11},{9,10,3},{13,14,6},{9,8,7,2}}]//AbsoluteTiming
Out[]=
Example 4
Example 4
In[]:=
mincase[{{1,1},{2,2}}{{2,2}},2]//AbsoluteTiming
Example 5: all 3 sub examples should produce same canonical form
Example 5: all 3 sub examples should produce same canonical form
mincase
mincase
CanonRule
CanonRule
FindCanonicalWolframModel
FindCanonicalWolframModel
NewFindCanonicalWolframModel
NewFindCanonicalWolframModel