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

Systems Based on Numbers

The Notion of Numbers

({{Implementation of digit sequences,  (page 901)}})

Reverse[Mod[NestWhileList[Floor[#/k]&,n,#≥k&],k]]

With[{n=123,k=3},Reverse[Mod[NestWhileList[Floor[#/k]&,n,#≥k&],k]]]

IntegerDigits[123,3]

Fold[k #1+#2&,0,list]

With[{data={1,1,1,2,0},k=3},Fold[k #1+#2&,0,data]]

FromDigits[{1,1,1,2,0},3]

Floor[k NestList[Mod[k #,1]&,x,m-1]]

With[{x=π-3,k=10,m=5},Floor[k NestList[Mod[k #,1]&,x,m-1]]]

RealDigits[π-3,10,5]

Fold[#1/k+#2&,0,Reverse[list]]/k

With[{k=10,list={1,4,1,5,9}},Fold[#1/k+#2&,0,Reverse[list]]/k]

FromDigits[{{1,4,1,5,9},0}]

({{Gray code,  (page 901)}})

GrayCode[m_]:=Nest[Join[#,Length[#]+Reverse[#]]&,{0},m]

BitXor[i,Floor[i/2]]

GrayCode[m_]:=Nest[Join[#,Length[#]+Reverse[#]]&,{0},m]

GrayCode[4]

Table[BitXor[i,Floor[i/2]],{i,0,15}]

Further information on Gray codes is available at MathWorld.

Elementary Arithmetic

({{Page 117 · Digit counts,  (page 902)}})

n-IntegerExponent[n!,2]

2 n-Log[2,Denominator[Derivative[n][(((1-#))^(  -1/2))&][0]/n!]]

DigitCount[127,2,1]

With[{n=127},n-IntegerExponent[n!,2]]

With[{n=127},2 n-Log[2,Denominator[Derivative[n][(((1-#))^(  -1/2))&][0]/n!]]]

({{Page 122 · Powers of 3/2,  (page 903)}})

{a_,b_,c_}->3 Mod[a+Quotient[b,2],2]+Quotient[3 Mod[b,2]+Quotient[c,2],2]

NestList[Partition[#,3,1,{2,2}]/.{a_,b_,c_}->3 Mod[a+Quotient[b,2],2]+Quotient[3 Mod[b,2]+Quotient[c,2],2]&,{0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0},5]

({{Relation to substitution systems,  (page 903)}})

Map[({0->Join[#,{1}],1->Join[#,{1,0}]}&)[Table[0,{#-1}]]&,Reverse[Rest[ContinuedFraction[h,m]]]]

Floor[h]+Fold[Flatten[#1/.#2]&,{0},rules]

With[{h=Sqrt[2],m=3},Map[({0->Join[#,{1}],1->Join[#,{1,0}]}&)[Table[0,{#-1}]]&,Reverse[Rest[ContinuedFraction[h,m]]]]]

With[{h=Sqrt[2],m=5},With[{rules=Map[({0->Join[#,{1}],1->Join[#,{1,0}]}&)[Table[0,{#-1}]]&,Reverse[Rest[ContinuedFraction[h,m]]]]},Floor[h]+Fold[Flatten[#1/.#2]&,{0},rules]]]

With[{h=Sqrt[2]},Table[Floor[(n+1)h]-Floor[n h],{n,1,29}]]

({{Page 122 · Implementation,  (page 904)}})

NestList[If[EvenQ[#],3 #/2,3/2 (#+1)]&,1,t]

NestList[If[EvenQ[#],3 #/2,3/2 (#+1)]&,1,5]

({{Page 122 · The 3n+1 problem,  (page 904)}})

n->If[EvenQ[n],n/2,(3n+1)/2]

NestList[Function[n,If[EvenQ[n],n/2,(3n+1)/2]],10,10]

FixedPoint[(3 #/2^IntegerExponent[#,2]+1)/2&,n]

Table[FixedPoint[(3 #/2^IntegerExponent[#,2]+1)/2&,n],{n,2,30}]

({{3n+1 problem as cellular automaton,  (page 904)}})

{a_,b_,c_}->If[b==6,If[EvenQ[a],6,4],3 Mod[a,2]+Quotient[b,2]/.0:>6/;a==6]

NestList[(Partition[#,3,1,2]/.{a_,b_,c_}->If[b==6,If[EvenQ[a],6,4],3 Mod[a,2]+Quotient[b,2]/.0:>6/;a==6])&,{6,1,4,6},10]

Map[FromDigits[DeleteCases[#,6],6]&,%]

NestList[Function[n,If[EvenQ[n],n/2,(3n+1)/2]],10,10]

Note that if n is odd, the cellular automaton takes two steps to perform the update.

({{Reconstructing initial conditions,  (page 904)}})

IntegerDigits[First[Fold[{Mod[If[OddQ[#2],2 First[#1]-1,2 First[#1] PowerMod[5,-1,Last[#1]]],Last[#1]],2 Last[#1]}&,{0,2},Reverse[list]]],2,Length[list]]

FromDigits[With[{list={0,1,0,0,0,1,1,0,0,0,0}},
IntegerDigits[First[Fold[
{Mod[If[OddQ[#2],2 First[#1]-1,2 First[#1] PowerMod[5,-1,Last[#1]]],Last[#1]],2 Last[#1]}&,{0,2},Reverse[list]]],2,Length[list]]],2]

With[{n=6,t=10},Map[Last[IntegerDigits[#,2]]&,NestList[If[EvenQ[#],5 #/2,(#+1)/2]&,n,t]]]

({{A reversible system,  (page 905)}})

n->If[EvenQ[n],3 n/2,Round[3 n/4]]

NestList[#/.n_:>If[EvenQ[n],3 n/2,Round[3 n/4]]&,260,10]

n->If[Mod[n,3]==0,2 n/3,Round[4 n/3]]

NestList[#/.n_:>If[Mod[n,3]==0,2 n/3,Round[4 n/3]]&,234,10]

({{Page 125 · Reversal-addition systems,  (page 905)}})

n->n+FromDigits[Reverse[IntegerDigits[n,2]],2]

NestList[Function[n,n+FromDigits[Reverse[IntegerDigits[n,2]],2]],16,10]

({{Digit reversal,  (page 905)}})

Table[FromDigits[Reverse[IntegerDigits[n,k,m]],k],{n,0,(k^(  m))-1}]

With[{k=3,m=3},
Table[FromDigits[Reverse[IntegerDigits[n,k,m]],k],{n,0,(k^( m))-1}]
]

({{Iterated run-length encoding,  (page 905)}})

Flatten[Map[{Length[#],First[#]}&,Split[list]]]

Also known as the "Look and Say" sequence.

NestList[Function[{list},Flatten[Map[{Length[#],First[#]}&,Split[list]]]], {1},8]

({{Digit count sequences,  (page 905)}})

Join[list,IntegerDigits[Apply[Plus,list],2]]

Nest[Function[list,Join[list,IntegerDigits[Apply[Plus,list],2]]],{1},10]

Recursive Sequences

({{Page 128 · Recurrence relations,  (page 906)}})

f[1]=1;f[n_]:=n f[n-1]

f[1]=1; f[n_]:=n f[n-1]

Table[f[n],{n,1,10}]

f[0]=x;f[n_]:=a f[n-1] (1-f[n-1])

f[0]=3;f[n_]:=1/2 f[n-1] (1-f[n-1])

Table[f[k],{k,1,7}]

({{Ackermann functions,  (page 906)}})

f[1,n_]:=n;f[m_,1]:=f[m-1,2]

f[m_,n_]:=f[m-1,f[m,n-1]+1]

f[1,n_]:=n;f[m_,1]:=f[m-1,2]
f[m_,n_]:=f[m-1,f[m,n-1]+1]

Table[f[a,b],{a,1,4},{b,1,4}]//Grid

Array[f,{4,4}]//Grid

f[1,x_,y_]:=x+y;f[m_,x_,y_]:=Nest[f[m-1,x,#]&,x,y-1]

f[1,x_,y_]:=x+y
f[m_,x_,y_]:=Nest[f[m-1,x,#]&,x,y-1]

Array[f,{3,3,3}]//TableForm

f[m_,x_,y_]:=Nest[Function[z,Nest[#1,x,z-1]]&,x+#&,m-1][y]

f[m_,x_,y_]:=Nest[Function[z,Nest[#1,x,z-1]]&,x+#&,m-1][y]

Array[f,{3,3,3}]//TableForm

({{Page 129 · Computation of sequences,  (page 906)}})

f[n_]:=f[n]=f[n-f[n-1]]+f[n-f[n-2]]

f[1]=f[2]=1

f[n_]:=f[n]=f[n-f[n-1]]+f[n-f[n-2]]
f[1]=f[2]=1;

Array[f,20]

({{Page 131 · Properties of sequences,  (page 906)}})

f[n_]:=(n+g[IntegerDigits[n,2]])/2

g[{(1)..}]=1;g[{1,(0)..}]=0

g[{1,s__}]:=1+g[IntegerDigits[FromDigits[{s},2]+1,2]]

Flatten[Table[Table[n,{IntegerExponent[n,2]+1}],{n,m}]]

f[n_]:=(n+g[IntegerDigits[n,2]])/2
g[{(1)..}]=1;g[{1,(0)..}]=0;
g[{1,s__}]:=1+g[IntegerDigits[FromDigits[{s},2]+1,2]]

With[{m=10},Flatten[Table[Table[n,{IntegerExponent[n,2]+1}],{n,m}]]]

Nest[Replace[#,{x___}->{x,1,x,0}]&,{},k]

With[{k=5},Nest[Replace[#,{x___}->{x,1,x,0}]&,{},k]]

FoldList[Plus,0,Flatten[Nest[Delete[NestList[Rest,#,Length[#]-1],2]&,Append[Table[1,{m}],0],m]]-1/2]

Table[FoldList[Plus,0,Flatten[Nest[Delete[NestList[Rest,#,Length[#]-1],2]&,Append[Table[1,{m}],0],m]]-1/2],{m,1,4}]

FoldList[Plus,1,Map[Last[Last[#]]&,Sort[Table[({Length[#],Apply[Plus,#],1-#}&)[IntegerDigits[i,2]],{i,(2^(  m))}]]]]

With[{m=3},FoldList[Plus,1,Map[Last[Last[#]]&,Sort[Table[({Length[#],Apply[Plus,#],1-#}&)[IntegerDigits[i,2]],{i,(2^( m))}]]]]]

({{Primitive recursive functions,  (page 907)}})

f[0,y___Integer]:=g[y]

f[x_Integer,y___Integer]:=h[f[x-1,y],x-1,y]

plus[0,y_]=y;plus[x_,y_]:=s[plus[x-1,y]]

times[0,y_]=0;times[x_,y_]:=plus[times[x-1,y],y]

s=#+1&;
plus[0,y_]=y;plus[x_,y_]:=s[plus[x-1,y]]
times[0,y_]=0;times[x_,y_]:=plus[times[x-1,y],y];

plus[7,9]

times[7,9]

f[x_,y___]:=Fold[h[#1,#2,y]&,g[y],Range[0,x-1]]

μ[f_]=NestWhile[#+1&,0,Function[n,f[n,##1]≠0]]&

c[g_,h___]=Apply[g,Through[{h}[##]]]&;

r[g_,h_]=If[#1==0,g[##2],h[#0[#1-1,##2],#1-1,##2]]&

r[g_,h_]=Fold[Function[{u,v},h[u,v,##2]],g[##2],Range[0,#-1]]&

plus=r[p[1],s]

s=#+1&;p[i_]:=Slot[i]&;
r[g_,h_]=Fold[Function[{u,v},h[u,v,##2]],g[##2],Range[0,#-1]]&;
plus=r[p[1],s];

plus[7,9]

r[z,r[s,s]]

1/2 #(#+1)&

z=0&;s=#+1&;p[i_]:=Slot[i]&;
r[g_,h_]=Fold[Function[{u,v},h[u,v,##2]],g[##2],Range[0,#-1]]&;

Array[r[z,r[s,s]],10]

Array[1/2 #(#+1)&,10]

r[z,r[s,c[s,s]]]

(2^(#+1))-#-2&

z=0&;s=#+1&;p[i_]:=Slot[i]&;
c[g_,h___]=Apply[g,Through[{h}[##]]]&;
r[g_,h_]=Fold[Function[{u,v},h[u,v,##2]],g[##2],Range[0,#-1]]&;

Array[r[z,r[s,c[s,s]]],10]

Array[(2^(#+1))-#-2&,10]

r[z,r[s,p[2]]]

2^Ceiling[Log[2,#+2]]-#-2&

z=0&;s=#+1&;p[i_]:=Slot[i]&;
c[g_,h___]=Apply[g,Through[{h}[##]]]&;
r[g_,h_]=Fold[Function[{u,v},h[u,v,##2]],g[##2],Range[0,#-1]]&;

Array[r[z,r[s,p[2]]],10]

Array[2^Ceiling[Log[2,#+2]]-#-2&,10]

r[z,r[c[s,z],z]]

Mod[#,2]&

z=0&;s=#+1&;p[i_]:=Slot[i]&;
c[g_,h___]=Apply[g,Through[{h}[##]]]&;
r[g_,h_]=Fold[Function[{u,v},h[u,v,##2]],g[##2],Range[0,#-1]]&;

Array[r[z,r[c[s,z],z]],10]

Array[Mod[#,2]&,10]

r[z,r[s,r[s,s]]]

Fold[1/2 #1(#1+1)+#2&,0,Range[#]]&

z=0&;s=#+1&;p[i_]:=Slot[i]&;
c[g_,h___]=Apply[g,Through[{h}[##]]]&;
r[g_,h_]=Fold[Function[{u,v},h[u,v,##2]],g[##2],Range[0,#-1]]&;

Array[r[z,r[s,r[s,s]]],5]

Array[Fold[1/2 #1(#1+1)+#2&,0,Range[#]]&,5]

r[z,r[s,r[s,r[s,p[2]]]]]

Fold[Fold[2^Ceiling[Log[2,Ceiling[(#1+2)/(#2+2)]]] (#2+2)-2-#1&,#2,Range[#1]]&,0,Range[#]]&

z=0&;s=#+1&;p[i_]:=Slot[i]&;
c[g_,h___]=Apply[g,Through[{h}[##]]]&;
r[g_,h_]=Fold[Function[{u,v},h[u,v,##2]],g[##2],Range[0,#-1]]&;

Array[r[z,r[s,r[s,r[s,p[2]]]]],20]

Array[Fold[Fold[2^Ceiling[Log[2,Ceiling[(#1+2)/(#2+2)]]] (#2+2)-2-#1&,#2,Range[#1]]&,0,Range[#]]&,20]

Nest[r[c[s,z],#]&,c[s,s],n]

f[n+1,2,#+1]-1&

z=0&;s=#+1&;p[i_]:=Slot[i]&;
c[g_,h___]=Apply[g,Through[{h}[##]]]&;
r[g_,h_]=Fold[Function[{u,v},h[u,v,##2]],g[##2],Range[0,#-1]]&;
f[m_,x_,y_]:=Nest[Function[z,Nest[#1,x,z-1]]&,x+#&,m-1][y]

With[{n=3},Array[Nest[r[c[s,z],#]&,c[s,s],n],3]]

With[{n=3},Array[f[n+1,2,#+1]-1&,3]]

({{Ulam sequences,  (page 908)}})

{1,2,3,4,6,8,11,13,16,18,26,28,36,38,47,48,53,57,…}

The Sequence of Primes

({{Decimation systems,  (page 909)}})

Module[{q=n+k-1,s=1},While[Mod[q,k]≠0,q=Ceiling[(k-1) q/k];s++];s]

Table[With[{k=2},Module[{q=n+k-1,s=1},While[Mod[q,k]≠0,q=Ceiling[(k-1) q/k];s++];s]],{n,15}]

Fold[Mod[#1+k,#2,1]&,0,Range[n]]

Table[With[{k=3},Fold[Mod[#1+k,#2,1]&,0,Range[n]]],{n,15}]

FromDigits[RotateLeft[IntegerDigits[n,2]],2]

Table[FromDigits[RotateLeft[IntegerDigits[n,2]],2],{n,15}]

({{Page 135 · Properties,  (page 910)}})

DivisorSigma[0,n]

Length[Divisors[n]]

Log[n]+2EulerGamma-1

With[{n=10^7},{DivisorSigma[0,n],Length[Divisors[n]],Log[n]+2EulerGamma-1}]//N

Apply[Plus,Table[{DivisorSigma[0,n],Log[n]+2EulerGamma-1},{n,10^7,10^7+1000}]//N]/1000

DivisorSigma[1,n]-2n

Apply[Plus,Divisors[n]]-2n

Table[{DivisorSigma[1,n]-2n,Apply[Plus,Divisors[n]]-2n},{n,100,110}]

1/6 (π^(  2)) n Sum[Apply[Plus,Cos[2 π n Select[Range[s],GCD[s,#]==1&]/s]]/(s^(  2)),{s,∞}]

An approximate value:

With[{n=100},1/6 (π^(  2)) n Sum[Apply[Plus,Cos[2 π n Select[Range[s],GCD[s,#]==1&]/s]]/(s^(  2)),{s,400}]]//N

4Apply[Plus,Im[i^Divisors[n]]]

With[{n=10},4Apply[Plus,Im[I^Divisors[n]]]]

8Apply[Plus,Select[Divisors[n],Mod[#,4]≠0&]]

With[{n=10},8Apply[Plus,Select[Divisors[n],Mod[#,4]≠0&]]]

Length[Select[n-Table[Prime[i],{i,PrimePi[n]}],PrimeQ]]

With[{n=10},Length[Select[n-Table[Prime[i],{i,PrimePi[n]}],PrimeQ]]]

Table[Length[Select[n-Table[Prime[i],{i,PrimePi[n]}],PrimeQ]],{n,5000,25000,5000}]

2 n Apply[Times,Map[(#-1)/(#-2)&,Map[First,Rest[FactorInteger[n]]]]]/((Log[n])^(  2))

Table[2 n Apply[Times,Map[(#-1)/(#-2)&,Map[First,Rest[FactorInteger[n]]]]]/((Log[n])^(  2)),{n,5000,25000,5000}]//N

{183.8000986328639`,314.3528283526898`,865.2042584849015`,543.7789700679476`,650.0978977507378`}/{152,254,710,462,528}

Mathematical Constants

({{Page 137 · Digits of pi,  (page 911)}})

{30841,-85289,136978,69393,-78309,-82947,-118485,-32406,291044,-130820}

Pi data courtesy of Yasumasa Kanada.

4 Sum[(((-1))^(  k))/(2 k+1),{k,0,m}]

N[With[{m=100},4 Sum[(((-1))^(  k))/(2 k+1),{k,0,m}]],20]

2 Apply[Times,2/Rest[NestList[Sqrt[2+#]&,0,m]]]

N[With[{m=50},2 Apply[Times,2/Rest[NestList[Sqrt[2+#]&,0,m]]]],40]

N[Pi,40]

(((#[[2]])^(  2))/#[[3]]&)[NestWhile[Apply[Function[{a,b,c,d},{(a+b)/2,Sqrt[a b],c-d (((a-b))^(  2)),2 d}],#]&,{1,1/Sqrt[N[2,n]],1/4,1/4},#[[1]]≠#[[2]]&]]

With[{n=100},(((#[[2]])^(  2))/#[[3]]&)[NestWhile[Apply[Function[{a,b,c,d},{(a+b)/2,Sqrt[a b],c-d (((a-b))^(  2)),2 d}],#]&,{1,1/Sqrt[N[2,n]],1/4,1/4},#[[1]]≠#[[2]]&]]]

N[Pi,100]

({{Computing (n^(th ))digits directly,  (page 912)}})

Round[FractionalPart[2^n Sum[2^(-k)/k,{k,Infinity}]]]

Table[Round[FractionalPart[2^n Sum[2^(-k)/k,{k,Infinity}]]],{n,1,10}]

Drop[RealDigits[Log[2],2,11]//First,1]

Round[FractionalPart[Sum[FractionalPart[PowerMod[2,n-k,k]/k],{k,n}]+Sum[(2^(  n-k))/k,{k,n+1,n+d}]]]

Table[Round[FractionalPart[Sum[FractionalPart[PowerMod[2,n-k,k]/k],{k,n}]+Sum[(2^(  n-k))/k,{k,n+1,n+d}]]],{n,101,110},{d,1,10}]

Map[First,%]

Take[First[RealDigits[Log[2],2,111]],-10]

Sum[(16^(  -k)) (4/(8 k+1)-2/(8 k+4)-1/(8 k+5)-1/(8 k+6)),{k,0,∞}]

Sum[(16^(  -k)) (4/(8 k+1)-2/(8 k+4)-1/(8 k+5)-1/(8 k+6)),{k,0,∞}]//FullSimplify

({{Page 139 · Rational numbers,  (page 912)}})

MultiplicativeOrder[b,FixedPoint[#/GCD[#,b]&,n]]

With[{b=4,n=13},MultiplicativeOrder[b,FixedPoint[#/GCD[#,b]&,n]]]

With[{b=4,n=13},RealDigits[1/n,b,20]]

({{Page 141 · Square roots,  (page 913)}})

x->1/2 (x+n/x)

N[With[{n=3,t=5},Nest[Function[x,1/2 (x+n/x)],n,t]],20]

N[Sqrt[3],20]

f[i_]:=2f[i-1]+f[i-2]

f[1]=f[2]=1

f[i_]:=2f[i-1]+f[i-2]
f[1]=f[2]=1;

N[f[20]/f[19],20]

N[1+Sqrt[2],20]

({{Concatenation sequences,  (page 913)}})

Flatten[Table[IntegerDigits[i,k],{i,n}]]

With[{k=10,n=30},Flatten[Table[IntegerDigits[i,k],{i,n}]]]

FoldList[Plus,0,Table[Apply[Plus,2 Rest[IntegerDigits[i,2]]-1],{i,n}]]

With[{n=20},FoldList[Plus,0,Table[Apply[Plus,2 Rest[IntegerDigits[i,2]]-1],{i,n}]]]

((IntegerDigits[#3+Quotient[#1,#2],2][[Mod[#1,#2]+1]]&)[n-(#-2) (2^(  #-1))-2,#,(2^(  #-1))]&)[NestWhile[#+1&,0,(#-1) (2^(  #))+1<n&]]

Table[((IntegerDigits[#3+Quotient[#1,#2],2][[Mod[#1,#2]+1]]&)[n-(#-2) (2^(  #-1))-2,#,(2^(  #-1))]&)[NestWhile[#+1&,0,(#-1) (2^(  #))+1<n&]],{n,1,20}]

Ceiling[1+ProductLog[1/2 (n-1) Log[2]]/Log[2]]

Table[NestWhile[#+1&,0,(#-1) (2^(  #))+1<n&],{n,1,10}]

Table[Ceiling[1+ProductLog[1/2 (n-1) Log[2]]/Log[2]],{n,1,10}]

k/(((k-1))^(  2))-(k-1) Sum[(k^(  ((k^(  s))-1) (1+s-s k)/(k-1))) 
(1/((k-1) ((((k^(  s))-1))^(  2)))-k/((k-1) ((((k^(  s+1))-1))^(  2)))+1/((k^(  s+1))-1)),{s,n}]

N[With[{k=10,n=2},k/(((k-1))^(  2))-(k-1) 
Sum[(k^(  ((k^(  s))-1) (1+s-s k)/(k-1))) 
(1/((k-1) ((((k^(  s))-1))^(  2)))-k/((k-1) ((((k^(  s+1))-1))^(  2)))+1/((k^(  s+1))-1)),{s,n}]],100]

({{Runs of digits,  (page 914)}})

Fold[Join[#1,Table[1-Last[#1],{#2}]]&,{0},list]

With[{list={7,5,1,6}},Fold[Join[#1,Table[1-Last[#1],{#2}]]&,{0},list]]

Mod[Floor[1/2+Sqrt[2*n]],2]

Table[Mod[Floor[1/2+Sqrt[2*n]],2],{n,1,20}]

(1-2^(1/4) EllipticTheta[2,0,1/2]+EllipticTheta[3,0,1/2])/2

BaseForm[N[(1-2^(1/4) EllipticTheta[2,0,1/2]+EllipticTheta[3,0,1/2])/2,18],2]

({{Leading digits,  (page 914)}})

Log[b,(s+1)/s]

With[{b=10},Table[Log[b,(s+1)/s],{s,1,9}]]//N

({{Page 143 · Continued fractions,  (page 914)}})

Floor[NestList[1/Mod[#,1]&,x,n-1]]

With[{x=π,n=15},Floor[NestList[1/Mod[#,1]&,x,n-1]]]

ContinuedFraction[π,15]

Fold[1/#1+#2&,Last[list],Rest[Reverse[list]]]

With[{list={3,7,15,1,292,1,1,1,2,1,3,1,14,2,1}},Fold[1/#1+#2&,Last[list],Rest[Reverse[list]]]]//N

With[{list={3,7,15,1,292,1,1,1,2,1,3,1,14,2,1}},FromContinuedFraction[list]]//N

4/(Fold[#2/#1+2&,2,Reverse[((Range[1,n,2])^(  2))]]-1)

N@With[{n=10000},4/(Fold[#2/#1+2&,2,Reverse[((Range[1,n,2])^( 2))]]-1)]

{0,k-1,k+2,k,k,k-2,k,k+2,k-2,k}[[Nest[Flatten[{{1,2},{3,4},{5,6},{7,8},{5,6},{3,4},{9,10},{7,8},{9,10},{3,4}}[[#]]]&,1,n]]]

BaseForm[N[FromContinuedFraction[With[{k=3,n=8},{0,k-1,k+2,k,k,k-2,k,k+2,k-2,k}[[Nest[Flatten[{{1,2},{3,4},{5,6},{7,8},{5,6},{3,4},{9,10},{7,8},{9,10},{3,4}}[[#]]]&,1,n]]]]],100],3]

Flatten[Table[Rest[ContinuedFraction[a/b]],{b,2,n},{a,b-1}]]

With[{n=10},Flatten[Table[Rest[ContinuedFraction[a/b]],{b,2,n},{a,b-1}]]]

With[{r=FromContinuedFraction[ContinuedFraction[x,n]]},-Log[Denominator[r],Abs[x-r]]]

With[{x=Sqrt[2],n=20},With[{r=FromContinuedFraction[ContinuedFraction[x,n]]},-Log[Denominator[r],Abs[x-r]]]]//N

({{History,  (page 915)}})

{a_,b_}:>If[a>b,{a-b,b},{a,b-a}]

FixedPoint[#/.{a_,b_}:>If[a>b,{a-b,b},{a,b-a}]&,{28,21}]

GCD[28,21]

({{Egyptian fractions,  (page 915)}})

Sum[1/a[n],{n,∞}]

a[n_]=2^n; Sum[1/a[n],{n,∞}]

a[n_]=n(n+1); Sum[1/a[n],{n,∞}]

a[n_]=n!; Sum[1/a[n],{n,∞}]

a[n_]=n!^2; Sum[1/a[n],{n,∞}]

a[n_]=n (2^n); Sum[1/a[n],{n,∞}]

a[n_]=n^2; Sum[1/a[n],{n,∞}]

a[n_]=(2n-1)(2n-3); Sum[1/a[n],{n,∞}]

a[n_]=3-16n+16n^2; Sum[1/a[n],{n,∞}]

a[n_]= n n!; Sum[1/a[n],{n,∞}]

({{Nested radicals,  (page 915)}})

Fold[Sqrt[#1+#2]&,0,Reverse[list]]
(1+Sqrt[4d+1])/2

With[{list =Table[4,{100}]},Fold[Sqrt[#1+#2]&,0,Reverse[list]]]//N

With[{d=4},(1+Sqrt[4d+1])/2]//N

Ceiling[NestList[(((2-Mod[-#,1]))^(  2))&,(x^(  2)),n-1]-2]

With[{x=3/2,n=20},Ceiling[NestList[(((2-Mod[-#,1]))^(  2))&,(x^(  2)),n-1]-2]]

({{Digital slope representation,  (page 916)}})

Max[MapIndexed[#1/First[#2]&,FoldList[Plus,First[list],Rest[list]]]]

With[{list=Table[With[{h=GoldenRatio},Floor[n h]-Floor[(n-1) h]],{n,1,50}]},Max[MapIndexed[#1/First[#2]&,FoldList[Plus,First[list],Rest[list]]]]]

Union[Flatten[Table[a/b,{b,n},{a,0,b}]]]

MemberQ[With[{n=34},Union[Flatten[Table[a/b,{b,n},{a,0,b}]]]],FractionalPart[(55/34)]]

({{Number classification,  (page 916)}})

Integrate[1/(1+(x^(  2))+(y^(  2))),{x,0,1},{y,0,1}]==HypergeometricPFQ[{1/2,1,1},{3/2,3/2},1/9]/6+1/2 π ArcSinh[1]-Catalan

N[Integrate[1/(1+(x^(  2))+(y^(  2))),{x,0,1},{y,0,1}],30]

N[HypergeometricPFQ[{1/2,1,1},{3/2,3/2},1/9]/6+1/2 π ArcSinh[1]-Catalan,30]

Mathematical Functions

({{Page 147 · Substitution systems,  (page 917)}})

(Floor[(n+1) #]-Floor[n #]&)[(b-a)/(a+b)]

Table[With[{a=7,b=13},(Floor[(n+1) #]-Floor[n #]&)[(b-a)/(a+b)]],{n,1,30}]

({{Many sine functions,  (page 917)}})

(((π/(2 q)))^(  2)) Sum[Sin[(n^(  2)) p π/q]/((Sin[n π/(2 q)])^(  2)),{n,q-1}]

With[{p=7,q=17},(((π/(2 q)))^(  2)) Sum[Sin[(n^(  2)) p π/q]/((Sin[n π/(2 q)])^(  2)),{n,q-1}]]//N

({{Page 148 · Zeta function,  (page 918)}})

RiemannSiegelTheta[t_]=Arg[Gamma[1/4+i t/2]]-1/2 t Log[π]

RiemannSiegelTheta is also a built-in Mathematica function.

Iterated Maps and the Chaos Phenomenon

({{Page 151 · Problems with computer experiments,  (page 919)}})

IntegerDigits[Mod[(2^(  n)) Floor[(2^(  53)) x],(2^(  53))],2,53]

Grid[Table[With[{x=1/7.},IntegerDigits[Mod[(2^(  n)) Floor[(2^(  53)) x],(2^(  53))],2,53]],{n,0,20}],Spacings->.2]

Flatten[IntegerDigits[IntegerDigits[Mod[(2^(  n)) Floor[(10^(  12)) x],(10^(  12))],10,12],2,4]]

Grid[Table[With[{x=1/7.},Flatten[IntegerDigits[IntegerDigits[Mod[(2^(  n)) Floor[(10^(  12)) x],(10^(  12))],10,12],2,4]]],{n,0,20}],Spacings->.2]

Continuous Cellular Automata

({{Implementation,  (page 921)}})

CCAEvolveStep[f_,list_List]:=Map[f,(RotateLeft[list]+list+RotateRight[list])/3]

CCAEvolveList[f_,init_List,t_Integer]:=NestList[CCAEvolveStep[f,#]&,init,t]

CCAEvolveStep[f_,list_List]:=Map[f,(RotateLeft[list]+list+RotateRight[list])/3]
CCAEvolveList[f_,init_List,t_Integer]:=NestList[CCAEvolveStep[f,#]&,init,t]

Grid[CCAEvolveList[FractionalPart[3#/2]&,{0,0,0,0,0,1,0,0,0,0,0},5],Spacings->.6]

({{Additive rules,  (page 922)}})

Mod[RotateLeft[list]+RotateRight[list],1]

Grid[NestList[Function[list,Mod[RotateLeft[list]+RotateRight[list],1]],{0,0,0,0,0,1/3,0,0,0,0,0},5],Spacings->.6]

Partial Differential Equations

({{Klein–Gordon equation,  (page 922)}})

u[t,x]=If[(x^(  2))>(t^(  2)),0,BesselJ[0,Sqrt[(t^(  2))-(x^(  2))]]]

Block[{u},u[t,x]=If[(x^( 2))>(t^( 2)),0,BesselJ[0,Sqrt[(t^( 2))-(x^( 2))]]];FullSimplify[(∂_(t,t))u[t,x]-(∂_(x,x))u[t,x]-u[t,x],{(x^2)>(t^2)}]]

({{Page 164 · Singular behavior,  (page 923)}})

(∂_t)u[t,x]==-(∂_(x,x))u[t,x]

({{Page 165 · Field equations,  (page 923)}})

(∂_(t,t))u[t,x]==(∂_(x,x))u[t,x]+f[u[t,x]]

v[u]=-Integrate[f[u],u]

(((((∂_t)u))^(  2))-((((∂_x)u))^(  2)))/2-v[u]

Integrate[(((((∂_t)u))^(  2))+((((∂_x)u))^(  2)))/2+v[u],{x,-∞,∞}]

({{Equation for the background,  (page 924)}})

(u^(  ″))[t]==(1-((u[t])^(  2))) (1+a u[t])

u[0]==(u^(  ′))[0]==0

(Sqrt[3]) ((JacobiSN[t/(3^(  1/4)),1/2])^(  2))/(1+((JacobiCN[t/(3^(  1/4)),1/2])^(  2)))

Simplify[Module[{a=0,u},u[t_]=(Sqrt[3]) ((JacobiSN[t/(3^(  1/4)),1/2])^(  2))/(1+((JacobiCN[t/(3^(  1/4)),1/2])^(  2)));(u^(  ″))[t]-(1-((u[t])^(  2))) (1+a u[t])]]/.t->.3`40

b d ((JacobiSN[r t,s])^(  2))/(b-d ((JacobiCN[r t,s])^(  2)))

r=-Sqrt[1/8 a c (b-d)]

s=d (c-b)/(c (d-b))

(x-b) (x-c) (x-d)==-(12+6 a x-4 (x^(  2))-3 a (x^(  3)))/(3 a)

3 ((Sin[Sqrt[5/6] t])^(  2))/(2+3 ((Cos[Sqrt[5/6] t])^(  2)))

FullSimplify[Module[{a=8/3,u},u[t_]=3 ((Sin[Sqrt[5/6] t])^( 2))/(2+3 ((Cos[Sqrt[5/6] t])^( 2)));
(u^(  ″))[t]-(1-((u[t])^(  2))) (1+a u[t])],{t∈Reals,t>0}]

({{Implementation,  (page 924)}})

(∂_(t,t))u[t,x]==(∂_(x,x))u[t,x]+f[u[t,x]]

PDEKernel[f_,{dx_,dt_}]:=Compile[{a,b,c,d},Evaluate[(2 b-d)+((a+c-2 b)/(dx^(  2))+f[b]) (dt^(  2))]]

PDEStep[ker_,{u1_,u2_}]:={u2,Apply[ker,Transpose[{RotateLeft[u2],u2,RotateRight[u2],u1}],{1}]}

PDEEvolveList[ker_,{u0_,u1_},n_]:=Map[First,NestList[PDEStep[ker,#]&,{u0,u1},n]]

PDEEvolveList[PDEKernel[0&,{0.1,0.05}],Transpose[Table[{1,1} N[Exp[-(x^( 2))]],{x,-5,5,0.1}]],50]

PDEKernel[f_,{dx_,dt_}]:=Compile[{a,b,c,d},Evaluate[(2 b-d)+((a+c-2 b)/(dx^(  2))+f[b]) (dt^(  2))]]
PDEStep[ker_,{u1_,u2_}]:={u2,Apply[ker,Transpose[{RotateLeft[u2],u2,RotateRight[u2],u1}],{1}]}
PDEEvolveList[ker_,{u0_,u1_},n_]:=Map[First,NestList[PDEStep[ker,#]&,{u0,u1},n]]

ListPlot3D[PDEEvolveList[PDEKernel[0&,{0.1,0.05}],Transpose[Table[{1,1} N[Exp[-(x^( 2))]],{x,-5,5,0.1}]],50]]

({{Different powers,  (page 925)}})

(∂_(t,t))u[t,x]==(∂_(x,x))u[t,x]+(1-((u[t,x])^(  n))) (1+a u[t,x])