From: A New Kind of Science, by Stephen Wolfram © 2002 Stephen Wolfram, LLC

The Crucial Experiment

How Do Simple Programs Behave?

({{Implementing cellular automata,  (page 865)}})

CenterList[n_Integer]:=ReplacePart[Table[0,{n}],1,Ceiling[(n/2)]]

CenterList[n_Integer]:=ReplacePart[Table[0,{n}],1,Ceiling[(n/2)]]

CenterList[11]

ElementaryRule[num_Integer]:=IntegerDigits[num,2,8]

CenterList[n_Integer]:=ReplacePart[Table[0,{n}],1,Ceiling[(n/2)]]
ElementaryRule[num_Integer]:=IntegerDigits[num,2,8]

ElementaryRule[30]

CAStep[rule_List,a_List]:=rule[[8-(RotateLeft[a]+2 (a+2 RotateRight[a]))]]

CenterList[n_Integer]:=ReplacePart[Table[0,{n}],1,Ceiling[(n/2)]]
ElementaryRule[num_Integer]:=IntegerDigits[num,2,8]
CAStep[rule_List,a_List]:=rule[[8-(RotateLeft[a]+2 (a+2 RotateRight[a]))]]

CAStep[ElementaryRule[30],CenterList[11]]

CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#1]&,init,t]

CenterList[n_Integer]:=ReplacePart[Table[0,{n}],1,Ceiling[(n/2)]]
ElementaryRule[num_Integer]:=IntegerDigits[num,2,8]
CAStep[rule_List,a_List]:=rule[[8-(RotateLeft[a]+2 (a+2 RotateRight[a]))]]
CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#1]&,init,t]

CAEvolveList[ElementaryRule[30],CenterList[11],5]//Grid

CAGraphics[history_List]:=Graphics[Raster[1-Reverse[history]],AspectRatio->Automatic]

CAGraphics[CAEvolveList[ElementaryRule[30],CenterList[103],50]]

CenterList[n_Integer]:=ReplacePart[Table[0,{n}],1,Ceiling[n/2]]
ElementaryRule[num_Integer]:=IntegerDigits[num,2,8]
CAStep[rule_List,a_List]:=rule[[8-(RotateLeft[a]+2 (a+2 RotateRight[a]))]]
CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]
CAGraphics[history_List]:=Graphics[Raster[1-Reverse[history]],AspectRatio->Automatic]

CAGraphics[CAEvolveList[ElementaryRule[30],CenterList[103],50]]

CAStep=Compile[{{rule,_Integer,1},{a,_Integer,1}},rule[[8-(RotateLeft[a]+2 (a+2 RotateRight[a]))]]]

CenterList[n_Integer]:=ReplacePart[Table[0,{n}],1,Ceiling[n/2]]
ElementaryRule[num_Integer]:=IntegerDigits[num,2,8]
CAStep=Compile[{{rule,_Integer,1},{a,_Integer,1}},rule[[8-(RotateLeft[a]+2 (a+2 RotateRight[a]))]]];
CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]

CAEvolveList[ElementaryRule[30],CenterList[11],5]//Grid

CAStep[rule_,a_]:=rule[[8-ListConvolve[{1,2,4},a,2]]]

CenterList[n_Integer]:=ReplacePart[Table[0,{n}],1,Ceiling[n/2]]
ElementaryRule[num_Integer]:=IntegerDigits[num,2,8]
CAStep[rule_,a_]:=rule[[8-ListConvolve[{1,2,4},a,2]]]
CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]

CAEvolveList[ElementaryRule[30],CenterList[11],5]//Grid

CAStep[num_,a_]:=Sign[BitAnd[2^ListConvolve[{1,2,4},a,2],num]]

CenterList[n_Integer]:=ReplacePart[Table[0,{n}],1,Ceiling[n/2]]
CAStep[num_,a_]:=Sign[BitAnd[2^ListConvolve[{1,2,4},a,2],num]]
CAEvolveList[num_,init_List,t_Integer]:=NestList[CAStep[num,#]&,init,t]

CAEvolveList[30,CenterList[11],5]//Grid

({{More general rules,  (page 866)}})

{{1,1,1}->0,{1,1,0}->0,{1,0,1}->0,{1,0,0}->1,{0,1,1}->1,{0,1,0}->1,{0,0,1}->1,{0,0,0}->0}

CAStep[rule_,a_List]:=Transpose[{RotateRight[a],a,RotateLeft[a]}]/.rule

CAStep[rule_,a_List]:=Partition[a,3,1,2]/.rule

CenterList[n_Integer]:=ReplacePart[Table[0,{n}],1,Ceiling[n/2]]
CAStep[rule_,a_List]:=Partition[a,3,1,2]/.rule
CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]

CAEvolveList[{{1,1,1}->0,{1,1,0}->0,{1,0,1}->0,{1,0,0}->1,{0,1,1}->1,{0,1,0}->1,{0,0,1}->1,{0,0,0}->0},CenterList[11],5]//Grid

The two definitions of CAStep above are equivalent.

{{1,_,1}->0,{1,_,0}->1,{0,_,1}->1,{0,_,0}->0}

CenterList[n_Integer]:=ReplacePart[Table[0,{n}],1,Ceiling[n/2]]
CAStep[rule_,a_List]:=Partition[a,3,1,2]/.rule
CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]

CAEvolveList[{{1,_,1}->0,{1,_,0}->1,{0,_,1}->1,{0,_,0}->0},CenterList[11],5]//Grid

CAStep[ElementaryCARule[rule_List],a_List]:=rule[[8-(RotateLeft[a]+2 (a+2 RotateRight[a]))]]

CAStep[GeneralCARule[rule_,r_Integer:1],a_List]:=Partition[a,2 r+1,1,r+1]/.rule

CAStep[FunctionCARule[f_,r_Integer:1],a_List]:=Map[f,Partition[a,2 r+1,1,r+1]]

CenterList[n_Integer]:=ReplacePart[Table[0,{n}],1,Ceiling[n/2]]
ElementaryRule[num_Integer]:=IntegerDigits[num,2,8]
CAStep[ElementaryCARule[rule_List],a_List]:=rule[[8-(RotateLeft[a]+2 (a+2 RotateRight[a]))]]
CAStep[GeneralCARule[rule_,r_Integer:1],a_List]:=Partition[a,2 r+1,1,r+1]/.rule
CAStep[FunctionCARule[f_,r_Integer:1],a_List]:=Map[f,Partition[a,2 r+1,1,r+1]]
CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]

CAEvolveList[ElementaryCARule[ElementaryRule[45]],CenterList[11],5]//Grid

CAEvolveList[GeneralCARule[{{1,_,1}->0,{1,_,0}->1,{0,_,1}->1,{0,_,0}->0},1],CenterList[11],5]//Grid

CAEvolveList[FunctionCARule[Mod[Apply[Plus,#],2]&,1],CenterList[11],5]//Grid

({{Audio representation,  (page 869)}})

Play[Evaluate[Apply[Plus,Flatten[Map[Sin[1000 # t]&,N[(2^(  1/12))]^Position[list,1]]]]],{t,0,0.2}]

CenterList[n_Integer]:=ReplacePart[Table[0,{n}],1,Ceiling[n/2]]
ElementaryRule[num_Integer]:=IntegerDigits[num,2,8]
CAStep[rule_List,a_List]:=rule[[8-(RotateLeft[a]+2 (a+2 RotateRight[a]))]]
CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]
CAPlay[list_List]:=Play[Evaluate[Apply[Plus,Flatten[Map[Sin[1000 # t]&,N[(2^(  1/12))]^Position[list,1]]]]],{t,0,0.2}]

CAPlay[Last[CAEvolveList[ElementaryRule[90],CenterList[23],10]]]

({{Cellular automaton rules as formulas,  (page 869)}})

f[1,_,1]=0;f[0,_,1]=1;f[1,_,0]=1;f[0,_,0]=0

a[0,0]=1;a[0,_]=0

a[t_,i_]:=a[t,i]=f[a[t-1,i-1],a[t-1,i],a[t-1,i+1]]

f[1,_,1]=0;f[0,_,1]=1;f[1,_,0]=1;f[0,_,0]=0;
a[0,0]=1;a[0,_]=0;
a[t_,i_]:=a[t,i]=f[a[t-1,i-1],a[t-1,i],a[t-1,i+1]];

Table[a[i,j],{i,0,5},{j,-5,5}]//Grid

f[p_,q_,r_]:=Mod[p+r,2]

f[p_,q_,r_]:=Mod[p+r,2]
a[0,0]=1;a[0,_]=0;
a[t_,i_]:=a[t,i]=f[a[t-1,i-1],a[t-1,i],a[t-1,i+1]];

Table[a[i,j],{i,0,5},{j,-5,5}]//Grid

a[0,-1]=p;a[0,0]=q;a[0,1]=r;a[0,_]=0

a[0,-1]=p;a[0,0]=q;a[0,1]=r;a[0,_]=0;
a[t_,i_]:=a[t,i]=f[a[t-1,i-1],a[t-1,i],a[t-1,i+1]];
f[p_,q_,r_]:=Mod[p+r,2]

Table[a[1,i],{i,-3,3}]

Table[a[2,i],{i,-4,4}]

Table[a[2,i],{i,-4,4}]/.{p->0,q->1,r->0}

({{Page 26 · Pascal's triangle and rule 90,  (page 870)}})

Fold[Flatten[{#1-#2,#1+#2}]&,{0},2^DigitPositions[t]]

DigitPositions[n_]:=Flatten[Position[Reverse[IntegerDigits[n,2]],1]]-1

DigitPositions[n_]:=Flatten[Position[Reverse[IntegerDigits[n,2]],1]]-1

With[{t=30},Fold[Flatten[{#1-#2,#1+#2}]&,{0},2^DigitPositions[t]]]

1-Sign[BitAnd[-t,n]]

Table[1-Sign[BitAnd[-t,n]],{t,1,6},{n,0,5}]//Grid

The evolution starts at t = 1; the results are only valid for n ≥ 0.

With[{d=Ceiling[Log[2,Max[t,n]+1]]},If[FreeQ[IntegerDigits[t,2,d]-IntegerDigits[n,2,d],-1],1,0]]

Table[With[{d=Ceiling[Log[2,Max[t,n]+1]]},If[FreeQ[IntegerDigits[t,2,d]-IntegerDigits[n,2,d],-1],1,0]],{t,0,5},{n,0,5}]//Grid

The evolution starts at t = 0; the results are only valid for n ≥ 0.

({{More colors,  (page 870)}})

CAStep[k_Integer,a_List]:=Mod[RotateLeft[a]+RotateRight[a],k]

CAStep[k_Integer,a_List]:=Mod[RotateLeft[a]+RotateRight[a],k]

Grid[NestList[CAStep[5,#]&,Flatten[{Table[0,{10}],1,Table[0,{10}]}],10]]

With[{d=Ceiling[Log[k,Max[t,n]+1]]},Mod[Apply[Times,Apply[Binomial,Transpose[{IntegerDigits[t,k,d],IntegerDigits[n,k,d]}],{1}]],k]]

With[{k=5},Table[With[{d=Ceiling[Log[k,Max[t,n]+1]]},Mod[Apply[Times,Apply[Binomial,Transpose[{IntegerDigits[t,k,d],IntegerDigits[n,k,d]}],{1}]],k]],{t,0,5},{n,0,5}]]//Grid

({{Page 29 · Rule 30,  (page 871)}})

Module[{a=1},Table[First[IntegerDigits[a,a=BitXor[a,BitOr[2 a,4 a]];2,i]],{i,n}]]

Module[{a=1},Table[First[IntegerDigits[a,a=BitXor[a,BitOr[2a,4a]];2,i]],{i,20}]]