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
RuleSignatureRandom
RuleSignatureRandom
Given a rule signature and a number of distinct symbols, create a random rule.
The Enumeration Setup
The Enumeration Setup
A typical instance of might be:
2
2
3
2
{{1,1},{2,1}}{{2,1},{2,2},{2,2}}
The ordering inside the outer list doesn’t matter.
The ordering within each sublist does matter.
The names of the symbols don’t matter.
Formulas for the total counts would be nice, but are not essential.
The ordering within each sublist does matter.
The names of the symbols don’t matter.
Formulas for the total counts would be nice, but are not essential.
Examples of RuleSignatures and Rules
Examples of RuleSignatures and Rules
1
3
2
3
{{{1,2,2}}{{1,3,3},{2,1,1}}}
2
3
4
3
{{{2,2,1},{2,2,2}}{{1,1,3},{1,1,1},{2,1,2},{3,3,2}}}
3
2
11
2
{{{0,1},{0,2},{0,3}}{{4,5},{5,4},{4,6},{6,4},{5,6},{6,5},{4,1},{5,2},{6,3},{1,6},{3,4}}}
2
3
2
2
4
3
8
2
{{{2,5},{5,2},{2,3,1},{5,6,4}}{{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}}}
Canonicalization
Canonicalization
Together, these seem to quickly canonicalize most rules.
SemiCanonUnionFirst[rule_Rule]:=With[{replace=DeleteDuplicates[Flatten[Table[SortBy[Sort[rule[[n]]],{Length[Union[#]],-Length[#]}&],{n,1,Length[rule]}]]]},SortBy[Sort[#],{Length[Union[#]],-Length[#]}&]&/@(rule/.Thread[replaceRange[Length[replace]]])];
SemiCanon[rule_Rule]:=With[{replace=DeleteDuplicates[Flatten[Table[SortBy[Sort[rule[[n]]],{-Length[#],Length[Union[#]]}&],{n,1,Length[rule]}]]]},SortBy[Sort[#],{-Length[#]}&]&/@(rule/.Thread[replaceRange[Length[replace]]])];
SW:
Need to be able to take a rule like:
{{2, 3, 3}} -> {{3, 2, 2}, {2, 1, 1}}
and reduce it to the minimal representative (as would be found in the enumeration)
In[59]:= {Sort /@ ({{2, 3, 3}} -> {{3, 2, 2}, {2, 1, 1}} /. {2 -> 1, 3 -> 2, 1 -> 3})}
Out[59]= {{{1, 2, 2}} -> {{1, 3, 3}, {2, 1, 1}}}
Need to be able to take a rule like:
{{2, 3, 3}} -> {{3, 2, 2}, {2, 1, 1}}
and reduce it to the minimal representative (as would be found in the enumeration)
In[59]:= {Sort /@ ({{2, 3, 3}} -> {{3, 2, 2}, {2, 1, 1}} /. {2 -> 1, 3 -> 2, 1 -> 3})}
Out[59]= {{{1, 2, 2}} -> {{1, 3, 3}, {2, 1, 1}}}
SemiCanon[SemiCanonUnionFirst[{{2,3,3}}{{3,2,2},{2,1,1}}]]
{{1,2,2}}{{1,3,3},{2,1,1}}
SemiCanon[SemiCanonUnionFirst[{{2,2,1},{2,2,2}}{{1,1,3},{1,1,1},{2,1,2},{3,3,2}}]]
{{1,1,1},{1,1,2}}{{1,2,1},{2,2,2},{2,2,3},{3,3,1}}
SemiCanon[SemiCanonUnionFirst[{{0,1},{0,2},{0,3}}{{4,5},{5,4},{4,6},{6,4},{5,6},{6,5},{4,1},{5,2},{6,3},{1,6},{3,4}}]]
{{1,2},{1,3},{1,4}}{{2,5},{4,6},{5,4},{5,6},{5,7},{6,2},{6,5},{6,7},{7,3},{7,5},{7,6}}
SemiCanon[SemiCanonUnionFirst[{{2,5},{5,2},{2,3,1},{5,6,4}}{{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}}]]
{{1,2,3},{4,5,6},{1,4},{4,1}}{{3,7,8},{6,9,10},{11,12,2},{13,14,5},{7,11},{8,10},{9,13},{10,8},{11,7},{12,14},{13,9},{14,12}}
RuleSignatureRandom
RuleSignatureRandom
RuleSignatureRandom[rulesignature_Rule,s_Integer]:=SemiCanon[SemiCanonUnionFirst[Rule@@Table[Flatten[RandomInteger[{1,s},#]&/@rulesignature[[n]],1],{n,1,Length[rulesignature]}]]];
Table[RuleSignatureRandom[{{2,3},{2,2}}{{4,3},{8,2}},12],{10}]
Table[RuleSignatureRandom[{{2,3}}{{3,2}},2],{12}]
Table[RuleSignatureRandom[{{2,3}}{{3,2}},4],{12}]
IndexedSubset
IndexedSubset
Give the index of a subset or return the subset with that index
IndexedSubset[list_List]:=(Total[MapIndexed[Binomial[#1,#2[[1]]]&,list]]+1);
IndexedSubset[choose_Integer,index_Integer]:=Module[{tab,total,x},tab=Table[0,{choose}];total=index;Do[tab[[in]]=Ceiling[x/.Flatten[NSolve[{Product[(x-n+1)/n,{n,1,in}]total,x>0},x]]]-1;total=total-Binomial[tab[[in]],in],{in,choose,1,-1}];tab];
The following 3-subset ordering can be extended to infinity:
SortBy[Subsets[Range[0,4],{3}],Reverse]
{{0,1,2},{0,1,3},{0,2,3},{1,2,3},{0,1,4},{0,2,4},{1,2,4},{0,3,4},{1,3,4},{2,3,4}}
The function returns the same subsets in the same order:
Table[IndexedSubset[3,index],{index,1,10}]
{{0,1,2},{0,1,3},{0,2,3},{1,2,3},{0,1,4},{0,2,4},{1,2,4},{0,3,4},{1,3,4},{2,3,4}}
The function can return subsets of a large index:
sub3=Table[IndexedSubset[3,index],{index,182101,182110}]
{{98,102,103},{99,102,103},{100,102,103},{101,102,103},{0,1,104},{0,2,104},{1,2,104},{0,3,104},{1,3,104},{2,3,104}}
Applying the function to a subset returns the index:
IndexedSubset/@sub3
{182101,182102,182103,182104,182105,182106,182107,182108,182109,182110}
Any strictly increasing list of integers can be considered as a subset with a unique index:
IndexedSubset[%]
11053286874820117020478130685354111912851920141
The index above generates a unique 10-subset:
IndexedSubset[10,%]
{182101,182102,182103,182104,182105,182106,182107,182108,182109,182110}
The structure of 3-subsets in 3D:
triples=SortBy[Subsets[Range[0,5],{3}],Reverse];Graphics3D[{Text[Style[Column[{StringJoin[ToString/@#],IndexedSubset[#]},AlignmentCenter],20],#]&/@triples,Blue,Line[triples]}]
Find the trillionth number with binary weight eight:
Find the index of an eight term subset:
IndexedTuples
IndexedTuples
This sort of ordering could be applied to Tuples
We also need an ordering for ordered tuples.
Use that for each part of the rule signature.
Then some degeneracy handling is needed.
Say that s=4, four distinct symbols.
2728704-57915-480-1 use all 4 symbols
57915-480-1 use 3 symbols
480-1 use 2 symbols
1 uses 1 symbol
Then some degeneracy handling is needed.
Say that s=4, four distinct symbols.
2728704-57915-480-1 use all 4 symbols
57915-480-1 use 3 symbols
480-1 use 2 symbols
1 uses 1 symbol