This notebook plots Schroeder Figure 3.8

It also makes Table 3.2 and does the numerical N=100 version of Figure 3.9

Remove["Global`*"]

Set up the variables corresponding to the figure (and Table 3.2)

Ntot=100;
Ndn=Range[0,Ntot];
Nup=Ntot-Ndn;
Ω=Binomial[Ntot,Nup];
S=Log[Ω];
U=Ndn-Nup;
M=Nup-Ndn;

The temperature is a little trickier. The value at a point is from the differences on either side of the point. See the textbook for a bit of an explanation. We’ll do it out explicitly here, with the ends and middle by hand.

iLo=Range[1, Ntot-1];
iHi=Range[3,Ntot+1];

Tinv=(S[[iHi]]-S[[iLo]])/(U[[iHi]]-U[[iLo]]);
T=Flatten[{0,1/Tinv[[1;;49]],"∞",1/Tinv[[51;;99]],0}];

Print out Table 3.2

i={1,2,3,4,49,50,51,52,53,100,101};
Grid[Transpose[{
Nup[[i]],N[U[[i]],2],N[M[[i]],2],N[Ω[[i]],2],N[S[[i]],4],N[T[[i]],3]}]]

Plot Figure 3.8

ListLinePlot[Transpose[{U,S}],PlotStyle->Black]

Plot Figure 3.9 (Which, in the book, uses the analytical solution.)

PosTemp=ListLinePlot[Transpose[{U[[1;;50]]/Ntot,T[[1;;50]]}],
PlotStyle->Black,PlotRange->{{-1,1},{-20,20}}];
NegTemp=ListLinePlot[Transpose[{U[[52;;101]]/Ntot,T[[52;;101]]}],
PlotStyle->Black,PlotRange->{{-1,1},{-20,20}}];
Show[PosTemp,NegTemp]