At every step, take n tokens and generate m....
At every step, take n tokens and generate m....
{{a,b}->{c,a,b}}
In[]:=
SubsetCases[{a,b,c,a,d,b},{a,b}]
Out[]=
{{a,b},{a,b}}
Connect these tokens to an event, and then show output...
{n_,m_}:>{n+m,n-m}
“Multi-input multiway system”
“Multi-input multiway system”
This is a kind of generalization of SubsetMap in which the output list isn’t same length as input [and the order of elements in the initial list doesn’t matter]
Untracked version is basically repeated SubsetReplace
Untracked version is basically repeated SubsetReplace
In[]:=
NestList[SubsetReplace[#,{n_,m_}:>{n+m,n-m}]&,{1,2,3},4]
Out[]=
{{1,2,3},{{3,-1},3},{{{6,2},{0,-4}}},{{{6,2},{0,-4}}},{{{6,2},{0,-4}}}}
Need a general mechanism for tracing where Replace was done....
Need a general mechanism for tracing where Replace was done....
Possibly include an action for ReplaceAll etc.
ReplaceRepeatedGraph[](*??*)
Full SubsetCases is multicomputational
Full SubsetCases is multicomputational
In[]:=
SubsetCases[{1,2,3,4},{n_,m_},Overlaps->True]
Out[]=
{{1,2},{1,3},{1,4},{2,3},{2,4},{3,4}}
In[]:=
ClearAll[MIMWEvolveList,MIMWGraph,MIMWStep]
In[]:=
MIMWStep[rules:{__Rule|__RuleDelayed},list_,opts:OptionsPattern[]]:=MapIndexed[Function[{r,ri},{#->ev[++$event,ri],ev[$event,ri]->Replace[#,r]}&/@SubsetCases[list,First[r],Overlaps->OptionValue[Overlaps]]],rules]
In[]:=
MIMWEvolveList[rules_,list_,t_,opts:OptionsPattern[]]:=Module[{rules2=If[OptionValue[UniqueTokens],Function[r,(tk[#,_]&/@First[r]):>(tk[#,++$token]&/@#)&[Last[r]]]/@rules,rules],list2=If[OptionValue[UniqueTokens],tk[#,$token]&/@list,list]},Block[{$event=0,$token=0},NestList[({Union[Catenate[Cases[#,(_ev->u_):>u]]],#}&[Catenate[Catenate[MIMWStep[rules2,First[#],opts]]]])&,{list2,{}},t]]]
In[]:=
Options[MIMWGraph]=Options[MIMWStep]=Options[MIMWEvolveList]={Overlaps->True,UniqueTokens->True,VertexLabeling->True};
In[]:=
MIMWGraph[rules_,list_,t_,opts:OptionsPattern[]]:=With[{g=Graph[Flatten[Thread/@Flatten[Last/@Rest[MIMWEvolveList[rules,list,t,opts]]]]]},Graph[g,VertexStyle->(#->If[Head[#]===ev,ResourceFunction["WolframPhysicsProjectStyleData"]["CausalGraph","VertexStyle"],ResourceFunction["WolframPhysicsProjectStyleData"]["StatesGraph","VertexStyle"]]&/@VertexList[g]),VertexLabels->(If[!OptionValue[VertexLabeling],None,#->Replace[#,{ev[_,{x_}]->Placed[x,Center],tk[x_,_]->x}]&/@VertexList[g]]),GraphLayout->"LayeredDigraphEmbedding"]]
In[]:=
MIMWGraph[{{n_,m_}:>{n+m}},{1,2,3,4},2,UniqueTokens->True,Overlaps->False,VertexLabeling->True]
Out[]=
In[]:=
MIMWGraph[{{n_,m_}:>{n+m,n-m}},{1,2,3},3,UniqueTokens->True,Overlaps->False,VertexLabeling->True]
Out[]=
In[]:=
MIMWGraph[{{n_,m_}:>Range[n-m,n+m]},{1,2,3},3,UniqueTokens->True,Overlaps->False,VertexLabeling->True]
Out[]=
In[]:=
MIMWGraph[{{n_,m_}:>Range[n-m,n+m]},{1,1,1},5,UniqueTokens->True,Overlaps->False,VertexLabeling->True]
Out[]=
In[]:=
MIMWGraph[{{n_,m_}:>{n-m,n+m,m-n}},{1,1,1},6,UniqueTokens->True,Overlaps->False,VertexLabeling->True]
Out[]=
[[ This is not correct; the initial 1s should be separate tokens ]]
Multi-history version: