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

Fundamental Physics

The Notion of Reversibility

({{Page 437 · Testing for reversibility,  (page 1017)}})

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

ReversibleQ[rule_,k_,n_]:=Catch[Do[If[
Length[Union[Table[CAStep[rule,IntegerDigits[i,k,m]],{i,0,(k^(  m))-1}]]]≠(k^(  m)),Throw[False]],{m,n}];True]

CAStep[rule_List,a_List]:=rule[[8-(RotateLeft[a]+2 (a+2 RotateRight[a]))]]
ReversibleQ[rule_,k_,n_]:=Catch[Do[If[
Length[Union[Table[CAStep[rule,IntegerDigits[i,k,m]],{i,0,(k^(  m))-1}]]]≠(k^(  m)),Throw[False]],{m,n}];True]

ReversibleQ[IntegerDigits[51,2,8],2,4]

({{Page 437 · Second-order cellular automata,  (page 1017)}})

CA2EvolveList[rule_List,{a_List,b_List},t_Integer]:=Map[First,NestList[CA2Step[rule,#]&,{a,b},t]]

CA2Step[rule_List,{a_,b_}]:={b,Mod[a+rule[[8-(RotateLeft[b]+2 (b+2 RotateRight[b]))]],2]}

CA2EvolveList[rule_List,{a_List,b_List},t_Integer]:=Map[First,NestList[CA2Step[rule,#]&,{a,b},t]]
CA2Step[rule_List,{a_,b_}]:={b,Mod[a+rule[[8-(RotateLeft[b]+2 (b+2 RotateRight[b]))]],2]}

Grid[CA2EvolveList[IntegerDigits[214,2,8],{{0,0,0,0,0,1,0,0,0,0,0},{0,0,0,0,0,1,0,0,0,0,0}},6]]

({{Generalized additive rules,  (page 1018)}})

Append[Rest[list],Map[Mod[Apply[Plus,Flatten[c #]],2]&,Transpose[Table[RotateLeft[list,{0,i}],{i,-r,r}],{3,2,1}]]]

r=(Length[First[c]]-1)/2

Module[{c={{1,0,1}},r,init={{0,0,0,0,0,1,0,0,0,0,0}}},r=(Length[First[c]]-1)/2; NestList[Function[list,Append[Rest[list],Map[Mod[Apply[Plus,Flatten[c #]],2]&,Transpose[Table[RotateLeft[list,{0,i}],{i,-r,r}],{3,2,1}]]]],init,5]]

({{Other reversible systems,  (page 1018)}})

Table[(IntegerDigits[i,2,3]->If[First[#]==0,{#,-1},{Reverse[#],1}]&)[IntegerDigits[perm[[i]],2,3]],{i,8}]

With[{perm={1,7,5,3,6,2,8,4}},Table[(IntegerDigits[i,2,3]->If[First[#]==0,{#,-1},{Reverse[#],1}]&)[IntegerDigits[perm[[i]],2,3]],{i,8}]]

Conserved Quantities and Continuum Phenomena

({{Implementation,  (page 1022)}})

Catch[Do[(If[Apply[Plus,CAStep[rule,#]-#]≠0,Throw[False]]&)[IntegerDigits[i,k,m]],{m,w},{i,0,(k^(  m))-1}];True]

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

With[{rule=IntegerDigits[204,2,8],k=2,n=5},Catch[Do[(If[Apply[Plus,CAStep[rule,#]-#]≠0,Throw[False]]&)[IntegerDigits[i,k,m]],{m,n},{i,0,(k^(  m))-1}];True]]

({{More general conserved quantities,  (page 1022)}})

BC[list_]:=With[{z=Map[FromDigits[#,k]&,Partition[list,b,1,1]]},Map[Count[z,#]&,Range[0,(k^(  b))-1]]]

NullSpace[Table[With[{u=Table[Random[Integer,{0,k-1}],{m}]},BC[CAStep[u]]-BC[u]],{s}]]

BC[list_]:=With[{z=Map[FromDigits[#,k]&,Partition[list,b,1,1]]},Map[Count[z,#]&,Range[0,(k^(  b))-1]]]
CAStep[list_]:=IntegerDigits[12,2,8][[8-ListConvolve[{1,2,4},list,2]]]

Block[{k=2,b=2,m=20,s=5}, 
{BC[{1,1,0,0,1,0}],NullSpace[Table[With[{u=Table[Random[Integer,{0,k-1}],{m}]},BC[CAStep[u]]-BC[u]],{s}]]}]

({{Block cellular automata,  (page 1023)}})

BCAEvolveList[{n_Integer,rule_},init_,t_]:=FoldList[BCAStep[{n,rule},#1,#2]&,init,Range[t]]/;Mod[Length[init],n]==0

BCAStep[{n_,rule_},a_,d_]:=RotateRight[Flatten[Partition[RotateLeft[a,d],n]/.rule],d]

BCAEvolveList[{n_Integer,rule_},init_,t_]:=FoldList[BCAStep[{n,rule},#1,#2]&,init,Range[t]]/;Mod[Length[init],n]==0
BCAStep[{n_,rule_},a_,d_]:=RotateRight[Flatten[Partition[RotateLeft[a,d],n]/.rule],d]

Grid[BCAEvolveList[{2,{{1,1}->{1,1},{1,0}->{1,0},{0,1}->{0,0},{0,0}->{0,1}}},{0,0,0,0,1,1,0,0,0,0,0,0},5]]

({{Derivation of the diffusion equation,  (page 1024)}})

f[x+dx,t]==f[x,t]+(∂_x)f[x,t] dx+1/2 (∂_(x,x))f[x,t] (dx^(  2))+…

f[x,t+dt]==(Subscript[p, 1]) f[x-dx,t]+(Subscript[p, 2]) f[x,t]+(Subscript[p, 3]) f[x+dx,t]

f[x,t+dt]==c (f[x-dx,t]+f[x+dx,t])+(1-2 c) f[x,t]

f[x,t]+dt (∂_t)f[x,t]==f[x,t]+c (dx^(  2)) (∂_(x,x))f[x,t]

Space as a Network

({{Page 477 · 3D network,  (page 1030)}})

x[m:{_,_,_}]:={(Subscript[x, 1])[m],(Subscript[x, 1])[m+4],(Subscript[x, 2])[m+{4,2,0}],(Subscript[x, 2])[m+{0,6,4}]}

(Subscript[x, 1])[m:{_,_,_}]:=Line[Map[#+m&,{{1,0,0},{1,1,1},{0,2,1},{1,1,1},{3,1,3},{3,0,4},{3,1,3},{4,2,3}}]]

(Subscript[x, 2])[{i_,j_,k_}]:=(Subscript[x, 1])[{-i-4,-j-2,k}]/.{a_,b_,c_}->{-a,-b,c}

x[m:{_,_,_}]:={(Subscript[x, 1])[m],(Subscript[x, 1])[m+4],(Subscript[x, 2])[m+{4,2,0}],(Subscript[x, 2])[m+{0,6,4}]}
(Subscript[x, 1])[m:{_,_,_}]:=Line[Map[#+m&,{{1,0,0},{1,1,1},{0,2,1},{1,1,1},{3,1,3},{3,0,4},{3,1,3},{4,2,3}}]]
(Subscript[x, 2])[{i_,j_,k_}]:=(Subscript[x, 1])[{-i-4,-j-2,k}]/.{a_,b_,c_}->{-a,-b,c}

Graphics3D[Array[x[8{##}]&,{2,2,2}]]

({{Page 478 · Definitions of dimension,  (page 1030)}})

Det[Table[(x[i]-x[j]) . (x[i]-x[j]),{i,d+3},{j,d+3}]]==0

({{Page 478 · Counting of nodes,  (page 1031)}})

First[Select[4 (r^(  3))/9+2 (r^(  2))/3+{2,5/3,5/3} r-{10/9,1,-4/9},IntegerQ]]

With[{r=3},First[Select[4 (r^(  3))/9+2 (r^(  2))/3+{2,5/3,5/3} r-{10/9,1,-4/9},IntegerQ]]]

({{Page 480 · Implementation,  (page 1031)}})

{1->{2,3,4},2->{1,3,4},3->{1,2,4},4->{1,2,3}}

NodeLists[g_,i_,n_]:=NestList[Union[Flatten[#/.g]]&,{i},n]

NodeLists[g_,i_,n_]:=NestList[Union[Flatten[#/.g]]&,{i},n]

NodeLists[{1->{2,3,4},2->{1,3,4},3->{1,2,4},4->{1,2,3}},1,2]

With[{dodec= {1->{2,17,20},2->{1,3,15},3->{13,2,4},4->{20,5,3},5->{12,6,4},6->{5,7,19},7->{6,8,11},8->{18,7,9},9->{8,10,16},10->{9,11,14},11->{10,12,7},12->{11,13,5},13->{12,14,3},14->{13,15,10},15->{14,16,2},16->{15,17,9},17->{16,18,1},18->{17,19,8},19->{18,20,6},20->{19,1,4}}},
NodeLists[dodec,1,4]]

Distance[g_,{i_,j_}]:=Length[NestWhileList[Union[Flatten[#/.g]]&,{i},!MemberQ[#,j]&]]-1

Distance[g_,{i_,j_}]:=Length[NestWhileList[Union[Flatten[#/.g]]&,{i},!MemberQ[#,j]&]]-1

With[{dodec= {1->{2,17,20},2->{1,3,15},3->{13,2,4},4->{20,5,3},5->{12,6,4},6->{5,7,19},7->{6,8,11},8->{18,7,9},9->{8,10,16},10->{9,11,14},11->{10,12,7},12->{11,13,5},13->{12,14,3},14->{13,15,10},15->{14,16,2},16->{15,17,9},17->{16,18,1},18->{17,19,8},19->{18,20,6},20->{19,1,4}}},
Distance[dodec,{1,11}]]

({{Finding layouts,  (page 1031)}})

With[{n=Length[g]},Apply[Plus,Flatten[(((((Table[Distance[g,{i,j}],{i,n},{j,n}])^(  2))-Table[Sum[(((x[i,k]-x[j,k]))^(  2)),{k,d}],{i,n},{j,n}]))^(  2))]]]

Distance[g_,{i_,j_}]:=Length[NestWhileList[Union[Flatten[#/.g]]&,{i},!MemberQ[#,j]&]]-1
Block[{g={1->{2,3,4},2->{1,3,4},3->{1,2,4},4->{1,2,3}},d=2},FindMinimum[With[{n=Length[g]},Apply[Plus,Flatten[(((((Table[Distance[g,{i,j}],{i,n},{j,n}])^(  2))-Table[Sum[(((x[i,k]-x[j,k]))^(  2)),{k,d}],{i,n},{j,n}]))^(  2))]]],Evaluate[Apply[Sequence,Flatten[Table[{x[i,k],If[i==1,0,Random[]]},{i,Length[g]},{k,d}],1]]]]]

With[{g={1->{2,3,4},2->{1,3,4},3->{1,2,4},4->{1,2,3}},d=2},Graphics[Map[Line,Flatten[Map[Function[y,{x[y[[1]]],x[#]}&/@y[[2]]],g],1]/.x[i_]:>(Table[x[i,k],{k,d}]/.%[[2]])]]]

Block[{g= {1->{2,17,20},2->{1,3,15},3->{13,2,4},4->{20,5,3},5->{12,6,4},6->{5,7,19},7->{6,8,11},8->{18,7,9},9->{8,10,16},10->{9,11,14},11->{10,12,7},12->{11,13,5},13->{12,14,3},14->{13,15,10},15->{14,16,2},16->{15,17,9},17->{16,18,1},18->{17,19,8},19->{18,20,6},20->{19,1,4}},d=3},FindMinimum[With[{n=Length[g]},Apply[Plus,Flatten[(((((Table[Distance[g,{i,j}],{i,n},{j,n}])^(  2))-Table[Sum[(((x[i,k]-x[j,k]))^(  2)),{k,d}],{i,n},{j,n}]))^(  2))]]],Evaluate[Apply[Sequence,Flatten[Table[{x[i,k],If[i==1,0,Random[]]},{i,Length[g]},{k,d}],1]]]]]

With[{g= {1->{2,17,20},2->{1,3,15},3->{13,2,4},4->{20,5,3},5->{12,6,4},6->{5,7,19},7->{6,8,11},8->{18,7,9},9->{8,10,16},10->{9,11,14},11->{10,12,7},12->{11,13,5},13->{12,14,3},14->{13,15,10},15->{14,16,2},16->{15,17,9},17->{16,18,1},18->{17,19,8},19->{18,20,6},20->{19,1,4}},d=3},Graphics3D[Map[Line,Flatten[Map[Function[y,{x[y[[1]]],x[#]}&/@y[[2]]],g],1]/.x[i_]:>(Table[x[i,k],{k,d}]/.%[[2]])]]]

Time and Causal Networks

({{Implementation,  (page 1033)}})

MAToNet[list_]:=Module[{u,j,k},u[_]=∞;Reverse[Table[j=list[[i]];k={u[j-1],u[j],u[j+1]};u[j-1]=u[j]=u[j+1]=i;i->k,{i,Length[list],1,-1}]]]

The Sequencing of Events in the Universe

({{Implementation,  (page 1033)}})

GSSEvolveList[rule_,s_,n_]:=NestList[GSSStep[rule,#]&,s,n]

GSSStep[rule_,s_]:=g[rule,s,f[StringPosition[s,Map[First,rule]]]]

f[{}]={};
f[s_]:=Fold[If[Last[Last[#1]]≥First[#2],#1,Append[#1,#2]]&,{First[s]},Rest[s]]

g[rule_,s_,{}]:=s

g[rule_,s_,pos_]:=StringReplacePart[s,Map[StringTake[s,#]&,pos]/.rule,pos]

GSSEvolveList[rule_,s_,n_]:=NestList[GSSStep[rule,#]&,s,n]
GSSStep[rule_,s_]:=g[rule,s,f[StringPosition[s,Map[First,rule]]]]
f[{}]={};
f[s_]:=Fold[If[Last[Last[#1]]≥First[#2],#1,Append[#1,#2]]&,{First[s]},Rest[s]]
g[rule_,s_,{}]:=s
g[rule_,s_,pos_]:=StringReplacePart[s,Map[StringTake[s,#]&,pos]/.rule,pos]

GSSEvolveList[{"ABA"-> "BAAB", "BBBB"->"AA"},"AAABAAA",7]

({{Generating causal networks,  (page 1033)}})

With[{u=Map[First,list]},MapIndexed[Function[{e,i},First[i]->Map[(If[#==={},∞,#[[1,1]]]&)[Position[u,#]]&,Last[e]]],list]]

With[{list={{1,2,3}->{4,5},{4}->{6,7},{5}->{8,9},{6}->{10,11},{8}->{13,14}}},With[{u=Map[First,list]},MapIndexed[Function[{e,i},First[i]->Map[(If[#==={},∞,#[[1,1]]]&)[Position[u,#]]&,Last[e]]],list]]]

From the example on page 497 in A New Kind of Science.

({{String overlaps,  (page 1033)}})

a[0]=1;a[n_]:=k a[n-1]-If[EvenQ[n],a[n/2],0]

a[0]=1;a[n_]:=k a[n-1]-If[EvenQ[n],a[n/2],0]

Block[{k=2},a[4]]

({{Simulating mobile automata,  (page 1033)}})

Map[StringJoin,Map[{"AAABB","ABABB","ABAABB"}[[#+1]]&,Map[Insert[#[[1]],2,2]->Insert[#[[2,1]],2,2+#[[2,2]]]&,rule],{2}],{2}]

With[{rule={{1,1,1}->{{0,0,0},-1},{1,1,0}->{{1,0,1},-1},{1,0,1}->{{1,1,1},1},{1,0,0}->{{1,0,0},1},{0,1,1}->{{0,0,0},1},{0,1,0}->{{0,1,1},-1},{0,0,1}->{{1,0,1},1},{0,0,0}->{{1,1,1},1}}},Map[StringJoin,Map[{"AAABB","ABABB","ABAABB"}[[#+1]]&,Map[Insert[#[[1]],2,2]->Insert[#[[2,1]],2,2+#[[2,2]]]&,rule],{2}],{2}]]

The mobile automaton initial condition {list,n} is translated as follows:

With[{init={{0,0,0,0,1,0,0,0,0},5}},StringJoin[{"AAABB","ABABB","ABAABB"}[[Insert[init[[1]],2,init[[2]]]+1]]]]

({{Sequential cellular automata,  (page 1034)}})

OrderedUpdate[f_,a_,order_]:=Fold[ReplacePart[#1,f[Take[#1,{#2-1,#2+1}]],#2]&,a,order]

OrderedUpdate[f_,a_,order_]:=Fold[ReplacePart[#1,f[Take[#1,{#2-1,#2+1}]],#2]&,a,order]
f[a_]:=IntegerDigits[90,2,8][[8-ListConvolve[{1,2,4},a,2]]][[2]]

OrderedUpdate[f,{1,0,0,1,0,0},{2,5,3,4}]

Fold[Insert[#1,#2,Random[Integer,Length[#1]]+1]&,{},Range[n]]

With[{n=10}, Fold[Insert[#1,#2,Random[Integer,Length[#1]]+1]&,{},Range[n]]]

Uniqueness and Branching in Time

({{Page 506 · String transformations,  (page 1035)}})

{"A"->"AA","AA"->"A","A"->"B","B"->"A"}

Evolution of Networks

({{Implementation,  (page 1037)}})

Attributes[u]={Flat,Orderless};Attributes[v]=Orderless;

u[i1_->v[i2_,i3_,i4_],i3_->v[i1_,i5_,i6_],i4_->v[i1_,i7_,i8_]]:>u[i1->v[i2,new[1],new[2]],new[1]->v[i1,new[2],i3],new[2]->v[i1,new[1],i4],i3->v[new[1],i5,i6],i4->v[new[2],i7,i8]]

NetStep[rule_,net_]:=Block[{new},net/.rule/.new[n_]->n+Apply[Max,Map[First,net]]]

Attributes[u]={Flat,Orderless};Attributes[v]=Orderless;
NetStep[rule_,net_]:=Block[{new},net/.rule/.new[n_]->n+Apply[Max,Map[First,net]]]

NetStep[u[i1_->v[i2_,i3_,i4_],i3_->v[i1_,i5_,i6_],i4_->v[i1_,i7_,i8_]]:>u[i1->v[i2,new[1],new[2]],new[1]->v[i1,new[2],i3],new[2]->v[i1,new[1],i4],i3->v[new[1],i5,i6],i4->v[new[2],i7,i8]],u[1->v[2,3,4],2->v[1],3->v[1,5,6],4->v[1,7,8],5->v[3],6->v[3],7->v[4],8->v[4]]]

({{Random networks,  (page 1038)}})

RandomNetwork[n_?EvenQ]:=Partition[Fold[Insert[#1,#2,Random[Integer,Length[#1]]+1]&,{},Floor[Range[1,n+2/3,1/3]]],2]

RandomNetwork[n_?EvenQ]:=Partition[Fold[Insert[#1,#2,Random[Integer,Length[#1]]+1]&,{},Floor[Range[1,n+2/3,1/3]]],2]

RandomNetwork[10]

Space, Time and Relativity

({{Standard treatment,  (page 1042)}})

{t,x}->{t-v x/(c^(  2)),x-v t}/Sqrt[1-(v^(  2))/(c^(  2))]

The Phenomenon of Gravity

({{Differential geometry,  (page 1048)}})

(Transpose[#] . #&)[Outer[D,e,p]]

With[{p={x,y},e={x,y,Sqrt[1-x^2-y^2]}},(Transpose[#] . #&)[Outer[D,e,p]]//FullSimplify]

The metric on the unit half sphere.

Integrate[Sqrt[(∂_t)s . g[s] . (∂_t)s],{t,(Subscript[t, 1]),(Subscript[t, 2])}]

Block[{s,x,y,t,g},x=t;y=0;s={x,y};g[s]={{((-1+(y^2))/(-1+(x^2)+(y^2))),-((x y)/(-1+(x^2)+(y^2)))},{-((x y)/(-1+(x^2)+(y^2))),((-1+(x^2))/(-1+(x^2)+(y^2)))}};Integrate[Sqrt[(∂_t)s . g[s] . (∂_t)s],{t,0,1}]]

The distance from the equator to the North Pole on the unit half sphere.

Riemann=Table[(∂_(p[[j]]))Γ[[i,k]]-(∂_(p[[i]]))Γ[[j,k]]+Γ[[i,k]] . Γ[[j]]-Γ[[j,k]] . Γ[[i]],{i,d},{j,d},{k,d}]

Γ=With[{gi=Inverse[g]},Table[Sum[gi[[l,k]] ((∂_(p[[j]]))g[[i,l]]+(∂_(p[[i]]))g[[j,l]]-(∂_(p[[l]]))g[[i,j]]),{l,d}],{i,d},{j,d},{k,d}]]/2

Block[{Riemann,Γ,d=2,p={x,y},g={{((-1+(y^2))/(-1+(x^2)+(y^2))),-((x y)/(-1+(x^2)+(y^2)))},{-((x y)/(-1+(x^2)+(y^2))),((-1+(x^2))/(-1+(x^2)+(y^2)))}}},Γ=With[{gi=Inverse[g]},Table[Sum[gi[[l,k]] ((∂_(p[[j]]))g[[i,l]]+(∂_(p[[i]]))g[[j,l]]-(∂_(p[[l]]))g[[i,j]]),{l,d}],{i,d},{j,d},{k,d}]]/2;Riemann=Table[(∂_(p[[j]]))Γ[[i,k]]-(∂_(p[[i]]))Γ[[j,k]]+Γ[[i,k]] . Γ[[j]]-Γ[[j,k]] . Γ[[i]],{i,d},{j,d},{k,d}];Riemann//FullSimplify]

RicciTensor=Map[Tr,Transpose[Riemann,{1,3,2,4}],{2}]

Block[{RicciTensor,Riemann,Γ,d=2,p={x,y},g={{((-1+(y^2))/(-1+(x^2)+(y^2))),-((x y)/(-1+(x^2)+(y^2)))},{-((x y)/(-1+(x^2)+(y^2))),((-1+(x^2))/(-1+(x^2)+(y^2)))}}},Γ=With[{gi=Inverse[g]},Table[Sum[gi[[l,k]] ((∂_(p[[j]]))g[[i,l]]+(∂_(p[[i]]))g[[j,l]]-(∂_(p[[l]]))g[[i,j]]),{l,d}],{i,d},{j,d},{k,d}]]/2;Riemann=Table[(∂_(p[[j]]))Γ[[i,k]]-(∂_(p[[i]]))Γ[[j,k]]+Γ[[i,k]] . Γ[[j]]-Γ[[j,k]] . Γ[[i]],{i,d},{j,d},{k,d}];RicciTensor=Map[Tr,Transpose[Riemann,{1,3,2,4}],{2}];RicciTensor//FullSimplify]

RicciScalar=Tr[RicciTensor . Inverse[g]]

Block[{RicciScalar,RicciTensor,Riemann,Γ,d=2,p={x,y},g={{((-1+(y^2))/(-1+(x^2)+(y^2))),-((x y)/(-1+(x^2)+(y^2)))},{-((x y)/(-1+(x^2)+(y^2))),((-1+(x^2))/(-1+(x^2)+(y^2)))}}},Γ=With[{gi=Inverse[g]},Table[Sum[gi[[l,k]] ((∂_(p[[j]]))g[[i,l]]+(∂_(p[[i]]))g[[j,l]]-(∂_(p[[l]]))g[[i,j]]),{l,d}],{i,d},{j,d},{k,d}]]/2;Riemann=Table[(∂_(p[[j]]))Γ[[i,k]]-(∂_(p[[i]]))Γ[[j,k]]+Γ[[i,k]] . Γ[[j]]-Γ[[j,k]] . Γ[[i]],{i,d},{j,d},{k,d}];RicciTensor=Map[Tr,Transpose[Riemann,{1,3,2,4}],{2}];RicciScalar=Tr[RicciTensor . Inverse[g]];RicciScalar//FullSimplify]

({{Page 531 · Geodesics,  (page 1049)}})

(x^(  ″))[t]==-(Derivative[1,0][f][x[t],y[t]] ((((y^(  ′))[t])^(  2)) Derivative[0,2][f][x[t],y[t]]+2 (x^(  ′))[t] (y^(  ′))[t] Derivative[1,1][f][x[t],y[t]]+(((x^(  ′))[t])^(  2)) Derivative[2,0][f][x[t],y[t]]))/(1+((Derivative[0,1][f][x[t],y[t]])^(  2))+((Derivative[1,0][f][x[t],y[t]])^(  2)))

f[x_,y_]:=Sqrt[1-x^2-y^2]

NDSolve[Simplify[{x''[t]==-(Derivative[1,0][f][x[t],y[t]] (((y'[t])^2) Derivative[0,2][f][x[t],y[t]]+2 x'[t] y'[t] Derivative[1,1][f][x[t],y[t]]+((x'[t])^2) Derivative[2,0][f][x[t],y[t]]))/(1+((Derivative[0,1][f][x[t],y[t]])^2)+((Derivative[1,0][f][x[t],y[t]])^2)),y''[t]==-(Derivative[0,1][f][x[t],y[t]] (((y'[t])^2) Derivative[0,2][f][x[t],y[t]]+2 x'[t] y'[t] Derivative[1,1][f][x[t],y[t]]+((x'[t])^2) Derivative[2,0][f][x[t],y[t]]))/(1+((Derivative[0,1][f][x[t],y[t]])^2)+((Derivative[1,0][f][x[t],y[t]])^2)),x[0]==0,x'[0]==1,y[0]==0,y'[0]==0}],{x[t],y[t]},{t,0,5}]

Plot[x[t]/.First[%],{t,0,5}]

({{Page 533 · Sphere volumes,  (page 1050)}})

s[d]=(π^(d/2))/(d/2)!

2 π (a^(  2)) (1-Cos[r/a])=π (r^(  2)) (1-(r^(  2))/(12 (a^(  2)))+(r^(  4))/(360 (a^(  4)))-…)

d s[d] (a^(  d)) Integrate[((Sin[θ])^(  d-1)),{θ,0,r/a}]=s[d] (r^(  d)) (1-d (d-1) (r^(  2))/((6 (d+2)) (a^(  2)))+(d (5 (d^(  2))-12 d+7)) (r^(  4))/((360 (d+4)) (a^(  4)))+…)

Integrate[((Sin[x])^(  d-1)),x]=-Cos[x] Hypergeometric2F1[1/2,(2-d)/2,3/2,((Cos[x])^(  2))]

s[d] (r^(  d)) (1-RicciScalar (r^(  2))/(6 (d+2))+…)

s[d] (r^(  d)) (1-RicciScalar (r^(  2))/(6 (d+2))+(5 (RicciScalar^(  2))-3 RiemannNorm+8 RicciNorm-18 Laplacian[RicciScalar]) (r^(  4))/(360 (d+2) (d+4))+…)

RicciNorm=NormSquared[RicciTensor,{g,g}]

RiemannNorm=NormSquared[Riemann,{g,g,g,Inverse[g]}]

NormSquared[t_,gl_]:=Flatten[t].Flatten[Dual[t,gl]]

Dual[t_,gl_]:=Fold[Transpose[#1 . Inverse[#2],RotateLeft[Range[TensorRank[t]]]]&,t,Reverse[gl]]

Laplacian[f_]:=Inner[D,Sqrt[Det[g]] (Inverse[g] . Map[(∂_(#))f&,p]),p]/Sqrt[Det[g]]

NormSquared[t_,gl_]:=Flatten[t].Flatten[Dual[t,gl]]
Dual[t_,gl_]:=Fold[Transpose[#1 . Inverse[#2],RotateLeft[Range[TensorRank[t]]]]&,t,Reverse[gl]]
Laplacian[f_]:=Inner[D,Sqrt[Det[g]] (Inverse[g] . Map[(∂_(#))f&,p]),p]/Sqrt[Det[g]]

Block[{RicciNorm,RiemannNorm,RicciScalar,RicciTensor,Riemann,Γ,d=2,p={x,y},s,g={{((-1+(y^2))/(-1+(x^2)+(y^2))),-((x y)/(-1+(x^2)+(y^2)))},{-((x y)/(-1+(x^2)+(y^2))),((-1+(x^2))/(-1+(x^2)+(y^2)))}}},s[d_]:=(π^(d/2))/(d/2)!;Γ=With[{gi=Inverse[g]},Table[Sum[gi[[l,k]] ((∂_(p[[j]]))g[[i,l]]+(∂_(p[[i]]))g[[j,l]]-(∂_(p[[l]]))g[[i,j]]),{l,d}],{i,d},{j,d},{k,d}]]/2;Riemann=Table[(∂_(p[[j]]))Γ[[i,k]]-(∂_(p[[i]]))Γ[[j,k]]+Γ[[i,k]] . Γ[[j]]-Γ[[j,k]] . Γ[[i]],{i,d},{j,d},{k,d}];RicciTensor=Map[Tr,Transpose[Riemann,{1,3,2,4}],{2}];RicciScalar=Tr[RicciTensor . Inverse[g]]//FullSimplify;
RicciNorm=NormSquared[RicciTensor,{g,g}]//FullSimplify;RiemannNorm=NormSquared[Riemann,{g,g,g,Inverse[g]}]//FullSimplify;
s[d] (r^(  d)) (1-RicciScalar (r^(  2))/(6 (d+2))+(5 (RicciScalar^(  2))-3 RiemannNorm+8 RicciNorm-18 Laplacian[RicciScalar]) (r^(  4))/(360 (d+2) (d+4))+…)//FullSimplify]

This is identical to (as it should be):

Block[{d=2,a=1,s},s[d_]:=(π^(d/2))/(d/2)!;s[d] (r^(  d)) (1-d (d-1) (r^(  2))/((6 (d+2)) (a^(  2)))+(d (5 (d^(  2))-12 d+7)) (r^(  4))/((360 (d+4)) (a^(  4)))+…)]

({{Cylinder volumes,  (page 1050)}})

s[d-1] (r^(  d-1)) x (1-(d-1) (RicciScalar-RicciTensor . v . v) (r^(  2))/(d+1)+…)

Block[{RicciScalar,RicciTensor,Riemann,Γ,d=2,p={x,y},s,L=1,v={1,0},g={{((-1+(y^2))/(-1+(x^2)+(y^2))),-((x y)/(-1+(x^2)+(y^2)))},{-((x y)/(-1+(x^2)+(y^2))),((-1+(x^2))/(-1+(x^2)+(y^2)))}}},s[d_]:=(π^(d/2))/(d/2)!;Γ=With[{gi=Inverse[g]},Table[Sum[gi[[l,k]] ((∂_(p[[j]]))g[[i,l]]+(∂_(p[[i]]))g[[j,l]]-(∂_(p[[l]]))g[[i,j]]),{l,d}],{i,d},{j,d},{k,d}]]/2;Riemann=Table[(∂_(p[[j]]))Γ[[i,k]]-(∂_(p[[i]]))Γ[[j,k]]+Γ[[i,k]] . Γ[[j]]-Γ[[j,k]] . Γ[[i]],{i,d},{j,d},{k,d}];RicciTensor=Map[Tr,Transpose[Riemann,{1,3,2,4}],{2}];RicciScalar=Tr[RicciTensor . Inverse[g]];s[d-1] (r^(  d-1)) L (1-(d-1) (RicciScalar-RicciTensor . v . v) (r^(  2))/(d+1))//FullSimplify]

Note that we substituted L for the cylinder length x, to avoid confusion with the coordinate x.

({{Page 534 · Lorentzian spaces,  (page 1051)}})

s[d] (t^(  d+1)) (1-(t^(  2)) (d+1) (d RicciScalar+2 (d+1) (RicciTensor . e . e))/((d+2) (d+3))+…)/(d+1)

Block[{RicciScalar,RicciTensor,Riemann,Γ,d=2,s,p={t,x},e1={1,0},e,g={{1,0},{0,-1}}},s[d_]:=(π^(d/2))/(d/2)!;e=e1/Sqrt[e1.g.e1];Γ=With[{gi=Inverse[g]},Table[Sum[gi[[l,k]] ((∂_(p[[j]]))g[[i,l]]+(∂_(p[[i]]))g[[j,l]]-(∂_(p[[l]]))g[[i,j]]),{l,d}],{i,d},{j,d},{k,d}]]/2;Riemann=Table[(∂_(p[[j]]))Γ[[i,k]]-(∂_(p[[i]]))Γ[[j,k]]+Γ[[i,k]] . Γ[[j]]-Γ[[j,k]] . Γ[[i]],{i,d},{j,d},{k,d}];RicciTensor=Map[Tr,Transpose[Riemann,{1,3,2,4}],{2}];RicciScalar=Tr[RicciTensor . Inverse[g]];s[d] (H^(  d+1)) (1-(H^(  2)) (d+1) (d RicciScalar+2 (d+1) (RicciTensor . e . e))/((d+2) (d+3))+…)/(d+1)//FullSimplify]

We replaced the cone height t by the variable H, to avoid confusion with the variable for time.

({{Page 534 · Einstein equations,  (page 1053)}})

(∂_(t,t))v[t]/v[t]==-1/2 (ρ+3 p)

Quantum Phenomena

({{Page 540 · Feynman diagrams,  (page 1060)}})

2 (1+α/(2 π)+(3 Zeta[3]/4-1/2 (π^(  2)) Log[2]+(π^(  2))/12+197/144) (((α/π))^(  2))+(83/72 (π^(  2)) Zeta[3]-215 Zeta[5]/24-239 (π^(  4))/2160+139 Zeta[3]/18+25/18 (24 PolyLog[4,1/2]+((Log[2])^(  4))-(π^(  2)) ((Log[2])^(  2)))-298/9 (π^(  2)) Log[2]+17101 (π^(  2))/810+28259/5184) (((α/π))^(  3))-1.4 (((α/π))^(  4))+…)

N[2 (1+α/(2 π)+(3 Zeta[3]/4-1/2 (π^(  2)) Log[2]+(π^(  2))/12+197/144) (((α/π))^(  2))+(83/72 (π^(  2)) Zeta[3]-215 Zeta[5]/24-239 (π^(  4))/2160+139 Zeta[3]/18+25/18 (24 PolyLog[4,1/2]+((Log[2])^(  4))-(π^(  2)) ((Log[2])^(  2)))-298/9 (π^(  2)) Log[2]+17101 (π^(  2))/810+28259/5184) (((α/π))^(  3))-1.4 (((α/π))^(  4)))]//Expand

2.+0.32 α-0.067 (α^(  2))+0.076 (α^(  3))-0.029 (α^(  4))+…

({{Page 543 · Bell's inequalities,  (page 1064)}})

Integrate[f[ϕ] f[θ-ϕ],{ϕ,0,2 π}]/(2 π)