Today we revisit the three previous posts about playing with circles with Mathematica Code, as promised.
First, we set up a reference image we want to play with:
width = 3;
height = 2;
spacing = .2;
vectorrectangle = Graphics[{Thickness[.01],
Join[
Table[
Line[{{i, 0}, {i, height}}, VertexColors -> {Red, Green}], {i, 0,
width, spacing}],
Table[
Line[{{0, j}, {width, j}}, VertexColors -> {Blue, Yellow}], {j,
0, height, spacing}]
]
}
]
and convert this vector graphics into a bit image:
a = 500 width;
b = 500 height;
bitimage = Image[vectorrectangle, ImageSize -> {a, b}];
rectangleimage = ImageData[bitimage];
Instead of this, you can paste any bitmap into the Image[] function and adjust a and b to the correct dimensions.
ImageData converts the bitmap into an array of RGB values.
Now we do some complex analysis magic, using elliptic functions, in order to map the unit disk to the rectangle.
tau = b/a I;
modul = 1./(ModularLambda[2 tau])^(1/4);
ellipticwidth = (2*EllipticK[1/modul^4])/modul;
DiskToUpperHalfPlane[z_] := (1 - I z)/(-I + z);
UpperHalfPlaneToRectangle[z_] :=
EllipticF[ArcSin[modul z], 1/modul^4]/modul;
UpperHalfPlaneToNormalizedRectangle[z_] :=
1/2 + UpperHalfPlaneToRectangle[z]/ellipticwidth;
imre[z_] := {Im[z], Re[z]};
DiskToNormalizedRectangle[z_]
To compute the circular preimage of the rectangle, we create a 750×750 square and map each pixel of the disk within that square to the rectangle, using DiskToNormalizedRectangle, and some rescaling. We record in the square the coordinates of the image pixels, and mark all other pixels in the square that lie not inside the disk as {0,0}.
nn = 750;
scale[{i_, j_}] := 2 (i + I j)/nn - (1 + I);
tab = Transpose[Table[
If[Abs[scale[{i, j}]] > .99,
{0, 0},
imre[a (DiskToNormalizedRectangle[scale[{i, j}]])]],
{i, 1, nn}, {j, 1, nn}]];
As the image coordinates are not integers, we interpolate the color of a pixel in the disk as the weighted average of the four adjacent pixels.
WeightedExtract[t_, {x_, y_}] := (1 - FractionalPart[x]) (1 - FractionalPart[y]) t[[Floor[x], Floor[y]]] +
(1 - FractionalPart[x]) (FractionalPart[y]) t[[Floor[x], Ceiling[y]]] +
(FractionalPart[x]) (1 - FractionalPart[y]) t[[Ceiling[x], Floor[y]]] +
(FractionalPart[x]) (FractionalPart[y]) t[[Ceiling[x], Ceiling[y]]];
colorpick[i_] :=
If[i == {0, 0}, RGBColor[1, 1, 1],
RGBColor @@ WeightedExtract[rectangleimage, i]];
Image[Map[colorpick, tab, {2}]]
To use Black products to create multiple copies of this image within the disk, we first generate a list of the zeroes of the Blasche factor, and then multiply the Black factors. Precomposing the Blaschke function with DiskToNormalizedRectangle makes things pretty.
ww = Table[(1 - 1/n^1.4) E^(.4 I n), {n, 2, 20}];
Blaschke[z_] := Product[
Abs[ww[[n]]]/ww[[n]] (ww[[n]] - z)/(1 - Conjugate[ww[[n]]] z), {n,
1, Length[ww]}];
tab = Transpose[Table[
If[Abs[scale[{i, j}]] > .99,
{0, 0},
imre[a (DiskToNormalizedRectangle[scale[Blaschke[{i, j}]]])]],
{i, 1, nn}, {j, 1, nn}]];
Image[Map[colorpick, tab, {2}]]
To get this back into a rectangle, we need the inverse of the DiskToNormalizedRectangle function. This is done with Jacobi’s elliptical functions:
UpperHalfPlaneToDisk[w_] := (I (-I + w))/(I + w);
RectangleToUpperHalfPlane[w_] := JacobiSN[modul w, 1/modul^4]/modul;
NormalizedRectangleToUpperHalfPlane[w_] := -RectangleToUpperHalfPlane[-ellipticwidth (w - 1/2)];
RectangleSelfMap[z_] := UpperHalfPlaneToNormalizedRectangle[
DiskToUpperHalfPlane[
Blaschke[
UpperHalfPlaneToDisk[
NormalizedRectangleToUpperHalfPlane[z]
]
]
]
]
Again, after some bookkeeping
aa = a/2;
bb = b/2;
eps = 0.000001;
scale2[{i_, j_}] := (i + I j)/aa
smash[x_, u_] := If[x u, u, x]];
smash[{i_, j_}] := {smash[i, b], smash[j, a]};
colorpick2[i_] := colorpick[smash[i]];
tab = Transpose[Table[
imre[a RectangleSelfMap[(1 - eps) scale2[{i, j}] + eps/2 b/a I ]], {i, 1, aa}, {j, 1, bb}]];
Image[Map[colorpick2, tab, {2}]]
we get our rectangular image back.
The Inner Frame 