Code
Code
This is needed to get SubsetReplace, which will be a System` function in 12.1:
In[]:=
Needs["GraphStore`"];Needs["GraphStore`Subsets`"]
Basic evolution
Basic evolution
In[]:=
MultiwaySystem[<|"StateEvolutionFunction"evolfun_,"StateEquivalenceFunction"equivfun_,"StateEventFunction"eventfun_|>,init_,n_Integer,"AllStatesListUnmerged"]:=NestList[Catenate[evolfun/@#]&,init,n]
In[]:=
MultiwaySystem[<|"StateEvolutionFunction"evolfun_,"StateEquivalenceFunction"equivfun_,"StateEventFunction"eventfun_|>,init_,n_Integer,"AllStatesList"]:=NestList[Union[Catenate[evolfun/@#],SameTestequivfun]&,init,n]
In[]:=
MultiwaySystem[<|"StateEvolutionFunction"evolfun_,"StateEquivalenceFunction"equivfun_,"StateEventFunction"eventfun_|>,init_,n_Integer]:=MultiwaySystem[<|"StateEvolutionFunction"evolfun,"StateEquivalenceFunction"equivfun,"StateEventFunction"eventfun|>,init,n,"AllStatesList"]
Counting states at each step
Counting states at each step
In[]:=
MultiwaySystem[<|"StateEvolutionFunction"evolfun_,"StateEquivalenceFunction"equivfun_,"StateEventFunction"eventfun_|>,init_,n_Integer,"StatesCountList"]:=Append[#[[-1,1]],Length[#[[1]]]]&[Reap[Nest[(Sow[Length[#]];Union[Catenate[evolfun/@#],SameTestequivfun])&,init,n]]]
In[]:=
Keeping track of predecessors
Keeping track of predecessors
In[]:=
MultiwaySystemRuledStepX[evolfun_,state_]:=SortBy[(#[[1,1]]Sort[(Last/@#)])&/@GatherBy[Catenate[(Function[x,x#]/@evolfun[#])&/@state],First],First]
In[]:=
MultiwaySystem[<|"StateEvolutionFunction"evolfun_,"StateEquivalenceFunction"equivfun_,"StateEventFunction"eventfun_|>,init_,n_Integer,"PredecessorRulesList"]:=NestList[MultiwaySystemRuledStepX[evolfun,First/@#]&,(#{})&/@init,n]
In[]:=
Generating the graph of relationships between states
Generating the graph of relationships between states
In[]:=
MultiwaySystem[<|"StateEvolutionFunction"evolfun_,"StateEquivalenceFunction"equivfun_,"StateEventFunction"eventfun_|>,init_,n_Integer,"StatesGraph",opts:OptionsPattern[]]:=Graph[Catenate[Map[(Function[r,rFirst[#]]/@Last[#])&,Catenate[MultiwaySystem[<|"StateEvolutionFunction"evolfun,"StateEquivalenceFunction"equivfun,"StateEventFunction"eventfun|>,init,n,"PredecessorRulesList"]]]],VertexShapeFunctionGraphStateRendering[OptionValue["StateGraphLabels"]],FilterRules[{opts},Options[Graph]]]
Rendering for states in graphs:
In[]:=
GraphStateRendering[Inherited]="Name";
In[]:=
GraphStateRendering[None]="Circle";
In[]:=
GraphStateRendering[Automatic]=(Text[Framed[Style[#2,Black],FrameMarginsNone,FrameStyleNone,BackgroundDirective[Opacity[.2],Gray]],#1,{0,0}]&);
In[]:=
GraphStateRendering[s_String]:=s;
GraphStateRendering[func_Function]:=f;
State event functions
State event functions
StateEventFunction for substitution systems on strings and lists:
In[]:=
StringRewriteEvent[rule_,state_String]:={rule,{StringTake[state,First[#]-1],StringDrop[state,Last[#]]}}&/@StringPosition[state,First[rule]]
In[]:=
StringRewriteEvents[rules_List,states_List]:=Catenate[Function[s,Catenate[StringRewriteEvent[#,s]&/@rules]]/@states]
In[]:=
StringRewriteEvents[{"B""AA","A""AB"},{"AABA"}]
Out[]=
{{BAA,{AA,A}},{AAB,{,ABA}},{AAB,{A,BA}},{AAB,{AAB,}}}
In[]:=
ListRewriteEvent[rule_,state_List]:={rule,{Take[state,First[#]-1],Drop[state,Last[#]]}}&/@SequencePosition[state,First[rule]]
In[]:=
ListRewriteEvents[rules_List,states_List]:=Catenate[Function[s,Catenate[ListRewriteEvent[#,s]&/@rules]]/@states]
In[]:=
ListRewriteEvents[{{0}{0,0},{0}{0,1}},{{0,0,1,0}}]
Out[]=
stepno->{trans,{prefix,suffix}}
Generating traced evolution
Generating traced evolution
MultiwaySystem[<|"StateEvolutionFunction"evolfun_,"StateEquivalenceFunction"equivfun_,"StateEventFunction"eventfun_|>,init_,n_Integer,"TracedStatesList",opts:OptionsPattern[]]:=If[OptionValue["IncludeStepNumber"],FoldList[],NestList[
In[]:=
MultiwaySystem[{"B""AA","A""AB"},{"AABA"},3,"TracedStatesList"]
Out[]=
Cases
Cases
MultiwaySystem["SubstitutionSystem"(rules:{(_String_String)..}),rest___]:=MultiwaySystem[<|"StateEvolutionFunction"(StringReplaceList[#,rules]&),"StateEquivalenceFunction"SameQ,"StateEventFunction"(StringRewriteEvents[rules,#]&)|>,rest]
MultiwaySystem["SubstitutionSystem"(rules:{(_List_List)..}),rest___]:=With[{prules=((Join[{x___},#1,{y___}]Join[{x},#2,{y}])&@@@rules)},MultiwaySystem[<|"StateEvolutionFunction"(ReplaceList[#,prules]&),"StateEquivalenceFunction"SameQ,"StateEventFunction"(ListRewriteEvents[rules,#]&)|>,rest]]
For each LHS, get SequenceCases, etc.
NOTE: generally need to handle cases where init is naked, and not a list of states....
In[]:=
MultiwaySystem["CellularAutomaton"rules_List,rest___]:=MultiwaySystem[<|"StateEvolutionFunction"Function[state,Catenate[MapIndexed[ReplacePart[state,#2[[1]]#]&,Transpose[Map[#[state]&,CellularAutomaton/@rules]],{2}]]],"StateEquivalenceFunction"SameQ,"StateEventFunction"XXX|>,rest]
This should also support symbolic WolframModel[ ... ], as well as integer indices etc.
In[]:=
WolframModelStateEvolutionFunction[rules:{(_List_List)..},initialCondition:{_List...}]:=Module[{spaceGraph=$subset[Sort[initialCondition]]},Catenate[Function[{rule},$subset[Sort[subsetReplaceNew[spaceGraph[[1]],{#(#/.rule)}]]]&/@SubsetCases[spaceGraph[[1]],rule[[1]]]]/@rules]]/.($subset[x_]x)
In[]:=
subsetReplaceNew[initialCondition:{_List...},rules:{(_List_List)..}]:=Module[{subsetReplaceOld},subsetReplaceOld=SubsetReplace[initialCondition,rules];Join[Select[subsetReplaceOld,Depth[#]2&],Select[subsetReplaceOld,Depth[#]>2&][[1]]]];
In[]:=
MultiwaySystem["WolframModel"rules_List,rest___]:=MultiwaySystem[<|"StateEvolutionFunction"(WolframModelStateEvolutionFunction[rules,#]&),"StateEquivalenceFunction"ResourceFunction["IsomorphicOrderedHypergraphQ"],"StateEventFunction"XXX|>,rest]
Examples
Examples
[[ This is wrong : ]]
More
More
Visualization
Visualization
Each incoming evolution edge is causally connected to some number of outgoing evolution edges