How to make a Cahn–Hilliard model GIF

I am delighted by this problem mostly because I was not aware of the underlying physical model of phase separation (the Cahn–Hilliard equation)!

Anyway, here is an approximation of a somewhat similar behavior to start the discussion:

NestList[
    Sharpen@Threshold[GaussianFilter[#, 2], {"Hard", {"BlackFraction", 0.1}}] &, 
    img, 50
];

ListAnimate[%]

Imgur

I am looking forward to something better from the image processing experts!


Here is an alternative method. It is still based on image processing, but it uses CommonestFilter instead of the combination of operations used before. It is interesting to note that these situations almost always reach a steady state in relatively few iterations (hence the use of FixedPointList rather than NestList here.

SeedRandom[20160216]
img = Image@RandomChoice[{0, 1}, {256, 256}];
list = FixedPointList[Binarize[CommonestFilter[#, 3], 0.5] &, img, 2000];

Results of CommonestFilter


Taken from the Matlab code here http://www.math.utah.edu/~eyre/computing/matlab-intro/ch.txt with slight modifications:

m = n = 256;
delx = 1/(m - 1);
delx2 = delx^2;
x = Range[0, 1, delx];

delt = 0.00000001;
ntmax = 250;

epsilon = 0.01;
eps2 = epsilon^2;

a = 2;

lam1 = delt/delx2;
lam2 = eps2*lam1/delx2;

leig = Transpose@Table[2 Cos[π Range[0., n - 1]/(n - 1)] - 2, {m}] + 
 Table[2 Cos[π Range[0., m - 1]/(m - 1)] - 2, {n}];

cheig = 1 - (a*lam1*leig) + (lam2*leig^2);

seig = lam1*leig;

u = RandomReal[{-.5, .5}, {n, m}];
hatu = FourierDCT[u];

t = 0.;
Monitor[
 While[t < ntmax*delt,
  t += delt;
  hatu = (hatu + seig*FourierDCT[u^3 - (1 + a)*u])/cheig;
  u = FourierDCT[hatu];
  ], ArrayPlot[Sign[u - Mean[u]] + 1, PixelConstrained -> 1]]
ArrayPlot[Sign[u - Mean[u]] + 1, PixelConstrained -> 1]

animation

After 10000 time steps:

final image


Here's a version using CellularAutomaton to simulate the Ising model (with Glauber dynamics), which can be viewed as a lattice version of the Cahn–Hilliard equation. It's not quite as smooth as the GIF, but it can probably be improved with some tweaks:

With[{L = 100, T = 0.1, t = 100, dt = 10, r = 0.1},
    ArrayPlot[#, ColorRules -> {-1 -> Black, 1 -> White}, PixelConstrained -> True] & /@
    CellularAutomaton[
        {
            ( {{_, a_, _},{d_, x_, b_},{_, c_, _}} ) :> 
                If[RandomReal[] < r/(E^(2/T x (a + b + c + d)) + 1), -x, x]
        },
        RandomChoice[{-1, 1}, {L, L}],
        {{0, t, dt}}]
] // ListAnimate

animation