WolframModel Emulators
WolframModel Emulators
In[]:=
<<SetReplace`
Elementary Cellular Automata
Elementary Cellular Automata
In[]:=
caBlock[id_,neighborIDs_:{_,_},color:0|1]:={{cellCenter[id],"nextStepLeftNeighborInput",nextStepLeftNeighborInput[id]},{cellCenter[id],"nextStepRightNeighborInput",nextStepRightNeighborInput[id]},{cellCenter[id],"nextStep",nextStepCenter[id]},{cellCenter[id],"inputFromLeftNeighbor",rightNeighborInput[neighborIDs〚1〛]},{cellCenter[id],"inputFromRightNeighbor",leftNeighborInput[neighborIDs〚2〛]},{cellCenter[id],color},{leftNeighborInput[id],"nextStep",nextStepLeftNeighborInput[id]},{leftNeighborInput[id],color},{rightNeighborInput[id],"nextStep",nextStepRightNeighborInput[id]},{rightNeighborInput[id],color}}
In[]:=
caEndExtensionRules[color:0|1]:={{{xCenter_,"inputFromLeftNeighbor",leftEnd_},{leftEnd_,"inputFromRightNeighbor",xLeftNeighborInput_},{leftEnd_,"leftEnd"}}Module[{cellCenter,nextStepLeftNeighborInput,nextStepRightNeighborInput,nextStepCenter,newLeftEnd,leftNeighborInput,rightNeighborInput},{{cellCenter,"nextStepLeftNeighborInput",nextStepLeftNeighborInput},{cellCenter,"nextStepRightNeighborInput",nextStepRightNeighborInput},{cellCenter,"nextStep",nextStepCenter},{cellCenter,"inputFromLeftNeighbor",newLeftEnd},{newLeftEnd,"leftEnd"},{newLeftEnd,"inputFromRightNeighbor",leftNeighborInput},{cellCenter,"inputFromRightNeighbor",xLeftNeighborInput},{cellCenter,color},{leftNeighborInput,"nextStep",nextStepLeftNeighborInput},{leftNeighborInput,color},{rightNeighborInput,"nextStep",nextStepRightNeighborInput},{rightNeighborInput,color},{xCenter,"inputFromLeftNeighbor",rightNeighborInput}}],{{xCenter_,"inputFromRightNeighbor",rightEnd_},{rightEnd_,"inputFromLeftNeighbor",xRightNeighborInput_},{rightEnd_,"rightEnd"}}Module[{cellCenter,nextStepRightNeighborInput,nextStepLeftNeighborInput,nextStepCenter,newRightEnd,rightNeighborInput,leftNeighborInput},{{cellCenter,"nextStepRightNeighborInput",nextStepRightNeighborInput},{cellCenter,"nextStepLeftNeighborInput",nextStepLeftNeighborInput},{cellCenter,"nextStep",nextStepCenter},{cellCenter,"inputFromRightNeighbor",newRightEnd},{newRightEnd,"rightEnd"},{newRightEnd,"inputFromLeftNeighbor",rightNeighborInput},{cellCenter,"inputFromLeftNeighbor",xRightNeighborInput},{cellCenter,color},{rightNeighborInput,"nextStep",nextStepRightNeighborInput},{rightNeighborInput,color},{leftNeighborInput,"nextStep",nextStepLeftNeighborInput},{leftNeighborInput,color},{xCenter,"inputFromRightNeighbor",leftNeighborInput}}]};
In[]:=
caRules[rule_Integer]:=With[{oldLeft=#〚1〛,oldMiddle=#〚2〛,oldRight=#〚3〛,newColor=#〚4〛},{{cellCenter_,"inputFromLeftNeighbor",leftColorReference_},{leftColorReference_,"nextStep",nextStepLeftColorReference_},{cellCenter_,"inputFromRightNeighbor",rightColorReference_},{rightColorReference_,"nextStep",nextStepRightColorReference_},{cellCenter_,"nextStepLeftNeighborInput",nextStepLeftNeighborInput_},{cellCenter_,"nextStepRightNeighborInput",nextStepRightNeighborInput_},{cellCenter_,"nextStep",nextStepCenter_},{cellCenter_,#〚2〛},{leftColorReference_,#〚1〛},{rightColorReference_,#〚3〛}}Module[{nextNextStepLeftNeighborInput,nextNextStepRightNeighborInput,nextNextStepCellCenter},{{nextStepCenter,"inputFromLeftNeighbor",nextStepLeftColorReference},{nextStepCenter,"inputFromRightNeighbor",nextStepRightColorReference},{nextStepCenter,"nextStep",nextNextStepCellCenter},{nextStepCenter,"nextStepLeftNeighborInput",nextNextStepLeftNeighborInput},{nextStepCenter,"nextStepRightNeighborInput",nextNextStepRightNeighborInput},{nextStepCenter,newColor},{nextStepLeftNeighborInput,newColor},{nextStepRightNeighborInput,newColor},{nextStepLeftNeighborInput,"nextStep",nextNextStepLeftNeighborInput},{nextStepRightNeighborInput,"nextStep",nextNextStepRightNeighborInput}}]]&/@(1-Flatten/@Thread[{IntegerDigits[Range[0,7],2,3],1-IntegerDigits[rule,2,8]}]);
In[]:=
caLocalization={{x_,"inputFromLeftNeighbor",y_}{x,x,y},{x_,"inputFromRightNeighbor",y_}{x,y,x},{x_,"nextStepLeftNeighborInput",y_}{x,x,x,y},{x_,"nextStepRightNeighborInput",y_}{x,x,y,x},{x_,0}{x},{x_,1}{x,x},{x_,"nextStep",y_}{x,y,y},{x_,"leftEnd"}{x,x,x,x,x},{x_,"rightEnd"}{x,x,x,x,x,x},Pattern(#&),Module(#2&),RuleDelayedRule};
In[]:=
encodeCAState[colors:{(0|1)..}]:=Join[Catenate[caBlock[#〚2,1〛,#〚{1,3},1〛,#〚2,2〛]&/@Partition[Join[{{"leftEnd",-1}},MapIndexed[{#2〚1〛,#}&,colors],{{"rightEnd",-1}}],3,1]]/.{rightNeighborInput["leftEnd"]"leftEnd",leftNeighborInput["rightEnd"]"rightEnd"},{{"leftEnd","inputFromRightNeighbor",leftNeighborInput[1]},{"leftEnd","leftEnd"},{"rightEnd","inputFromLeftNeighbor",rightNeighborInput[Length[colors]]},{"rightEnd","rightEnd"}}]/.caLocalization
In[]:=
encodeCARule[ruleNumber_,background_]:=Join[caEndExtensionRules[background],caRules[ruleNumber]]//.caLocalization
In[]:=
ClearAll[decodeCAEvolution];decodeCAEvolution[evo_WolframModelEvolutionObject,grayingFactor_:0.3]:=With[{stateColors=With[{state=evo[#]},FreeQ[state,{#}]&/@With[{graph=SimpleGraph[UndirectedEdge@@@Catenate[Partition[#,2,1,-1]&/@state]],leftEnd=FirstCase[state,{v_,v_,v_,v_,v_}v]},Last/@Sort[Cases[Transpose[{VertexList[graph],VertexDegree[graph],GraphDistance[graph,leftEnd]}],{v_,5,distance_}{distance,v}]]]/.{True1,False0}]&/@Range[0,evo["TotalGenerationsCount"]]},With[{shiftedStates=(Join[stateColors〚#,2#-1;;-2#+1〛&/@Reverse[Range[Ceiling[Length[stateColors[[1]]]/2],1,-1]],Rest@stateColors]//.{lll___,{middle1__},{l__,middle2__,r__},rrr___}/;Length[{middle1}]==Length[{middle2}]&&Length[{l}]Length[{r}]{lll,{l,middle1,r},{middle2},rrr})〚1;;-1;;2〛},partialArrayPlot[CenterArray[#,Max[Length/@shiftedStates],Missing[]]&/@shiftedStates,grayingFactor]]]
In[]:=
ClearAll[partialArrayPlot];partialArrayPlot[data_,grayingFactor_:.3]:=ArrayPlot[ReplacePart[data,#Extract[data,#]+grayingFactor(0.5-Extract[data,#])&/@Transpose@{(Length[data]+1-FirstPosition[#,Except[Missing[]],{2},HeadsFalse]〚1〛&/@Reverse/@Transpose[data]),Range[Length[data〚1〛]]}]/.Missing[]White,FrameFalse,Epilog{Transparent,EdgeForm[GrayLevel[GoldenRatio-1]],Rectangle[{#〚2〛-1,Length[data]-#〚1〛}]&/@Position[data,Except[Missing[]],{2},HeadsFalse]}]
In[]:=
decodeCAEvolution[WolframModel[encodeCARule[110,0],encodeCAState[{1}],5]]
Out[]=
In[]:=
decodeCAEvolution[WolframModel[encodeCARule[110,0],encodeCAState[{1}],10]]
Out[]=
Turing Machines 2,3
Turing Machines 2,3
S,K combinators
S,K combinators
Not done yet.