Wolfram Cloud Page

RuleArrayLifetime=FunctionCompile[Function[{Typed[ruleArray,"PackedArray"::["MachineInteger",2]]},Module[{i,state,newState,raHeight=Length[ruleArray],raWidth=Length[ruleArray[[1]]],loss},state=ConstantArray[0,raWidth];state[[Quotient[raWidth,2]]]=1;i=1;While[Total[state]>0&&i<=raHeight,state=Table[Module[{left,center,right,raElement,input},left=If[j==1,state[[-1]],state[[j-1]]];center=state[[j]];right=If[j==raWidth,state[[1]],state[[j+1]]];raElement=ruleArray[[i,j]];input=BitOr[BitShiftLeft[left,2],BitShiftLeft[center,1],right];BitShiftRight[BitAnd[raElement,BitShiftLeft[1,input]],input]],{j,raWidth}];++i;];i-1]]];

In[]:=

RuleArrayStates=FunctionCompile[Function[{Typed[ruleArray,"PackedArray"::["MachineInteger",2]]},Module[{i,state,states,newState,raHeight=Length[ruleArray],raWidth=Length[ruleArray[[1]]],loss},state=ConstantArray[0,raWidth];state[[Quotient[raWidth,2]]]=1;states={state};i=1;While[Total[state]>0&&i<=raHeight,state=Table[Module[{left,center,right,raElement,input},left=If[j==1,state[[-1]],state[[j-1]]];center=state[[j]];right=If[j==raWidth,state[[1]],state[[j+1]]];raElement=ruleArray[[i,j]];input=BitOr[BitShiftLeft[left,2],BitShiftLeft[center,1],right];BitShiftRight[BitAnd[raElement,BitShiftLeft[1,input]],input]],{j,raWidth}];AppendTo[states,state];++i;];states]]];

In[]:=

ICAEvolveList[{rulearray_,r_},init_]:=FoldList[Boole[MapThread[BooleanFunction[#1,2r+1]@@#2&,{#2,Partition[#,2r+1,1,2r]}]]&,init,rulearray]

In[]:=

ICAEvolvePlot[{ruleindices_,r_},init_,rulelist_]:=ArrayPlot[Transpose[Transpose[{Most@ICAEvolveList[{Map[rulelist[[#]]&,ruleindices,{2}],r},init],ruleindices},1<->3]],ColorRules->{{1,1}->Darker[Red,.7],{0,1}->Lighter[Red,.7],{1,2}->Darker[Blue,.7],{0,2}->Lighter[Blue,.7]}]

In[]:=

mutateRuleArray[ruleArray_,nRules_]:=Module[{raHeight,raWidth,i,j,val,newVal},{raHeight,raWidth}=Dimensions[ruleArray];i=RandomInteger[{1,raHeight}];j=RandomInteger[{1,raWidth}];val=ruleArray[[i,j]];newVal=Mod[val-1+RandomInteger[{1,nRules-1}],nRules]+1;ReplacePart[ruleArray,{i,j}->newVal]]

In[]:=

lossvalue[life_,tmax_]:=If[life==tmax,Infinity,Abs[(tmax-1)-life]]

In[]:=

AdaptRuleArray[ruleArray_List,rules_List,nIters_Integer]:=With[{actrules=MapThread[Rule,{Range[Length[rules]],rules}]},NestList[Module[{m=mutateRuleArray[#[[1]],Length[rules]],lo},lo=lossvalue[RuleArrayLifetime[m/.actrules],Length[m]];If[lo<=#[[2]],{m,lo},#]]&,{ruleArray,Infinity},nIters]]

Note: this is just picking a “random different rule” (but it’s always flipping when there are only 2 rules):

In[]:=

localmutateRuleArray[ruleArray_,nRules_,{i_,j_}]:=Module[{raHeight,raWidth,val,newVal},{raHeight,raWidth}=Dimensions[ruleArray];val=ruleArray[[i,j]];newVal=Mod[val-1+RandomInteger[{1,nRules-1}],nRules]+1;ReplacePart[ruleArray,{i,j}->newVal]]

In[]:=