File:DiffusionMicroMacro.svg is a vector version of this file. It should be used in place of this GIF file when not inferior. File:DiffusionMicroMacro.gif → File:DiffusionMicroMacro.svg For more information, see Help:SVG. In other languages Alemannisch ∙ العربية ∙ беларуская (тарашкевіца) ∙ български ∙ বাংলা ∙ català ∙ нохчийн ∙ čeština ∙ dansk ∙ Deutsch ∙ Ελληνικά ∙ English ∙ British English ∙ Esperanto ∙ español ∙ eesti ∙ euskara ∙ فارسی ∙ suomi ∙ français ∙ Frysk ∙ galego ∙ Alemannisch ∙ עברית ∙ हिन्दी ∙ hrvatski ∙ magyar ∙ հայերեն ∙ Bahasa Indonesia ∙ Ido ∙ italiano ∙ 日本語 ∙ ქართული ∙ 한국어 ∙ lietuvių ∙ македонски ∙ മലയാളം ∙ Bahasa Melayu ∙ မြန်မာဘာသာ ∙ norsk bokmål ∙ Plattdüütsch ∙ Nederlands ∙ norsk nynorsk ∙ norsk ∙ occitan ∙ polski ∙ prūsiskan ∙ português ∙ português do Brasil ∙ română ∙ русский ∙ sicilianu ∙ Scots ∙ slovenčina ∙ slovenščina ∙ српски / srpski ∙ svenska ∙ தமிழ் ∙ ไทย ∙ Türkçe ∙ татарча / tatarça ∙ українська ∙ vèneto ∙ Tiếng Việt ∙ 中文 ∙ 中文（中国大陆） ∙ 中文（简体） ∙ 中文（繁體） ∙ 中文（马来西亚） ∙ 中文（新加坡） ∙ 中文（臺灣） ∙ +/−

 

{assav}

I, the copyright holder of this work, release this work into the public domain. This applies worldwide. In some countries this may not be legally possible; if so: I grant anyone the right to use this work for any purpose, without any conditions, unless such conditions are required by law.

<< Mathematica source code >>

(* Source code written in Mathematica 6.0, by Steve Byrnes, 2010.
I release this code into the public domain. Sorry it's messy...email me any questions. *)

(*Particle simulation*)
SeedRandom[1];
NumParticles = 70;
xMax = 0.7;
yMax = 0.2;
xStartMax = 0.5;
StepDist = 0.04;
InitParticleCoordinates = Table[{RandomReal[{0, xStartMax}], RandomReal[{0, yMax}]}, {i, 1, NumParticles}];
StayInBoxX[x_] := If[x < 0, -x, If[x > xMax, 2 xMax - x, x]];
StayInBoxY[y_] := If[y < 0, -y, If[y > yMax, 2 yMax - y, y]];
StayInBoxXY[xy_] := {StayInBoxX[xy[[1]]], StayInBoxY[xy[[2]]]};
StayInBarX[x_] := If[x < 0, -x, If[x > xStartMax, 2 xStartMax - x, x]];
StayInBarY[y_] := If[y < 0, -y, If[y > yMax, 2 yMax - y, y]];
StayInBarXY[xy_] := {StayInBarX[xy[[1]]], StayInBarY[xy[[2]]]};
MoveAStep[xy_] := StayInBoxXY[xy + {RandomReal[{-StepDist, StepDist}], RandomReal[{-StepDist, StepDist}]}];
MoveAStepBar[xy_] := StayInBarXY[xy + {RandomReal[{-StepDist, StepDist}], RandomReal[{-StepDist, StepDist}]}];
NextParticleCoordinates[ParticleCoords_] := MoveAStep /@ ParticleCoords;
NextParticleCoordinatesBar[ParticleCoords_] := MoveAStepBar /@ ParticleCoords;
NumFramesBarrier = 10;
NumFramesNoBarrier = 50;
NumFrames = NumFramesBarrier + NumFramesNoBarrier;
ParticleCoordinatesTable = Table[0, {i, 1, NumFrames}];
ParticleCoordinatesTable[[1]] = InitParticleCoordinates;
For[i = 2, i <= NumFrames, i++,
  If[i <= NumFramesBarrier,
   ParticleCoordinatesTable[[i]] = NextParticleCoordinatesBar[ParticleCoordinatesTable[[i - 1]]], 
   ParticleCoordinatesTable[[i]] = NextParticleCoordinates[ParticleCoordinatesTable[[i - 1]]]];];

(*Plot full particle simulation*)
makeplotbar[ParticleCoord_] := 
  ListPlot[{ParticleCoord, {{xStartMax, 0}, {xStartMax, yMax}}}, Frame -> True, Axes -> False,
   PlotRange -> {{0, xMax}, {0, yMax}}, Joined -> {False, True}, PlotStyle -> {PointSize[.03], Thick},
   AspectRatio -> yMax/xMax, FrameTicks -> None];

makeplot[ParticleCoord_] := 
 ListPlot[ParticleCoord, Frame -> True, Axes -> False, PlotRange -> {{0, xMax}, {0, yMax}}, Joined -> False, 
  PlotStyle -> PointSize[.03], AspectRatio -> yMax/xMax, FrameTicks -> None]

ParticlesPlots = 
  Join[Table[makeplotbar[ParticleCoordinatesTable[[i]]], {i, 1, NumFramesBarrier}], 
   Table[makeplot[ParticleCoordinatesTable[[i]]], {i, NumFramesBarrier + 1, NumFrames}]];

(*Plot just the first particle in the list...Actually the fifth particle looks better. *) 
FirstParticleTable = {#[[5]]} & /@ ParticleCoordinatesTable;

FirstParticlePlots = 
  Join[Table[makeplotbar[FirstParticleTable[[i]]], {i, 1, NumFramesBarrier}], 
   Table[makeplot[FirstParticleTable[[i]]], {i, NumFramesBarrier + 1, NumFrames}]];


(* Continuum solution *)

(* I can use the simple diffusion-on-an-infinite-line formula, as long as I correctly periodically replicate the
initial condition. Actually just computed nearest five replicas in each direction, that was a fine approximation. *)

(* k = diffusion coefficient, visually matched to simulation. *)
k = .0007; 
u[x_, t_] := If[t == 0, If[x <= xStartMax, 1, 0], 1/2 Sum[
     Erf[(x - (-xStartMax + 2 n xMax))/Sqrt[4 k t]] - Erf[(x - (xStartMax + 2 n xMax))/Sqrt[4 k t]], {n, -5, 5}]];

ContinuumPlots = Join[
   Table[Show[
     DensityPlot[1 - u[x, 0], {x, 0, xMax}, {y, 0, yMax}, 
      ColorFunctionScaling -> False, AspectRatio -> yMax/xMax, 
      FrameTicks -> None],
     ListPlot[{{xStartMax, 0}, {xStartMax, yMax}}, Joined -> True, 
      PlotStyle -> {Thick, Purple}]],
    {i, 1, NumFramesBarrier}],
   Table[
    DensityPlot[1 - u[x, tt], {x, 0, xMax}, {y, 0, yMax}, 
     ColorFunctionScaling -> False, AspectRatio -> yMax/xMax, 
     FrameTicks -> None],
    {tt, 1, NumFramesNoBarrier}]];

(*Combine and export *)

TogetherPlots = 
  Table[GraphicsGrid[{{FirstParticlePlots[[i]]}, {ParticlesPlots[[i]]}, {ContinuumPlots[[i]]}},
   Spacings -> Scaled[0.2]], {i, 1, NumFrames}];

Export["test.gif", Join[TogetherPlots, Table[Graphics[], {i, 1, 5}]], 
 "DisplayDurations" -> {10}, "AnimationRepititions" -> Infinity ]