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]
https://www.wolframscience.com/nks/notes-7-7--the-ising-model/
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[]=
-322,-2432,-2064,-16424,-121728,-86688,020524,-413568,413568,86688,16424,121728,2432,2064,322
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...

[or could this be a block CA instead?]

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[#22&&#31,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...

[We can summarize the equivalence class by some ID if we want to]

Distributed Consensus

This always goes to “extreme magnetization”...