Skip to main content
Commonmark migration
Source Link

#Getting the Inkblots

Getting the Inkblots

#Getting the Inkblots

Getting the Inkblots

Source Link
Musang
  • 1k
  • 1
  • 9
  • 20

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

enter image description here

And a classic reflected inkblot:

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