You are using a browser not supported by the Wolfram Cloud
Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.
I understand and wish to continue anyway »
WOLFRAM NOTEBOOK
Ed’s Canonicalization
Ed’s Canonicalization
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]
CanonRule[rule_,s_]:=First[Sort[Sort[(rule/.#)]&/@(Thread[Range[s]#]&/@Permutations[Range[s]])]];(*ThisisWrong*)
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];
The steps followed in Ed’s code
The steps followed in Ed’s code
◼
Find Canonical form for LHS.. Find the integer ordering of the canonical form
◼
Use the ordering to canonicalize the RHS..
Example
Example
{{1,1},{2,2}}{{2,2}}
{{1,1},{2,2}}{{1,1}}
Canonicalize the LHS and determine that ordering is {1->1, 2->2}
Canonicalize the RHS using {1->1,2->2}
SW’s Canonicalization
SW’s Canonicalization
Canonicalization
Canonicalization
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]];First[Sort[Map[SortBy[#,{-Length[#],#}&]&,(convertedrule/.#)&/@(Thread[Range[s]#]&/@Permutations[Range[s]]),{2}]]]]
In[]:=
PutInStandardOrder[{{1,1,1},{2,2}}{{2,2}}]
Out[]=
{{1,1,1},{2,2}}{{2,2}}
In[]:=
PutInStandardOrder[{{2,2,2},{1,1}}{{1,1}}]
Out[]=
{{1,1,1},{2,2}}{{2,2}}
Question:
Question:
◼
The Canonicalizer doesn’t require s (list of integers used), does it?
RuleEnumeration
RuleEnumeration
Slightly better Enumeration
Slightly better Enumeration
In[]:=
GrowStandardOrder[order_]:=Module[{max},max=Max[order];Append[order,#]&/@Range[max+1]]
In[]:=
GrowStandardOrder[order_,s_]:=Module[{max},max=Min[Max[order]+1,s];Append[order,#]&/@Range[max]]
WolframModelRules[rulesignature_Rule,s_]:=Module[{lhs=Apply[List,rulesignature][[1]],rhs=Apply[List,rulesignature][[2]],max,tuplesbegin,tuples},max=Max[lhs[[All,2]]];tuplesbegin=Switch[max,2,{{1,1},{1,2}},_,Select[Fold[Flatten[GrowStandardOrder/@#,1]&,Flatten[GrowStandardOrder[{1,#},3]&/@Range[2],1],Range[max-3]],!ContainsAny[#,Range[s+1,max]]&]];tuples=Flatten[Table[Flatten[{u,v}],{u,tuplesbegin},{v,Tuples[Range[s],Total[#[[1]]*#[[2]]&/@Flatten[{lhs,rhs},1]]-max]}],1];Apply[Rule,TakeList[#,{Total[Flatten[lhs[[All,1]]]],Total[Flatten[rhs[[All,1]]]]}]&/@(TakeList[#,Flatten[Table[#[[2]],#[[1]]]&/@Flatten[{lhs,rhs},1]]]&/@tuples),{1}]]
In[]:=
RuleShapeToCases1[rulesignature_Rule,s_Integer]:=Union[PutInStandardOrder/@WolframModelRules[rulesignature,s]]
In[]:=
RuleShapeToCases1[{{2,3},{2,2}}->{{3,2}},2]//AbsoluteTiming
Out[]=
In[]:=
RuleShapeToCases1[{{4,3}}->{{3,2}},2]//AbsoluteTiming
Out[]=
RuleShapeToCases1[{{1,3}}{{2,3}},4]//AbsoluteTiming
Out[]=
LazyEnumeration
LazyEnumeration
In[]:=
IndexedOrderedTuple[s_Integer,n_Integer,index_Integer]:=Module[{end=Power[s,n],tab=Table[0,{n}],total=index},If[index>end,Missing,Do[tab[[in]]=First[Select[{#*Power[s,n-in],#}&/@Range[s],#[[1]]>=total&]][[2]];total=total-(Power[s,n-in]*(tab[[in]]-1)),{in,1,n}];tab]]
In[]:=
WolframModelRules[rulesignature_Rule,s_,{start_Integer,end_Integer}]:=Module[{lhs=Apply[List,rulesignature][[1]],rhs=Apply[List,rulesignature][[2]],max,tuples,n=Total[#[[1]]*#[[2]]&/@Flatten[{lhs,rhs},1]],rend},max=Max[lhs[[All,2]]];rend=Min[end,Power[s,n]];Apply[Rule,TakeList[#,{Total[Flatten[lhs[[All,1]]]],Total[Flatten[rhs[[All,1]]]]}]&/@(TakeList[#,Flatten[Table[#[[2]],#[[1]]]&/@Flatten[{lhs,rhs},1]]]&/@(IndexedOrderedTuple[s,n,#]&/@Range[start,rend])),{1}]]
In[]:=
RuleShapeToCases1[rulesignature_Rule,s_Integer,{start_Integer,end_Integer}]:=Union[PutInStandardOrder/@WolframModelRules[rulesignature,s,{start,end}]]
In[]:=
RuleShapeToCases1[{{1,3},{2,2}}{{2,3}},4,{1345500,1455000}]
Out[]=