(******************************************************************* This file was generated automatically by the Mathematica front end. It contains Initialization cells from a Notebook file, which typically will have the same name as this file except ending in ".nb" instead of ".m". This file is intended to be loaded into the Mathematica kernel using the package loading commands Get or Needs. Doing so is equivalent to using the Evaluate Initialization Cells menu command in the front end. DO NOT EDIT THIS FILE. This entire file is regenerated automatically each time the parent Notebook file is saved in the Mathematica front end. Any changes you make to this file will be overwritten. ***********************************************************************) SMWEvolveList[rule_,s_,n_]:=NestList[SMWStep[rule,#]&,s,n] SMWStep[rule_,s_]:=SMWStep1[rule,s,SMWFilter[StringPosition[s,First/@rule]]] SMWFilter[s_]:= Fold[If[Last[Last[#1]]>=First[#2],#,Append[#,#2]]&,{First[s]},Rest[s]] SMWFilter[{}]={}; SMWStep1[rule_,s_,pos_]:= StringReplacePart[s,(StringTake[s,#]&/@pos)/.rule,pos] SMWStep1[rule_,s_,{}]:=s SMWEvolveList[rule_,s_,n_,Backward]:=NestList[SMWStepBackward[rule,#]&,s,n] SMWStepBackward[rule_,s_]:= SMWStep1[rule,s, Reverse[SMWFilterBackward[Reverse[StringPosition[s,First/@rule]]]]] SMWFilterBackward[s_]:= Fold[If[First[Last[#1]]<=Last[#2],#,Append[#,#2]]&,{First[s]},Rest[s]] SMWFilterBackward[{}]={}; SMWEvolveList[rule_,s_,n_,First]:=NestList[SMWStepFirst[rule,#]&,s,n] SMWStepFirst[rule_,s_]:=SMWStep1[rule,s,StringPosition[s,First/@rule,1]] SMWEvolveList[rule_,s_,n_,SSS]:=NestList[SMWStepSSS[rule,#]&,s,n] SMWStepSSS[rule_,s_]:= SMWStep1[rule,s, If[#==={},{},{First[#]}]&[Flatten[StringPosition[s,First[#],1]&/@rule,1]]] SMWEvolveListX[rule_,s_,n_]:=NestList[SMWStepX[rule,First[#]]&,{s},n] SMWStepX[rule_,s_]:= Module[{q,z}, z=SMWStep1X[rule,s, q=SMWFilter[StringPosition[s,First/@rule]]];{StringReplace[ z,{"<"->"",">"->""}],MapThread[Rule,{q,FinalPositions[z]}]}] SMWStep1X[rule_,s_,pos_]:= StringReplacePart[s,(StringTake[s,#]&/@pos)/.ModRules[rule],pos] SMWStep1X[rule_,s_,{}]:=s ModRules[rule_]:=(First[#]->StringJoin["<",Last[#],">"])&/@rule FinalPositions[s_]:=(#-2(Range[Length[#]]-1))&[ Transpose[{First/@StringPosition[s,"<"],First/@StringPosition[s,">"]-2}]] SMWEvolveListX[rule_,s_,n_,Backward]:= NestList[SMWStepXBackward[rule,First[#]]&,{s},n] SMWStepXBackward[rule_,s_]:= Module[{q,z}, z=SMWStep1X[rule,s, q=Reverse[ SMWFilterBackward[ Reverse[StringPosition[s,First/@rule]]]]];{StringReplace[ z,{"<"->"",">"->""}],MapThread[Rule,{q,FinalPositions[z]}]}] SMWEvolveListX[rule_,s_,n_,First]:= NestList[SMWStepXFirst[rule,First[#]]&,{s},n] SMWStepXFirst[rule_,s_]:= Module[{q,z}, z=SMWStep1X[rule,s,q=StringPosition[s,First/@rule,1]];{StringReplace[ z,{"<"->"",">"->""}],MapThread[Rule,{q,FinalPositions[z]}]}] SMWEvolveListX[rule_,s_,n_,SSS]:=NestList[SMWStepXSSS[rule,First[#]]&,{s},n] SMWStepXSSS[rule_,s_]:= Module[{q,z}, z=SMWStep1X[rule,s, q=If[#==={},{},{First[#]}]&[ Flatten[StringPosition[s,First[#],1]&/@rule,1]]];{StringReplace[ z,{"<"->"",">"->""}],MapThread[Rule,{q,FinalPositions[z]}]}] SMWEvolveListRandomX[rule_,s_,n_,max_:1]:= NestList[SMWStepRandomX[rule,First[#],max]&,{s},n] SMWStepRandomX[rule_,s_,max_]:= Module[{q,z}, z=SMWStep1X[rule,s, q=SMWFilterRandom[StringPosition[s,First/@rule],max]];{StringReplace[ z,{"<"->"",">"->""}],MapThread[Rule,{q,FinalPositions[z]}]}] SMWFilterRandom[{},_]={}; SMWFilterRandom[s_,max_]:=Sort[Block[{used={}},Nest[SFR0,s,max];used]] SFR0[{}]={}; SFR0[s_]:=Module[{i=Random[Integer,{1,Length[s]}],s0,s1},{s0,s1}=s[[i]]; If[Select[ used,((s0<=First[#]&&s1>=First[#])||(s0<=Last[#]&& s1>=Last[#])||(s0>=First[#]&&s1<=Last[#])||(s0<=First[#]&& s1>=Last[#]))&]==={},AppendTo[used,s[[i]]];Drop[s,{i}],s]] SMWCyclicEvolveListX[rule_,s_,n_]:= NestList[SMWCyclicStepX[rule,First[#], Max[StringLength[First[#]]&/@rule]-1]&,{s},n] SMWCyclicStepX[rule_,s_,max_]:=Module[{q,z,ss,addon,beg,end}, addon=Min[StringLength[s],max]; ss=StringJoin[s,StringTake[s,addon]]; q=SMWFilter[StringPosition[ss,First/@rule]]; q=Cases[ q,{x_,y_}/; y<=StringLength[s]|| y-StringLength[s]0, Max[Last[q]\[LeftDoubleBracket]2\[RightDoubleBracket]-StringLength[s], 0],0]; end= If[Length[q]>0, addon-Max[0, Last[q]\[LeftDoubleBracket]2\[RightDoubleBracket]- StringLength[s]],addon]; z=StringDrop[StringDrop[SMWStep1X[rule,ss,q],beg],-end]; (* If[Last[q]\[LeftDoubleBracket]2\[RightDoubleBracket]>StringLength[s], q\[LeftDoubleBracket]Length[ q]\[RightDoubleBracket]={q\[LeftDoubleBracket]Length[q], 1\[RightDoubleBracket],StringLength[s], q\[LeftDoubleBracket]Length[q],2\[RightDoubleBracket]- StringLength[s]}]; *) {StringReplace[z,{"<"->"",">"->""}], MapThread[Rule,{q,FinalPositions[z]}]}] SMWEvolveListNW[rule_,s_,n_]:= TransformNW[SMWEvolveListNW0[SMWEvolveListX[rule,s,n]]] SMWEvolveListNW0::usage= "The input to SMWEvolveListNW0[v_] is the output from SMWEvolveListX. The \ output is a list of the edges in the causal network. Each edge is of the form \ {{w,x},{y,z}} where w is the starting node, x is the spatial position on that \ node (relative to the left-hand side of the whole space, not to the left-hand \ side of the node), and similarly y is the finishing node and z is the spatial \ position on that node. Note that the initial state is considered to be node \ 0. Edges which constitute the final state are not included unless the option \ AddFinalNode is set to True, in which case the final state is also considered \ to be a node. If IncludeColors->True, then the edge is listed as \ {{w,x},{y,z},C} where C is the color of the edge (by color I mean the \ character associated with the edge; typically this is some capital letter \ like A or B)."; Options[SMWEvolveListNW0]={AddFinalNode->False,IncludeColors->False}; SMWEvolveListNW0[v_,opts___?OptionQ]:= Module[{nw={},c=1, state={0,#, StringTake[v\[LeftDoubleBracket]1,1\[RightDoubleBracket],{#}]}&/@ Range[StringLength[v\[LeftDoubleBracket]1,1\[RightDoubleBracket]]], newstate,addfinalnode, includecolors},{addfinalnode, includecolors}={AddFinalNode,IncludeColors}/.{opts}/.Options[ SMWEvolveListNW0]; Function[y, If[Length[y\[LeftDoubleBracket]2\[RightDoubleBracket]]>0, newstate= state\[LeftDoubleBracket]Range[1, y\[LeftDoubleBracket]2,1,1, 1\[RightDoubleBracket]-1]\[RightDoubleBracket]; MapIndexed[Function[{z,w}, newstate= Join[newstate,{c,#, StringTake[ y\[LeftDoubleBracket]1\[RightDoubleBracket],{#}]}&/@ Range@@z\[LeftDoubleBracket]2\[RightDoubleBracket]]; nw=Join[nw, If[includecolors,{state\[LeftDoubleBracket]#,{1, 2}\[RightDoubleBracket],{c,#}, state\[LeftDoubleBracket]#, 3\[RightDoubleBracket]},{state\[LeftDoubleBracket]\ #,{1,2}\[RightDoubleBracket],{c,#}}]&/@ Range@@z\[LeftDoubleBracket]1\[RightDoubleBracket]]; newstate= Join[newstate, If[First[w]== Length[y\[LeftDoubleBracket]2\[RightDoubleBracket]], state\[LeftDoubleBracket]Range[ z\[LeftDoubleBracket]1,2\[RightDoubleBracket]+1, Length[state]]\[RightDoubleBracket], state\[LeftDoubleBracket]Range[ z\[LeftDoubleBracket]1,2\[RightDoubleBracket]+1, y\[LeftDoubleBracket]2,First[w]+1,1, 1\[RightDoubleBracket]-1]\[RightDoubleBracket]]]; c++],y\[LeftDoubleBracket]2\[RightDoubleBracket]]; state=newstate]]/@Rest[v]; If[addfinalnode, nw=Join[nw, MapIndexed[ If[includecolors,{#1\[LeftDoubleBracket]{1, 2}\[RightDoubleBracket],{c, First[#2]},#1\[LeftDoubleBracket]3\[RightDoubleBracket]},{\ #1\[LeftDoubleBracket]{1,2}\[RightDoubleBracket],{c,First[#2]}}]&,state]]]; nw] Options[SMWEvolveListNW1]={AddFinalNode->False,IncludeColors->False, Complete->False,SSS->False}; SMWEvolveListNW1[rule_,s_,n_,init_,opts___?OptionQ]:= Module[{nw={},c=1,ss=s,t=0,nodelocations={},level, states={state={0,#,StringTake[s,{#}]}&/@Range[StringLength[s]]}, newstate,addfinalnode,includecolors,complete, sss},{addfinalnode,includecolors,complete, sss}={AddFinalNode,IncludeColors,Complete,SSS}/.{opts}/.Options[ SMWEvolveListNW1]; level[0]=0; (level[#]=1)&/@init; While[True, Function[y,t++;ss=y\[LeftDoubleBracket]1\[RightDoubleBracket]; If[Length[y\[LeftDoubleBracket]2\[RightDoubleBracket]]>0, newstate= state\[LeftDoubleBracket]Range[1, y\[LeftDoubleBracket]2,1,1, 1\[RightDoubleBracket]-1]\[RightDoubleBracket]; MapIndexed[Function[{z,w}, If[complete&&!MemberQ[init,c], level[c]=(If[#=={},0,Min[#]+1]&[ Cases[level/@ First/@state\[LeftDoubleBracket] Range@@ z\[LeftDoubleBracket]1\[RightDoubleBracket]\ \[RightDoubleBracket],_?((#!=0)&)]])]; nodelocations=Append[nodelocations,{t,z}]; newstate= Join[newstate,{c,#, StringTake[ y\[LeftDoubleBracket]1\[RightDoubleBracket],{#}]}&\ /@Range@@z\[LeftDoubleBracket]2\[RightDoubleBracket]]; nw=Join[nw, If[includecolors,{state\[LeftDoubleBracket]#,{1, 2}\[RightDoubleBracket],{c,#}, state\[LeftDoubleBracket]#, 3\[RightDoubleBracket]},{state\ \[LeftDoubleBracket]#,{1,2}\[RightDoubleBracket],{c,#}}]&/@ Range@@z\[LeftDoubleBracket]1\[RightDoubleBracket]]; newstate= Join[newstate, If[First[w]== Length[y\[LeftDoubleBracket]2\[RightDoubleBracket]], state\[LeftDoubleBracket]Range[ z\[LeftDoubleBracket]1,2\[RightDoubleBracket]+1, Length[state]]\[RightDoubleBracket], state\[LeftDoubleBracket]Range[ z\[LeftDoubleBracket]1,2\[RightDoubleBracket]+1, y\[LeftDoubleBracket]2,First[w]+1,1, 1\[RightDoubleBracket]-1]\[RightDoubleBracket]]]\ ; c++],y\[LeftDoubleBracket]2\[RightDoubleBracket]]; state=newstate; states=Append[states,state]]][ If[sss,SMWStepXSSS[rule,ss],SMWStepX[rule,ss]]]; If[(complete &&((#!={0}&&Min[Complement[#,{0}]]>=n)&@ Union[level/@First/@state]) )||(!complete && t==n), Break[]]]; If[addfinalnode, nw=Join[nw, MapIndexed[ If[includecolors,{#1\[LeftDoubleBracket]{1, 2}\[RightDoubleBracket],{c, First[#2]},#1\[LeftDoubleBracket]3\[RightDoubleBracket]},{\ #1\[LeftDoubleBracket]{1,2}\[RightDoubleBracket],{c,First[#2]}}]&,state]]]; {nw,states,nodelocations}] TransformNW[s_]:= (Function[x,(x->Function[y,#[[y,2]]]/@Flatten[Position[First/@#,x]])]/@ Union[First/@#])&[{#[[1,1]],#[[2,1]]}&/@Sort[s]] TransformNWX::usage= "TransformNWX[s] deals with directed networks with parallel edges. It \ takes input from SMWEvolveListNW0 with IncludeColors->True, and it produces a \ list of items of the form 0->{{a1,a2,a3,alist},{b1,b2,b3,{blist}},...} where \ this means that: there are a2 edges going from node 0 to node a1 and a3-a2 \ edges going from node a1 to node 0; there are b2 edges going from node 0 to \ node b1 and b3-b2 edges going from node b1 to node 0; and so on. alist is the \ list of letters associated with the edges going from 0 to a1 and from a1 to \ 0, in that order."; TransformNWX[s_]:=Module[{g,nodes,connectnodes}, g={#\[LeftDoubleBracket]1,1\[RightDoubleBracket],#\[LeftDoubleBracket]2, 1\[RightDoubleBracket]}&/@s; nodes=Union[Flatten[g]]; connectnodes=(Union[ g\[LeftDoubleBracket]#\[LeftDoubleBracket]1\[RightDoubleBracket]\ ,3-#\[LeftDoubleBracket]2\[RightDoubleBracket]\[RightDoubleBracket]&/@ Position[g,#]])&/@nodes; MapThread[ Function[{x,y}, x->({#,Count[g,{x,#}],Count[g,{x,#}|{#,x}], Join[Last/@Cases[s,{{x,_},{#,_},_}], Last/@Cases[s,{{#,_},{x,_},_}]]}&)/@y],{nodes, connectnodes}]] SMWCyclicEvolveListNW[rule_,s_,n_]:= TransformNW[SMWCyclicEvolveListNW0[rule,s,n]] SMWCyclicEvolveListNW0[rule_,s_,n_]:= Module[{nw={},c=1,v=SMWCyclicEvolveListX[rule,s,n], state={0,#}&/@Range[StringLength[s]],newstate,x,t}, (Do[If[ Length[v\[LeftDoubleBracket]t,2\[RightDoubleBracket]]> 0,(newstate= state\[LeftDoubleBracket]Range[ Max[1,Last[ v\[LeftDoubleBracket]t, 2\[RightDoubleBracket]]\[LeftDoubleBracket]1, 2\[RightDoubleBracket]+1- StringLength[ v\[LeftDoubleBracket]t-1,1\[RightDoubleBracket]]], v\[LeftDoubleBracket]t,2,1,1, 1\[RightDoubleBracket]-1]\[RightDoubleBracket];Do[( newstate= Join[newstate,{c,#}&/@ Range@@v\[LeftDoubleBracket]t,2,x, 2\[RightDoubleBracket]]; nw=Join[ nw,{state\[LeftDoubleBracket] Mod[#-1, StringLength[ v\[LeftDoubleBracket]t-1, 1\[RightDoubleBracket]]]+1\ \[RightDoubleBracket],{c,#}}&/@ Range@@v\[LeftDoubleBracket]t,2,x, 1\[RightDoubleBracket]]; newstate= Join[newstate, If[x==Length[ v\[LeftDoubleBracket]t,2\[RightDoubleBracket]], state\[LeftDoubleBracket]Range[ v\[LeftDoubleBracket]t,2,x,1, 2\[RightDoubleBracket]+1, Length[state]]\[RightDoubleBracket], state\[LeftDoubleBracket]Range[ v\[LeftDoubleBracket]t,2,x,1, 2\[RightDoubleBracket]+1, v\[LeftDoubleBracket]t,2,x+1,1, 1\[RightDoubleBracket]-1]\[RightDoubleBracket]]]\ ; c++), {x,Length[v\[LeftDoubleBracket]t,2\[RightDoubleBracket]]}]; state=newstate)],{t,2,n+1}]; nw)] <2.5, ColorTable->{{1,0,0},{0,1,1}}], ParametricPlot[#[x],{x,#[[2,1]],#[[2,2]]}, DisplayFunction->Identity]&/@(SplineFit[#,Cubic]&/@ CauchyCoordinates[history,2.5])} CauchyPlot::usage= "Feed in output to SMWEvolveListX and get a network graphics plot of the \ evolution along with plots of all Cauchy surfaces. I need to clean this up a \ bit so that lines stay within their channels, and specify a few options for \ this function (namely ColorTable and YFactor)."; FindNextEdge[path_]:= Module[{w,x,y,z},{w,x}= Last[path]\[LeftDoubleBracket]1\[RightDoubleBracket]; While[Length[t\[LeftDoubleBracket]w+1,2\[RightDoubleBracket]]==x, If[w==0,paths=Join[paths,{path}];Return[]];{w,x}= Last[t\[LeftDoubleBracket]w+1,1\[RightDoubleBracket]]];x++; While[True, FindNextEdge[ Join[path,{{{w,x},{y,z}= t\[LeftDoubleBracket]w+1,2,x\[RightDoubleBracket]}}]]; If[z==1,{w,x}={y,1},Break[]]]] Cauchy[s_]:= Block[{t=EvolveListToTensor[s],paths={}}, Module[{w=0,x}, While[w+1x\[LeftDoubleBracket]2\[RightDoubleBracket], x\[LeftDoubleBracket]2\[RightDoubleBracket], w]]}],#]],#])&@yrange] YCoordinates::usage= "Input to YCoordinates[path,nodelocations,yfactor]: path is a Cauchy \ surface (presumably taken from the list of paths output by Cauchy); it is a \ list of the timelike edges that are crossed by the surface. nodelocations is \ the output to NodeLocations. yfactor is the value of the YFactor option in \ SMWGraphicsNetwork or SMWXGraphicsStreamed. The output is a list of y \ coordinates, one for each timelike edge crossed by the path, indicating where \ that edge is to be crossed. The y coordinates are computed using a weighting \ method. Say you are computing where to cross edge i. The weight of edge j is \ 1/(Abs[i-j]+1), and the y-coordinate vote for edge j is the midpoint of the \ intersection of edges i and j if this is nonempty, and the bottom or top of \ edge i otherwise (depending on whether edge j is completely below or above \ edge i). The resulting y coordinate is the dot product of the weights and the \ y-coordinate votes divided by the sum of the weights. Of course different \ weighting functions could be easily substituted here. Also it may make things \ look a little better if you make the minimum and maximum y coordinate for an \ edge not be the very bottom and very top of the edge; make it a little higher \ than the bottom and lower than the top."; XCoordinate[{ii_,jj_},nodelocations_,history_,yfactor_,y_]:= Module[{x1,y1,x2,y2,i=ii,j=jj,step=True,eps=.000001}, {i,j}=If[ i==0,{0,j},{#\[LeftDoubleBracket]1\[RightDoubleBracket],#\ \[LeftDoubleBracket]2,2,1\[RightDoubleBracket]+j-1}&@ nodelocations\[LeftDoubleBracket]i\[RightDoubleBracket]];{x2, y2}={j+.5,(i+1)*yfactor-1}; While[True,{x1,y1}={x2,y2}; If[step,{x2,y2}={x1,y1+1},y2=y1+yfactor-1; If[++i+1>Length[history],x2=x1, j+=(Function[x,#[[x,2,2]]-#[[x,1,2]]]@ First[Last[Position[First/@#,{_,x_}/;j>x]]])&@ Join[{{0,0}->{0,0}},history[[i+1,2]]]; x2=j+.5]]; If[y1-epsTrue]]]]] EvolveListToTensor::usage= "The input to EvolveListToTensor[s_] is the output to SMWEvolveListX. The \ output is a list of terms of the form {{e1,e2,...,em},{f1,f2,...,fn}}, one \ for each causal node in the system. These represent the incoming and outgoing \ edges for the node, respectively. Each edge ei and fj is of the form {x,y}, \ where x represents the destination node and y represents the location on the \ node, with the leftmost location on the node denoted number 1. (So for the ei \ y denotes an incoming location and for the fj it denotes an outgoing \ location.) The initial and final states are considered as nodes, with the \ initial node numbered 0; the former has no incoming edges and the latter no \ outgoing edges. So the first term in the list corresponds to the initial \ node, the second to node 1 and so on."; SMWSimpleGraphics[history_]:= RPadGraphics[ToCharacterCode/@history-First[ToCharacterCode["A"]]] SMWSimpleGraphicsCW[history_]:= Surround[Graphics[ MapIndexed[sgcw0[#,-First[#2]]&, ToCharacterCode/@history-First[ToCharacterCode["A"]]],AspectRatio->1]] SMWXGraphics[history_,fac_:2.5]:= Graphics[{MapIndexed[frx[Last[#1],-fac First[#2],-fac (First[#2]+1)+1,0]&, Rest[history]],MapIndexed[erx[First[#1],-fac First[#2]]&,history]}, PlotRange->All,AspectRatio->Automatic] SMWXGraphicsStreamed[history_,opts___?OptionQ]:= Block[{colortable,graphicsoptions,fac,wedgenumber,numbersize, n},{colortable,graphicsoptions,fac,wedgenumber, numbersize}={ColorTable,GraphicsOptions,YFactor,WedgeNumber, NumberSize}/.{opts}/.Options[SMWXGraphicsStreamed];n[1]=0; Do[n[i]=n[i-1]+ Length[history\[LeftDoubleBracket]i,2\[RightDoubleBracket]],{i,2, Length[history]-1}]; Graphics[{MapIndexed[erxp[First[#1],-fac First[#2]]&,history], MapIndexed[ qrx[#1,-fac First[#2],-fac (First[#2]+1)+1, StringLength[history[[First[#2],1]]]]&,Rest[history]], MapIndexed[ frx[Last[#1],-fac First[#2],-fac (First[#2]+1)+1,0,wedgenumber, n[First[#2]]]&,Rest[history]]},graphicsoptions,PlotRange->All, AspectRatio->Automatic]] Options[SMWXGraphicsStreamed]={ColorTable->{{.85},{0},{.5,0,0},{0,.5,0},{0, 0,.5},{.5,.5,0},{.5,0,.5},{0,.5,.5},{.25,.75,0}}, GraphicsOptions->{},YFactor->2.5,WedgeNumber->False, NumberSize->$DefaultFont\[LeftDoubleBracket]2\[RightDoubleBracket]}; SMWXGraphicsStreamedCW[history_,fac_:2.5]:= MakeConstantWidth[SMWXGraphicsStreamed[history,YFactor->2,AspectRatio->1], StringLength[First[#]]&/@history,fac/2] SMWXGraphicsNetwork[history_,opts___?OptionQ]:= Block[{colortable,graphicsoptions,fac,thinwedge,ribbonwidth,wedgenumber, numbersize, n},{colortable,graphicsoptions,fac,thinwedge,ribbonwidth,wedgenumber, numbersize}={ColorTable,GraphicsOptions,YFactor,ThinWedge,RibbonWidth, WedgeNumber,NumberSize}/.{opts}/.Options[SMWXGraphicsNetwork]; n[1]=0;Do[ n[i]=n[i-1]+ Length[history\[LeftDoubleBracket]i,2\[RightDoubleBracket]],{i,2, Length[history]-1}]; Graphics[{MapIndexed[erxp[First[#1],-fac First[#2],"nw"]&,history], MapIndexed[ qrx[#1,-fac First[#2],-fac (First[#2]+1)+1, StringLength[history[[First[#2],1]]],"nw"]&,Rest[history]], MapIndexed[ frx[Last[#1],-fac First[#2],-fac (First[#2]+1)+1,thinwedge, wedgenumber,n[First[#2]]]&,Rest[history]]},graphicsoptions, PlotRange->All,AspectRatio->Automatic]] Options[SMWXGraphicsNetwork]={ColorTable->{{.85},{0},{.5,0,0},{0,.5,0},{0, 0,.5},{.5,.5,0},{.5,0,.5},{0,.5,.5},{.25,.75,0}}, GraphicsOptions->{},YFactor->2.5,ThinWedge->.3,RibbonWidth->.15, WedgeNumber->False, NumberSize->$DefaultFont\[LeftDoubleBracket]2\[RightDoubleBracket]}; sgcw0[a_,y_]:= MapIndexed[{GrayLevel[1-#], Rectangle[{(First[#2]-1)/Length[a],y},{First[#2]/Length[a],y+1}]}&,a] erx[s_,y_]:= MapIndexed[ EdgedRectangle[{First[#2],y},{First[#2]+1,y+1}, GrayLevel[#/.{"A"->.85,"B"->0}],GrayStyle]&,Characters[s]] frx[list_,y1_,y2_,thin_]:=frx0[#,y1,y2,thin]&/@list frx[list_,y1_,y2_,thin_,wedgenumber_,n_]:= MapIndexed[frx0[#,y1,y2,thin,wedgenumber,n+First[#2]]&,list] frx0[{a_,b_}->{c_,d_},y1_,y2_,thin_]:= EdgedPolygon[{{a+thin,y1},{b+1-thin,y1},{d+1-thin,y2},{c+thin,y2},{a+thin, y1}},GrayLevel[.5],GrayStyle] frx0[{a_,b_}->{c_,d_},y1_,y2_,thin_,wedgenumber_, n_]:={EdgedPolygon[{{a+thin,y1},{b+1-thin,y1},{d+1-thin,y2},{c+thin, y2},{a+thin,y1}},GrayLevel[.5],GrayStyle], If[wedgenumber,{Text[ StyleForm[n, FontSize->numbersize],{(a+b+c+d+2)*.25,(y1+y2)*.5}]},{}]} qrx[{s_,pos_},y1_,y2_,oldlength_,opts___]:= Module[{si=(First[ToCharacterCode[#]]-65)&/@Characters[s],t}, t=DeleteCases[ qrx0/@Partition[ Join[{{0, If[Length[pos]>0,Max[0,pos[[Length[pos],1,2]]-oldlength], 0]}->{0,0}}, pos,{({1,1}(Length[si]+1- If[pos=!={},pos[[-1,-1,-1]]-pos[[-1,1,-1]], 0]))->({1,1}(Length[si]+1))}],2,1],{}]; qrx1[si,#,y1,y2,opts]&/@t] qrx0[{{_,b_}->{_,d_},{ap_,_}->{cp_,_}}]:=If[b+1>ap-1,{},{d-b,{d+1,cp-1}}] qrx1[si_,{d_,{i0_,i1_}},y1_,y2_]:= Table[{CharColor[si\[LeftDoubleBracket]i\[RightDoubleBracket]], Polygon[{{i-d,y1},{i+1-d,y1},{i+1,y2},{i,y2}}], Flatten[{GrayStyle,Line[{{i-d,y1},{i,y2}}], Line[{{i+1-d,y1},{i+1,y2}}]}]},{i,i0,i1}] qrx1[si_,{d_,{i0_,i1_}},y1_,y2_,"nw"]:= Table[{CharColor[si\[LeftDoubleBracket]i\[RightDoubleBracket]], Polygon[{{i-d+.5-ribbonwidth,y1},{i+.5+ribbonwidth-d, y1},{i+.5+ribbonwidth,y2},{i+.5-ribbonwidth,y2}}], Flatten[{GrayStyle, Line[{{i-d+.5-ribbonwidth,y1},{i+.5-ribbonwidth,y2}}], Line[{{i+.5+ribbonwidth-d,y1},{i+.5+ribbonwidth,y2}}]}]},{i,i0,i1}] erxp[s_,y_]:= MapIndexed[ erxp0[{First[#2],y},{First[#2]+1,y+1}, CharColor[First[ToCharacterCode[#]]-65],GrayStyle]&,Characters[s]] erxp[s_,y_,"nw"]:= MapIndexed[ erxp0[{First[#2]+.5-ribbonwidth,y},{First[#2]+.5+ribbonwidth,y+1}, CharColor[First[ToCharacterCode[#]]-65],GrayStyle]&,Characters[s]] erxp0[{x1_,y1_},{x2_,y2_},g_,e_]:= Flatten[{g,Rectangle[{x1,y1},{x2,y2}],e,Line[{{x1,y1},{x1,y2}}], Line[{{x2,y1},{x2,y2}}]}] CharColor[i_]:= If[Length[#]==1,GrayLevel@@#,RGBColor@@#]&[ If[i+1<=Length[colortable], colortable\[LeftDoubleBracket]i+1\[RightDoubleBracket],{0}]] MakeConstantWidth[g_,lens_,fac_]:= g/.{x_Integer,y_Integer}:>{(x-1)/lens[[-Floor[y/2]]],y fac} SMWRuleGraphic[rule_List,k_Integer:2]:= FramedGraphicsRow[(SMWRG1[First[#1],Last[#1],k]&)/@rule] SMWRG1[s0_List,s1_List,k_Integer]:= Graphics[{{AbsoluteThickness[0.25],GrayLevel[0.5], Polygon[{{1,0},{1,-1},{Length[s1]+1,-1},{Length[s0]+1,0}}], GrayLevel[0],Line[{{1,0},{1,-1}}], Line[{{Length[s0]+1,0},{Length[s1]+1,-1}}]}, Table[{EdgedRectangle[{i,0},{i+1,1}, GrayLevel[ If[s0\[LeftDoubleBracket]i\[RightDoubleBracket]\[Equal]1,0, 0.75]],GrayStyle],GrayLevel[0]},{i,Length[s0]}], Table[EdgedRectangle[{i,-2},{i+1,-1}, GrayLevel[ If[s1\[LeftDoubleBracket]i\[RightDoubleBracket]\[Equal]1,0,0.75]], GrayStyle],{i,Length[s1]}]},AspectRatio\[Rule]Automatic, PlotRange\[Rule]{{0,Max[Length[s1],Length[s0]]+2},{-2.6,1.6}}, Frame\[Rule]True,FrameTicks\[Rule]None,FrameStyle\[Rule]HairlineStyle] SMWNetworkPicture::usage= "SMWNetworkPicture[rule,s,n,init,opts] produces a set of graphic objects \ which represent the causal network given by SMWEvolveListX[rule,s,n]. g is a \ list of items of the form 0\[Rule]S{{a1,a2,a3,alist},{b1,b2,b3,blist},...} \ where this means that: there are a2 edges going from node 0 to node a1 and \ a3-a2 edges going from node a1 to node 0; there are b2 edges going from node \ 0 to node b1 and b3-b2 edges going from node b1 to node 0; and so on. The \ colors of the edges emerging from node a are given in alist, with the \ outgoing colors listed first. The edges are drawn as quadratic curves. init \ is a list containing nodes to put at the top of the network. Internal data \ structures used: time[t] is a list of nodes at time t; nodecoordinates[i] are \ the abstract {space,time} coordinates of node i. Options: ArrowAngle specifies the angle those segments make with the edge. ArrowLength specifies the length of the line segments making up the arrows. ArrowLocation is a number between 0 and 1 which specifies where the arrow \ is on the edge (default is .6). Arrows\[Rule]True gives arrows on the edges. ArrowThickness is the absolute point size of the arrow lines. AspectRatio is the aspect ratio. Complete\[Rule]True completes the network up to causal level n; \ Complete->False displays the network corresponding to n time steps of \ SMWEvolveListX. Dip is the amount that edges between nodes at the same time slice dip \ downward (if not in Hyperbola mode). FinalEdges\[Rule]True means the edges which have starting node but no \ ending node are drawn. Hyperbola\[Rule]True puts nodes at the same time slice on hyperbolas. LightCone\[Rule]True presents the picture the way I have described it \ (initial nodes at top, picture is created downwards); if it's false then \ initial nodes are at left and picture grows to the right. MaxLevel is the maximum time slice that will be displayed. Hence if for \ example one cannot use the Complete option and one wants something that is as \ complete as possible, one can set n to be very large and MaxLevel to be the \ level you want completed. NodeNumber \[Rule]True means the nodes will be numbered. NodeSize is the size of disks drawn at nodes. NumberSize is the point size of the node numbers. ParallelSeparation is the amount that parallel edges are separated. Reordered\[Rule]True attempts to order the nodes on each horizontal row to \ eliminate crossings. Ribbon\[Rule]True draws the edges as ribbons, and arrows (if any) as \ triangles. RibbonColorTable is a list of ribbon colors, corresponding to the letters \ A, B, ... RibbonPointCount specifies how many polygonal edges to use to make each \ side of the ribbon. RibbonWidth is half the coordinate width of the ribbons. SSS->True does replacements only the first replacement found at a given \ time step. Symmetrized\[Rule]True centers the nodes horizontally."; Options[DNPicture]={Symmetrized\[Rule]True,ParallelSeparation\[Rule].1, Dip\[Rule].35,Hyperbola\[Rule]False,NodeSize\[Rule]0,NodePoint\[Rule]0, NodeColor\[Rule]GrayLevel[.5],AspectRatio\[Rule]Automatic, LightCone\[Rule]True,Arrows\[Rule]False,ArrowLength\[Rule].11, ArrowThickness\[Rule].25,ArrowAngle\[Rule]Pi/6,EdgeThickness->.25, ArrowLocation\[Rule].6,Ribbon\[Rule]False,NodeNumber->False, NumberSize->$DefaultFont\[LeftDoubleBracket]2\[RightDoubleBracket], RibbonWidth\[Rule].03,RibbonPointCount\[Rule]100, RibbonColorTable\[Rule]{GrayLevel[.85],GrayLevel[0]}}; Options[SMWNetwork]={Reordered\[Rule]False,MaxLevel\[Rule]\[Infinity], FinalEdges\[Rule]True,Complete->False,SSS\[Rule]False}; SMWNetwork[rule_,s_,n_,init_,opts___?OptionQ]:= Block[{g,y,z,edges,states,nodelocations,already,future,time,nodecoordinates, maxt,reord,finaledges,complete,sss, maxlevel},{reord,finaledges,complete,sss, maxlevel}={Reordered,FinalEdges,Complete,SSS, MaxLevel}/.{opts}/.Options[SMWNetwork]; {edges,states,nodelocations}= SMWEvolveListNW1[rule,s,n,init,Complete->complete,IncludeColors->True, AddFinalNode->(complete||finaledges),SSS->sss]; g=TransformNWX[edges]; time[0]=init; already={}; maxt = 0; While[time[maxt]\[NotEqual]{}, already=Union[already,time[maxt]]; MapIndexed[(nodecoordinates[#1]={First[#2],maxt})&,time[maxt]]; maxt++; time[maxt]= Complement[ Flatten[(First/@ Cases[#,_?((#\[LeftDoubleBracket]2\[RightDoubleBracket]> 0)&)])&/@(time[maxt-1]/.g)],already]; If[(maxt==maxlevel)||(complete&&MemberQ[time[maxt],Length[g]-1]),Break[]]; If[finaledges,time[maxt]=Complement[time[maxt],{Length[g]-1}]]; If[reord,time[maxt]=Sort[time[maxt],SMWsort]]; ]; future=already; While[time[maxt]\[NotEqual]{},future=Union[future,time[maxt]];maxt++; time[maxt]= Complement[ Flatten[(First/@ Cases[#,_?((#\[LeftDoubleBracket]2\[RightDoubleBracket]> 0)&)])&/@(time[maxt-1]/.g)],future]]; g=(#\[LeftDoubleBracket]1\[RightDoubleBracket]\[Rule] Join[Cases[#\[LeftDoubleBracket]2\[RightDoubleBracket],{x_,__}/;\ !MemberQ[Complement[future,already],x]],y=z={}; Function[w, Do[If[i>w\[LeftDoubleBracket]2\[RightDoubleBracket], z=Append[z, w\[LeftDoubleBracket]4,i\[RightDoubleBracket]], y=Append[y, w\[LeftDoubleBracket]4, i\[RightDoubleBracket]]],{i, w\[LeftDoubleBracket]3\[RightDoubleBracket]}]]/@ Cases[#\[LeftDoubleBracket]2\[RightDoubleBracket],{x_,__}/; MemberQ[Complement[future,already],x]];{{\[Infinity], Length[y],Length[y]+Length[z],Join[y,z]}}])&/@ Cases[g,HoldPattern[_Integer?(MemberQ[already,#]&)->_]]; {g,already,nodecoordinates[#]&/@already,time[#]&/@Range[0,maxt]}] SMWNetworkR[args___]:=SMWNetwork[args,Reordered->True] DNPicture[{g_,already_,nodecoords_,t_},opts___?OptionQ]:= Block[{nodecoordinates,a,b,c,d,psep,dip,hyperbola,sym,ar,cone,nodesize, nodepoint,arrows,arrowlength,arrowthickness,arrowangle,arrowlocation,up, ribbon,ribbonwidth,ribbonpointcount,nodecolor,ribboncolortable, nodenumber,numbersize, edgethickness},{sym,ar,cone,hyperbola,nodesize,nodepoint,dip,psep, arrows,arrowlength,arrowthickness,arrowangle,arrowlocation,ribbon, ribbonwidth,ribbonpointcount,nodecolor,ribboncolortable,nodenumber, numbersize, edgethickness}={Symmetrized,AspectRatio,LightCone,Hyperbola,NodeSize, NodePoint,Dip,ParallelSeparation,Arrows,ArrowLength, ArrowThickness,ArrowAngle,ArrowLocation,Ribbon,RibbonWidth, RibbonPointCount,NodeColor,RibbonColorTable,NodeNumber,NumberSize, EdgeThickness}/.{opts}/.Options[DNPicture]; MapIndexed[(nodecoordinates[ already\[LeftDoubleBracket]First[#2]\[RightDoubleBracket]]=#1)&, nodecoords]; MapIndexed[(time[First[#2]-1]=#1)&,t]; Graphics[{Table[ If[!MemberQ[already, g\[LeftDoubleBracket]i,2,j,1\[RightDoubleBracket]]|| g\[LeftDoubleBracket]i,1\[RightDoubleBracket]< g\[LeftDoubleBracket]i,2,j,1\[RightDoubleBracket], Table[QuadraticCurve[{a,b}= DNPcoords[ nodecoordinates[ g\[LeftDoubleBracket]i,1\[RightDoubleBracket]]]; If[MemberQ[already, g\[LeftDoubleBracket]i,2,j,1\[RightDoubleBracket]],{c,d}= DNPcoords[ nodecoordinates[ g\[LeftDoubleBracket]i,2,j,1\[RightDoubleBracket]]]; {{a, b},{If[cone||hyperbola||(a\[NotEqual]c),0,dip]+(a+c)*.5- psep( k-(g\[LeftDoubleBracket]i,2,j, 3\[RightDoubleBracket]+1)/2) (d-b), If[!cone||hyperbola||(b\[NotEqual]d),0,-dip]+(b+d)*.5- psep(k-(g\[LeftDoubleBracket]i,2,j, 3\[RightDoubleBracket]+1)/2)(a-c)},{c, d}},{c,d}= If[g\[LeftDoubleBracket]i,1\[RightDoubleBracket]> g\[LeftDoubleBracket]i,2,j,1\[RightDoubleBracket], If[cone,{a,b+.75},{a-.75,b}], If[cone,{a,b-.75},{a+.75,b}]]; {{a, b},{(a+c)*.5+ psep(k-(g\[LeftDoubleBracket]i,2,j, 3\[RightDoubleBracket]+1)/2)(d-b),(b+ d)*.5+psep(k-(g\[LeftDoubleBracket]i,2,j, 3\[RightDoubleBracket]+1)/2)(a-c)},{c+2* psep(k-(g\[LeftDoubleBracket]i,2,j, 3\[RightDoubleBracket]+1)/2)(d-b), d+2*psep(k-(g\[LeftDoubleBracket]i,2,j, 3\[RightDoubleBracket]+1)/2)(a-c)}}], Up->If[k>g\[LeftDoubleBracket]i,2,j,2\[RightDoubleBracket], False,True],Arrows->arrows,ArrowLength->arrowlength, ArrowThickness->arrowthickness,ArrowAngle->arrowangle, ArrowLocation->arrowlocation, CurveThickness->edgethickness,Ribbon->ribbon, RibbonWidth->ribbonwidth,RibbonPointCount->ribbonpointcount, RibbonColor-> DNPgetcolor[ g\[LeftDoubleBracket]i,2,j,4,k\[RightDoubleBracket]]],{k, g\[LeftDoubleBracket]i,2,j,3\[RightDoubleBracket]}],{}],{i, Length[g]},{j, Length[g\[LeftDoubleBracket]i,2\[RightDoubleBracket]]}], Print[Max[already]]; If[nodesize>0,{nodecolor,Disk[DNPcoords[nodecoordinates[#]],nodesize], Black,AbsoluteThickness[.25], Circle[DNPcoords[nodecoordinates[#]],nodesize], If[nodenumber,{Text[StyleForm[#,FontSize->numbersize], DNPcoords[nodecoordinates[#]]]},{}]}, If[nodepoint>0,{AbsolutePointSize[nodepoint],Black, Point[DNPcoords[nodecoordinates[#]]]},{}]]&/@already}, AspectRatio->ar,PlotRange->All]] SMWNetworkPicture[rule_,s_,n_,init_,opts___?OptionQ]:= DNPicture[SMWNetwork[rule,s,n,init,opts],opts] SMWNetworkPictureR[args___]:=SMWNetworkPicture[args,Reordered->True] SMWsort::usage= "This function is used when Reorder->True in SMWNetworkPicture. The input \ is two node numbers i and j. The goal is to determine which comes first \ (spatially). Method: look at the edges which arrive at i and j from the \ previous causal time step. These edges are naturally ordered using the \ ordering of nodes at that time step. There are two possibilities. One is that \ all of one node's edges come before the other node's edges. In that case the \ nodes are put in that same order. The other is that one node's edges are \ surrounded by the other node's edges. In that case if the number of \ surrounding edges that come before the surrounded edges is greater than or \ equal to the number of surrounding edges that come after the surrounded \ edges, then the surrounding node comes first."; SMWsort[i_,j_]:=Module[{p,minnode,minedge,maxnode,maxedge,cmin,cmax}, p=Function[x, Function[ y,{Position[time[maxt-1], y\[LeftDoubleBracket]1\[RightDoubleBracket]]\ \[LeftDoubleBracket]1,1\[RightDoubleBracket], y\[LeftDoubleBracket]2\[RightDoubleBracket]}]/@ Cases[states\[LeftDoubleBracket] nodelocations\[LeftDoubleBracket]x,1\[RightDoubleBracket], Range@@nodelocations\[LeftDoubleBracket]x,2, 1\[RightDoubleBracket]\[RightDoubleBracket],_?(MemberQ[ time[maxt-1],First[#]]&)]]/@{i,j}; minnode=Min[First/@#]&/@p; maxnode=Max[First/@#]&/@p; minedge= Min[Last/@Cases[ p\[LeftDoubleBracket]#\[RightDoubleBracket],{minnode\ \[LeftDoubleBracket]#\[RightDoubleBracket],_}]]&/@{1,2}; maxedge= Max[Last/@Cases[ p\[LeftDoubleBracket]#\[RightDoubleBracket],{maxnode\ \[LeftDoubleBracket]#\[RightDoubleBracket],_}]]&/@{1,2}; cmin=Count[ p\[LeftDoubleBracket]#\[RightDoubleBracket],{x_,y_}/; xmaxnode\[LeftDoubleBracket]3-#\[RightDoubleBracket]||(x== maxnode\[LeftDoubleBracket]3-#\[RightDoubleBracket]&& y>maxedge\[LeftDoubleBracket]3-#\[RightDoubleBracket])]&/@\ {1,2}; If[cmin\[LeftDoubleBracket]1\[RightDoubleBracket]>0, If[cmax\[LeftDoubleBracket]1\[RightDoubleBracket]==0,True, cmin\[LeftDoubleBracket]1\[RightDoubleBracket]- cmax\[LeftDoubleBracket]1\[RightDoubleBracket]>=0], If[cmax\[LeftDoubleBracket]1\[RightDoubleBracket]>0,False, cmin\[LeftDoubleBracket]2\[RightDoubleBracket]- cmax\[LeftDoubleBracket]2\[RightDoubleBracket]<0]]] DNPcoords::usage= "Given a point in abstract coordinates used in SMWNetworkPicture (e.g., \ given the location of node i as nodecoordinates[i]) the actual graphical \ location of the point depends on the options Symmetrized, LightCone and \ Hyperbola. The routine DNPcoords[{x,t}] computes those coordinates. Each time \ slice is centered at 0 if Symmetrized->True, and start at 0 and goes to the \ left if not. The spacelike slices are on hyperbolas if Hyperbola->True and on \ horizontal lines if not. Time moves down. This is the picture if \ LightCone->True; if not, the whole picture is rotated 90 degrees \ counterclockwise."; DNPcoords[{x_,t_}]:=Module[{xx,tt}, xx=If[sym,x-.5*(Length[time[t]]+1),x-1]; tt=If[hyperbola,If[t==0,0,Sqrt[t^2+xx^2]],t]; If[cone,{xx,-tt},{tt,xx}]]; DNPgetcolor::usage= "If ribbon is true in SMWNetworkPicture, then the edges are colored \ ribbons. If so, the color is computed using DNPgetcolor. Here x is a capital \ letter."; DNPgetcolor[x_]:= If[#<1||#>Length[ribboncolortable], ribboncolortable\[LeftDoubleBracket]1\[RightDoubleBracket], ribboncolortable\[LeftDoubleBracket]#\[RightDoubleBracket]]&@(First[ ToCharacterCode[x]]-64); QuadraticCurve::usage= "QuadraticCurve[{{a,b},{c,d},{e,f}}] creates a list of graphics objects \ for the quadratic curve beginning at {a,b}, passing through {c,d} and ending \ at {e,f}. If Arrows->True, it then draws an arrow pointing towards {e,f} if \ Up->True and towards {a,b} if Up->False. CurveThickness is the absolute \ thickness of the curve (this probably only affects things if Ribbon->False). \ The arrow is controlled by the following options: ArrowLength is the length \ of the two line segments that make up the arrow (currently this is a \ coordinate length, not an absolute length); ArrowAngle is the angle these \ lines make with the tangent to the curve; ArrowLocation is the value of the \ parameter t where the arrow is to be drawn (t=0 at {a,b}, .5 at {c,d} and 1 \ at {e,f}); ArrowThickness is the absolute point size of the arrow. If \ Ribbon->True, the edges are drawn as ribbons, and the arrows as triangles. \ RibbonWidth is the coordinate width of the ribbon; RibbonPointCount is the \ number of edges used on each side of the polygon that is drawn to produce the \ ribbon; RibbonColor is the ribbon color. A box is drawn around the ribbon, \ but there are options Front and Back which control whether the front of the \ box (the end at {e,f}) and the back of the box (the end at {a,b}) are drawn."; Options[QuadraticCurve]={Arrows->False,ArrowThickness->.25,ArrowLength->.11, ArrowAngle->Pi/6,ArrowLocation->.6,Ribbon->False,RibbonWidth->.03, RibbonPointCount->100,RibbonColor->GrayLevel[.85],Up->True, CurveThickness->.25,Front\[Rule]True, Back\[Rule]True}; QuadraticCurve[{{a_,b_},{c_,d_},{e_,f_}},opts___?OptionQ]:= Module[{coefs,fx,fy,unittangent,unitnormal,arrowvector,loc,arrows, arrowlength,arrowthickness,arrowangle,arrowlocation,ribbon,ribbonwidth, ribbonpointcount,ribboncolor,up,curvethickness,front, back},{arrows,arrowlength,arrowthickness,arrowangle,arrowlocation, ribbon,ribbonwidth,ribbonpointcount,ribboncolor,up,curvethickness, front,back}={Arrows,ArrowLength,ArrowThickness,ArrowAngle, ArrowLocation,Ribbon,RibbonWidth,RibbonPointCount,RibbonColor,Up, CurveThickness,Front,Back}/.{opts}/.Options[QuadraticCurve]; If[ribbon,arrowlength+=ribbonwidth/(2Sin[arrowangle])]; coefs={2#\[LeftDoubleBracket]3\[RightDoubleBracket]-4#\[LeftDoubleBracket]2\ \[RightDoubleBracket]+2#\[LeftDoubleBracket]1\[RightDoubleBracket],-#\ \[LeftDoubleBracket]3\[RightDoubleBracket]+4#\[LeftDoubleBracket]2\ \[RightDoubleBracket]-3#\[LeftDoubleBracket]1\[RightDoubleBracket],#\ \[LeftDoubleBracket]1\[RightDoubleBracket]}&/@{{a,c,e},{b,d,f}}; {fx,fy}=Function[t,{t^2,t,1}.#]&/@coefs; loc=If[up,arrowlocation,1-arrowlocation]; unittangent[ t_]:=(#/Sqrt[#.#])&[(2t #\[LeftDoubleBracket]1\[RightDoubleBracket]+#\ \[LeftDoubleBracket]2\[RightDoubleBracket])&/@coefs]; unitnormal[ t_]:={-#\[LeftDoubleBracket]2\[RightDoubleBracket],#\ \[LeftDoubleBracket]1\[RightDoubleBracket]}&@unittangent[t]; arrowvector=-arrowlength(unittangent[loc]); {AbsoluteThickness[curvethickness], If[ribbon, With[{L1= Table[{fx[t],fy[t]}+ribbonwidth*unitnormal[t],{t,0,1, 1/ribbonpointcount}], L2=Table[{fx[t],fy[t]}-ribbonwidth*unitnormal[t],{t,1, 0,-1/ribbonpointcount}]},{ribboncolor,Polygon[Join[L1,L2]], Sequence@@GrayStyle,Line[L1],Line[L2], If[back,Line[{{fx[0],fy[0]}- ribbonwidth*unitnormal[0],{fx[0],fy[0]}+ ribbonwidth*unitnormal[0]}],{}], If[front, Line[{{fx[1],fy[1]}-ribbonwidth*unitnormal[1],{fx[1],fy[1]}+ ribbonwidth*unitnormal[1]}],{}]}], Cases[ ParametricPlot[{fx[t],fy[t]},{t,0,1}, DisplayFunction->Identity],_Line,Infinity]], If[arrows,{AbsoluteThickness[arrowthickness], If[ribbon, EdgedPolygon[ Flatten[{{{fx[loc],fy[loc]}},#,{{fx[loc],fy[loc]}}},1], ribboncolor,GrayStyle], Line[{{fx[loc],fy[loc]},#}]&/@#]&@({fx[ loc]+{Cos[#],-Sin[#]}.arrowvector, fy[loc]+{Sin[#],Cos[#]}.arrowvector}&/@ If[up,{arrowangle,-arrowangle},{Pi+arrowangle, Pi-arrowangle}])},{}]}] Options[DirectedNeighborsPicture]={Reordered\[Rule]True, Symmetrized\[Rule]True,ParallelSeparation\[Rule].1,Dip\[Rule]0, Hyperbola\[Rule]False,NodeSize\[Rule]0,NodePoint\[Rule]0, NodeColor\[Rule]GrayLevel[.5],AspectRatio\[Rule]Automatic, LightCone\[Rule]True,Arrows\[Rule]True,MaxLevel->\[Infinity], ArrowLength\[Rule].11,ArrowThickness\[Rule].25,ArrowAngle\[Rule]Pi/6, ArrowLocation\[Rule].6,Ribbon\[Rule]False,FinalEdges\[Rule]True, EdgeThickness->.25,NodeNumber->False, NumberSize->$DefaultFont\[LeftDoubleBracket]2\[RightDoubleBracket], Complete->False,RibbonWidth\[Rule].03,RibbonPointCount\[Rule]100, RibbonColorTable\[Rule]{GrayLevel[.85],GrayLevel[0]}}; DirectedNeighborsPicture[h_,init_:{1},opts___?OptionQ]:= Block[{g,a,b,c,d,already,time,nodecoordinates,maxt,psep,dip,hyperbola,reord, sym,ar,cone,nodesize,nodepoint,arrows,arrowlength,arrowthickness, arrowangle,arrowlocation,up,ribbon,ribbonwidth,ribbonpointcount, nodecolor,ribboncolortable,finaledges,nodenumber,numbersize,complete, maxlevel,edgethickness},{reord,sym,ar,cone,hyperbola,nodesize,nodepoint, dip,psep,arrows,arrowlength,arrowthickness,arrowangle,arrowlocation, ribbon,ribbonwidth,ribbonpointcount,nodecolor,ribboncolortable, finaledges,nodenumber,numbersize,complete,maxlevel, edgethickness}={Reordered,Symmetrized,AspectRatio,LightCone,Hyperbola, NodeSize,NodePoint,Dip,ParallelSeparation,Arrows,ArrowLength, ArrowThickness,ArrowAngle,ArrowLocation,Ribbon,RibbonWidth, RibbonPointCount,NodeColor,RibbonColorTable,FinalEdges,NodeNumber, NumberSize,Complete,MaxLevel,EdgeThickness}/.{opts}/.Options[ DirectedNeighborsPicture]; g=DirectedNetworkToNW1[h]; time[0]=init; already={}; maxt = 0; While[time[maxt]\[NotEqual]{}&&maxt 0)&)])&/@(time[maxt-1]/.g)], Union[already,{\[Infinity]}]]; If[complete&&MemberQ[time[maxt],Length[g]-1],Break[]]; (* If[finaledges,time[maxt]=Complement[time[maxt],{Length[g]-1}]];*) If[reord,time[maxt]=Sort[time[maxt],DNPsort]]; ]; Graphics[{Table[ If[MemberQ[already, g\[LeftDoubleBracket]i, 1\[RightDoubleBracket]]&&(!MemberQ[already, g\[LeftDoubleBracket]i,2,j,1\[RightDoubleBracket]]|| g\[LeftDoubleBracket]i,1\[RightDoubleBracket]< g\[LeftDoubleBracket]i,2,j,1\[RightDoubleBracket]), Table[QuadraticCurve[{a,b}= DNPcoords[ nodecoordinates[ g\[LeftDoubleBracket]i,1\[RightDoubleBracket]]]; If[MemberQ[already, g\[LeftDoubleBracket]i,2,j,1\[RightDoubleBracket]],{c,d}= DNPcoords[ nodecoordinates[ g\[LeftDoubleBracket]i,2,j, 1\[RightDoubleBracket]]];{{a, b},{If[cone||hyperbola||(a\[NotEqual]c),0,dip]+(a+c)*.5+ psep( k-(g\[LeftDoubleBracket]i,2,j, 3\[RightDoubleBracket]+1)/2) (d-b), If[!cone||hyperbola||(b\[NotEqual]d),0,-dip]+(b+d)*.5+ psep(k-(g\[LeftDoubleBracket]i,2,j, 3\[RightDoubleBracket]+1)/2)(a-c)},{c, d}},{c,d}= If[k>g\[LeftDoubleBracket]i,2,j,2\[RightDoubleBracket], If[cone,{a,b+.75},{a-.75,b}],{a,b-.75},{a+.75,b}]; {{a, b},{(a+c)*.5+ psep(k-(g\[LeftDoubleBracket]i,2,j, 3\[RightDoubleBracket]+1)/2)(d-b),(b+ d)*.5+psep(k-(g\[LeftDoubleBracket]i,2,j, 3\[RightDoubleBracket]+1)/2)(a-c)},{c+2* psep(k-(g\[LeftDoubleBracket]i,2,j, 3\[RightDoubleBracket]+1)/2)(d-b), d+2*psep(k-(g\[LeftDoubleBracket]i,2,j, 3\[RightDoubleBracket]+1)/2)(a-c)}}], Up->If[k>g\[LeftDoubleBracket]i,2,j,2\[RightDoubleBracket], False,True],Arrows->arrows,ArrowLength->arrowlength, ArrowThickness->arrowthickness,ArrowAngle->arrowangle, ArrowLocation->arrowlocation, CurveThickness->edgethickness,Ribbon->ribbon,RibbonWidth->ribbonwidth, RibbonPointCount->ribbonpointcount,RibbonColor->Blue],{k, g\[LeftDoubleBracket]i,2,j,3\[RightDoubleBracket]}],{}],{i, Length[g]},{j, Length[g\[LeftDoubleBracket]i,2\[RightDoubleBracket]]}], If[nodesize>0,{nodecolor,Disk[DNPcoords[nodecoordinates[#]],nodesize], Black,AbsoluteThickness[.25], Circle[DNPcoords[nodecoordinates[#]],nodesize], If[nodenumber,{Text[StyleForm[#,FontSize->numbersize], DNPcoords[nodecoordinates[#]]]},{}]}, If[nodepoint>0,{AbsolutePointSize[nodepoint],Black, Point[DNPcoords[nodecoordinates[#]]]},{}]]&/@already}, AspectRatio->ar,PlotRange->All]] DNPsort[i_, j_]:=(#\[LeftDoubleBracket]2\[RightDoubleBracket]-#\[LeftDoubleBracket]1\ \[RightDoubleBracket]>=0)&[ Function[x, Function[ y,(Plus@@y\[LeftDoubleBracket]1\[RightDoubleBracket])/(Plus@@ y\[LeftDoubleBracket]2\[RightDoubleBracket])]@(Transpose@(\ Function[z,{nodecoordinates[ z\[LeftDoubleBracket]1\[RightDoubleBracket]]\ \[LeftDoubleBracket]1\[RightDoubleBracket]*(z\[LeftDoubleBracket]3\ \[RightDoubleBracket]-z\[LeftDoubleBracket]2\[RightDoubleBracket]), z\[LeftDoubleBracket]3\[RightDoubleBracket]- z\[LeftDoubleBracket]2\[RightDoubleBracket]}]/@ Cases[x,_?(MemberQ[ time[maxt-1],#\[LeftDoubleBracket]1\ \[RightDoubleBracket]]&)]))]/@({i,j}/.g)] DirectedNetworkToNW1[g_]:= Function[h, h\[LeftDoubleBracket]1\[RightDoubleBracket]\[Rule](Function[ x,{x,Count[h\[LeftDoubleBracket]2\[RightDoubleBracket],x], Count[h\[LeftDoubleBracket]2\[RightDoubleBracket],x]+ Count[x/.g,h\[LeftDoubleBracket]1\[RightDoubleBracket]]}]/@ Union[h\[LeftDoubleBracket]2\[RightDoubleBracket], First/@Cases[ g,_?((MemberQ[#\[LeftDoubleBracket]2\[RightDoubleBracket], h\[LeftDoubleBracket]1\[RightDoubleBracket]])&)]])\ ]/@g NeighborCountsI[g_,i0_,n_]:= Map[If[MemberQ[#,Infinity],Infinity,Length[#]]&, Module[{gp=Dispatch[Prepend[g,\[Infinity]->{\[Infinity]}]]}, NestList[Union[Flatten[{#,#/.gp}]]&,{i0},n]]] Normalize[list_]:= list-First[list]- Range[0,Length[list]-1](Last[list]-First[list])/(Length[list]-1) Differences[list_]:=Rest[list]-Drop[list,-1] Ratios[list_]:=Drop[list,1]/Drop[list,-1] ChopEvolution[history_,max_:40]:= Module[{p},p=Position[First/@history,_?(StringLength[#]>max&)]; If[p==={},history,Take[history,p[[1,1]]-1]]] RandomSMW[nr_,len_]:= Table[Apply[StringJoin, Table[Random[Integer],{Random[Integer,{1,len}]}]/.{0->"A",1->"B"}]-> Apply[StringJoin, Table[Random[Integer],{Random[Integer,{1,len}]}]/.{0->"A", 1->"B"}],{nr}] RandomSMWGivenLHS[alls_, len_]:=(#-> Apply[StringJoin, Table[Random[Integer],{Random[Integer,{1,len}]}]/.{0->"A", 1->"B"}])&/@alls[[Random[Integer,{1,Length[alls]}]]] AllRules[{m_,n_}]:=List/@Flatten[Outer[Rule,AllStrings[m],AllStrings[n]]] AllStrings[n_]:= Table[FromCharacterCode[Rest[IntegerDigits[i,2]]+65],{i,2,2^(n+1)-1}] RandomString[n_]:=FromCharacterCode[Table[Random[Integer],{n}]+65] SMWSafeEvolveList[rule_,s_,n_,max_:100]:= NestList[If[StringLength[#]>max,"",#]&[SMWStep[rule,#]]&,s,n] SMWTestEvolveList[rule_,s_,n_,max_:50]:= FixedPointList[If[StringLength[#]>max,"",#]&[SMWStep[rule,#]]&,s,n] SMWTestEvolveList[rule_,s_,n_,max_:50,SSS]:= FixedPointList[If[StringLength[#]>max,"",#]&[SMWStepSSS[rule,#]]&,s,n] SMWTestEvolveListBackward[rule_,s_,n_,max_:50]:= FixedPointList[If[StringLength[#]>max,"",#]&[SMWStepBackward[rule,#]]&,s,n] <max || RuleOverlapQ[rule,#],Throw[False],#]&[ SMWStep[rule,#]]&,s,n];True] OverlapFreeQ[a_String,b_String]:= If[StringLength[a]>StringLength[b],OFQ2[b,a],OFQ2[a,b]] OFQ2[a_,b_]:= StringPosition[b,a,1]=={}&& MatchQ[StringPosition[a,Table[StringTake[b,-i],{i,StringLength[a]}], 1],{}|{{x_,_}}/;x>1]&& MatchQ[StringPosition[b,Table[StringTake[a,-i],{i,StringLength[a]}], 1],{}|{{x_,_}}/;x>1] OverlapFreeQ[a_String]:= StringLength[a]==1|| MatchQ[StringPosition[a,Table[StringTake[a,-i],{i,StringLength[a]-1}], 1],{}|{{x_,_}}/;x>1] <<"MultiwaySystems/Multiway.m" mwp[{rr_,init_},t_,rs_:0.2]:= Surround[MWEvolGraphic[FromChars[MWEvolveListT[rr,{init},t]]]] MAToMWRule[ rule_]:=(StringJoin[{If[#\[LeftDoubleBracket]1,1\[RightDoubleBracket]==0, "A","B"], If[#\[LeftDoubleBracket]1,2\[RightDoubleBracket]==0,"C","D"], If[#\[LeftDoubleBracket]1,3\[RightDoubleBracket]==0,"A","B"]}]-> StringJoin[{If[#\[LeftDoubleBracket]2,1,1\[RightDoubleBracket]==0, If[#\[LeftDoubleBracket]2,2\[RightDoubleBracket]==1,"A","C"], If[#\[LeftDoubleBracket]2,2\[RightDoubleBracket]==1,"B","D"]], If[#\[LeftDoubleBracket]2,1,2\[RightDoubleBracket]==0,"A","B"], If[#\[LeftDoubleBracket]2,1,3\[RightDoubleBracket]==0, If[#\[LeftDoubleBracket]2,2\[RightDoubleBracket]==1,"C","A"], If[#\[LeftDoubleBracket]2,2\[RightDoubleBracket]==1,"D", "B"]]}])&/@rule MAToMWState[state_]:= StringJoin[ ReplacePart[#, If[#\[LeftDoubleBracket] state\[LeftDoubleBracket]2\[RightDoubleBracket]\ \[RightDoubleBracket]=="A","C","D"], state\[LeftDoubleBracket]2\[RightDoubleBracket]]&@(state\ \[LeftDoubleBracket]1\[RightDoubleBracket]/.{0->"A",1->"B"})] SMWElementaryCAEvolveListX::usage= "SMWElementaryCAEvolveListX[n,t] does a simulation of time steps 0 \ through t of elementary CA number n using sequential multiway systems. The \ initial state is ...0001000.... The CA must be quiescent on state 0; i.e., \ 000->0, so n is even. (This could easily be generalized to the rest of the \ elementary CA and to other initial states. It could also be generalized \ to all CA, but then you'd need to deal with the fact that you need way more \ than 26 letters.)"; SMWElementaryCAEvolveListX[n_,t_]:= SMWEvolveListX[ Join[{"AGCHA"->"AHCGA","AGDHA"->"AHCGA","AGEHA"->"AHCGA","AGFHA"->"AHCGA", "AGCHB"->"AHDGB","AGDHB"->"AHDGB", "AGEHB"->"AHDGB","AGFHB"->"AHDGB","BGCHA"->"BHEGA","BGDHA"->"BHEGA", "BGEHA"->"BHEGA","BGFHA"->"BHEGA", "BGCHB"->"BHFGB","BGDHB"->"BHFGB","BGEHB"->"BHFGB","BGFHB"->"BHFGB", "IHA"->"IHCGA","IHB"->"IHDGB", "IHC"->"IHAGC", "IHD"->StringInsert[ "IHGD",#\[LeftDoubleBracket]2\[RightDoubleBracket],3], "AGI"->"AHCGI","BGI"->"BHEGI","CGI"->"CHAGI", "EGI"->StringInsert[ "EHGI",#\[LeftDoubleBracket]5\[RightDoubleBracket],3]}, ReplacePart[#\[LeftDoubleBracket]1\[RightDoubleBracket], StringInsert[#\[LeftDoubleBracket]1, 2\[RightDoubleBracket],#\[LeftDoubleBracket]2\ \[RightDoubleBracket],3],{2}]&/@Transpose[{{"CGAHC"->"CHGC","CGAHD"->"CHGD", "DGBHE"->"DHGE","DGBHF"->"DHGF","EGAHC"->"EHGC","EGAHD"->"EHGD", "FGBHE"->"FHGE","FGBHF"->"FHGF"},#}]]&[ EvenQ/@NestList[Quotient[#,2]&,n,7]/.{True->"A",False->"B"}],"IHDGBGI", t]