In[]:=
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[]]:=IndexGraphDirectedGraphFlatten[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}]],VertexCoordinatesCatenate[Table[v[{i,j}]transform[{2(#2-#1/2)-1,If[orientation==="Up",-#,#]&@#1}&@@{i,j}],{i,layerCount},{j,i}]],VertexSize.33,VertexStyleDirectiveDirectiveOpacity[.7],,EdgeFormDirectiveOpacity[0.4],,VertexShapeFunction"Rectangle",EpilogstraightFoliationLines[{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,ImageSizeTiny]];
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〛},ContourStylestyle],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",VertexLabelsAutomatic]
Out[]=
In[]:=
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〛],AxesTrue]
Out[]=
In[]:=
Show[upTriangleGraph,skewPosetDiagram[vertexToDiagram/@Reap[DepthFirstScan[upTriangleGraph,1,"PrevisitVertex"(Sow[#1]&)]]〚2,1〛],AxesTrue]
Out[]=
In[]:=
Show[upTriangleGraph,SeedRandom[23424];skewPosetDiagram[SkewPoset[YoungTableauToPoset@RandomTableau[{9,8,7,6,5,4,3,2,1}]]],AxesTrue]
Out[]=
In[]:=
diamondCausalGraphPlot[10,{1,0},{0.0,0.0},lorentz[0],"Up"]
Out[]=
In[]:=
diamondCausalGraphPlot[10,{1,0},{0.3,0.0},lorentz[0],"Up"]
Out[]=