Genuary 2022 Space: traveling tubes forming the digits​
​by Sander Huisman
Each year there are several challenges for generative arts in the month January called “Genuary” ( https://genuary.art/prompts ). For this genuary on space i wanted to do a little space-travelling and showing the digits of 2022:
(*(*noneedtousetheseinmostcases…*)​​​​method={"HardwareDepthBuffer","HardwareDepthPeeling","BSPTree","Software"};​​method=method[[4]]​​SetOptions[$FrontEndSession,RenderingOptions{"Graphics3DRenderingEngine"method}];​​SetOptions[EvaluationNotebook[],RenderingOptions{"Graphics3DRenderingEngine"method}];​​CurrentValue[$FrontEnd,{RenderingOptions,"Graphics3DRenderingEngine"}]=MethodOptions;​​CurrentValue[$FrontEndSession,{"Antialiasing"}]=True;​​CurrentValue[EvaluationNotebook[],{"Antialiasing"}]=True;​​CurrentValue[$FrontEnd,{"Antialiasing"}]=True;*)
Set the size
In[]:=
SetDirectory[NotebookDirectory[]];​​size=600;
Generate some uniform points in regions the shape of the letters
In[]:=
SeedRandom[1234];​​txt=Text[Style[#,FontFamily"Univers LT Std"]]&/@Characters["2022"];​​regs=DiscretizeGraphics[#,_Text,MaxCellMeasure0.05]&/@txt;​​regs//=Map[RegionResize[#,4/3]&];​​proc=HardcorePointProcess[100,0.04,2];​​pts=RandomPointConfiguration[proc,#,Method->{"MCMC","LengthOfRun"30000}]&/@regs;​​pts=#["Points"]&/@pts;​​pts*=10;(*makethelettersroughly10unitstall*)​​Length/@pts
Out[]=
{86,80,82,85}
SeedRandom[1234];​​sz=1000(Range[Length[pts]]-1)(*movethecharactersa1000unitsapart*)​​newpts=MapThread[Append[#2]/@#1&,{pts,sz}];​​newpts=Apply[{RandomColor[Hue[0.55,NormalDistribution[.2,.1],1]],Tube[{{#1,#3+RandomReal[{-40,40}],#2},{#1,#3+RandomReal[{-40,40}],#2}},RandomReal[{0.75,1.33}]0.1]}&,newpts,{2}];(*Generateblue-ishcolorsandmakesome'tubes'thatcreatethedigitsof2022*)​​m=1000;​​stars={RandomReal[{-500,500},m],RandomReal[{-500,3500},m],RandomReal[{-500,500},m]}//Transpose;(*addsomerandomstars*)​​stars//=Map[Sphere[#,1]&];​​ClearAll[MakeScene];​​MakeScene[t_]:=Module[{px,g},​​px=-1000+1000t;​​g=Graphics3D[{newpts,Translate[newpts,{0,4000,0}],White,stars,Translate[stars,{0,4000,0}],Translate[stars,{0,-4000,0}]}(*addcopiestomakeitloop-able*),​​ViewVector{{0,px,0},{0,px+10000,0}},​​ViewAngle35Degree,​​ViewVertical{0,0,1},​​Boxed->False,​​BackgroundBlack,​​Lighting"Neutral",​​ImageSize2size,​​ViewRange{0.001,10000},​​SphericalRegionTrue​​];​​Rasterize[g,"Image",RasterSizesize,ImageSizesize]​​]
Out[]=
{0,1000,2000,3000}
Try it out:
In[]:=
MakeScene[0.93]
Out[]=
Create the images and export them
Dynamic[N@t]​​imgs=Table[MakeScene[t],{t,Most[Subdivide[0,4,300]]}];​​Export["2022_3.gif",imgs,"DisplayDurations"->1/60]