ClearAll[straightFoliationLines];​​straightFoliationLines[{lineDensityHorizontal_:1,lineDensityVertical_:1},{tanHorizontal_:0.0,tanVertical_:0.0},transform_:(#&),offset_:{0,0}]:={If[lineDensityHorizontal≠0,Style[Table[Line[transform/@{{-100+offset〚1〛,k-100tanHorizontal+offset〚2〛},{100+offset〚1〛,k+100tanHorizontal+offset〚2〛}}],{k,-100.5,100.5,1/lineDensityHorizontal}],Red],{}],If[lineDensityVertical≠0,Style[Table[Line[transform/@{{k-100tanVertical+offset〚1〛,-100+offset〚2〛},{k+100tanVertical+offset〚1〛,100+offset〚2〛}}],{k,-100.5,100.5,1/lineDensityVertical}],Red],{}]}
In[]:=
ClearAll[diamondCausalGraphPlot];​​Options[diamondCausalGraphPlot]=Options[IndexGraph];​​diamondCausalGraphPlot[layerCount_:9,{lineDensityHorizontal_:1,lineDensityVertical_:1},{tanHorizontal_:0.0,tanVertical_:0.0},transform_:(#&),orientation_:"Down",opts:OptionsPattern[]]:=IndexGraphDirectedGraphFlatten[Table[If[orientation==="Up",Reverse,#&]/@{v[{i+1,j}]v[{i,j}],v[{i+1,j+1}]v[{i,j}]},{i,layerCount-1},{j,i}]],VertexCoordinatesCatenate[Table[v[{i,j}]transform[{2(#2-#1/2)-1,If[orientation==="Up",-#,#]&@#1}&@@{i,j}],{i,layerCount},{j,i}]],VertexSize.33,VertexStyleDirectiveDirectiveOpacity[.7],
,EdgeFormDirectiveOpacity[0.4],
,VertexShapeFunction"Rectangle",EpilogstraightFoliationLines[{lineDensityHorizontal,lineDensityVertical},{tanHorizontal,tanVertical},transform],opts
In[]:=
skewPosetDiagram[skew_,opts___]:=With[{p={2#2-#1+1,#1}&@@@-skew},Graphics[{Point[p],Orange,Arrowheads[Medium],Arrow/@Partition[p,2,1]},opts,ImageSizeTiny]];
In[]:=
lorentz[β_][{t_,x_}]:={t-βx,-tβ+x}/Sqrt[1-β^2]
In[]:=
drawFoliation[graph_,vertexLists_]:=Quiet[Module[{vertexCoordinates=Association[Thread[VertexList[graph](VertexCoordinates/.AbsoluteOptions[graph,VertexCoordinates]〚1〛)]],lines},Show[graph,FoldPairList[foliationLine[vertexCoordinates],{},vertexLists]]],NearestFunction::neard]
In[]:=
foliationLine[coordinates_,style_:Red][extraPoints_,chosenVertices_]:=Module[{chosenCoordinates=Join[coordinates/@chosenVertices,extraPoints],nearest1,nearest2,coordinateBounds=CoordinateBounds[coordinates]},{nearest1,nearest2}=Nearest/@{chosenCoordinates,Complement[Values[coordinates],chosenCoordinates]};{ContourPlot[EuclideanDistance[nearest1[{x,y}]〚1〛,{x,y}]-EuclideanDistance[nearest2[{x,y}]〚1〛,{x,y}]0,{x,coordinateBounds〚1,1〛,coordinateBounds〚1,2〛},{y,coordinateBounds〚2,1〛,coordinateBounds〚2,2〛},ContourStylestyle],Table[With[{x=x},Module[{func},func[y_?NumericQ]:=EuclideanDistance[nearest1[{x,y}]〚1〛,{x,y}]-EuclideanDistance[nearest2[{x,y}]〚1〛,{x,y}];{x,y/.FindRoot[func[y]0,{y,coordinateBounds〚2,1〛,coordinateBounds〚2,2〛}]}]],{x,coordinateBounds〚1,1〛,coordinateBounds〚1,2〛,1}];{}}]
In[]:=
applyEvents[evolution_,events_]:=evolution["AllEventsEdgesList"]〚Fold[Join[DeleteCases[#,Alternatives@@#2〚2,1〛],#2〚2,2〛]&,{},evolution["EventsList","IncludeBoundaryEvents""Initial"]〚Join[{1},events+1]〛]〛
In[]:=
toState[str_]:=MapThread[If[#"B",Append[#2,Last[#2]],#2]&,{Characters[str],Partition[Range[StringLength[str]+1],2,1]}]
In[]:=
upTriangleGraph=diamondCausalGraphPlot[9,{0,0},{},#&,"Up",VertexLabelsAutomatic]
In[]:=
Out[]=
vertexToDiagram=Association[Thread[VertexList[upTriangleGraph]Take[Catenate[Table[{m,n},{m,1,20},{n,m,1,-1}]],VertexCount[upTriangleGraph]]]];
In[]:=
Show[upTriangleGraph,skewPosetDiagram[vertexToDiagram/@Reap[BreadthFirstScan[upTriangleGraph,1,"PrevisitVertex"(Sow[#]&)]]〚2,1〛],AxesTrue]
In[]:=
Out[]=
Show[upTriangleGraph,skewPosetDiagram[vertexToDiagram/@Reap[DepthFirstScan[upTriangleGraph,1,"PrevisitVertex"(Sow[#1]&)]]〚2,1〛],AxesTrue]
In[]:=
Out[]=
Show[upTriangleGraph,SeedRandom[23424];skewPosetDiagram[SkewPoset[YoungTableauToPoset@RandomTableau[{9,8,7,6,5,4,3,2,1}]]],AxesTrue]
In[]:=
Out[]=
diamondCausalGraphPlot[10,{1,0},{0.0,0.0},lorentz[0],"Up"]
In[]:=
Out[]=
diamondCausalGraphPlot[10,{1,0},{0.3,0.0},lorentz[0],"Up"]
In[]:=
Out[]=
diamondCausalGraphPlot[10,{0,0},{0.3,0.0},lorentz[-0.3],"Up",VertexLabelsAutomatic]
In[]:=
Out[]=
drawFoliation[upTriangleGraph,{{1},{1,3,6,10,2,4,5},{1,3,6,10,2,4,5,8,9,15,13,14,19,20,26,7,12},{1,3,6,10,2,4,5,8,9,15,13,14,19,20,26,7,12,11,17,21,18,25,24,27,32,34,28,33,16,23,31,35,42}}]
In[]:=
Out[]=
drawFoliation[diamondCausalGraphPlot[10,{0,0},{0.3,0.0},lorentz[-0.3],"Up",VertexLabelsAutomatic],{{1},{1,3,6,10,2,4,5},{1,3,6,10,2,4,5,8,9,15,13,14,19,20,26,7,12},{1,3,6,10,2,4,5,8,9,15,13,14,19,20,26,7,12,11,17,21,18,25,24,27,32,34,28,33,16,23,31,35,42}}]
In[]:=
Out[]=
<<SetReplace`
In[]:=
evolution=WolframModel[{{x,y},{z,y}}{{x,z},{y,z},{w,z}},{{0,0},{0,0}},12]
In[]:=
Out[]=
gg=Graph[evolution["LayeredCausalGraph"],VertexLabelsAutomatic];
In[]:=
RandomChoice[{21,37,38,16,33,93,94,65,49,66}]
In[]:=
33
Out[]=
semiRandomWMFoliation={{1},{1,2,4,6,9,3},{1,2,4,6,9,3,13,19,12,26,36,5,7,10,51,14,69,18,8,25,11,34,20,35,50,17},{1,2,4,6,9,3,13,19,12,26,36,5,7,10,51,14,69,18,8,25,11,34,20,35,50,17,24,68,47,15,92,27,48,37,21,28,42,22,30,16,32,23,33,46,64,90,94,65,88,49,67,91,66,89}};
In[]:=
Quiet[drawFoliation[gg,semiRandomWMFoliation],FindRoot::cvmit]
In[]:=
Out[]=
WolframModelPlot[applyEvents[evolution,#]]&/@Join[{{}},semiRandomWMFoliation,{Range[evolution["EventsCount"]]}]
In[]:=
Out[]=
GraphPlot[gg,Epilog{Directive[Red,Thickness[.005]],straightFoliationLines[{0.5,0},{0,0},(#&),{0,1}]}]
In[]:=
Out[]=
WolframModelPlot/@Join[{evolution[0]},evolution["StatesList"]〚2;;;;2〛,{evolution["FinalState"]}]
In[]:=
Out[]=
VertexReplace[Graph[diamondCausalGraphPlot[10,{1,0},{0.3,0.0},lorentz[0],"Down"],VertexLabelsAutomatic],Normal[FindGraphIsomorphism[Graph[diamondCausalGraphPlot[10,{1,0},{0.3,0.0},lorentz[0],"Down"]],sortingEvolution["LayeredCausalGraph",VertexLabelsAutomatic]]〚1〛]]
In[]:=
Out[]=
WolframModelPlot[applyEvents[sortingEvolution,#]]&/@FoldList[Join,{},{{1},{2,3},{4,11,12},{5,6,13,14,20,21},{7,8,15,22,28},{9,16,17,23,24,29,30,35},{10,18,19,25,26,31,36},{27,32,33,37,38,41,42},{34,39,40,43,46},{44,45,47,48,50},{49,51},{52,53,54},{55}}]//Column
In[]:=
Out[]=
sortingEvolution["LayeredCausalGraph",VertexLabelsAutomatic]
In[]:=
Out[]=
sortingEvolution=WolframModel[{{1,2,2},{2,3}}{{1,2},{2,3,3}},toState[StringJoin[Table["BA",10]]],Infinity]
In[]:=
Out[]=
WolframModelPlot[applyEvents[sortingEvolution,#]]&/@{{}}