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
[Massive Particle Modeling]
[Massive Particle Modeling]
Can we make something that has more energy than momentum?
Can we make something that has more energy than momentum?
In[]:=
lorentz[β_][{t_,x_}]:={t-βx,-tβ+x}/Sqrt[1-β^2]
In[]:=
regularCausalGraphPlot[layerCount_:9,{lineDensityHorizontal_:1,lineDensityVertical_:1},verticalEdgeDensity_:0.2,{tanHorizontal_:0.0,tanVertical_:0.0},transform_:(#&)]:=DirectedGraphFlatten[Table[{v[{i+1,j}]v[{i,j}],If[i<layerCount-1&&RandomChoice[{verticalEdgeDensity,1-verticalEdgeDensity}{True,False}],v[{i+2,j+1}]v[{i,j}],Nothing],v[{i+1,j+1}]v[{i,j}]},{i,layerCount-1},{j,i}]],VertexCoordinatesCatenate[Table[v[{i,j}]transform[{2(#2-#1/2),#1}&@@{i,j}],{i,layerCount},{j,i}]],VertexSize.33,VertexStyleDirectiveDirectiveOpacity[.7],,EdgeFormDirectiveOpacity[0.4],,VertexShapeFunction"Rectangle",Epilog{If[lineDensityHorizontal≠0,Style[Table[Line[transform/@{{-100,k-100tanHorizontal},{100,k+100tanHorizontal}}],{k,-100.5,100.5,1/lineDensityHorizontal}],Red],{}],If[lineDensityVertical≠0,Style[Table[Line[transform/@{{k-100tanVertical,-100},{k+100tanVertical,100}}],{k,-100.5,100.5,1/lineDensityVertical}],Red],{}]}
In[]:=
SeedRandom[1234];regularCausalGraphPlot[10,{1,1},0.3,{0.0,0.0},lorentz[0.3]]
Out[]=
In[]:=
SeedRandom[1234];regularCausalGraphPlot[10,{1,1},0.3,{0.3,0.3},lorentz[0.1]]
Out[]=
In[]:=
SeedRandom[1234];regularCausalGraphPlot[10,{1,1},0.3,{0,0},lorentz[0]]
Out[]=
[ Unrelated: ]
[ Unrelated: ]
In[]:=
evo=SubstitutionSystemCausalEvolution[{"BA"->"AB"},StringRepeat["BA",10],10];
In[]:=
eventCoordinates[evo,2]
Out[]=
In[]:=
Graphics[Point[lorentz[0.3]/@eventCoordinates[evo,2]]]
Out[]=
In[]:=
eventCoordinates[history_,stretch_]:=Block[{n,yFactor},n[1]=0;Do[n[i]=n[i-1]+Length[history〚i,2〛],{i,2,Length[history]-1}];yFactor=(1+1);{#〚1〛-2,stretch(3+#〚2〛)/2}&/@Reap[MapIndexed[layerEventsShapes[Last[#1],-yFactorFirst[#2],-yFactor(First[#2]+1)+1,0,False,n[First[#2]]]&,Rest[history]]]〚2,1,All,2〛]
In[]:=
boostedEvolution[evolution_,boost_:0.3]:=Module[{eventIndexGroups,allEvents,eventGroups},eventIndexGroups=GatherBy[Normal@ReverseSort[Association[Thread[Range[Length[#]]#]&@Round[(lorentz[boost]/@eventCoordinates[evolution,2])〚All,2〛]]],#〚2〛&]〚All,All,1〛;allEvents=Catenate[Rest[evo]〚All,2〛];eventGroups=allEvents〚#〛&/@eventIndexGroups;Prepend[Transpose[{Rest[FoldList[Fold[StringReplacePart[#,"AB",#2〚1〛]&,#,#2]&,evolution〚1,1〛,eventGroups]],eventGroups}],{evolution〚1,1〛}]]
In[]:=
SubstitutionSystemCausalPlot[boostedEvolution[evo,0.3],EventLabelsFalse,CellLabelsTrue,CausalGraphFalse]
Out[]=