How to make an inkblot?

Question

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.

Answer 1

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).

Answer 2

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}]];

spatter[points_] := ImagePad[Rasterize@
Graphics[
 Thread[Disk[#, 
     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}}]

Answer 3

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]]

Answer 4

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}]

Answer 5

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

drop[
    tan_ /; NumberQ[N[tan]] && NonNegative[tan], 
    rad_ /; NumberQ[N[rad]] && NonNegative[rad], 
    n_Integer /; Positive[n], num_Integer /; Positive[num]] := 
    Module[{phi, radialDirection, tangentialDirection, radialAmplitudes,
        tangentialAmplitudes, tmp},
        radialDirection[phi_] := N[{Cos[phi], Sin[phi]}];
        tangentialDirection[phi_] := N[{-Sin[phi], Cos[phi]}];
        radialAmplitudes = Table[RandomReal[{-1, 1}], {n}];
        tangentialAmplitudes = Table[RandomReal[{-1, 1}], {n}];
        tmp = Table[radialDirection[phi] + Apply[Plus, 
        Map[N[rad*radialAmplitudes[[# - 2]]*
        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}]

Answer 6

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];
pl/. {___, a__Line} :> FilledCurve[Thread[{{a}}]]

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;

Answer 7

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)]];
     Blur[new, rad] // Binarize];

   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:

Answer 8

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}]]

---

(added 5/15/2012)

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}]]

Answer 9

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}]

Answer 10

There is a Wolfram Function Repository (WFR) function RandomRorschach. Here are examples:

SeedRandom[112];
Multicolumn@
 Table[ResourceFunction["RandomRorschach"][
   "NumberOfStrokes" -> {12, 12, 6}, "OrderedStrokePoints" -> False, 
   ColorFunction -> (GrayLevel[RandomReal[{0, 0.24}]] &), 
   "ImageEffects" -> RandomChoice[{{{"Jitter", 10}, {"OilPainting", 3}}, {{"OilPainting", 6}}}]], 16]

Answer 11

We can also use ImageSynthesize:

ImageSynthesize["Rorschach test inkblot", 3]