Tästä tiedostosta on saatavilla myös SVG-versio eli vektorigrafiikkatiedosto. SVG-versiota tulisi suosia, mikäli se on laadultaan tätä rasterikuvaa parempi. File:DiffusionMicroMacro.gif → File:DiffusionMicroMacro.svg Lisätietoa vektorigrafiikasta ja sen hyödyistä MediaWikin SVG-tiedostojen tukeminen Muilla kielillä 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 ∙ українська ∙ ქართული ∙ հայերեն ∙ বাংলা ∙ தமிழ் ∙ മലയാളം ∙ ไทย ∙ 한국어 ∙ 日本語 ∙ 简体中文 ∙ 繁體中文 ∙ עברית ∙ العربية ∙ فارسی ∙ +/−

 

Yhteenveto

Lisenssi

Minä, tämän teoksen tekijänoikeudellinen omistaja, julkaisen tämän teoksen public domainiin eli luovun kaikista tekijänoikeuksista lain sallimissa puitteissa. Tämä on voimassa maailmanlaajuisesti. Joissain maissa laki ei mahdollista tätä. Mikäli näin on: Myönnän kenelle tahansa oikeuden käyttää tätä teosta mihin tahansa tarkoitukseen, ilman mitään ehtoja, ellei laki vaadi ehtojen asettamista.

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