John Horton Conway, one of the numbers in COVID-19 statistical data, one of the most charming mathematicians in our time.
I'm not a person qualified to talk about most of his contributions, but if to name one thing among them that went beyond math and computer science communities, that has been inspiring many people constantly, would be his Game of Life.
In M. C. Escher’s work Three Spheres I, he showed us how it is an illusion to see a sphere out of drawing on planer paper. Here I took Escher’s idea, mapping Conway’s Game of Life on imaginary spheres. The grid on sphere conformally maps to infinite cylinder, yet the sphere itself is a visual illusion drawn on a disc. Escher’s spheres blurred the boundary between stero and flat. Through their everlasting works, the boundary between life and death shall be blurred for great minds.
The code for the animation
The code for the animation
I will explain the code in a separate post.
ClearAll[FindDivisionsExact]FindDivisionsExact[range:{_,_},n_Integer?(#≥2&)]:=Rescale[Range[n]//N//Rescale,{0,1},range]
ClearAll[arc2D]arc2D[β_,δ_]:=BSplineCurve{Cos[β],Sin[β]},Cos[β]-Sin[β]Tan,Sin[β]+Cos[β]Tan,{Cos[β+δ],Sin[β+δ]},SplineKnots{0,0,0,1,1,1},SplineDegree2,SplineWeights1,Cos,1
δ
2
δ
2
δ
2
ClearAll[arc3D]arc3D[β_,δ_]:=BSplineCurve{Cos[β],Sin[β],0},Cos[β]-Sin[β]Tan,Sin[β]+Cos[β]Tan,0,{Cos[β+δ],Sin[β+δ],0},SplineKnots{0,0,0,1,1,1},SplineDegree2,SplineWeights1,Cos,1
δ
2
δ
2
δ
2
ClearAll[simpleBSTensor]Clear[simpleBSTensor]simpleBSTensor[arc1_BSplineCurve,arc2_BSplineCurve]/;And[(#1/.False(Echo["arc1 must be dimension 3."];#1)&)[Dimensions[arc1〚1〛]〚2〛3],(#1/.False(Echo["arc2 must be dimension 2."];#1)&)[Dimensions[arc2〚1〛]〚2〛2]]:=Module[{pt1,d1,k1,w1,pt2,d2,k2,w2,cpts},pt1={#〚;;,;;2〛.{1,},#〚;;,-1〛}&@arc1〚1〛;pt2=#.{1,}&@arc2〚1〛;{d1,k1,w1}={SplineDegree,SplineKnots,SplineWeights}/.List@@Rest[arc1]/.Thread[{SplineDegree,SplineKnots,SplineWeights}{Automatic,Automatic,ConstantArray[1,Length[pt1]]}];{d2,k2,w2}={SplineDegree,SplineKnots,SplineWeights}/.List@@Rest[arc2]/.Thread[{SplineDegree,SplineKnots,SplineWeights}{Automatic,Automatic,ConstantArray[1,Length[pt2]]}];cpts=Outer[Insert[ReIm[#1〚1〛#2],#1〚-1〛,-1]&,pt1,pt2,1];BSplineSurface[cpts,SplineDegree{d2,d1},SplineKnots{k2,k1},SplineWeightsOuter[Times,w2,w1]]]
ClearAll[basicCircle]basicCircle=BSplineCurve{{1,0},{1,1},{0,1},{-1,1},{-1,0},{-1,-1},{0,-1},{1,-1},{1,0}},SplineKnots0,0,0,,,,,,,1,1,1,SplineDegree2,SplineWeights1,,1,,1,,1,,1;
1
4
1
4
1
2
1
2
3
4
3
4
1
2
1
2
1
2
1
2
ClearAll[cellArray]cellArray=ModuleΔλ=(**),ringLvl=(*30*)10,αmax=(*.45*).2,ϕinit=0,αSet,ϕminSet,ΔϕSet,baseArc,{ϕminSet,ΔϕSet}=Module{ϕmin},NestListϕmin=#1+#2;{ϕmin,Δϕ}/.FindRootΔϕΔλCosCos+ϕmin,Δϕ,&@@#&,{ϕinit,0},ringLvl//Rest//Transpose;{ϕminSet,ΔϕSet}=Join[{-ϕminSet-ΔϕSet,ΔϕSet}//Reverse,{ϕminSet,ΔϕSet}];αSet=Range[2ringLvl]//N//Rescale//&//Rescale[#,{0,1},{0,αmax}]&;TableMapThreadFunction{ϕmin,Δϕ,α},simpleBSTensorarc3D[ϕmin+αΔϕ,(1-2α)Δϕ]//MapAtRightCompositionRotationTransform,{1,0,0},RotationTransform[φ,{0,0,1}],1,arc2D[αΔλ,(1-2α)Δλ]//MapAt[RotationTransform[{{0,0,1},{1,-1,1}}],1],{ϕminSet,ΔϕSet,αSet},{φ,Range[0,2π,Δλ]//Most};
π
48
π
12
Δϕ
2
Δϕ
2
Δλ
2
2
#
π
2
Graphics3D[{StippleShading[],cellArray,Black,Sphere[{0,0,0},1-.001]},Lighting"Accent",ViewPoint{10,0,0},ViewVertical{0,0,1}]
stateArraySet=CellularAutomaton["GameOfLife",RandomInteger[1,Dimensions@cellArray],60];
frameSet=Module{g,stateArray=#},g=Transpose[{stateArray//Rescale[#,{0,1},{0,.8}]&//Map[GrayLevel,#,{2}]&,cellArray},{3,1,2}];g//Through@*{##}&[MapAt[RightComposition[MapAt[FaceForm[#,None]&,1],MapAt[MapAt[0&,{;;,;;,1}],{2,1}]],{;;,;;}],MapAt[RightComposition[MapAt[FaceForm[Darker@#,None]&,1],MapAt[RightComposition[MapAt[0&,{;;,;;,1}],RotationTransform[-70°,{0,1,0}],TranslationTransform[{0,0,-1}]],{2,1}]],{;;,;;}]]//Graphics3DEdgeForm[],#,White,simpleBSTensor[BSplineCurve[{{0,0,0},{1,0,0}}],basicCircle]//Append[SplineClosed{True,False}]//MapAtRightCompositionRotationTransform,{0,1,0},TranslationTransform[-.01{1,0,0}],1,simpleBSTensor[BSplineCurve[{{0,0,0},{1,0,0}}],basicCircle]//Append[SplineClosed{True,False}]//MapAt[RightComposition[RotationTransform[90°-70°,{0,1,0}],TranslationTransform[-1{0,0,1}],TranslationTransform[-.01{1,0,0}]],1],Lighting{{"Ambient",White}},ViewPoint{10,0,0},ViewVertical{0,0,1},ViewProjection"Orthographic",BackgroundBlack,BoxedFalse,ImageSize600&//Rasterize&/@stateArraySet;
π
2