Compiled Version


“Nearest” Version

In[]:=
simulateGas[initPos_,initVel_,width_,steps_]:=​​NestList[​​Function[state,Module[{ps,vs,nf,cols,intersection,unitDisplacement,mag},​​{ps,vs}=state;​​(*applyvelocities*)​​ps+=vs;​​(*ball-to-ballcollisions*)​​nf=Nearest[ps{"Index","Distance"}];​​cols=DeleteDuplicatesBy[Catenate[MapIndexed[{#1[[1]],#2[[1]],#1[[2]]}&,nf[ps,{All,2}][[All,2;;]],{2}]],Sort@*Most];​​Function[{i,j,dist},​​intersection=(dist-2)*(ps[[i]]-ps[[j]])/dist/2;​​ps[[i]]-=intersection;ps[[j]]+=intersection;​​unitDisplacement=(ps[[i]]-ps[[j]])/2;​​mag=(vs[[i]]-vs[[j]]).unitDisplacement*unitDisplacement;​​vs[[i]]-=mag;vs[[j]]+=mag;​​]@@@cols;​​(*ball-to-wallcollisions*)​​Do[​​If[ps[[i,d]]<1,ps[[i,d]]=1.0;vs[[i,d]]*=-1];​​If[ps[[i,d]]>width-1,ps[[i,d]]=width-1;vs[[i,d]]*=-1],​​{d,Length[initPos[[1]]]},{i,Length[initPos]}];​​{ps,vs}​​]],​​{initPos,initVel},steps]
In[]:=
sim=simulateGas[​​RandomPoint[Rectangle[{1,1},{50,50}],100],(*initialpositions*)​​RandomPoint[Disk[{0,0},0.5],100],(*initialvelocities*)​​100.0,(*boxsize*)​​1000(*steps*)​​];
In[]:=
Manipulate[Graphics[{{FaceForm[],EdgeForm[Red],Rectangle[{0,0},{100,100}]},Disk/@sim[[t,1]]}],{t,1,Length[sim],1},SaveDefinitionsTrue]
Out[]=
​
t
In[]:=
sim2=simulateGas[​​RandomPoint[Rectangle[{1,1},{20,20}],10],(*initialpositions*)​​RandomPoint[Disk[{0,0},0.5],10],(*initialvelocities*)​​20.0,(*boxsize*)​​1000(*steps*)​​];
In[]:=
Manipulate[Graphics[{{FaceForm[],EdgeForm[Red],Rectangle[{0,0},{20,20}]},Style[Disk/@sim2[[t,1]],Gray]}],{t,1,Length[sim2],1},SaveDefinitionsTrue]
Out[]=
​
t
In[]:=
sim2
Out[]=
{{{{12.5161,1.28219},{13.6354,4.72069},{2.46794,18.6838},{16.6803,16.2506},{16.3884,12.9024},{3.49844,19.4726},{17.7425,4.67225},{8.4071,18.7992},{17.8347,11.2174},{7.16009,9.75275}},{{-0.0741023,-0.260585},
⋯8⋯
,{-0.140547,0.337058}}},
⋯999⋯
,{{
⋯1⋯
},{
⋯1⋯
}}}
large output
show less
show more
show all
set size limit...
In[]:=
Dimensions[%]
Out[]=
{1001,2,10,2}

HardSphereGasSimulation

In[]:=
HardSphereGasSimulation0[initPos_,initVel_,width_,steps_]:=​​NestList[​​Function[state,Module[{ps,vs,nf,cols,intersection,unitDisplacement,mag},​​{ps,vs}=state;​​(*applyvelocities*)​​ps+=vs;​​(*ball-to-ballcollisions*)​​nf=Nearest[ps{"Index","Distance"}];​​cols=DeleteDuplicatesBy[Catenate[MapIndexed[{#1[[1]],#2[[1]],#1[[2]]}&,nf[ps,{All,2}][[All,2;;]],{2}]],Sort@*Most];​​Function[{i,j,dist},​​intersection=(dist-2)*(ps[[i]]-ps[[j]])/dist/2;​​ps[[i]]-=intersection;ps[[j]]+=intersection;​​unitDisplacement=(ps[[i]]-ps[[j]])/2;​​mag=(vs[[i]]-vs[[j]]).unitDisplacement*unitDisplacement;​​vs[[i]]-=mag;vs[[j]]+=mag;​​]@@@cols;​​(*ball-to-wallcollisions*)​​Do[​​If[ps[[i,d]]<1,ps[[i,d]]=1.0;vs[[i,d]]*=-1];​​If[ps[[i,d]]>width-1,ps[[i,d]]=width-1;vs[[i,d]]*=-1],​​{d,Length[initPos[[1]]]},{i,Length[initPos]}];​​{ps,vs}​​]],​​{initPos,initVel},steps]
In[]:=
sim2=HardSphereGasSimulation0[​​RandomPoint[Rectangle[{1,1},{20,20}],10],(*initialpositions*)​​RandomPoint[Disk[{0,0},0.5],10],(*initialvelocities*)​​20.0,(*boxsize*)​​1000(*steps*)​​];
Overpaints are due to “backups” when spheres interpenetrate...

CA version