Each year there are several challenges for generative arts in the month January called “Genuary” ( https://genuary.art/prompts ). I’ll be focusing on the ‘dithering’ challenge:
Set the size of frame
In[]:=
SetDirectory[NotebookDirectory[]];size=600;
Initialize the randomizer and discretize the letters of 2022
In[]:=
SeedRandom[1234];txt=Text[Style[#,FontFamily"Univers LT Std"]]&/@Characters["2022"];regs=DiscretizeGraphics[#,_Text,MaxCellMeasure0.05]&/@txt;regs//=Map[RegionResize[#,4/3]&];
add some random points to each region. Then the remaining space is filled such that they all have a 1000 points:
In[]:=
proc=HardcorePointProcess[400,0.04,2];pts=RandomPointConfiguration[proc,#,Method->{"MCMC","LengthOfRun"30000}]&/@regs;pts=#["Points"]&/@pts;pts/=2;other=1000-(Length/@pts)otherpts=RandomReal[{-1,1},{#,2}]&/@other;otherpts=ResourceFunction["LloydAlgorithm"][#,{{-1,1},{-1,1}},4]&/@otherpts;
Out[]=
{799,806,826,806}
Notice that I used Lloyd’s algorithm to more evenly spread the points.
Visualize the points for each character:
Visualize the points for each character:
In[]:=
MapThread[Graphics[{Point[#],Red,Point[#2]},AspectRatioAutomatic,PlotRange1]&,{pts,otherpts}]
Out[]=
,
,
,
Combine the points of the letters and the ‘background’:
In[]:=
ps=MapThread[Join,{pts,otherpts}];Graphics[{Point[#]},AspectRatioAutomatic,PlotRange1]&/@ps
Out[]=
,
,
,
Find the pairing between each point-set, such that we can morph between them, here is a greedy way of doing it:
pts1=ps[[1]];pts2=ps[[2]];Graphics[{Point@pts1,Red,Point@pts2}]p2={pts2,Range[Length[pts2]]}//Transpose;greedypairs=Table[i=First[Nearest[p2[[All,1]]->"Index",pts1[[p1i]]]];out={p1i,p2[[i,2]]};p2=Delete[p2,i];out,{p1i,Length@pts1}];ClearAll[Distances,TotalDistance]Distances[pairindices_]:=Map[Norm][pts1[[pairindices[[All,1]]]]-pts2[[pairindices[[All,2]]]]]TotalDistance[pairindices_]:=Total[Distances[pairindices]^2]TotalDistance[greedypairs]Table[Line@{pts1[[tups[[1]]]],pts2[[tups[[2]]]]},{tups,greedypairs}]//Graphics
Out[]=
Out[]=
62.8454
Out[]=
Now we can improve this pairing by randomly swapping pairs and see if their sum of distances is less:
In[]:=
pairing=greedypairs;
In[]:=
gr={};err=TotalDistance[pairing];take=1;Dynamic[gr]Dynamic[err]Dynamic[{j,take}]Do[dists=Distances[pairing];largest=Ordering[dists,-take][[1]];opts=Table[trialpair=pairing;trialpair[[{i,largest},2]]//=Reverse;trialdists=dists;trialdists[[i]]=Norm[pts1[[trialpair[[i,1]]]]-pts2[[trialpair[[i,2]]]]];trialdists[[largest]]=Norm[pts1[[trialpair[[largest,1]]]]-pts2[[trialpair[[largest,2]]]]];trialdists.trialdists,{i,Length[pairing]}];o=Ordering[opts,1][[1]];If[opts[[o]]==err,take=Mod[take+1,Length[pairing],1];,If[RandomInteger[10]==0,take=1];trialpair=pairing;trialpair[[{o,largest},2]]//=Reverse;pairing=trialpair;gr=Graphics[Table[Line@{pts1[[tups[[1]]]],pts2[[tups[[2]]]]},{tups,pairing}],ImageSize400];err=TotalDistance[pairing];];,{j,4000}]
here are the points now, but sorted in such a way that they ‘align’ such that the n-th point in each frame can be connected to make a trace:
Make each frame and interpolate between the positions using some cosine interpolation:
Make and export the frames: