You are using a browser not supported by the Wolfram Cloud
Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.
I understand and wish to continue anyway »
WOLFRAM NOTEBOOK
Ising Model
Ising Model
In[]:=
energy[s_]:=-1/2Total[sListConvolve[{{0,1,0},{1,0,1},{0,1,0}},s,2],2]
In[]:=
magnetization[s_]:=Total[s,2]
Out[]=
For low energy, magnetization for a given configuration will be +1 or -1 roughly...
In[]:=
ListPlot[{energy[#],magnetization[#]}&/@Tuples[{-1,1},{3,3}]]
Out[]=
In[]:=
BubbleChart[Flatten/@Tally[{energy[#],magnetization[#]}&/@Tuples[{-1,1},{3,3}]]]
Out[]=
In[]:=
Map[Labeled[ArrayPlot[#,ColorRules->{-1->LightBlue,1->LightRed},Mesh->True,ImageSize->60],magnetization[#]]&,GatherBy[Select[Tuples[{-1,1},{3,3}],energy[#]==-10&],magnetization],{2}]
Out[]=
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
-7 |
-7 |
-7 |
-7 |
-7 |
-7 |
-7 |
-7 |
-7 |
7 |
7 |
7 |
7 |
7 |
7 |
7 |
7 |
7 |
In[]:=
BubbleChart[Flatten/@Tally[{energy[#],magnetization[#]}&/@Tuples[{-1,1},{4,4}]]]
Out[]=
In[]:=
Histogram[energy/@Tuples[{-1,1},{4,4}],Automatic,{"Log","Count"}]
Out[]=
In[]:=
Counts[energy/@Tuples[{-1,1},{4,4}]]
Out[]=
-322,-2432,-2064,-16424,-121728,-86688,020524,-413568,413568,86688,16424,121728,2432,2064,322
In[]:=
Map[Labeled[ArrayPlot[#,ColorRules->{-1->LightBlue,1->LightRed},Mesh->True,ImageSize->60],magnetization[#]]&,GatherBy[Select[Tuples[{-1,1},{4,4}],energy[#]==-24&],magnetization],{2}]
Out[]=
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
-14 |
-14 |
-14 |
-14 |
-14 |
-14 |
-14 |
-14 |
-14 |
-14 |
-14 |
-14 |
-14 |
-14 |
-14 |
-14 |
14 |
14 |
14 |
14 |
14 |
14 |
14 |
14 |
14 |
14 |
14 |
14 |
14 |
14 |
14 |
14 |
In[]:=
Map[Labeled[ArrayPlot[#,ColorRules->{-1->LightBlue,1->LightRed},Mesh->True,ImageSize->40],magnetization[#]]&,GatherBy[Select[Tuples[{-1,1},{4,4}],energy[#]==-16&],magnetization],{2}]
Out[]=
Adding dynamics, we can make transitions from states to states...
Adding dynamics, we can make transitions from states to states...
[or could this be a block CA instead?]
Dynamical Evolution
Dynamical Evolution
[ modified from NKS to change to -1, +1 basis ]
In[]:=
energy[s_]:=-1/2Total[sListConvolve[{{0,1,0},{1,0,1},{0,1,0}},s,2],2]
In[]:=
magnetization[s_]:=Total[s,2]
In[]:=
IsingEvolve[list_,t_Integer]:=First[Nest[IsingStep,{list,Mask[list]},t]]
In[]:=
IsingEvolveList[list_,t_Integer]:=NestList[IsingStep,{list,Mask[list]},t][[All,1]]
In[]:=
IsingStep[{a_,mask_}]:={2MapThread[If[#22&,1-#1,#1]&,{(a+1)/2,ListConvolve[{{0,1,0},{1,0,1},{0,1,0}},(a+1)/2,2],mask},2]-1,1-mask}
In[]:=
Mask[list_]:=Array[Mod[#1+#2,2]&,Dimensions[list]]
In[]:=
RandomSample[Tuples[{-1,1},{3,3}],5]
Out[]=
{{{-1,-1,-1},{-1,1,-1},{1,1,1}},{{-1,-1,-1},{-1,1,-1},{-1,1,1}},{{1,1,1},{1,1,1},{-1,-1,-1}},{{-1,1,-1},{-1,-1,-1},{-1,-1,-1}},{{-1,-1,1},{1,1,-1},{-1,-1,-1}}}
In[]:=
IsingStep[{{{-1,1,-1},{1,1,1},{1,-1,1}},Mask[{{-1,1,-1},{1,1,1},{1,-1,1}}]}]
Out[]=
{{{-1,1,-1},{1,1,1},{1,-1,1}},{{1,0,1},{0,1,0},{1,0,1}}}
[[ The 3×3 case is weird and won’t work .... ]]
In[]:=
Graph[Catenate[{{#,Mask[#]}->IsingStep[{#,Mask[#]}],{#,1-Mask[#]}->IsingStep[{#,1-Mask[#]}]}&/@Tuples[{-1,1},{3,3}]]]
Out[]=
Everything stays in its “energy lane”:
Below the phase transition, we always stay “on the same size of magnetization”...
A state “falls into” a certain equivalence class ... i.e. a certain collection of cycles....
Everything here is irreversible.....
“Effective contractive mapping” is to go from an isolated state to an equivalence class...
“Effective contractive mapping” is to go from an isolated state to an equivalence class...
[We can summarize the equivalence class by some ID if we want to]
Distributed Consensus
Distributed Consensus
This always goes to “extreme magnetization”...