Wolfram Cloud Page

WOLFRAM NOTEBOOK

In[]:=

deathdiff[rule_,t_:100,max_:150]:=With[{array=CellularAutomaton[rule,{{1},0},{max,All}]},Abs[LengthWhile[Reverse[array],Total[#]==0&]-(max-t)]]

In[]:=

randrulesx[rule_,n_Integer,k_:5]:=FromDigits[#,k]&/@With[{dig=IntegerDigits[rule,k,k^3]},Union[Table[ReplacePart[dig,RandomInteger[{1,Length[dig]-1}]->RandomInteger[{0,k-1}]],n]]]

In[]:=

GridPartitionFramedArrayPlotCellularAutomaton[#,{{1},0},{55,{-14,14}}],GridLines->{None,{5}},GridLinesStyle->Directive[Thickness[.015],GrayLevel[0,.8]],ColorRules->0->White,1->

,2->

,3->

,Frame->None,ImageSize->59,FrameStyle->

,FrameMargins->0&/@(SeedRandom[7067];With[{k=3},NestList[{First[First[SortBy[{#,deathdiff[{#,k,1},50,100]}&/@randrulesx[#[[1]],100,k],Last]]],k,1}&,{kRandomInteger[k^k^3/k],k,1},20]]),10,Spacings->{.25,.25}

Out[]=

In[]:=

GridPartitionFramedArrayPlotCellularAutomaton[#,{{1},0},{55,{-14,14}}],GridLines->{None,{5}},GridLinesStyle->Directive[Thickness[.015],GrayLevel[0,.8]],ColorRules->0->White,1->

,2->

,3->

,Frame->None,ImageSize->59,FrameStyle->

,FrameMargins->0&/@(SeedRandom[7067];With[{k=2},NestList[{First[First[SortBy[{#,deathdiff[{#,k,1},50,100]}&/@randrulesx[#[[1]],100,k],Last]]],k,1}&,{kRandomInteger[k^k^3/k],k,1},20]]),10,Spacings->{.25,.25}

Out[]=

In[]:=

randrulesx[{6,2},100,2]

Out[]=

{{0,0,0,0,0,0,1,0},{2,2,2,2,2,2,3,2}}

In[]:=

randrulesx[6,100,2]

Out[]=

{2,4,6,14,22,38,70,134}

Loss function

If it doesn’t die, give it a loss of +(max time). If it does die, give it a loss of -(time to die).

Evolutionary Computation

Multi-case change:

In[]:=

CARuleMutations[{rn_,k_,r_},n_]:={FromDigits[#,k],k,r}&[With[{cases=IntegerDigits[rn,k,k^(2r+1)]},MapAt[Mod[#+RandomInteger[{1,k-1}],k]&,cases,List/@RandomSample[Range[Length[cases]-1],n]]]]

Single case change: [note: never changes the last bit]

In[]:=

CARuleMutation[{rn_,k_,r_}]:={FromDigits[#,k],k,r}&[With[{cases=IntegerDigits[rn,k,k^(2r+1)]},MapAt[Mod[#+RandomInteger[{1,k-1}],k]&,cases,RandomInteger[{1,Length[cases]-1}]]]]

In[]:=

Clear[DeathLossFunction]

In[]:=

DeathLossFunction[rule_,max_:100,infinity_:Infinity]:=With[{array=CellularAutomaton[rule,{{1},0},{max,All}]},If[#==0,infinity,#-max]&[Abs[LengthWhile[Reverse[array],Total[#]==0&]]]]

In[]:=

DeathLossFunction[{2663001524,2,2},150]

Out[]=

-96

In[]:=

DeathLossFunction[30,150]

Out[]=

∞

In[]:=

NestList[First[MinimalBy[Table[CARuleMutation[#],5],DeathLossFunction[#,100]&]]&,{0,2,2},1000];

In[]:=

DeathLossFunction[#,100]&/@%

In[]:=

NestList[First[MinimalBy[Table[CARuleMutation[#],5],DeathLossFunction[#,100]&]]&,{0,4,1},100];

In[]:=

DeathLossFunction[#,100]&/@%

Out[]=

{0,0,0,0,0,0,0,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-3,-3,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4,-4}

In[]:=

Clear[capix]

[[[ Add proper options handling ]]]

In[]:=

capix[rule_,max_,wid_,opts___]:=ArrayPlot[CellularAutomaton[rule,{{1},0},{max,{-wid,wid}}],opts,ColorRules->{0->White,1->Red,2->Blue,3->Green,4->Cyan}]

In[]:=

capix[rule_,max_:100]:=capix[rule,max,Round[max/3],ImageSize->Tiny]

In[]:=

capixbig[rule_,max_:100]:=capix[rule,max,Round[max/3]]

In[]:=

capix[#,8]&/@%77

In[]:=

NestList[First[MinimalBy[Table[CARuleMutation[#],20],DeathLossFunction[#,100]&]]&,{0,4,1},100];

In[]:=

DeathLossFunction[#,100]&/@%

Out[]=

{0,0,-1,-2,-2,-2,-2,-2,-2,-2,-4,-4,-4,-4,-4,-4,-4,-4,-4,-5,-6,-6,-6,-6,-6,-6,-6,-6,-6,-6,-6,-6,-8,-8,-8,-8,-11,-11,-11,-11,-11,-14,-19,-21,-23,-23,-23,-23,-23,-23,-23,-23,-29,-30,-39,-39,-39,-46,-46,-56,-71,-71,-71,-76,-76,-76,-91,-91,-98,-98,-98,-98,-98,-98,-98,-98,-98,-98,-98,-98,-98,-98,-98,-98,-98,-98,-98,-98,-98,-98,-41,-41,-61,-61,-61,-90,-90,-90,-90,-96,-96}

In[]:=