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

Processes of Perception and Analysis

Data Compression

({{Page 560 · Number representations,  (page 1070)}})

Table[0,{n}]

Array[Function[n,Table[0,{n}]],5]

IntegerDigits[n,2]

Array[Function[n,IntegerDigits[n,2]],5]

(Flatten[{Sign[-Range[1-Length[#],0]],#}]&)[Map[Rest,IntegerDigits[Rest[Reverse[NestWhileList[Floor[Log[2,#]]&,n+1,#>1&]]],2]]]

Array[Function[n,(Flatten[{Sign[-Range[1-Length[#],0]],#}]&)[Map[Rest,IntegerDigits[Rest[Reverse[NestWhileList[Floor[Log[2,#]]&,n+1,#>1&]]],2]]]],5]

Flatten[IntegerDigits[Append[2-With[{w=Floor[Log[3,2 n]]},IntegerDigits[n-((3^(  w+1))-1)/2,3,w]],3],2,2]]

Array[Function[n,Flatten[IntegerDigits[Append[2-With[{w=Floor[Log[3,2 n]]},IntegerDigits[n-((3^(  w+1))-1)/2,3,w]],3],2,2]]],5]

Apply[Take,RealDigits[(N[#,N[Log[10,#]+3]]&)[n (Sqrt[5])/(GoldenRatio^(  2))+1/2],GoldenRatio]]

Array[Function[n,Apply[Take,RealDigits[(N[#,N[Log[10,#]+3]]&)[n (Sqrt[5])/(GoldenRatio^(  2))+1/2],GoldenRatio]]],5]

Apply[Join,Map[Last,NestList[{#[[2]],Join[Map[Join[{1,0},Rest[#]]&,#[[2]]],Map[Join[{1,0},#]&,#[[1]]]]}&,{{},{{1}}},n-3]]]

With[{n=6},Apply[Join,Map[Last,NestList[{#[[2]],Join[Map[Join[{1,0},Rest[#]]&,#[[2]]],Map[Join[{1,0},#]&,#[[1]]]]}&,{{},{{1}}},n-3]]]]

Map[Rest[RotateLeft[Join[#,{0,1}]]]&,With[{n=6},Apply[Join,Map[Last,NestList[{#[[2]],Join[Map[Join[{1,0},Rest[#]]&,#[[2]]],Map[Join[{1,0},#]&,#[[1]]]]}&,{{},{{1}}},n-3]]]]]

({{Page 563 · Huffman coding,  (page 1071)}})

Map[Drop[Last[#],-1]&,Sort[Flatten[MapIndexed[Rule,FixedPoint[Replace[Sort[#],{{p0_,i0_},{p1_,i1_},pi___}->{{p0+p1,{i0,i1}},pi}]&,MapIndexed[List,p]][[1,2]],{-1}]]]]-1

First[{{},d}//.MapIndexed[{{r___},Flatten[{#1,s___}]}->{{r,#2[[1]]},{s}}&,c]]

CodeWords[p_List]:=Map[Drop[Last[#],-1]&,Sort[Flatten[MapIndexed[Rule,FixedPoint[Replace[Sort[#],{{p0_,i0_},{p1_,i1_},pi___}->{{p0+p1,{i0,i1}},pi}]&,MapIndexed[List,p]][[1,2]],{-1}]]]]-1
Frequencies[d_]:=Map[Count[d,#]/Length[d]&,Union[d]]
HuffmanEncode[d_]:=With[{chars=Union[d],code=CodeWords[Frequencies[d]]},{chars,code,Flatten[d/.MapThread[Rule,{chars,code}]]}]
HuffmanDecode[{chars_,c_,d_}]:=chars[[First[{{},d}//.MapIndexed[{{r___},Flatten[{#1,s___}]}->{{r,#2[[1]]},{s}}&,c]]]]

Frequencies[{a,b,b,c,a,a,b,a,a,c,a,a,a,c,d}]

CodeWords[{(8/15),(1/5),(1/5),(1/15)}]

HuffmanEncode[{a,b,b,c,a,a,b,a,a,c,a,a,a,c,d}]

HuffmanDecode[{{a,b,c,d},{{1},{0,1,1},{0,0},{0,1,0}},{1,0,1,1,0,1,1,0,0,1,1,0,1,1,1,1,0,0,1,1,1,0,0,0,1,0}}]

({{Arithmetic coding,  (page 1071)}})

Module[{c,m=0},Map[(c[#1]={m,m+=Count[s,#1]/Length[s]})&,Union[s]];Function[x,(First[RealDigits[2^#1Ceiling[Min[x]/2^#1],2,-#1,-1]]&)[Floor[Log[2,Max[x]-Min[x]]]]][Fold[(Max[#1]-Min[#1]) c[#2]+Min[#1]&,{0,1},s]]]

With[{s={0,1,1,1,0,1,1,1,1,1,1,1}},Module[{c,m=0},Map[(c[#1]={m,m+=Count[s,#1]/Length[s]})&,Union[s]];Function[x,(First[RealDigits[2^#1 Ceiling[Min[x]/2^#1],2,-#1,-1]]&)[Floor[Log[2,Max[x]-Min[x]]]]][Fold[(Max[#1]-Min[#1])c[#2]+Min[#1]&,{0,1},s]]]]

({{Page 565 · Pointer-based encoding,  (page 1071)}})

PEncode[d_,b_:4]:=Module[{i,a,u,v},i=2;a={First[d]};While[i≤Length[d],{u,v}=Last[Sort[Table[{MatchLength[d,i,j],j},{j,i-1}]]];If[u≥b,AppendTo[a,p[i-v,u]];i+=u,AppendTo[a,d[[i]]];i++]];a]

MatchLength[d_,i_,j_]:=With[{m=Length[d]-i},Catch[Do[If[d[[i+k]]=!=d[[j+k]],Throw[k]],{k,0,m}];m+1]]

PEncode[d_,b_:4]:=Module[{i,a,u,v},i=2;a={First[d]};While[i≤Length[d],{u,v}=Last[Sort[Table[{MatchLength[d,i,j],j},{j,i-1}]]];If[u≥b,AppendTo[a,p[i-v,u]];i+=u,AppendTo[a,d[[i]]];i++]];a]
MatchLength[d_,i_,j_]:=With[{m=Length[d]-i},Catch[Do[If[d[[i+k]]=!=d[[j+k]],Throw[k]],{k,0,m}];m+1]]

PEncode[{0,1,1,1,0,0,1,1,1,1,1,1,1,0,0,1,0,1,1,0}]

PDecode[a_]:=Module[{d=Flatten[a/.p[j_,r_]:>Table[p[j],{r}]]},Flatten[MapIndexed[If[Head[#1]===p,d[[#2]]=d[[#2-First[#1]]],#1]&,d]]]

PDecode[a_]:=Module[{d=Flatten[a/.p[j_,r_]:>Table[p[j],{r}]]},Flatten[MapIndexed[If[Head[#1]===p,d[[#2]]=d[[#2-First[#1]]],#1]&,d]]]

PDecode[{0,1,1,1,0,p[5,4],p[1,4],0,0,1,0,1,1,0}]

1-Sum[(((1-(2^(  -b))))^(  i)) Product[1+(((1-(2^(  -b))))^(  j))-(((1-(2^(  -b-1))))^(  j)),{j,i-b+1,i-1}],{i,b,n-b}]/(n-2 b+1)

With[{n=100},Table[1-Sum[(((1-(2^(  -b))))^(  i)) Product[1+(((1-(2^(  -b))))^(  j))-(((1-(2^(  -b-1))))^(  j)),{j,i-b+1,i-1}],{i,b,n-b}]/(n-2 b+1),{b,2,15}]//N]

({{Page 568 · Recursive subdivision,  (page 1072)}})

Subdivide[a_]:=Flatten[If[Length[a]==2,a,If[Apply[SameQ,a],{1,First[a]},{0,Map[Subdivide,Partition[a,Length[a]/2]]}]]]

Subdivide[a_,n_]:=With[{s=Table[1,{n}]},Flatten[If[Dimensions[a]==2 s,a,If[Apply[SameQ,Flatten[a]],{1,First[Flatten[a]]},{0,Map[Subdivide[#,n]&,Partition[a,1/2 Length[a] s],{n}]}]]]]

Subdivide[a_]:=Flatten[If[Length[a]==2,a,If[Apply[SameQ,a],{1,First[a]},{0,Map[Subdivide,Partition[a,Length[a]/2]]}]]]
Subdivide[a_,n_]:=With[{s=Table[1,{n}]},Flatten[If[Dimensions[a]==2 s,a,If[Apply[SameQ,Flatten[a]],{1,First[Flatten[a]]},{0,Map[Subdivide[#,n]&,Partition[a,1/2 Length[a] s],{n}]}]]]]

Subdivide[{1,0,1,1,1,0,0,0,0,1,0,0,0,0,1,0}]

Subdivide[{{0,0,0,0,0,1,0,0,0,0,0,0},{0,0,0,0,1,1,1,0,0,0,0,0},{0,0,0,1,1,0,0,1,0,0,0,0},{0,0,1,1,0,1,1,1,1,0,0,0},{0,1,1,0,0,1,0,0,0,1,0,0},{1,1,0,1,1,1,1,0,1,1,1,0},{1,0,0,1,0,0,0,0,1,0,0,0},{1,1,1,1,1,0,0,1,1,1,0,1}},2]

Irreversible Data Compression

({{Page 573 · Walsh transforms,  (page 1072)}})

Outer[Outer[Times,##]&,b,b,1,1]

Map[Transpose,Map[# b&,b,{2}]]

With[{b={{1,1},{1,-1}}},Outer[Outer[Times,##]&,b,b,1,1]]

With[{b={{1,1},{1,-1}}},Map[Transpose,Map[# b&,b,{2}]]]

Nest[Apply[Join,f[{Map[Flatten[Map[{#,#}&,#]]&,#],Map[Flatten[Map[{#,-#}&,#]]&,g[#]]}]]&,{{1}},s]

With[{s=2,f=Identity,g=Reverse},Nest[Apply[Join,f[{Map[Flatten[Map[{#,#}&,#]]&,#],Map[Flatten[Map[{#,-#}&,#]]&,g[#]]}]]&,{{1}},s]]

Nest[Flatten2D[Map[# {{1,1},{1,-1}}&,#,{2}]]&,{{1}},s]

Flatten2D[a_]:=Apply[Join,Apply[Join,Map[Transpose,a],{2}]]

Flatten2D[a_]:=Apply[Join,Apply[Join,Map[Transpose,a],{2}]]
With[{s=2},Nest[Flatten2D[Map[# {{1,1},{1,-1}}&,#,{2}]]&,{{1}},s]]

BitReverseOrder[a_]:=With[{n=Length[a]},a[[Map[FromDigits[Reverse[#],2]&,IntegerDigits[Range[0,n-1],2,Log[2,n]]]+1]]]

BitReverseOrder[a_]:=With[{n=Length[a]},a[[Map[FromDigits[Reverse[#],2]&,IntegerDigits[Range[0,n-1],2,Log[2,n]]]+1]]]
BitReverseOrder[{{1,1,1,1},{1,-1,1,-1},{1,1,-1,-1},{1,-1,-1,1}}]

Array[Apply[Times,(-1)^(IntegerDigits[#1,2,s] Reverse[IntegerDigits[#2,2,s]])]&,2^{s,s},0]

With[{s=2},Array[Apply[Times,(-1)^(IntegerDigits[#1,2,s] Reverse[IntegerDigits[#2,2,s]])]&,2^{s,s},0]]

Nest[Flatten[Transpose[Partition[#,2] . {{1,1},{1,-1}}]]&,data,Log[2,Length[data]]]

With[{data={1,1,1,-1}},Nest[Flatten[Transpose[Partition[#,2].{{1,1},{1,-1}}]]&,data,Log[2,Length[data]]]]

With[{data={1,1,1,-1}, m={{1,1,1,1},{1,1,-1,-1},{1,-1,1,-1},{1,-1,-1,1}}},data.m]

({{Hadamard matrices,  (page 1073)}})

PadLeft[Array[JacobiSymbol[#2-#1,n-1]&,{n,n}-1]-IdentityMatrix[n-1],{n,n},1]

With[{n=12},PadLeft[Array[JacobiSymbol[#2-#1,n-1]&,{n,n}-1]-IdentityMatrix[n-1],{n,n},1]]//MatrixForm

({{Fourier transforms,  (page 1074)}})

Nest[With[{c=BitReverseOrder[Range[0,Length[#]-1]/Length[#]]},Flatten2D[MapIndexed[#1 {{1,1},{1,-1} (-1)^c[[Last[#2]]]}&,#,{2}]]]&,{{1}},s]

Flatten2D[a_]:=Apply[Join,Apply[Join,Map[Transpose,a],{2}]]
BitReverseOrder[a_]:=With[{n=Length[a]},a[[Map[FromDigits[Reverse[#],2]&,IntegerDigits[Range[0,n-1],2,Log[2,n]]]+1]]]

With[{s=2},Nest[With[{c=BitReverseOrder[Range[0,Length[#]-1]/Length[#]]},Flatten2D[MapIndexed[#1 {{1,1},{1,-1} (-1)^c[[Last[#2]]]}&,#,{2}]]]&,{{1}},s]]//MatrixForm

With[{n=Length[data]},Fold[Flatten[Map[With[{k=Length[#]/2},{{1,1},{1,-1}} . {Take[#,k],Drop[#,k] (-1)^(Range[0,k-1]/k)}]&,Partition[##]]]&,BitReverseOrder[data],2^Range[Log[2,n]]]/(Sqrt[n])]

BitReverseOrder[a_]:=With[{n=Length[a]},a[[Map[FromDigits[Reverse[#],2]&,IntegerDigits[Range[0,n-1],2,Log[2,n]]]+1]]]
With[{data={1,2,3,4,5,6,7,8}},With[{n=Length[data]},Fold[Flatten[Map[With[{k=Length[#]/2},{{1,1},{1,-1}}.{Take[#,k],Drop[#,k] (-1)^(Range[0,k-1]/k)}]&,Partition[##]]]&,BitReverseOrder[data],2^Range[Log[2,n]]]/(Sqrt[n])]]

Visual Perception

({{Page 581 · Implementation,  (page 1077)}})

Sign[ListCorrelate[2 σ-1,data]-Count[σ,1,2]]+1

With[{σ={0,1},data={0,0,1,0,1,1,1,1,1,0,0,1,0,1,0}},Sign[ListCorrelate[2 σ-1,data]-Count[σ,1,2]]+1]

({{Halftoning,  (page 1077)}})

Nest[Flatten2D[{{4 #+0,4 #+2},{4 #+3,4 #+1}}]&,{{0}},n]

Flatten2D[a_]:=Apply[Join,Apply[Join,Map[Transpose,a],{2}]]
With[{n=2},Nest[Flatten2D[{{4 #+0,4 #+2},{4 #+3,4 #+1}}]&,{{0}},n]]

Module[{a=Flatten[data],r,s},{r,s}=Dimensions[data];Partition[Do[a[[i+{1,s-1,s,s+1}]]+=m (a[[i]]-If[a[[i]]<1/2,0,1]),{i,r s-s-1}];Map[If[#<1/2,0,1]&,a],s]]

With[{data=Table[1/8,{5},{5}],m={7,3,5,1}/16},Module[{a=Flatten[data],r,s},{r,s}=Dimensions[data];Partition[Do[a[[i+{1,s-1,s,s+1}]]+=m (a[[i]]-If[a[[i]]<1/2,0,1]),{i,r s-s-1}];Map[If[#<1/2,0,1]&,a],s]]]

Auditory Perception

({{Chords,  (page 1079)}})

Sin[(Subscript[ω, 1]) t]+Sin[(Subscript[ω, 2]) t]==2 Sin[1/2 ((Subscript[ω, 1])+(Subscript[ω, 2])) t] Cos[1/2 ((Subscript[ω, 1])-(Subscript[ω, 2])) t]

({{Page 586 · Spectra,  (page 1080)}})

((Fourier[list])^(  2))==Fourier[ListConvolve[list,list,{1,1}]]/Sqrt[Length[list]]

With[{list={1,1,0,1,1,0,0,1,1,0,1,1,0,1,1,0,1,1,0}},Chop[((Fourier[list])^( 2))-Fourier[ListConvolve[list,list,{1,1}]]/Sqrt[Length[list]]]==Table[0,{Length[list]}]]

({{Spectra of substitution systems,  (page 1080)}})

Thread[Map[ϕ[#][t+1,ω]&,Range[k]-1]==Apply[Plus,MapIndexed[Exp[i ω (Last[#2]-1) (s^(  t))] ϕ[#1][t,ω]&,Range[k]-1/.rules,{-1}],{1}]/(Sqrt[s])]

Module[{k=2,s=4,t=0,rules={1->2,2->2}},Thread[Map[ϕ[#][t+1,ω]&,Range[k]-1]==Apply[Plus,MapIndexed[Exp[I ω (Last[#2]-1) (s^( t))] ϕ[#1][t,ω]&,Range[k]-1/.rules,{-1}],{1}]/(Sqrt[s])]]

Nest[Range[2Length[#]]Join[#,Reverse[#]]&,{1},t]

With[{t=4},Nest[Range[2Length[#]]Join[#,Reverse[#]]&,{1},t]]

((2^(#))-(((-1))^(#))&)[1+IntegerExponent[n,2]]

Table[((2^(#))-(((-1))^(#))&)[1+IntegerExponent[n,2]],{n,20}]

({{Page 587 · Random block sequences,  (page 1081)}})

m[s_]:=With[{q=FoldList[Plus,0,s]},ReplacePart[RotateRight[IdentityMatrix[Last[q]],{0,1}],1/Length[s],Flatten[Outer[List,Rest[q],Drop[q,-1]+1],1]]]

m[s_]:=With[{q=FoldList[Plus,0,s]},ReplacePart[RotateRight[IdentityMatrix[Last[q]],{0,1}],1/Length[s],Flatten[Outer[List,Rest[q],Drop[q,-1]+1],1]]]

With[{list={{1,1},{0}}},m[Map[Length,list]]]

ξ[list_,r_]:=With[{w=(#-Apply[Plus,#]/Length[#]&)[Flatten[list]]},w . MatrixPower[m[Map[Length,list]],r] . w/Length[w]]

m[s_]:=With[{q=FoldList[Plus,0,s]},ReplacePart[RotateRight[IdentityMatrix[Last[q]],{0,1}],1/Length[s],Flatten[Outer[List,Rest[q],Drop[q,-1]+1],1]]]
ξ[list_,r_]:=With[{w=(#-Apply[Plus,#]/Length[#]&)[Flatten[list]]},w . MatrixPower[m[Map[Length,list]],r] . w/Length[w]]

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

Cryptography and Cryptanalysis

({{LFSR cryptanalysis,  (page 1087)}})

Nest[Mod[Append[#,Take[#,-n] . vec],2]&,list,t]

LinearSolve[Table[Take[seq,{i,i+n-1}],{i,n}],Take[seq,{n+1,2 n}],Modulus->2]

With[{n=7,vec={1,0,0,1,1,0,1},list={0,1,1,0,1,0,0},t=10},Nest[Mod[Append[#,Take[#,-n].vec],2]&,list,t]]

With[{n=7,seq={0,1,1,0,1,0,0,1,1,0,1,0,1,0,0,0,1}},
LinearSolve[Table[Take[seq,{i,i+n-1}],{i,n}],Take[seq,{n+1,2 n}],Modulus->2]]

Note that this setup assumes Length[list]<n,  Length[vec]=n,  t≥2n-Length[list]. The vec might not always be unique.

({{Properties of rule 30,  (page 1087)}})

Cases[Map[Fold[Prepend[#1,If[#2==1⊻Take[#1,2]=={0,0},0,1]]&,#,Reverse[list]]&,{{0,0},{0,1},{1,0},{1,1}}],{a_,b_,c___,a_,b_}->{b,c,a}]

With[{list={1,0,0,1,0,0,1,0,0,1,1,0}},Cases[Map[Fold[Prepend[#1,If[#2==1⊻Take[#1,2]=={0,0},0,1]]&,#,Reverse[list]]&,{{0,0},{0,1},{1,0},{1,1}}],{a_,b_,c___,a_,b_}->{b,c,a}]]

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

CAStep[IntegerDigits[30,2,8],{1,1,0,1,1,1,0,0,0,0,1,0}]

({{Alternative rules,  (page 1088)}})

p⊻(¬q∨r∨s∧¬t)

r⊻(¬p∨q∨s∧¬t)

u=¬p∧¬q∨q∧t;¬r∧u∨q∧¬s∧(p∨¬r)∨r∧s∧¬u

s∧(q∧¬r∨p∧¬q∧t)∨¬(s∨(p∨q)∧(r⊻(q∨t)))

({{Nonlinear feedback shift registers,  (page 1088)}})

NLFSRStep[f_,taps_,list_]:=Append[Rest[list],f[list[[taps]]]]

f=IntegerDigits[s,2,8][[8-#.{4,2,1}]]&

Nest[NLFSRStep[f,taps,#]&,list,n]

NLFSRStep[f_,taps_,list_]:=Append[Rest[list],f[list[[taps]]]]
CenterList[n_Integer]:=ReplacePart[Table[0,{n}],1,Ceiling[(n/2)]]

Block[{t=7,n=11,taps={1,2,3},f=IntegerDigits[90,2,8][[8-#.{4,2,1}]]&},NestList[Nest[(NLFSRStep[f,taps,#]&),#,n]&,CenterList[n],t]]//Grid

Block[{t=7,n=11,taps={1,2},f=Mod[Apply[Plus,#],2]&},NestList[Nest[(NLFSRStep[f,taps,#]&),#,n]&,Append[Table[0,{n-1}],1],t]]//Grid

f[{w_,x_,y_,z_}]:=Mod[w+y+z+x y+x z+y z,2]

NLFSRStep[f_,taps_,list_]:=Append[Rest[list],f[list[[taps]]]]
f[{w_,x_,y_,z_}]:=Mod[w+y+z+x y+x z+y z,2]

Block[{t=7,n=11,taps={1,2,3,4}},NestList[Nest[(NLFSRStep[f,taps,#]&),#,n]&,Append[Table[0,{n-1}],1],t]]//Grid

({{Linear congruential generators,  (page 1089)}})

NestList[Mod[a#,m]&,x,n]

With[{α=Apply[#2 . Rest[list]/#1&,Apply[ExtendedGCD,Drop[list,-1]]]},({Mod[α,#],#}&)[Fold[GCD[#1,If[#1==0,#2,Mod[#2,#1]]]&,0,ListCorrelate[{α,-1},list]]]]

With[{a=7,m=13,n=20,x=1},NestList[Mod[a#,m]&,x,n]]

With[{list={1,7,10,5,9,11,12,6,3,8,4,2,1,7,10,5,9,11,12,6,3}},With[{α=Apply[#2.Rest[list]/#1&,Apply[ExtendedGCD,Drop[list,-1]]]},({Mod[α,#],#}&)[Fold[GCD[#1,If[#1==0,#2,Mod[#2,#1]]]&,0,ListCorrelate[{α,-1},list]]]]]

({{Factoring integers,  (page 1090)}})

Module[{f=Mod[((#)^(  2))+1,n]&,a=2,b=5,c},While[(c=GCD[n,a-b])==1,{a,b}={f[a],f[f[b]]}];c]

With[{n=477310661},Module[{f=Mod[((#)^( 2))+1,n]&,a=2,b=5,c},While[(c=GCD[n,a-b])==1,{a,b}={f[a],f[f[b]]}];c]]

477310661/17389

({{Quadratic residue sequences,  (page 1090)}})

Mod[NestList[Mod[((#)^(  2)),m]&,x0,n],2]

With[{m=141,n=100,x0=101},Mod[NestList[Mod[((#)^( 2)),m]&,x0,n],2]]//Partition[#,11]&

Traditional Mathematics and Mathematical Formulas

({{Page 609 · Implementation,  (page 1091)}})

Map[Flatten[MapIndexed[#2-1->Position[rules,#1->_][[1,1]]&,Last[#],{-1}]]&,rules]

With[{rules={1->{{1,2},{2,1}},2->{{1,0},{1,1}},0->{{0,0},{0,0}}}},Map[Flatten[MapIndexed[#2-1->Position[rules,#1->_][[1,1]]&,Last[#],{-1}]]&,rules]]

({{Trinomial coefficients,  (page 1091)}})

Sum[Binomial[n+t-1-3 k,t-1] Boole[n≥3 k] Binomial[t,k] (-1)^k,{k,0,n/3}]

With[{t=3,n=4},Sum[Binomial[n+t-1-3 k,t-1] Boole[n≥3 k] Binomial[t,k] (-1)^k,{k,0,n/3}]]

Binomial[2 t,n] Hypergeometric2F1[-n,n-2 t,1/2-t,1/4]

With[{t=3,n=4},Binomial[2 t,n] Hypergeometric2F1[-n,n-2 t,1/2-t,1/4]]

(((1-2 x z+(x^(  2))))^(  -m))==Sum[GegenbauerC[n,m,z] (x^(  n)),{n,0,∞}]

({{1D sequences,  (page 1092)}})

1/2 (((-1))^(  n))+(((-3))^(  n)) (Sqrt[π]) Hypergeometric2F1[3/2,-n,3/2-n,-1/3]/(4 n! Gamma[3/2-n])

Table[1/2 (((-1))^( n))+(((-3))^( n)) (Sqrt[π]) Hypergeometric2F1[3/2,-n,3/2-n,-1/3]/(4 n! Gamma[3/2-n]),{n,0,10}]

({{Page 613 · GCD array,  (page 1093)}})

Product[With[{p=Prime[n]},1-Length[Union[Mod[v,p]]]/(p^(  s))],{n,∞}]

With[{v={{0,0}},s=2},Product[With[{p=Prime[n]},1-Length[Union[Mod[v,p]]]/(p^(  s))],{n,∞}]]

({{Page 615 · Computing powers,  (page 1093)}})

FoldList[((#1)^(  2)) (m^(  #2))&,1,IntegerDigits[t,2]]

With[{t=10},FoldList[((#1)^( 2)) (m^( #2))&,1,IntegerDigits[t,2]]]

FromDigits[ListConvolve[IntegerDigits[x,k],IntegerDigits[y,k],{1,-1},0],k]

With[{x=12345,y=67890,k=10},FromDigits[ListConvolve[IntegerDigits[x,k],IntegerDigits[y,k],{1,-1},0],k]]

FixedPoint[Flatten[Map[If[#<k,#,With[{e=Ceiling[Log[k,#]/2]},{Quotient[#,(k^(  e))],With[{s=Mod[#,(k^(  e))]},If[s==0,Table[0,{e}],{Table[0,{e-Floor[Log[k,s]]-1}],s}]]}]]&,#]]&,{x}]

With[{k=2,x=14},FixedPoint[Flatten[Map[If[#<k,#,With[{e=Ceiling[Log[k,#]/2]},{Quotient[#,(k^( e))],With[{s=Mod[#,(k^( e))]},If[s==0,Table[0,{e}],{Table[0,{e-Floor[Log[k,s]]-1}],s}]]}]]&,#]]&,{x}]]

({{Complex powers,  (page 1094)}})

(2 d[Re[#],w]+d[Im[#],w]&)[(z^(  t))]

d[x_,w_]:=If[x<0,1-d[-x,w],IntegerDigits[x,2,w]]

d[x_,w_]:=If[x<0,1-d[-x,w],IntegerDigits[x,2,w]]

With[{z=1+I,w=20},Table[(2 d[Re[#],w]+d[Im[#],w]&)[(z^( t))],{t,1,10}]]

({{The more general case,  (page 1094)}})

h[Fold[If[#2==0,h[#1,#1],h[r,h[#1,#1]]]&,r,Rest[IntegerDigits[t,2]]],s]

With[{t=10,h=Plus},h[Fold[If[#2==0,h[#1,#1],h[r,h[#1,#1]]]&,r,Rest[IntegerDigits[t,2]]],s]]

h[a_,b_]:=FromDigits[g[ListConvolve[IntegerDigits[a,k],IntegerDigits[b,k],{1,-1},0]],k]

h[a_,b_]:=FromDigits[g[ListConvolve[IntegerDigits[a,k],IntegerDigits[b,k],{1,-1},0]],k]

Block[{k=2,g=Mod[#,2]&},h[3,9]]

({{DNF minimization,  (page 1095)}})

PI[s_,n_]:=Union[Flatten[FixedPointList[f[Last[#],n]&,{{},s}][[All,1]],1]]

g[a_,b_]:=With[{i=Position[Transpose[{a,b}],{0,1}]},If[Length[i]==1&&Delete[a,i]===Delete[b,i],{ReplacePart[a,_,i]},{}]]

f[s_,n_]:=With[{w=Flatten[Apply[Outer[g,#1,#2,1]&,Partition[Table[Select[s,Count[#,1]==i&],{i,0,n}],2,1],{1}],3]},{Complement[s,w,SameTest->MatchQ],w}]

PI[s_,n_]:=Union[Flatten[FixedPointList[f[Last[#],n]&,{{},s}][[All,1]],1]]
g[a_,b_]:=With[{i=Position[Transpose[{a,b}],{0,1}]},If[Length[i]==1&&Delete[a,i]===Delete[b,i],{ReplacePart[a,_,i]},{}]]
f[s_,n_]:=With[
{w=Flatten[Apply[Outer[g,#1,#2,1]&,Partition[Table[Select[s,Count[#,1]==i&],{i,0,n}],2,1],{1}],3]},{Complement[s,w,SameTest->MatchQ],w}]

PI[{{1,0,0},{0,1,1},{0,1,0},{0,0,1}},3]

QM[s_,p_]:=First[Sort[Map[p[[#]]&,h[{},Range[Length[s]],Outer[MatchQ,s,p,1]]]]]

h[i_,r_,t_]:=Flatten[Map[h[Join[i,r[[#]]],Drop[r,#],Delete[Drop[t,{},#],Position[t[[All,#]],{True}]]]&,First[Sort[Map[Position[#,True]&,t]]]],1]

h[i_,_,{}]:={i}

QM[s_,p_]:=First[
Sort[Map[p[[#]]&,h[{},Range[Length[s]],Outer[MatchQ,s,p,1]]]]]
h[i_,r_,t_]:=Flatten[Map[
h[Join[i,r[[#]]],Drop[r,#],Delete[Drop[t,{},#],Position[t[[All,#]],{True}]]]&,First[Sort[Map[Position[#,True]&,t]]]],1]
h[i_,_,{}]:={i}

QM[{{1,0,0},{0,1,1},{0,1,0},{0,0,1}},{{0,1,_},{0,_,1},{1,0,0}}]

({{Page 619 · Nand expressions,  (page 1096)}})

Map[FromDigits[#,2]&,NestWhile[Append[#,Complement[Flatten[Table[Outer[1-Times[##]&,#[[i]],#[[-i]],1],{i,Length[#]}],2],Flatten[#,1]]]&,{1-Transpose[IntegerDigits[Range[(2^(  n))]-1,2,n]]},Length[Flatten[#,1]]<(2^(  (2^(  n))))&],{2}]

With[{n=2},Map[FromDigits[#,2]&,NestWhile[Append[#,Complement[Flatten[Table[Outer[1-Times[##]&,#[[i]],#[[-i]],1],{i,Length[#]}],2],Flatten[#,1]]]&,{1-Transpose[IntegerDigits[Range[(2^( n))]-1,2,n]]},Length[Flatten[#,1]]<(2^( (2^( n))))&],{2}]]

({{Cellular automaton formulas,  (page 1097)}})

Nest[{{#,#[[2]]+1},#[[2]]+1}&,{{1,1},{2,2}},t-2]

Table[Nest[{{#,#[[2]]+1},#[[2]]+1}&,{{1,1},{2,2}},t-2],{t,2,5}]

({{Continuous systems,  (page 1098)}})

((Sin[(2^(  t)) ArcSin[(Sqrt[x])]])^(  2))

With[{x=.32},Table[((Sin[(2^(  t)) ArcSin[(Sqrt[x])]])^(  2)),{t,0,4}]]

With[{a=4,x=.32},NestList[a#(1-#)&,x,4]]

(1-Cos[(2^(  t)) ArcCos[1-2 x]])/2

With[{x=.32},Table[(1-Cos[(2^(  t)) ArcCos[1-2 x]])/2,{t,0,4}]]

(1-ChebyshevT[(2^(  t)),1-2 x])/2

With[{x=.32},Table[(1-ChebyshevT[(2^(  t)),1-2 x])/2,{t,0,4}]]

(1-(((1-2 x))^(  (2^(  t)))))/2

With[{x=.32},Table[(1-(((1-2 x))^(  (2^(  t)))))/2,{t,0,4}]]

With[{a=2,x=.32},NestList[a#(1-#)&,x,4]]

1/2-Cos[1/3 (π-(((-2))^(  t)) (π-3 ArcCos[1/2-x]))]

With[{x=.32},Table[1/2-Cos[1/3 (π-(((-2))^(  t)) (π-3 ArcCos[1/2-x]))],{t,0,4}]]

With[{a=-2,x=.32},NestList[a#(1-#)&,x,4]]

1/2 (1-g[(a^(  t)) InverseFunction[g][1-2 x]])

Block[{a=2,g=Exp,x=.32},Table[1/2 (1-g[(a^(  t)) InverseFunction[g][1-2 x]]),{t,0,4}]]

g[a x]==1+1/2 a (((g[x])^(  2))-1)

Block[{a=2,g=Exp,x=.32},g[a x]==1+1/2 a (((g[x])^(  2))-1)]

2^(m-DigitCount[m,2,1]) Apply[Times,Table[Cyclotomic[s,a]^Floor[(m-1)/s],{s,m-1}]]

With[{a=2},Table[2^(m-DigitCount[m,2,1]) Apply[Times,Table[Cyclotomic[s,a]^Floor[(m-1)/s],{s,m-1}]],{m,0,5}]]

Series[Exp[x],{x,0,5}]

Human Thinking

({{Error-correcting codes,  (page 1101)}})

PM[s_]:=IntegerDigits[Range[(2^(  s))-1],2,s]

Join[data,Mod[data . Select[PM[s],Count[#,1]>1&],2]]

PM[s_]:=IntegerDigits[Range[(2^(  s))-1],2,s]

With[{data={1,1,0,0},s=3},Join[data,Mod[data.Select[PM[s],Count[#,1]>1&],2]]]

Drop[(If[#==0,data,MapAt[1-#&,data,#]]&)[FromDigits[Mod[data . PM[s],2],2]],-s]

PM[s_]:=IntegerDigits[Range[(2^(  s))-1],2,s]

With[{data={1,1,0,1,1,1,0},s=3},Drop[(If[#==0,data,MapAt[1-#&,data,#]]&)[FromDigits[Mod[data.PM[s],2],2]],-s]]

({{Context-free languages,  (page 1103)}})

{s[e]->s[e,e],s[e]->s["(",e,")"],s[e]->s["(",")"]}

Fold[#1/.rules[[#2]]&,s[e],list]

Parse[rules_,expr_]:=Catch[Block[{t={}},NestWhile[ReplaceList[#,MapIndexed[ReverseRule,rules]]&,{{expr,{}}},#/.{s[e],u_}:>Throw[u];#=!={}&];]]

ReverseRule[a_->b_,{i_}]:={___,{s[x___,b,y___],{u___}},___}:>{s[x,a,y],{i,u}}/;FreeQ[s[x],s[a]]

SetAttributes[s,Flat];
Parse[rules_,expr_]:=Catch[Block[{t={}},NestWhile[ReplaceList[#,MapIndexed[ReverseRule,rules]]&,{{expr,{}}},#/.{s[e],u_}:>Throw[u];#=!={}&];]]
ReverseRule[a_->b_,{i_}]:={___,{s[x___,b,y___],{u___}},___}:>{s[x,a,y],{i,u}}/;FreeQ[s[x],s[a]]

With[{list={1,2,1,1,3,3},rules={s[e]->s[e,e],s[e]->s["(",e,")"],s[e]->s["(",")"]}},Fold[#1/.rules[[#2]]&,s[e],list]]

Parse[{s[e]->s[e,e],s[e]->s["(",e,")"],s[e]->s["(",")"]},s["(","(",")","(",")",e,")",e]]