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

Mechanisms in Programs and Nature

Chaos Theory and Randomness from Initial Conditions

({{Page 314 · Simple case,  (page 973)}})

(∂_(t,t))z[t]==-z[t]/(((((z[t])^(  2))+(((1/2 (1+e Sin[2 π t])))^(  2))))^(  3/2))

sol=z/.First[With[{e=.1},NDSolve[{(∂_(t,t))z[t]==-z[t]/(((((z[t])^(  2))+(((1/2 (1+e Sin[2 π t])))^(  2))))^(  3/2)),z[0]==1,z'[0]==0},z,{t,0,7}]]]

Plot[sol[t],{t,0,7}]

The Intrinsic Generation of Randomness

({{Page 321 · Card shuffling,  (page 974)}})

s[list_]:=Flatten[Transpose[Reverse[Partition[list,Length[list]/2]]]]

s[list_]:=Flatten[Transpose[Reverse[Partition[list,Length[list]/2]]]]

s[{1,2,3,4,5,6}]

({{Random number generators,  (page 974)}})

n[i+2]==Mod[(65539^(  2)) n[i],(2^(  31))]==Mod[6 n[i+1]-9 n[i],(2^(  31))]

LFSRStep[list_]:=Append[Rest[list],Mod[list[[1]]+list[[2]],2]]
NestList[Nest[LFSRStep,#,n]&,Append[Table[0,{n-1}],1],t]

LFSRStep[list_]:=Append[Rest[list],Mod[list[[1]]+list[[2]],2]]

With[{t=5,n=30},NestList[Nest[LFSRStep,#,n]&,Append[Table[0,{n-1}],1],t]]

PolynomialMod[(x^(  t)),{1+x+(x^(  n)),2}]

With[{t=30*5,n=30},PolynomialMod[(x^( t)),{1+x+(x^( n)),2}]]

LFSRStep[taps_List,list_]:=Append[Rest[list],Mod[Apply[Plus,list[[taps]]],2]]

LFSRStep[taps_List,list_]:=Append[Rest[list],Mod[Apply[Plus,list[[taps]]],2]]

With[{t=5,n=30},NestList[Nest[(LFSRStep[{1,2},#]&),#,n]&,Append[Table[0,{n-1}],1],t]]

Append[Rest[list],Mod[list[[1]]+list[[q-p+1]],(2^(  k))]]

With[{p=24,q=55,k=1},Nest[Function[list,Append[Rest[list],Mod[list[[1]]+list[[q-p+1]],(2^(  k))]]],Append[Table[0,{q-1}],1], 3q]]

n->FromDigits[Take[IntegerDigits[(n^(  2)),10,20],{5,15}],10]

With[{n=1234567890},n/.n->FromDigits[Take[IntegerDigits[(n^(  2)),10,20],{5,15}],10]]

n->Mod[(n^(  2)),m]

With[{n=1234567890,m=13*19},n/.n->Mod[(n^( 2)),m]]

({{Unequal probabilities,  (page 976)}})

Fold[{BitAnd,BitOr}[[1+First[#2]]][#1,Last[#2]]&,0,Reverse[Transpose[{First[RealDigits[p,2,n,-1]],a}]]]

Table[With[{n=100,p=3/10},With[{a=Table[Random[Integer],{n}]},Fold[{BitAnd,BitOr}[[1+First[#2]]][#1,Last[#2]]&,0,Reverse[Transpose[{First[RealDigits[p,2,n,-1]],a}]]]]],{100}]

({{Page 325 · Noisy cellular automata,  (page 976)}})

λ[x_]:=Exp[-10 (((x-1))^(  2))]+Exp[-10 (((x-3))^(  2))]

λ[x_]:=Exp[-10 (((x-1))^(  2))]+Exp[-10 (((x-3))^(  2))]
f[{a_,b_,c_}]:=λ[a+b+c+b c]

Grid[NestList[f/@Partition[#,3,1,{2,2}]&,N@{0,0,0,0,1,0,0,0,0},4]]

The Phenomenon of Continuity

({{Central Limit Theorem,  (page 976)}})

Exp[-(((x-μ))^(  2))/(2 (σ^(  2)))]/(Sqrt[2 π] σ)

({{Related results,  (page 977)}})

Exp[-(((Log[x]-μ))^(  2))/(2 (σ^(  2)))]/(Sqrt[2 π] x σ)

Exp[(x-μ)/β] Exp[-Exp[(x-μ)/β]]/β

2 Sqrt[1-(x^(  2))] UnitStep[1-(x^(  2))]/π

1/2 (π x) Exp[1/4 (-π) (x^(  2))]

({{Page 328 · Random walks,  (page 977)}})

NestList[#+(-1)^Random[Integer]&,0,t]

With[{t=10},NestList[#+(-1)^Random[Integer]&,0,t]]

FoldList[Plus,0,Table[(-1)^Random[Integer],{t}]]

With[{t=10},FoldList[Plus,0,Table[(-1)^Random[Integer],{t}]]]

FoldList[Plus,Table[0,{d}],Table[RotateLeft[PadLeft[{(-1)^Random[Integer]},d],Random[Integer,d-1]],{t}]]

With[{t=10,d=2},FoldList[Plus,Table[0,{d}],Table[RotateLeft[PadLeft[{(-1)^Random[Integer]},d],Random[Integer,d-1]],{t}]]]

With[{σ=1},(((d/(2 π σ t)))^(  d/2)) Exp[-d (r^(  2))/(2 σ t)]]

e=Table[{Cos[2 π s/k],Sin[2 π s/k]},{s,0,k-1}]

FoldList[Plus,{0,0},Table[e[[Random[Integer,{1,k}]]],{t}]]

Block[{t=10,k=4,e},SeedRandom[1]; e=Table[{Cos[2 π s/k],Sin[2 π s/k]},{s,0,k-1}];
FoldList[Plus,{0,0},Table[e[[Random[Integer,{1,k}]]],{t}]]]

Sum[Outer[Times,e[[s]],e[[s]]],{s,Length[e]}]

Block[{k=4,e},e=Table[{Cos[2 π s/k],Sin[2 π s/k]},{s,0,k-1}];Sum[Outer[Times,e[[s]],e[[s]]],{s,Length[e]}]]

({{Implementation,  (page 978)}})

AEvolve[t_]:=Nest[AStep,{{0,0}},t]

AStep[c_]:=(If[!MemberQ[c,#],Append[c,#],AStep[c]]&)[f[c]+f[{{1,0},{0,1},{-1,0},{0,-1}}]]

f[a_]:=a[[Random[Integer,{1,Length[a]}]]]

AEvolve[t_]:=Nest[AStep,{{0,0}},t]
AStep[c_]:=(If[!MemberQ[c,#],Append[c,#],AStep[c]]&)[f[c]+f[{{1,0},{0,1},{-1,0},{0,-1}}]]
f[a_]:=a[[Random[Integer,{1,Length[a]}]]]

AEvolve[10]

AStep[a_]:=ReplacePart[a,1,(#[[Random[Integer,{1,Length[#]}]]]&)[Position[(1-a) Sign[ListConvolve[{{0,1,0},{1,0,1},{0,1,0}},a,{2,2}]],1]]]

AStep[a_]:=ReplacePart[a,1,(#[[Random[Integer,{1,Length[#]}]]]&)[Position[(1-a) Sign[ListConvolve[{{0,1,0},{1,0,1},{0,1,0}},a,{2,2}]],1]]]

With[{s=5},SeedRandom[1];Nest[AStep,ReplacePart[Table[0,{s},{s}],1,{Round[s/2],Round[s/2]}],4]]

({{Isotropy,  (page 980)}})

Apply[Plus,Map[Apply[Outer[Times,##]&,Table[#,{n}]]&,v]]

With[{k=6},With[
{n=4,vecs=Table[{Cos[2 Pi s/k],Sin[2Pi s/k]},{s,0,k-1}]},Apply[Plus,Map[Apply[Outer[Times,##]&,Table[#,{n}]]&,vecs]]]]

(d-2)!! Array[Apply[Times,Map[(1-Mod[#,2]) (#-1)!!&,Table[Count[{##},i],{i,d}]]]&,Table[d,{n}]]/(d+n-2)!!

With[{d=2,n=4},(d-2)!! Array[
Apply[Times,Map[(1-Mod[#,2]) (#-1)!!&,Table[Count[{##},i],{i,d}]]]&,Table[d,{n}]]/(d+n-2)!!]

Origins of Discreteness

({{Page 339 · 1D transitions,  (page 981)}})

{a1_,a2_,a3_,a4_,a5_,a6_,a7_}->If[If[a4==1,a1+a3+a4,a4+a5+a7]≥2,1,0]

With[{init=Table[Random[Integer],{15}],t=5},NestList[Partition[#,7,1,{4,4}]/.{a1_,a2_,a3_,a4_,a5_,a6_,a7_}->If[If[a4==1,a1+a3+a4,a4+a5+a7]≥2,1,0]&,init,t]]

({{The Ising model,  (page 981)}})

e[s_]:=-1/2 Apply[Plus,
s ListConvolve[{{0,1,0},{1,0,1},{0,1,0}},s,2],{0,1}]

e[s_]:=-1/2 Apply[Plus,
s ListConvolve[{{0,1,0},{1,0,1},{0,1,0}},s,2],{0,1}]
m[s_]:=Apply[Plus,s,{0,1}]

With[{s={{1,-1,1,1},
{1,1,1,-1},{-1,1,-1,1},{-1,1,1,-1}}},{e[s],m[s]}]

Abs[m[s]]==(((1-((Sinh[2 β])^(  -4))))^(  1/8))

e[s]==-(Coth[2 β] 
(1+2 EllipticK[4 ((Sech[2 β])^(  2)) ((Tanh[2 β])^(  2))] (-1+2 ((Tanh[2 β])^(  2)))/π))

IsingEvolve[list_,t_Integer]:=First[Nest[IsingStep,{list,Mask[list]},t]]

IsingStep[{a_,mask_}]:={MapThread[If[#2==2&&#3==1,1-#1,#1]&,{a,ListConvolve[{{0,1,0},{1,0,1},{0,1,0}},a,2],mask},2],1-mask}

Mask[list_]:=Array[Mod[#1+#2,2]&,Dimensions[list]]

IsingEvolve[list_,t_Integer]:=First[Nest[IsingStep,{list,Mask[list]},t]]
IsingStep[{a_,mask_}]:={MapThread[If[#2==2&&#3==1,1-#1,#1]&,{a,ListConvolve[{{0,1,0},{1,0,1},{0,1,0}},a,2],mask},2],1-mask}
Mask[list_]:=Array[Mod[#1+#2,2]&,Dimensions[list]]

IsingEvolve[{{0,1,0,1,0,1,0,0,0,1},{1,1,0,1,1,0,0,1,1,0},{0,0,1,0,1,1,0,0,0,1},{0,0,0,0,1,1,1,0,1,0},{1,0,0,0,1,1,0,0,1,0},{1,1,0,1,1,1,0,1,0,1},{0,0,0,1,0,0,0,0,1,0},{1,0,1,1,1,0,0,0,1,1},{1,1,1,0,1,0,0,1,0,1},{0,0,1,0,1,0,0,1,1,1}},5]

The Problem of Satisfying Constraints

({{Page 346 · Implementation,  (page 984)}})

Cost[list_]:=Apply[Plus,Abs[list-RotateLeft[list]]]

Move[list_]:=(If[Cost[#]<Cost[list],#,list]&)[MapAt[1-#&,list,Random[Integer,{1,Length[list]}]]]

Table[Cost[IntegerDigits[i,2,n]],{i,0,(2^( n))-1}]

Cost[list_]:=Apply[Plus,Abs[list-RotateLeft[list]]]
Move[list_]:=(If[Cost[#]<Cost[list],#,list]&)[MapAt[1-#&,list,Random[Integer,{1,Length[list]}]]]

With[{n=6,l={0,1,1,1,0,1,1,0,1,0}},
{Cost[l],Nest[Move,l,10]}]

({{Gradient descent,  (page 985)}})

FixedPoint[#-a (f^(  ′))[#]&,(Subscript[x, 0])]

FixedPoint[#-f[#]/(f^(  ′))[#]&,(Subscript[x, 0])]

Block[{a=0.1,x0=0.,f},f[x_]:=(x-1)(x-2);
  {FixedPoint[#-a (f^(  ′))[#]&,x0],FixedPoint[#-f[#]/(f^(  ′))[#]&,x0]}]

({{Discrete Voronoi diagrams,  (page 987)}})

{{0|1,n:(0|1),0|1}->n,{_,0,_}->2,{_,n_,_}->n-1}

Grid[NestList[Partition[#,3,1,2]/.{{0|1,n:(0|1),0|1}->n,{_,0,_}->2,{_,n_,_}->n-1}&,{0,2,0,0,0,0,0,0,0,2,0,0,0,0,0,0,2,0,0},10]]

Origins of Simple Behavior

({{Nested lists,  (page 989)}})

c[{_,_},-1]=0;c[{0,0},_]=1;

c[{m_,n_},_]:=0/;n>m;

c[{m_,n_},d_]:=Sum[c[{i,j},d],{i,0,m-1},{j,m-d,n-1}]

c[{_,_},-1]=0;c[{0,0},_]=1;c[{m_,n_},_]:=0/;n>m;
c[{m_,n_},d_]:=Sum[c[{i,j},d],{i,0,m-1},{j,m-d,n-1}]

With[{n=3},{Binomial[2n,n]/(n+1),Table[c[{n,n},d]-c[{n,n},d-1],{d,0,4}]}]

({{Self-organized criticality,  (page 989)}})

SandStep[s_]:=s+ListConvolve[{{0,1,0},{1,-4,1},{0,1,0}},UnitStep[s-4],2,0]

SandStep[s_]:=s+ListConvolve[{{0,1,0},{1,-4,1},{0,1,0}},UnitStep[s-4],2,0]
Grid[Nest[SandStep,
{{0,0,0,0,0,0,0,0,0},
{0,0,0,0,0,0,0,0,0},
{0,0,4,4,4,4,4,0,0},
{0,0,4,4,4,4,4,0,0},
{0,0,4,4,4,4,4,0,0},
{0,0,4,4,4,4,4,0,0},
{0,0,4,4,4,4,4,0,0},
{0,0,0,0,0,0,0,0,0},
{0,0,0,0,0,0,0,0,0}},5]]

SandStep[s_]:=s+ListConvolve[{1,-2,1},UnitStep[s-2],2,0]

SandStep[s_]:=s+ListConvolve[{1,-2,1},UnitStep[s-2],2,0]
Nest[SandStep,{0,0,4,4,4,4,4,0,0},5]