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
In[]:=
CartesianProduct[sets__]:=With[{setsList={sets}},Flatten[Outer[List,##]&@@setsList,Length[setsList]-1]]
In[]:=
MultistringRewriteStep[rule_Rule,state_List]/;Length[First[rule]]==Length[Last[rule]]:=Block[{canonicalisedState,lhs,rhs,lhsRhs,stringPermutations,matchPositions,generatedEvents},canonicalisedState=Sort@state;lhs=First[rule];rhs=Last[rule];lhsRhs=Transpose[{lhs,rhs}];stringPermutations=Permutations[MapIndexed[{First[#2],#1}&,canonicalisedState],{Length[First[rule]]}];matchPositions=Select[MapThread[{#1,Rule@@#2}->StringPosition[Last[#1],First[#2]]&,{#,lhsRhs}]&/@stringPermutations,AllTrue[#,(Length[Last[#]]>0&)]&];matchPositions=SortBy[#,#[[1,1,1]]&]&/@matchPositions;generatedEvents=Catenate[Block[{match=#,positionIndices,events},positionIndices=CartesianProduct@@(Range[Length[Last[#]]]&/@match);events=(positionIndex|->MapIndexed[First[#1]->Last[#1][[First@positionIndex[[#2]]]]&,match])/@positionIndices;DirectedEdge[canonicalisedState,Sort@Fold[Block[{strs=#1,event=#2,rewritePosition,rewrite,stringPosition},rewritePosition=event[[1,1,1]];rewrite=event[[1,-1]];stringPosition=event[[-1]];ReplacePart[strs,rewritePosition->StringReplacePart[strs[[rewritePosition]],Last[rewrite],stringPosition]]]&,canonicalisedState,#],#]&/@events]&/@matchPositions];generatedEvents]
In[]:=
MultistringRewrite[rule_Rule,initialState_List,nSteps_Integer]:=Catenate@Last@Nest[Block[{states=First[#],events=Last[#],newEvents,newStates},newEvents=Catenate[MultistringRewriteStep[rule,#]&/@states];{Union[#[[2]]&/@newEvents],AppendTo[events,newEvents]}]&,{{initialState},{}},nSteps]
In[]:=
MultistringRewriteSystem[rule_Rule,initialState_List,nSteps_Integer,"StatesGraph"]:=With[{statesGraph=Graph[MultistringRewrite[rule,initialState,nSteps]]},Graph[statesGraph,VertexShapeFunction->(Text[Framed[Style[StringTake[ToString[#2],{2,-2}],Hue[0.62,1,0.48]],BackgroundDirective[Opacity[0.2],Hue[0.62,0.45,0.87]],FrameMargins{{2,2},{0,0}},RoundingRadius0,FrameStyleDirective[Opacity[0.5],Hue[0.62,0.52,0.82]]],#1,{0,0}]&)]]
In[]:=
MultistringRewriteSystem[rule_Rule,initialState_List,nSteps_Integer,"EventsList"]:=MultistringRewrite[rule,initialState,nSteps]
In[]:=
MultistringRewriteSystem[{"AB","BB","AA"}->{"BB","AB","BA"},{"AAA","AAB","ABA","ABB"},1,"EventsList"]
Out[]=
{AAA,AAB,ABA,ABB}{AAB,ABA,ABB,BAA},{AAA,AAB,ABA,ABB}{AAB,ABA,ABA,ABB},{AAA,AAB,ABA,ABB}{AAB,AAB,BAA,BBA},{AAA,AAB,ABA,ABB}{AAB,AAB,ABA,BBA},{AAA,AAB,ABA,ABB}{AAA,AAB,BAB,BBA}
{{{1,AAA},AABA}{1,2},{{2,AAB},ABBB}{2,3},{{4,ABB},BBAB}{2,3}}
{{{1,AAA},AABA}{2,3},{{2,AAB},ABBB}{2,3},{{4,ABB},BBAB}{2,3}}
{{{1,AAA},AABA}{1,2},{{3,ABA},ABBB}{1,2},{{4,ABB},BBAB}{2,3}}
{{{1,AAA},AABA}{2,3},{{3,ABA},ABBB}{1,2},{{4,ABB},BBAB}{2,3}}
{{{2,AAB},AABA}{1,2},{{3,ABA},ABBB}{1,2},{{4,ABB},BBAB}{2,3}}
In[]:=
MultistringRewriteSystem[{"AB","BB","AA"}->{"BB","AB","BA"},{"AAA","AAB","ABA","ABB"},2,"StatesGraph"]
Out[]=
In[]:=
highlightStringPart[text_String,part_,color_]:=StringReplacePart[text,ToString[Style[StringTake[text,part],Background->color],StandardForm],part]
In[]:=
MultistringRewriteSystem[rule_Rule,initialState_List,nSteps_Integer,"TokenEventGraph"]:=GraphMultistringRewriteSystem[rule,initialState,nSteps,"StatesGraph"],EdgeShapeFunction->Arrowheads[0.015],Arrow[#1,0.025],Black,InsetFramedStyle[Row@Flatten@{MapAt[Highlighted[#,ContentPadding->False,FrameMargins->1.5]&,Fold[ReplacePart[#1,#2[[1,1,1]]->highlightStringPart[#1[[#2[[1,1,1]]]],#2[[2]],Lighter[Green,0.75]]]&,#2[[1]],#2[[3]]],{#[[1,1,1]]}&/@#2[[3]]],"\n",MapAt[Highlighted[#,ContentPadding->False,FrameMargins->1.5]&,Fold[ReplacePart[#1,#2[[1,1,1]]->highlightStringPart[StringReplacePart[#1[[#2[[1,1,1]]]],#2[[1,2,2]],#2[[2]]],#2[[2]],Lighter[Red,0.8]]]&,#2[[1]],#2[[3]]],{#[[1,1,1]]}&/@#2[[3]]]},FontSize->10],Background->,FrameStyle,FrameMargins->1,Mean@#1&
In[]:=
MultistringRewriteSystem[{"AB","BB","AA"}->{"BB","AB","BA"},{"AAA","AAB","ABA","ABB"},1,"TokenEventGraph"]
Out[]=
In[]:=
MultistringRewriteSystem[{"AA","BB"}->{"AAB","BAA"},{"AAB","BBA","ABB"},2,"TokenEventGraph"]
Out[]=
Petri Nets
Petri Nets
Total Petri Net
Total Petri Net
Reduced Petri Net
Reduced Petri Net