File:DiffusionMicroMacro.gif

File:DiffusionMicroMacro.svg是此文件的矢量版本。 如果此文件质量不低于原点阵图，就应该将这个GIF格式文件替换为此文件。 File:DiffusionMicroMacro.gif → File:DiffusionMicroMacro.svg 更多信息请参阅Help:SVG/zh。 其他语言 Alemannisch ∙ Bahasa Indonesia ∙ Bahasa Melayu ∙ British English ∙ català ∙ čeština ∙ dansk ∙ Deutsch ∙ eesti ∙ English ∙ español ∙ Esperanto ∙ euskara ∙ français ∙ Frysk ∙ galego ∙ hrvatski ∙ Ido ∙ italiano ∙ lietuvių ∙ magyar ∙ Nederlands ∙ norsk bokmål ∙ norsk nynorsk ∙ occitan ∙ Plattdüütsch ∙ polski ∙ português ∙ português do Brasil ∙ română ∙ Scots ∙ sicilianu ∙ slovenčina ∙ slovenščina ∙ suomi ∙ svenska ∙ Tiếng Việt ∙ Türkçe ∙ vèneto ∙ Ελληνικά ∙ беларуская (тарашкевіца) ∙ български ∙ македонски ∙ нохчийн ∙ русский ∙ српски / srpski ∙ татарча/tatarça ∙ українська ∙ ქართული ∙ հայերեն ∙ বাংলা ∙ தமிழ் ∙ മലയാളം ∙ ไทย ∙ 한국어 ∙ 日本語 ∙ 简体中文 ∙ 繁體中文 ∙ עברית ∙ العربية ∙ فارسی ∙ +/−

 

我，本作品著作权人，释出本作品至公有领域。这适用于全世界。 在一些国家这可能不合法；如果是这样的话，那么： 我无条件地授予任何人以任何目的使用本作品的权利，除非这些条件是法律规定所必需的。

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