## How to make an inkblot?

86

59

How to effectively create a polygon that looks like a realistic inkblot? So far, I could come up with this (borrowing from Ed Pegg Jr.'s Rorschach demonstration):

RandomBlot[num_, opts___] := Module[{pts},
pts = RandomReal[{0, 1}, {num, 2}];
pts = pts[[Append[Last@FindShortestTour[pts, Method -> "TwoOpt"], 1]]];
Graphics[{Polygon@
Table[BSplineFunction[pts, SplineKnots -> "Clamped"][a], {a, 0, 1, 0.001}]}, opts]
];

blot = RandomBlot[40, ImageSize -> 200, AspectRatio -> 1]


There are two problems with this:

• it is a bit slow due to FindShortestTour
• the blot contains corners being too sharp and has 'bays' reaching too far inward.

Compare it to a desired outcome:

Update:

I should mention that it is not necessary to actually create a Rorschach-like image, so mirroring is not a requirement.

I remember reading an approach to this using cellular automaton. – my account_ram – 2012-08-15T06:32:58.920

Is it important to have concave parts of in the shape? Without concave parts it's easy ... – Szabolcs – 2012-03-22T15:11:24.627

@Szabolcs, I noticed. ComputationalGeometryConvexHull does it quite well. – rcollyer – 2012-03-22T15:16:20.627

@Szabolcs I would say: let it be a parameter of the model, that specifies the amount of concavity/convexity. If the valu of this parameter is zero, the output could be an ellipse. – István Zachar – 2012-03-22T15:19:55.433

Can anyone post photographs of actual ink blots on paper, so we can judge what is realistic? – Colonel Panic – 2012-03-23T00:25:31.337

There's also the ink blot demonstration by Andy Ross link

– jrhodin – 2012-03-23T21:16:31.947

51

A bit of image processing:

Table[
Blur[
Dilation[
Graphics[
Table[
Rotate[
Disk[RandomReal[{-10, 10}, {2}], {RandomReal[{1, 5}],RandomReal[{1, 5}]}],
RandomReal[{0, 3.14}]
],
{40}
]
],
DiskMatrix[20]
], 20
]// Binarize,
{3}, {3}
] // Grid


Lots of parameters to play with...

Now these are bitmaps and if vector graphics are required (the question seems to imply that) we can adapt a bit of Vitaly's code from here:

img = Thinning@EdgeDetect@p;
points = N@Position[ImageData[img], 1];
pts = FindCurvePath[points] /. c_Integer :> points[[c]];
Graphics[{EdgeForm[Directive[Dashed, Thick, Red]],FilledCurve@({Line@#} & /@ pts)}]


with p our blob bitmap. (The contour is dashed to better show that we're dealing with vector graphics here).

Nice, these inkblots look more realistic than the others – rm -rf – 2012-03-22T21:12:03.333

4Ah, I see fish bones ... What does that mean? (+1) – rcollyer – 2012-03-22T21:25:02.857

I love parameters! – István Zachar – 2012-03-22T21:58:47.347

80

This approach is based on a random walk of a shrinking disk. Several of these are combined and a Gaussian filter is used to smooth it out. Optionally the smoothed image can be multiplied by the original to restore the tiny "droplets" that are wiped out by the smoothing. There is a streakiness parameter which biases the random walk in a particular direction.

randomstep := RandomReal[{0,1}] Through[{Cos,Sin}[RandomReal[{0,2Pi}]]];

rndwalk[numpts_, streakiness_, numruns_] := Module[{streak}, Table[
streak = streakiness randomstep;
RandomChoice[{Identity, Reverse}]@
NestList[# + streak + 0.1 randomstep &, randomstep, numpts]
, {numruns}]];

Graphics[
Range[(Length@# - 1), 0, -1]/(10. (Length@# - 1))]] & /@
points], 50, 1];

imageprocess[pic_, filterwidth_, threshold_, droplets_, reflect_] :=
Module[{smoothed, combined},
smoothed = Binarize[GaussianFilter[pic, filterwidth], threshold];
combined = If[droplets, ImageMultiply[smoothed, pic], smoothed];
If[reflect, ImageMultiply[combined, ImageReflect[combined, Left]],
combined]];

Manipulate[
SeedRandom[seed];
imageprocess[spatter[rndwalk[numpts, streakiness, numspatters]],
filterwidth, threshold, droplets, reflect],
{{seed, 0}, 0, 10^6, 1},
{{numpts, 100}, 10, 300, 1},
{{streakiness, 0}, 0, 0.05},
{{numspatters, 10}, 1, 20, 1},
{{filterwidth, 10}, 1, 20},
{{threshold, 0.6}, 0, 1},
{{droplets, True}, {True, False}},
{{reflect, True}, {True, False}}]


Very realistic and fast, I love it! – István Zachar – 2012-04-14T09:34:19.097

Take a look at this question :)

– Dr. belisarius – 2014-03-13T17:06:40.937

+1, those are awesome! You get a lot of alien looking pictures, though. – rcollyer – 2012-05-02T03:49:19.040

This is amazing! – Eli Lansey – 2012-05-02T13:37:01.610

2@rcollyer, I'm glad I'm not the only one seeing aliens! I wasn't sure if it was some deep-seated psychological issue... – Simon Woods – 2012-05-02T20:47:05.500

1

Here's two I made that I particularly liked: http://i.stack.imgur.com/aQjWa.png and http://i.stack.imgur.com/2ljZO.png

– rcollyer – 2012-05-02T21:48:08.787

I am pretty sure those are miraculous appearances of the spagetti flying monster. – Massimo – 2013-04-26T12:27:01.213

46

Here's a slow and concave version:

blot[smoothness_: 20, points_Integer: 10] :=
With[
{fun = Exp[-smoothness #.#] &, pts = RandomReal[1, {points, 2}]},
RegionPlot[
Total[fun[# - {x, y}] & /@ pts] > .5, {x, -.5, 1.5}, {y, -.5, 1.5},
Frame -> False, PlotStyle -> Black, BoundaryStyle -> Black]
]

Grid@Table[blot[], {3}, {3}]


Per Leonid's suggestion, here's a considerably faster version using "just in time" compiling:

blotc[smoothness_: 20, points_Integer: 10] :=
With[{fun = Exp[-smoothness #.#] &, pts = RandomReal[1, {points, 2}]},
With[{fc = Compile[{xl, yl}, Total[fun[# - {xl, yl}] & /@ pts] > .5]},
RegionPlot[fc[x, y], {x, -.5, 1.5}, {y, -.5, 1.5},
Frame -> False, PlotStyle -> Black, BoundaryStyle -> Black]
]
]


Thanks to the speed of the Mathematica compiler, this will speeds it up about 5 times on my computer.

Here's a fast but always convex version:

<< ComputationalGeometry
pts = With[{points = RandomReal[1, {20, 2}]}, points[[ConvexHull[points]]]]
Graphics@FilledCurve[BSplineCurve[pts, SplineClosed -> True]]


I'm not sure if this is desired but sometimes the slow code will generate multiple disconnected regions: http://i.stack.imgur.com/NAu8N.png Upvote regardless! Haha you edited your answer while I was writing my comment.

– s0rce – 2012-03-22T15:26:39.903

@s0rce Yep, but real inkblots can be disconnected too :) It's a good very good question how to get rid of disconnected parts. One possibility is MorphologicalComponents. If we're doing image processing, we might as well try implementing this in terms of image processing functions: Binarize@ImageAdjust@ ImageCorrelate[ ImagePad[ Image@SparseArray@Thread[RandomInteger[{1, 100}, {10, 2}] -> 1], 20], GaussianMatrix[40]] (It's a start, but it still has problems) – Szabolcs – 2012-03-22T15:33:40.293

Next question could be leopard spots :D Maybe someone will write a full reaction-diffusion system simulation – Szabolcs – 2012-03-22T15:35:27.420

@Szabolcs, I've already done that but to make a 2D pattern out of an ODE system is not trivial :) The answer is really nice, I think that disconnected spots/holes make it more realistic! – István Zachar – 2012-03-22T15:38:30.763

2Nice! +1. You can speed up your first function 8-10x by using With[{fc = Compile[{xl, yl}, Total[fun[# - {xl, yl}] & /@ pts] > .5]}, RegionPlot[fc[x, y],...]] in place of your RegionPlot call (compiled to MVM target, not C). I think this is a good example of JIT compilation in action for mma. – Leonid Shifrin – 2012-03-22T16:00:40.060

39

An inkblot used to look like this, in the days when I used fountain pens and indian ink, rather than Mathematica:

blot = Image[BubbleChart[RandomReal[1, {20, 3}] , Axes -> None,
Frame -> None, ColorFunction -> Function[Black],
BubbleSizes -> {.001, .3}, Background -> LightGray,
ChartElementFunction -> "NoiseBubble", ImageSize -> 400]]


Edit: The paper is then to be folded in half to stimulate those revealing subconscious thoughts:

ImageAdjust[ImageMultiply[blot, ImageReflect[blot, Left]], {0, .2}]


3Now you just need to factor in the porosity of the blotting paper, throw in some surface tension and capillary action and you'll be all set =) – rm -rf – 2012-03-22T19:48:22.267

Blotting paper was not yet invented in those days – Dr. belisarius – 2012-03-22T21:13:57.883

But since benches in those times were not flat but slanted any ink splattered on the paper immediatly ran off.

– István Zachar – 2012-03-22T22:07:34.060

1It would be nice to extract/reproduce the actual method "NoiseBubble" uses, as this could be a wrapper applied to the other solutions to give more realistic blot-edges. I guess it is just a radial positive noise over points of the circle. – István Zachar – 2012-03-23T09:38:07.580

To continue the food theme, the last one looks like a crab. – rcollyer – 2012-03-24T02:46:38.833

29

This solution uses Perlin noise to generate the blobs.

To generate the noise we use the following function. Here, range is the domain on which we will generate the noise, res is the number of points in x and y direction, and seed is the seed for the random number generator.

perlinNoise[range_: {{0, 1}, {0, 1}}, res_: {30, 30}, seed_: 1] :=
With[{
grid = (SeedRandom[seed]; Table[With[{t = RandomReal[2 Pi]},
{Cos[t], Sin[t]}], {res[[1]]}, {res[[2]]}]),
intf = 3 #^2 - 2 #^3 &},
Function[{x, y},
Module[{ind, xr, yr, pmat},
(* ind=={{xmin,xmax},{ymin,
ymax}} *)
{xr, yr} =
MapThread[Rescale[#1, #2, {1, #3}] &, {{x, y}, range, res}];
ind = Floor[{xr, yr}];
ind = MapThread[Min[#1, #2 - 1] &, {ind, res}];
{xr, yr} -= ind;

pmat = {{{xr, yr}.grid[[ind[[1]], ind[[2]]]],
{xr, yr - 1}.grid[[ind[[1]], ind[[2]] + 1]]},
{{xr - 1, yr}.grid[[ind[[1]] + 1, ind[[2]]]],
{xr - 1, yr - 1}.grid[[ind[[1]] + 1, ind[[2]] + 1]]}};

{1 - intf[xr], intf[xr]}.pmat.{1 - intf[yr], intf[yr]}]]]


Next we're going to superpose some noise on top of a two-dimensional Gaussian function and we use ListContourPlot to plot the region where the resulting function is larger than some level (note that we could use RegionPlot as well, but ListContourPlot is faster). There are a lot of parameters to play with here, such as the resolution of the noise, the ratio between the noise and Gaussian surface, and the level of the contour. For example for

res = 30; seed = 3; level = .6; ratio = .15;


we get

f = perlinNoise[{{-1, 1}, {-1, 1}}, {res, res}, seed];
tab1 = Table[Exp[-(x^2 + y^2)] + ratio*f[x, y], {x, -1, 1, 1/(2 res)}, {y, -1, 1,
1/(2 res)}];
pl = ListContourPlot[ArrayPad[tab1, {{1, 1}, {1, 1}}],
InterpolationOrder -> 2, Contours -> {level}, ContourShading -> None,
Frame -> False];


By increasing the ratio get more splattering:

res = 30; seed = 3; level = .6; ratio = .8;


And by lowering the resolution you get smoother blobs:

res = 8; seed = 3; level = .6; ratio = .8;


For the last one, I see a butterflied chicken, or possibly a face. Guess that indicates that I'm crazy. – rcollyer – 2012-03-22T23:53:15.653

@rcollyer First fish bones, now a butterflied chicken. Maybe you're just hungry. – Heike – 2012-03-22T23:57:48.040

Not anymore, just had pie, or if you prefer Pi/4. – rcollyer – 2012-03-22T23:58:13.180

2There's a Perlin noise example on the doc page of Compile, if you're interested – Szabolcs – 2012-03-23T09:26:14.383

29

This solution is based on a generation of blots that are deformations of a circle:

drop[
tan_ /; NumberQ[N[tan]] && NonNegative[tan],
n_Integer /; Positive[n], num_Integer /; Positive[num]] :=
tangentialAmplitudes, tmp},
tangentialDirection[phi_] := N[{-Sin[phi], Cos[phi]}];
tangentialAmplitudes = Table[RandomReal[{-1, 1}], {n}];
radialDirection[# phi]/#^2] &, Range[3, n + 2]]] + Apply[Plus,
Map[N[tan*tangentialAmplitudes[[# - 2]]*
tangentialDirection[# phi]/#^2] &, Range[3, n + 2]]],
{phi, 0, N[2 Pi - Pi/num], N[2 Pi/num]}]; Append[tmp, First[tmp]]
];


Then ink splatters can be generated in this way:

inksplatter = Image[Graphics[
Table[With[{loc = {RandomReal[{-5, 5}], RandomReal[{-5, 5}]}},
Scale[Polygon[Map[(# + loc) &,
drop[RandomReal[{.5, 1.5}], RandomReal[{.5, 1.5}], 10, 100]]],
RandomReal[{.1, 1.2}]]
], {20}], PlotRange -> {{-8, 8}, {-8, 8}}, AspectRatio -> 1]]


that produces this:

and a nice inkblot:

ImageAdjust[ImageMultiply[inksplatter, ImageReflect[inksplatter, Left]], {0, .2}]


2The last one's definitely a panda with mutton chops! – rm -rf – 2012-03-23T13:37:29.357

@R.M possibly a pig. – rcollyer – 2012-03-23T18:37:37.533

23

While I enjoyed fiddling with each of the beautiful solutions you gave, I chose two that are the closest to what I needed in form, splatter-distribution, parameterization and speed. As a token of my appreciation I've reworked them into a dynamic demo, showcasing Szabolcs's and Sjoerd's solutions. This does not mean that the other solutions could not be included: I think all of them could be easily extended to comply with the specified parameters. I simply don't have more time. But if anyone feels like doing it, please go ahead, and edit this post!

Both methods are wrapped in a smoothing function (Blur & Binarize), and then in a "fractalization" function that detects the edge and applies some noise to it in the form of black and white disks (idea coming from Sjoerd's solution). This can be done recursively, with disks of smaller and smaller sizes, adding more subtle details.

Options[RandomBlot] =
Join[Options@Graphics, {RandomSeed -> Automatic, Elevation -> 2,
EdgeRecursion -> 2, EdgeResolution -> 300, EdgeSmoothing -> 7,
Method -> Automatic}];

RandomBlot[bulk_: .1, pat_: 0, smo_: .2, opts : OptionsPattern[]] :=
Module[{ratio, seed, ele, rec, res, rad, method, edgeNoise, range},
ratio = OptionValue@AspectRatio /. Automatic -> 1;
ele = OptionValue@Elevation /. Automatic -> 2;
rec = OptionValue@EdgeRecursion /. Automatic -> 2;
res = OptionValue@EdgeResolution /. Automatic -> 300;
rad = OptionValue@EdgeSmoothing /. Automatic -> 5;
method = OptionValue@Method /. Automatic -> "Szabolcs";
seed =
OptionValue@RandomSeed /.
Automatic -> RandomInteger@{0, 99999999999999};

edgeNoise[img_, lev_, num_: 300] :=
Module[{pt =
N@Position[
Reverse[Transpose@ImageData@Thinning@EdgeDetect@img, {2}],
1], new},
pt = Take[RandomSample@pt, Min[num, Length@pt]];
new =
Show[img,
Graphics[({RandomChoice@{Black, White},
Rotate[Disk[#, RandomReal[{0, 15/lev}, {2}]],
RandomReal@{0, \[Pi]}]} & /@ pt)]];

BlockRandom[SeedRandom@seed;
Show[
Fold[edgeNoise[#1, #2, res] &,
Blur[Switch[method,
"Szabolcs", range = 10;
With[{fun = Exp[-Round[pat*100] #.#] &,
pts = Transpose@{RandomReal[{-range, range}, {Round[100*bulk]}],
RandomReal[{-range, range}*ratio, {Round[100*bulk]}]}},
With[{fc = Compile[{xl, yl},
Total[fun[# - {xl, yl}] & /@ (pts*.9)] > 1/ele]},
RegionPlot[
fc[x, y], {x, -range, range}, {y, -range*ratio,
range*ratio}, PlotStyle -> Black, BoundaryStyle -> Black,
Frame -> False]]],

"Sjoerd",
Dilation[Graphics[{
Black,
Table[Rotate[
Disk[{RandomReal@{-10, 10},
RandomReal@({-10, 10}*ratio)},
RandomReal[{.1, 4}, {2}]],
RandomReal@{0, \[Pi]}], {Round[100*bulk]}],
White,
Table[Rotate[
Disk[{RandomReal@{-10, 10},
RandomReal@({-10, 10}*ratio)},
RandomReal[{.1, 2}, {2}]],
RandomReal@{0, \[Pi]}], {Round[100*bulk*pat]}]
}], DiskMatrix@ele]
], 100*smo] // Binarize,
Range@rec],
FilterRules[{opts}, Options@Graphics]
]]];

Manipulate[
RandomBlot[bulk, pat, smo, AspectRatio -> ratio, RandomSeed -> seed,
ImageSize -> size, Elevation -> ele, EdgeRecursion -> rec,
EdgeResolution -> res, EdgeSmoothing -> rad, Method -> method],
{{seed, 0},
Button["randomize", seed = RandomInteger@{0, 99999999999999}] &},
{{method, "Szabolcs",
"method"}, {"Szabolcs" -> "RegionPlot (Szabolcs)",
"Sjoerd" -> "Disks (Sjoerd)"}},
Delimiter,
{{bulk, .1, "bulkiness"}, 0, 3, Appearance -> "Labeled"},
{{pat, .05, "patchiness"}, 0, 1, Appearance -> "Labeled"},
{{smo, .6, "smoothness"}, 0, 1, Appearance -> "Labeled"},
{{ele, 2, "elevation"}, 0, 10, Appearance -> "Labeled"},
Delimiter,
{{rec, 0, "edge recursion"}, 0, 3, 1, Appearance -> "Labeled"},
{{res, 300, "edge resolution"}, 0, 600, 10, Appearance -> "Labeled"},
{{rad, 7, "edge smoothness"}, 0, 30, Appearance -> "Labeled"},
Delimiter,
{{ratio, 1, "ratio"}, 0, 1, Appearance -> "Labeled"},
{{size, 300, "size"}, 100, 1000, 1, Appearance -> "Labeled"}
]


A collection of blots:

21

Hopefully, this entry is not too late. As with Heike, I also work with Perlin noise, but here I restrict myself to the one-dimensional version, and consider what happens when I treat it as a polar function:

fBm = With[{permutations =
Apply[Join, ConstantArray[RandomSample[Range[0, 255]], 2]]},
Compile[{{x, _Real}},
Module[{xf = Floor[x], xi, xa, u, i, j},
xi = Mod[xf, 16] + 1;
xa = x - xf; u = xa*xa*xa*(10.0 + xa*(xa*6.0 - 15.0));
i = permutations[[permutations[[xi]] + 1]];
j = permutations[[permutations[[xi + 1]] + 1]];
(2 Boole[OddQ[i]] - 1)*xa*(1.0 - u) +
(2 Boole[OddQ[j]] - 1)*(xa - 1)*u], "CompilationTarget" -> "WVM",
RuntimeAttributes -> {Listable}]];

With[{a = 1, b = 3/4, c = 30, d = 15},
Graphics[Cases[
ParametricPlot[(a + b fBm[c + d t/(2 Pi)]) {Cos[t], Sin[t]}, {t,
0, 2 Pi}], _Line, Infinity] /. Line -> Polygon]]


Here are a few more I got:

Play around with various values of a,b,c,d (and maybe tweak SeedRandom[] while you're at it) and see what you get.

Here's how to generate an entire zoo of them:

Graphics[Table[
With[{h = RandomReal[100], k = RandomReal[100],
a = RandomInteger[{1, 6}], b = RandomInteger[{1, 6}],
c = RandomInteger[255], d = RandomInteger[{3, 30}],
n = RandomInteger[{3, 30}]},
Cases[ParametricPlot[
{h, k} + (a + b fBm[c + d t/(2 Pi)]) {Cos[t], Sin[t]},
{t, 0, 2 Pi}], _Line, Infinity] /. Line -> Polygon], {30}]]


If one wants inkblots with inherent bilateral symmetry, it is a simple matter to modify the code for generating them:

With[{a = 4, b = 3, c = 4, d = 6, n = 1},
Graphics[Cases[
ParametricPlot[(a + b fBm[c + d Sin[n t]]) {Cos[t], Sin[t]}, {t,
0, 2 Pi}], _Line, Infinity] /. Line -> Polygon]]


Here are a few more:

Again, tweak the parameters to taste.

Here, we do something similar to cormullion's ink splotches:

Graphics[Table[
With[{h = RandomReal[100], k = RandomReal[100],
a = RandomInteger[{4, 6}], b = RandomInteger[{1, 3}],
c = RandomInteger[255], d = RandomInteger[{3, 30}],
n = RandomInteger[{3, 30}]},
Cases[ParametricPlot[
{h, k} + (a + b fBm[c + d Sin[n t]]) {Cos[t], Sin[t]},
{t, 0, 2 Pi}], _Line, Infinity] /. Line -> Polygon], {30}]]


1Never too late, and vector-graphics are always welcome as they are usually much faster than image-processed solutions. – István Zachar – 2012-05-02T07:30:59.173

You already got my vote, what more do you want? :) – rcollyer – 2012-05-15T14:44:05.157

@rcollyer: nothing else, really. :) But I do have a few more inkblot-related ideas on the pipeline... which I will add to this answer later when I've polished them up. – J. M.'s ennui – 2012-05-15T14:48:40.710

3Your last figure looks like plankton. – Szabolcs – 2012-06-02T10:10:04.530

@Szabolcs Or viruses.

– Mechanical snail – 2012-12-02T01:08:35.233

7

Here's a cellular automaton based approach. I guess it has the advantage that you can see the inkblot in the making.

# Cellular Automaton Rules

The rules I'm using is called a "twisted majority" or "anneal" rule with a Moore neigbourhood (diagonal cells count as neighbours). It basically means that if there is a majority of live neighbours, then the cell stays alive, otherwise it dies. The "twisted" part comes from switching the 4-neighbour and 5-neighbour rule, where 5 neighbours lead to a dead cell and 4 to a live one. It effectively introduces "noise" and prevents the array from settling into a permanent state too soon.

So let's get the Wolfram code for this rule first

FromDigits[Reverse[{0, 0, 0, 0, 1, 0, 1, 1, 1, 1}], 2]


976

# Getting the Inkblots

And that's it! All that's left is to plot the evolution of the array. Using a random grid as initial condition:

Module[{rule = {976, {2, 1}, {1, 1}},
init = SparseArray[RandomInteger[{0, 1}, {300, 300}]],
iterationmax = 500},
Manipulate[
ArrayPlot[First@CellularAutomaton[rule, init, {{iterations}}]]
, {iterations, 0, iterationmax, 1}]
]


Anyone who's familiar with cellular automatons knows this is a classic pattern, I just thought that if you plotted it in monochrome, the patterns look very much like ink blots.

Of course, you then have to compromise between your blot resolution and the rendering speed. And the shape you get is very much dependent on the initial array.

Use an inset random array for the "ink on paper feel":

Module[{rule = {976, {2, 1}, {1, 1}},
dim = 500,
factor = 1./6,
iterationmax = 500,
init},
init = SparseArray[
Flatten[Table[{i, j} -> RandomInteger[], {i, Round[dim*factor],
Round[dim*(1 - factor)]}, {j, Round[dim*factor],
Round[dim*(1 - factor)]}]], {dim, dim}];
ArrayPlot[First@CellularAutomaton[rule, init, {{iterationmax}}]]
]


Use a normally-distributed random array for a "splatter" feel:

Module[{rule = {976, {2, 1}, {1, 1}},
iterationmax = 10,
dim = 500,
amplitude = .5,
widthfactor = 100000,
init},
init = Table[
RandomChoice[{1 - (amplitude*
Exp[-((i - dim/2)^2/widthfactor + (j - dim/2)^2/
widthfactor)]),
amplitude*
Exp[-((i - dim/2)^2/widthfactor + (j - dim/2)^2/
widthfactor)]} -> {0, 1}], {i, dim}, {j, dim}];
ArrayPlot[First@CellularAutomaton[rule, init, {{iterationmax}}]]
]


And a classic reflected inkblot:

ImageAdjust[
ImageMultiply[inkblot, ImageReflect[inkblot, Left]], {0, .2}]