# Where is Abbott? How to make logograms from the film "Arrival"?

The film Arrival showed Wolfram Language code in action analysing alien logograms. A recent blog describes some details and mentions a live-coding video by Christopher Wolfam. See also Stephen Wolfram's blog post.

The logograms appear to be hand drawn in ink, and I seek help from the community to reproduce them via the Wolfram Language. Some examples follow.

Three Questions What techniques can you suggest to improve the match between computer-generated logograms and those which appear in the movie? Specifically, how to improve: 1) background circular strokes 2) blobs 3) tendrils

• Abbott is in death process. Feb 7, 2017 at 10:59

For making tendrils, I used AnglePath on 1/f noise from NoiseGen.

NoiseGen[n_, e_] :=
Block[{f, fe = Range[n/2]^e, d = {}},
f = E^(I 2.0 \[Pi] RandomReal[{0., 1.}, n/2])/fe;
f[[-1]] = Re[f[[-1]]];
d = Join[d, Chop[InverseFourier[
Join[{0}, f, Conjugate[Reverse[Drop[f, -1]]]]]]];
Rescale[d]]


For making blobs and blurring lines, I borrowed code from the answer by @Sjoerd C. de Vries.

A long definition of Logogram

Logogram[{rmin_, rmax_}, {wmin_, wmax_}, cv_, nc_, {dmin_, dmax_},
nd_, b_, phi0_, seed_,
{rbmin_, rbmax_}, {pmin_, pmax_}, {bmin_, bmax_}, nb_, phi1_,
{nxmin_, nxmax_}, {tlenmin_, tlenmax_}, noiseExp_, scale_,
ntendrils_] :=

Block[{radius = 1000., r, c, p, w, t, dp, g, nx, tlen, noise, c0},
SeedRandom[seed];
Binarize[Blur[Dilation[
Graphics[{CapForm["Round"],

(* circles composing circular stroke *)
Table[
c = RandomReal[{-r, r}*cv, 2];
p = RandomReal[{0, 6.283}, 2];
w = Thickness[RandomReal[{wmin, wmax}]];
{w, Circle[c, r, p + phi0]},
{i, 1, nc}],

(* additional disks composing circular stroke *)
Table[
t = RandomReal[{0, 6.283}] + phi0;
{i, 1, nd}],

(* disks composing blob on circular stroke *)
Table[
dp = RandomReal[{pmin, pmax}];
Disk[r*{Cos[phi1 + dp], Sin[phi1 + dp]},
{i, 1, nb}],

(* tendrils on blob *)
g = Table[
nx = RandomReal[{nxmin, nxmax}];
tlen = 2*RandomInteger[{tlenmin, tlenmax}];
noise = nx*NoiseGen[tlen, noiseExp];
noise = noise - Mean[noise];
c0 = radius*{Cos[#], Sin[#]} &[phi1 + RandomReal[{pmin, pmax}]];
Transpose[
c0 + scale*
Transpose[(-1)^RandomInteger[{0, 1}] AnglePath[noise]]],
{i, 1, ntendrils}];
Thickness[0.008], Map[Line, g]

}, ImageSize -> 1000],
DiskMatrix[2]], 3], b]
]


Manipulate to experiment.

Manipulate[
Logogram[{rmin, rmax}, {wmin, wmax}, cv, nc, {dmin, dmax},
nd, b, phi0, seed,
{rbmin, rbmax}, {pmin, pmax}, {bmin, bmax}, nb, phi1,
{nxmin, nxmax}, {tlenmin, tlenmax}, noiseExp, scale, ntendrils],

Style["Circular Brush Stroke", 12, Bold], Style["", 12, Bold],
{{rmin, 0.98, "Minimum Circle Radius"}, 0.9, 1.1, Appearance -> "Labeled"},
{{rmax, 1.02, "Maximum Circle Radius"}, 0.9, 1.1, Appearance -> "Labeled"},
Delimiter,
{{wmin, 0.0003, "Minimum Line Thickness"}, 0.0002, 0.008, Appearance -> "Labeled"},
{{wmax, 0.0010, "Maximum Line Thickness"}, 0.0002, 0.008, Appearance -> "Labeled"},
Delimiter,
{{cv, 0.05, "Circle Centre Variation"}, 0.01, 0.2, Appearance -> "Labeled"},
{{nc, 300, "Number of Circles"}, 20, 1000, 20, Appearance -> "Labeled"},
{{phi0, 5.0, "Angle of Circle Gap"}, 0.0, 6.3, Appearance -> "Labeled"},
Delimiter,
{{dmin, 0.010, "Minimum Disk Radius"}, 0.001, 0.2, Appearance -> "Labeled"},
{{dmax, 0.030, "Maximum Disk Radius"}, 0.001, 0.2, Appearance -> "Labeled"},
{{nd, 50, "Number of Disks"}, 10, 300, 10, Appearance -> "Labeled"},
Delimiter,

Style["", 12, Bold], Style["", 12, Bold], Style["Blob", 12, Bold], Style["", 12, Bold],
{{rbmin, 0.98, "Minimum Radial Distance"}, 0.9, 1.1, Appearance -> "Labeled"},
{{rbmax, 1.02, "Maximum Radial Distance"}, 0.9, 1.5, Appearance -> "Labeled"},
Delimiter,
{{bmin, 0.020, "Minimum Blob Radius"}, 0.001, 0.2, Appearance -> "Labeled"},
{{bmax, 0.070, "Maximum Blob Radius"}, 0.001, 0.2, Appearance -> "Labeled"},
{{nb, 30, "Number of Blob Disks"}, 5, 200, 5, Appearance -> "Labeled"},
Delimiter,
{{phi1, 2.0, "Initial Blob Angle"}, 0.0, 6.3, Appearance -> "Labeled"},
{{pmin, 0.0, "Minimum Angular Extent"}, 0.0, 0.5, Appearance -> "Labeled"},
{{pmax, 0.8, "Maximum Angular Extent"}, 0.1, 2.5, Appearance -> "Labeled"},
Delimiter,

Style["", 12, Bold], Style["", 12, Bold], Style["Tendrils", 12, Bold], Style["", 12, Bold],
{{nxmin, 0.1, "Minimum Curliness"}, 0.01, 1.0, Appearance -> "Labeled"},
{{nxmax, 0.5, "Maximum Curliness"}, 0.03, 1.0, Appearance -> "Labeled"},
Delimiter,
{{tlenmin, 10, "Minimum Tendril Length"}, 2, 100, 1, Appearance -> "Labeled"},
{{tlenmax, 20, "Maximum Tendril Length"}, 2, 100, 1, Appearance -> "Labeled"},
Delimiter,
{{noiseExp, 1.0, "Noise Exponent"}, 0.1, 3.0, Appearance -> "Labeled"},
{{scale, 10.0, "Tendril Step Size"}, 1.0, 50.0, Appearance -> "Labeled"},
{{ntendrils, 7, "Number Of Tendrils"}, 2, 50, 1, Appearance -> "Labeled"},
Delimiter,

Style["", 12, Bold], Style["", 12, Bold], Style["Overall Parameters", 12, Bold], Style["", 12, Bold],
{{b, 0.8, "Binarize Threshold"}, 0.1, 1.0, Appearance -> "Labeled"},
{{seed, 0, "Random Number Seed"}, 0, 1000, 1, Appearance -> "Labeled"},
Delimiter,

ControlPlacement -> Left, SaveDefinitions -> True
]


• Could someone make me two? Wife Daughter Jul 14, 2021 at 10:27