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

Implications for Everyday Systems

The Growth of Crystals

({{Page 369 · Implementation,  (page 992)}})

CAStep[rule_List,a_]:=Map[rule[[14-#]]&,a+2 ListConvolve[{{1,1,0},{1,0,1},{0,1,1}},a,2],{2}]

rule=IntegerDigits[10926,2,14];
CAStep[rule_List,a_]:=Map[rule[[14-#]]&,a+2 ListConvolve[{{1,1,0},{1,0,1},{0,1,1}},a,2],{2}]

Nest[CAStep[rule,#]&,With[{n=15},PadLeft[{{1}},{n,n},0,Floor[{n,n}/2]]],6]

Growth of Plants and Animals

({{Page 402 · Implementation,  (page 1005)}})

Nest[Flatten[Outer[Times,1+#,b]]&,{0},n]

With[{n=2,b={1/2(E^(I π/4)),1/2,1/2(E^(-I π/4))}},Nest[Flatten[Outer[Times,1+#,b]]&,{0},n]//Expand]

ListPlot[{Re[#],Im[#]}&/@With[{n=7,b=N@{1/2(E^(I π/4)),1/2,1/2(E^(-I π/4))}},Nest[Flatten[Outer[Times,1+#,b]]&,{0},n]],AspectRatio->Automatic]

({{Page 407 · Parameter space sets,  (page 1006)}})

With[{d=Conjugate[c],r=1-((Abs[c])^(  2))},Which[Im[c]<0,d,Im[c]==0,0,Re[c]>0,With[{n=Ceiling[π/2/Arg[c]]},Im[c (1-(d^(  n)))/(1-d)]+Im[c (d^(  n)) (1+d)]/r],Arg[c]>3 π/4,Im[c+(c^(  2))]/r,True,Im[c]+Im[(c^(  2))+(c^(  3))]/r]]

With[{c=1/2+2I/3},With[{d=Conjugate[c],r=1-((Abs[c])^( 2))},Which[Im[c]<0,d,Im[c]==0,0,Re[c]>0,With[{n=Ceiling[π/2/Arg[c]]},Im[c (1-(d^( n)))/(1-d)]+Im[c (d^( n)) (1+d)]/r],Arg[c]>3 π/4,Im[c+(c^( 2))]/r,True,Im[c]+Im[(c^( 2))+(c^( 3))]/r]]]

({{Shell model,  (page 1008)}})

(a^(  t)) {Cos[t] (1+c (Cos[e] Cos[θ]+d Sin[e] Sin[θ])),Sin[t] (1+c (Cos[e] Cos[θ]+d Sin[e] Sin[θ])),b+c (Cos[θ] Sin[e]-d Cos[e] Sin[θ])}

With[{a=1.2,b=3,c=.6,d=2,e=.3},ParametricPlot3D[(a^( t)) {Cos[t] (1+c (Cos[e] Cos[θ]+d Sin[e] Sin[θ])),Sin[t] (1+c (Cos[e] Cos[θ]+d Sin[e] Sin[θ])),b+c (Cos[θ] Sin[e]-d Cos[e] Sin[θ])},{θ,-Pi,Pi},{t,0,2Pi},ViewPoint->{-2.117, 1.723, 2.000}]]

({{Page 418 · Intrinsically defined curves,  (page 1009)}})

NDSolve[{(x^(  ′))[s]==Cos[θ[s]],(y^(  ′))[s]==Sin[θ[s]],(θ^(  ′))[s]==f[s],x[0]==y[0]==θ[0]==0},{x,y,θ},{s,0,(Subscript[s, max])}]

Block[{f},f[s]=s;DSolve[{x'[s]==Cos[θ[s]],y'[s]==Sin[θ[s]],θ'[s]==f[s],x[0]==y[0]==θ[0]==0},{x,y,θ},s]]

Biological Pigmentation Patterns

({{Page 427 · Implementation,  (page 1012)}})

WeightedStep[w_List,a_]:=Map[If[#>0,1,0]&,Sum[w[[1+i]] Apply[Plus,Map[RotateLeft[a,#]&,Layer[i]]],{i,0,Length[w]-1}],{2}]

Layer[n_]:=Layer[n]=Select[Flatten[Table[{i,j},{i,-n,n},{j,-n,n}],1],MemberQ[#,n|-n]&]

WeightedStep[w_List,a_]:=Map[If[#>0,1,0]&,Sum[w[[1+i]] Apply[Plus,Map[RotateLeft[a,#]&,Layer[i]]],{i,0,Length[w]-1}],{2}]
Layer[n_]:=Layer[n]=Select[Flatten[Table[{i,j},{i,-n,n},{j,-n,n}],1],MemberQ[#,n|-n]&]

With[{w={1,1,-1/5,-1/5},a={{0,1,1,1,0,1,1,0,1,0},{1,0,0,1,0,0,1,0,1,0},{1,0,0,0,0,0,0,0,0,1},{1,1,1,1,0,0,1,0,1,0},{1,1,1,0,1,0,0,0,0,0},{0,1,0,0,1,0,1,0,1,1},{0,1,0,0,1,1,1,1,0,1},{1,0,1,1,1,1,0,1,1,0},{1,0,0,1,0,1,0,1,1,0},{0,1,1,1,1,1,1,1,0,0}}},Grid[Nest[WeightedStep[w,#]&,a,6]]]