In[]:=
BellMaskRadix[len_]:={Flatten[{1,Split[#[[1]]][[2]]/.01,Drop[Split[#[[1]]],2]}],#[[2]]}&/@({With[{zer=Table[0,{len}],rep=Normal[PositionIndex[Prepend[#,1]]][[1,2]]},ReplacePart[zer,Thread[repRange[Length[rep]]]]],Prepend[Select[Flatten[MapIndexed[Table[#2[[1]],{(#1-1)}]&,Differences[Flatten[{1,Position[#,1]+1,len+1}]]],1],#>1&],1]}&/@Table[IntegerDigits[k,2,len-1],{k,0,2^(len-1)-1}]);
In[]:=
StandardOrderFromIndex[index_Integer,len_Integer]:=Module[{bell,fold,needle,position,mask,radix,term,number,fill,zeropos,return},If[index>BellB[len],Return["Out of range"]];bell=BellMaskRadix[len];fold=Drop[FoldList[Plus,0,Times@@Last[#]&/@bell],1];needle=Select[fold,#<index&];position=Length[needle]+1;mask=bell[[position,1]];radix=Drop[bell[[position,2]],1];If[Count[mask,0]0,Return[mask]];term=fold[[position-1]];number=index-term-1;fill=Flatten[IntegerDigits[number,MixedRadix[radix],Length[radix]]+1];zeropos=Flatten[Position[mask,0]];return=ReplacePart[mask,Thread[zeroposfill]];return];
In[]:=
DelDup[list_List]:=Module[{alphabet},alphabet=DeleteDuplicates[Flatten[list]];list/.Thread[alphabetRange[Length[alphabet]]]];
In[]:=
MiserTermsInTuples[tup_List]:=Module[{gather,gat,size,seqs},gather=Gather[tup];size=Length[gather];seqs={#}&/@Range[size];gat=First/@gather;Do[seqs=Flatten[With[{grow=#,new=Complement[Range[size],#]},Append[grow,#]&/@new]&/@First[SplitBy[SortBy[seqs,Length[Union[Flatten[gat[[#]]]]]&],Length[Union[Flatten[gat[[#]]]]]&]],1],{k,1,size-1}];First[SplitBy[SortBy[Union[Flatten[gather[[#]],1]&/@seqs],DelDup[#]&],DelDup[#]&]]];
In[]:=
CanonicalizeParts[rule_]:=Module[{leftright,leftrightparts,len,parts,maxpartlength,alphabet,alphabetlength,partalphabets,canonicalparts,temp,tab},leftright=Table[SortBy[rule[[n]],-Length[#]&],{n,1,2}];leftrightparts=SplitBy[#,Length]&/@leftright;len=Length[leftrightparts[[1]]];parts=Flatten[leftrightparts,1];canonicalparts=MiserTermsInTuples[#]&/@parts;parts=First[SortBy[Tuples[canonicalparts],DelDup[Flatten[#]]&]];alphabet=DeleteDuplicates[Flatten[parts]];alphabetlength=Length[alphabet];(Flatten[Take[parts,len],1]Flatten[Drop[parts,len],1])/.Thread[alphabetRange[alphabetlength]]];
In[]:=
FindCanonicalWolframModel[rules_]:=CanonicalizeParts[rules];
In[]:=
MaskedRadixStandardOrder[{mask_,radix_}]:=Module[{position,len,prod,fills,restRadix=Rest[radix]},position=Flatten[Position[mask,0]];len=Length[restRadix];prod=Times@@restRadix;fills=Table[IntegerDigits[n,MixedRadix[restRadix],len]+1,{n,0,prod-1}];ReplacePart[mask,Thread[position#]]&/@fills];
In[]:=
ruleSignatureLength[signature_Rule]:=Total[ruleSignatureLength/@List@@signature]
In[]:=
ruleSignatureLength[signature:{___List}]:=Total[Times@@@signature]
In[]:=
signatureToRule[sign_,numbers_]:=Module[{index,expandedSignature,s},index=1;expandedSignature=Catenate[Table[s,##]&@@@#]&/@sign/.sSlot[index++];Evaluate[expandedSignature]&@@numbers]
In[]:=
ApplyWolframRuleSignaturetoList[sig_,list_]:=Module[{lhs,rhs,part,all},lhs=Table[#[[2]],{#[[1]]}]&/@sig[[1]];rhs=Table[#[[2]],{#[[1]]}]&/@sig[[2]];part=Partition[FoldList[Plus,0,Flatten[{lhs,rhs}]],2,1];all=Take[list,{#[[1]]+1,#[[2]]}]&/@part;Take[all,Length[Flatten[lhs]]]Drop[all,Length[Flatten[lhs]]]]
In[]:=
Options[EnumerateWolframModelRules]={"Monitored"False};
In[]:=
EnumerateWolframModelRules[signature_,opts:OptionsPattern[]]:=Catenate@If[OptionValue["Monitored"],ResourceFunction["ParallelMapMonitored"],ParallelMap][Select[ApplyWolframRuleSignaturetoList[signature,#]&/@MaskedRadixStandardOrder[#],ConnectedWolframModelQ[#]&&#===FindCanonicalWolframModel[#]&]&,BellMaskRadix[ruleSignatureLength[signature]]]
In[]:=
EnumerateWolframModelRules[{{2,2}}{{3,2}}]
Out[]=
In[]:=
EnumerateWolframModelRules[{{2,2}}{{4,2}},"Monitored"True]
Out[]=
In[]:=
AbsoluteTiming[EnumerateWolframModelRules[{{2,2}}{{3,2}}]]
Out[]=
In[]:=
AbsoluteTiming[Catenate@ParallelMap[Select[Take[Partition[#,2],2]Drop[Partition[#,2],2]&/@MaskedRadixStandardOrder[#],ConnectedWolframModelQ[#]&&#===FindCanonicalWolframModel[#]&]&,BellMaskRadix[10]]]
Out[]=
{52.3,12.4,6.74}
Out[]=
4.21774
In[]:=
ConnectedHypergraphQ[edges:{__List}]:=ConnectedGraphQ@Graph[UndirectedEdge@@@Catenate[Partition[#,2,1,-1]&/@edges]]
In[]:=
ConnectedWolframModelQ[rules:{__Rule},type_]:=And@@(ConnectedWolframModelQ[#,type]&/@rules)