squareLattice[L_]:=Graph[Join[#\[UndirectedEdge](L Quotient[#-1,L]+Mod[#,L]+1)&/@Range[(L^2)],#\[UndirectedEdge]1+Mod[#+L-1,(L^2)]&/@Range[(L^2)],0\[UndirectedEdge]#&/@Range[(L^2)]]]

ZIsing[H_][r_,s_][i_,j_]:=Piecewise[{
{H r s[[j]],i==0},
{H r s[[i]],j==0}},
s[[i]]s[[j]]
]

dAct[q_][d1i_,d2_]:=If[IntegerQ[d2],Mod[d1i-d2,q],{!d2[[1]],Mod[d1i-d2[[2]],q]}]

dActFull[q_][d_][s_]:=If[d[[1]],Mod[q-Mod[s+d[[2]],q],q],Mod[s+d[[2]],q]]

dInverse[q_][d_][s_]:=If[d[[1]],Mod[q-Mod[s-d[[2]],q],q],Mod[s-d[[2]],q]]

ZPotts[J_,H_][r_,s_][i_,j_]:=With[{q=Length[J]},
Piecewise[{
{H[[1+dInverse[q][r][s[[j]]]]],i==0},
{H[[1+dInverse[q][r][s[[i]]]]],j==0}},
J[[Mod[s[[i]]-s[[j]],q]+1]]]
]

ZOrderN[J_,H_][r_,s_][i_,j_]:=Piecewise[{
{H[Transpose[r].s[[j]]],i==0},
{H[Transpose[r].s[[i]]],j==0}},
J[s[[i]].s[[j]]]
]

rotGenIsing[]:=-#&

Ref[r_]:=IdentityMatrix[Length[r]]-2Outer[Times,r,r]

rotGenPotts[q_][]:=Module[{r},r=RandomInteger[q-1];dAct[q][r,#]&]

rotGenOrderN[n_][]:=Module[{r},r=Ref[RandomPoint[Sphere[n]]];r.#&]

wolffStep[g_,Z_,rotGen_,T_][{r0_,s_}]:=Module[{stack,cluster,r},
AppendTo[record,{r0,s,{}}];
stack={RandomInteger[{1,VertexCount[g]-1}]};
r=rotGen[];
cluster={};
While[stack≠{},
record[[-1,3]]=Join[record[[-1,3]],{First[stack]}];
cluster=Append[cluster,First[stack]];
With[
{ΔE=Z[r0,s][First[stack],#]-If[#==0,Z[r[r0],s][First[stack],#],Z[r0,ReplacePart[s,#->r[s[[#]]]]][First[stack],#]]},
If[RandomReal[]<1-Exp[-ΔE/T],AppendTo[stack,#]]
]&/@Complement[AdjacencyList[g,First[stack]],cluster,Rest[stack]];
stack=Rest[stack];
];
{If[MemberQ[cluster,0],r[r0],r0],ReplacePart[s,{#}->r[s[[#]]]&/@Select[cluster,#≠0&]]}
]

metropolisStep[g_,Z_,rotGen_,T_][{r0_,s_}]:=Module[{i,r,snew,ΔE},
r=rotGen[];
i=RandomInteger[{1,VertexCount[g]-1}];
snew=ReplacePart[s,i->r[s[[i]]]];
ΔE=-Total[Z[r0,snew][i,#]-Z[r0,s][i,#]&/@AdjacencyList[g,i]];
If[RandomReal[]<Exp[-ΔE/T],{r0,snew},{r0,s}]
]

plotVectorCluster[L_][r_,s_,clust_]:=ListVectorPlot[{Partition[s,L],Partition[ReplacePart[ConstantArray[{0,0},(L^2)],{#}->s[[#]]&/@Select[clust,#≠0&]],L]},VectorPoints->All,VectorStyle->{{Black,Arrowheads[0.022,Thick]},{Red,Arrowheads[0.022],Thick}},FrameTicks->False,ImageSize->500,VectorScale->0.03]

plotPottsCluster[L_][r_,s_,clust_]:=ArrayPlot[Partition[ReplacePart[1+s,{#}->I&/@Select[clust,#≠0&]],L],ImageSize->500,ColorFunction->ColorData[97],ColorRules->{I->Red},ColorFunctionScaling->False]

pottsPoly[q_][r_,sel_,H_,loc_,ps_,color_:Black,bord_:Black]:=Graphics[{{color,EdgeForm[Directive[bord,Thick]],Polygon[ConstantArray[loc,q]+CirclePoints[q]Part[H,1+dActFull[q][r]/@(Range[q]-1)]]},Thread[{PointSize[ps],ColorData[97][#]&/@(1+dActFull[q][r]/@(Range[q]-1)),(Point[loc+(Part[H,1+dActFull[q][r]/@(Range[q]-1)] CirclePoints[q])[[#]]]&/@Range[q])}]},ImageSize->100,PlotRange->{{-2.5,2.5},{-2.5,2.5}}]

L=32;g=squareLattice[L];

ss=ConstantArray[1,(L^2)];rr=1;

record={};

{rr1,ss1}=Nest[wolffStep[g,ZIsing[0],rotGenIsing,2/Log[1+(Sqrt[2])]+0.1],{rr,ss},100];

{rr2,ss2}=Nest[metropolisStep[g,ZIsing[0],rotGenIsing,2/Log[1+(Sqrt[2])]+0.1],{rr1,ss1},L^2];

{rr3,ss3}=Nest[wolffStep[g,ZIsing[0],rotGenIsing,2/Log[1+(Sqrt[2])]+0.1],{rr2,ss2},1];

ms={Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[1+ss1,L]]],Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[1+ss2,L]]]}

i=1;gs={Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[1+ss2,32]]],Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[ReplacePart[1+ss2,{#}->I&/@record[[-i,3]]],32],ColorRules->{I->Red}]],Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[1+ss3,32]]]}

Export["~/doc/research/pres/statphys27/figs/ising_hl_00_0.pdf",ms[[1]]];
Export["~/doc/research/pres/statphys27/figs/ising_hl_00_1.pdf",ms[[2]]];
Export["~/doc/research/pres/statphys27/figs/ising_hl_00_2.pdf",gs[[2]]];
Export["~/doc/research/pres/statphys27/figs/ising_hl_00_3.pdf",gs[[3]]];

{rr,ss}=Nest[wolffStep[g,ZIsing[0.1],rotGenIsing,2/Log[1+(Sqrt[2])]+0.1],{rr,ss},100];

ArrayPlot[Partition[1+record[[-2-1,2]],32],ColorRules->{I->Red}]

MemberQ[record[[-6,3]],662+32]

record[[-6,3]][[1]]

i=5;gs={Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[1+record[[-i-1,2]],32]]],Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[1+ReplacePart[record[[-i-1,2]],record[[-i-1,3]][[1]]->I-1],32],ColorRules->{I->Red}]],Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[1+ReplacePart[record[[-i-1,2]],record[[-i-1,3]][[1]]->I-1],32],ColorRules->{I->Red}],Graphics[{{Green,Rectangle[{Mod[662-1+1,32],32-1-Quotient[662-1+1,32]},{1,1}+{Mod[662-1+1,32],32-1-Quotient[662-1+1,32]}]},{Directive[FontWeight->Bold,FontColor->Black],Inset["?",{0.5,0.5}+{Mod[662-1+1,32],32-1-Quotient[662-1+1,32]}]}}]],Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[1+ReplacePart[record[[-i-1,2]],{record[[-i-1,3]][[1]]->I-1}],32],ColorRules->{I->Red}],Graphics[{{Green,Rectangle[{Mod[662-1+32,32],32-1-Quotient[662-1+32,32]},{1,1}+{Mod[662-1+32,32],32-1-Quotient[662-1+32,32]}]},{Directive[FontWeight->Bold,FontColor->Black],Inset["?",{0.5,0.5}+{Mod[662-1+32,32],32-1-Quotient[662-1+32,32]}]}}]],Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[1+ReplacePart[record[[-i-1,2]],{record[[-i-1,3]][[1]]->I-1,662+32->I-1}],32],ColorRules->{I->Red}],Graphics[{{Green,Rectangle[{Mod[662-1-1,32],32-1-Quotient[662-1-1,32]},{1,1}+{Mod[662-1-1,32],32-1-Quotient[662-1-1,32]}]},{Directive[FontWeight->Bold,FontColor->Black],Inset["?",{0.5,0.5}+{Mod[662-1-1,32],32-1-Quotient[662-1-1,32]}]}}]],Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[1+ReplacePart[record[[-i-1,2]],{record[[-i-1,3]][[1]]->I-1,662+32->I-1,662-1->I-1}],32],ColorRules->{I->Red}],Graphics[{{Green,Rectangle[{Mod[662-1-32,32],32-1-Quotient[662-1-32,32]},{1,1}+{Mod[662-1-32,32],32-1-Quotient[662-1-32,32]}]},{Directive[FontWeight->Bold,FontColor->Black],Inset["?",{0.5,0.5}+{Mod[662-1-32,32],32-1-Quotient[662-1-32,32]}]}}]],Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[1+ReplacePart[record[[-i-1,2]],{record[[-i-1,3]][[1]]->I-1,662+32->I-1,662-1->I-1}],32],ColorRules->{I->Red}]],Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[ReplacePart[1+record[[-i-1,2]],({#}->I&/@DeleteCases[record[[-i-1,3]],0])],32],ColorRules->{2->Black,0->White,I->Red}]],Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[1+record[[-i,2]],32]]]}

gs[[3]]

Export["~/doc/research/pres/statphys27/figs/ising_hl_0_1.pdf",gs[[1]]];
Export["~/doc/research/pres/statphys27/figs/ising_hl_0_2.pdf",gs[[2]]];
Export["~/doc/research/pres/statphys27/figs/ising_hl_0_3.pdf",gs[[3]]];
Export["~/doc/research/pres/statphys27/figs/ising_hl_0_4.pdf",gs[[4]]];
Export["~/doc/research/pres/statphys27/figs/ising_hl_0_5.pdf",gs[[5]]];
Export["~/doc/research/pres/statphys27/figs/ising_hl_0_6.pdf",gs[[6]]];
Export["~/doc/research/pres/statphys27/figs/ising_hl_0_7.pdf",gs[[7]]];
Export["~/doc/research/pres/statphys27/figs/ising_hl_0_8.pdf",gs[[8]]];
Export["~/doc/research/pres/statphys27/figs/ising_hl_0_9.pdf",gs[[9]]];

gs[[2]]

test=Flatten[With[{ΔE=ZIsing[0][record[[-4,1]],record[[-4,2]]][#[[1]],#[[2]]]},If[ΔE>0&&RandomReal[]>Exp[-2 ΔE/(2/Log[1+(Sqrt[2])]+0.1)],#,{}]]&/@EdgeList[g]];

edgeLine[L_][e1_\[UndirectedEdge]e2_]:=With[{x1=Mod[e1-1,L],x2=Mod[e2-1,L],y1=L-1-Quotient[e1-1,L],y2=L-1-Quotient[e2-1,L]},
If[x2-x1>1,{Line[0.5+{{x1,y1},{x1-1,y2}}],Line[0.5+{{x2+1,y1},{x2,y2}}]},
If[x1-x2>1,{Line[0.5+{{x1,y1},{x1+1,y2}}],Line[0.5+{{x2-1,y1},{x2,y2}}]},
If[y2-y1>1,{Line[0.5+{{x1,y1},{x2,y1-1}}],Line[0.5+{{x1,y2+1},{x2,y2}}]},If[y1-y2>1,{Line[0.5+{{x1,y1},{x2,y1+1}}],Line[0.5+{{x1,y2-1},{x2,y2}}]},
{Line[0.5+{{x1,y1},{x2,y2}}]}]]]]]

clusters=Partition[(If[Length[#]>0,#[[1,1]],RandomInteger[{L^2+1,10^9}]]&@Position[VertexList/@ConnectedGraphComponents[Graph[test]],#])&/@Range[L^2],L];

fk4=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[clusters,ColorFunction->(If[OddQ[#],Black,White]&),ColorFunctionScaling->False]]

fk3=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[clusters,ColorFunction->ColorData[97],ColorFunctionScaling->False]]

fk1=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[1+record[[-4,2]],L]]]

fk2=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[1+record[[-4,2]],L]],Graphics[Thread[{Thickness[0.008],ColorData[97]/@Range[Length[#]],#}]&@({edgeLine[32]/@#}&/@(EdgeList/@ConnectedGraphComponents[Graph[test]]))]]

Export["~/doc/research/pres/statphys27/figs/ising_fk_0_1.pdf",fk1];

Export["~/doc/research/pres/statphys27/figs/ising_fk_0_2.pdf",fk2];

Export["~/doc/research/pres/statphys27/figs/ising_fk_0_3.pdf",fk3];

Export["~/doc/research/pres/statphys27/figs/ising_fk_0_4.pdf",fk4];

ss=ConstantArray[1,(L^2)];rr=1;

record={};

{rr,ss}=Nest[wolffStep[g,ZIsing[0.1],rotGenIsing,2/Log[1+(Sqrt[2])]+0.1],{rr,ss},100];

i=4;

gs={ArrayPlot[Partition[1+record[[-i-1,2]],32]],ArrayPlot[Partition[ReplacePart[1+record[[-i,2]],{#}->I&/@record[[-i-1,3]]],32],ColorRules->{I->Red}],ArrayPlot[Partition[1+record[[-i,2]],32]]}

test=Flatten[With[{ΔE=ZIsing[0.1][record[[-5,1]],record[[-5,2]]][#[[1]],#[[2]]]},If[ΔE>0&&RandomReal[]>Exp[-2 ΔE/(2/Log[1+(Sqrt[2])]+0.1)],#,{}]]&/@EdgeList[g]];

clusters=Partition[(If[Length[#]>0,#[[1,1]],RandomInteger[{L^2+1,10^9}]]&@Position[VertexList/@ConnectedGraphComponents[Graph[test]],#])&/@Range[L^2],L];

fk4=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[clusters,ColorFunction->(If[EvenQ[#],Black,White]&),ColorFunctionScaling->False],Graphics[{White,EdgeForm[Directive[Thin,Black]],Rectangle[{11L/10,L/2-0.5},{11L/10+1,L/2+0.5}]}]]

fk3=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[clusters,ColorFunction->ColorData[97],ColorFunctionScaling->False],Graphics[{ColorData[97][1],Rectangle[{11L/10,L/2-0.5},{11L/10+1,L/2+0.5}]}]]

fk1=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[record[[-5,2]]+1,L]],Graphics[{Black,Rectangle[{11L/10,L/2-0.5},{11L/10+1,L/2+0.5}]}]]

Cases[test,0\[UndirectedEdge]x_:>x]

fk2=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[1+record[[-5,2]],L]],Graphics[Thread[{Thickness[0.008],ColorData[97]/@Range[Length[#]],#}]&@({edgeLine[32]/@#}&/@(Select[#,#[[1]]≠0&&#[[2]]≠0&]&/@EdgeList/@ConnectedGraphComponents[Graph[test]]))],Graphics[{EdgeForm[Directive[White,Thickness[0.005]]],ColorData[97][1],Disk[0.5+{Mod[#-1,L],L-1-Quotient[#-1,L]},0.25]}&/@Cases[test,0\[UndirectedEdge]x_:>x]],Graphics[{Black,EdgeForm[Directive[ColorData[97][1],Thick]],Rectangle[{11L/10,L/2-0.5},{11L/10+1,L/2+0.5}]}]]

Export["~/doc/research/pres/statphys27/figs/ising_fk_h_1.pdf",fk1];

Export["~/doc/research/pres/statphys27/figs/ising_fk_h_2.pdf",fk2];

Export["~/doc/research/pres/statphys27/figs/ising_fk_h_3.pdf",fk3];

Export["~/doc/research/pres/statphys27/figs/ising_fk_h_4.pdf",fk4];

g1=Graphics[{{Gray,Circle[{3.1,0}]},{Thick,Arrow[{{3.1,0},{3.1+Cos[1+0.6],Sin[1+0.6]}}]},{Gray,Thick,Arrow[{{3.1,0},{3.1+Cos[1-0.6],Sin[1-0.6]}}]},{Red,Dashed,Thick,Line[1.3{{3.1/1.3+Cos[1+π],Sin[1+π]},{3.1/1.3+Cos[1],Sin[1]}}]},{Gray,Circle[]},{Thick,Arrow[{{0,0},{Cos[1+1.4],Sin[1+1.4]}}]},{Gray,Thick,Arrow[{{0,0},{Cos[1-1.4],Sin[1-1.4]}}]},{Red,Dashed,Thick,Line[1.3{{Cos[1+π],Sin[1+π]},{Cos[1],Sin[1]}}]},{Red,Directive[FontSize->15],Text["r  =  (r^(-1))",{3.1+1.4,1.1}]}}]

Export["~/doc/research/pres/statphys27/figs/clocks.pdf",g1];

L=32;

g=squareLattice[L];ss=ConstantArray[{1,0},(L^2)];rr=IdentityMatrix[2];

record={};

{rr,ss}=Nest[wolffStep[g,ZOrderN[Identity,0.1Cos[5ArcTan@@#]&],rotGenOrderN[2],0.8],{rr,ss},100];

plotVectors[L_,n_][rr_,ss_,c_:{},v_:{0,0}]:=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],Graphics[{Thick,Arrowheads[0.015],MapIndexed[{If[MemberQ[c,#2[[1]]],Red,Black],Arrow[0.5+ConstantArray[{Mod[#2[[1]]-1,L],L-1-Quotient[#2[[1]]-1,L]},2]+0.45{-#1,#1}]}&,ss]}],Graphics[{Inset[PolarPlot[{1,1+0.2 Cos[5(ArcTan@@(Inverse[rr].{1,0})-θ)]},{θ,0,2π},PlotStyle->{{Dashed,Black},{Black}},Axes->False,PlotRange->{{-1.25,1.25},{-1.2,1.2}}],{1.2L,L/2},{0,0},5],{If[MemberQ[c,0],Red,Black],Thick,Arrowheads[0.015],Arrow[{1.2L,L/2}+Inverse[rr].#&/@{{0,0},{1.5,0}}],Arrow[{1.2L,L/2}+Inverse[rr].#&/@{{0,0},{0,0.9}}]},
{Dashed,Black,Thick, Line[{{1.2L, L/2}-v,{1.2L,L/2}+v}]}}]]

i=1;

v1=plotVectors[L,5][IdentityMatrix[2],Inverse[record[[-i-1,1]]].#&/@record[[-i-1,2]]]

vv=(Inverse[record[[-i-1,1]]].record[[-i,1]])[[1]]

Solve[{lx^2-ly^2==vv[[1]],2 lx ly==vv[[2]]},{lx,ly}]

v1a=plotVectors[L,5][IdentityMatrix[2],Inverse[record[[-i-1,1]]].#&/@record[[-i-1,2]],{},3{-0.738496,-0.674258}]

v2=plotVectors[L,5][IdentityMatrix[2],Inverse[record[[-i-1,1]]].#&/@record[[-i-1,2]],record[[-i-1,3]],3{-0.738496,-0.674258}]

v3=plotVectors[L,5][Inverse[record[[-i-1,1]]].record[[-i,1]],Inverse[record[[-i-1,1]]].#&/@record[[-i,2]],record[[-i-1,3]],3{-0.738496,-0.674258}]

v4=plotVectors[L,5][Inverse[record[[-i-1,1]]].record[[-i,1]],Inverse[record[[-i-1,1]]].#&/@record[[-i,2]]]

v5=plotVectors[L,5][IdentityMatrix[2],Inverse[record[[-i,1]]].#&/@record[[-i,2]]]

Export["~/doc/research/pres/statphys27/figs/vector_hl_h5_0.pdf",v1];
Export["~/doc/research/pres/statphys27/figs/vector_hl_h5_1.pdf",v1a];
Export["~/doc/research/pres/statphys27/figs/vector_hl_h5_2.pdf",v2];
Export["~/doc/research/pres/statphys27/figs/vector_hl_h5_3.pdf",v3];
Export["~/doc/research/pres/statphys27/figs/vector_hl_h5_4.pdf",v4];
Export["~/doc/research/pres/statphys27/figs/vector_hl_h5_5.pdf",v5];

Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],Graphics[{Thick,Arrowheads[0.023],MapIndexed[{If[MemberQ[record[[-1,3]],#2[[1]]],Black,Black],Arrow[0.5+ConstantArray[{Mod[#2[[1]]-1,L],L-1-Quotient[#2[[1]]-1,L]},2]+0.45{-#1,#1}]}&,record[[-1,2]]]}],Graphics[{Inset[PolarPlot[{1,1+0.1 Cos[5(ArcTan@@(Inverse[record[[-1,1]]].{1,0})-θ)]},{θ,0,2π},PlotStyle->{{Dashed,Black},{Black}},Axes->False,PlotRange->{{-1.2,1.2},{-1.2,1.2}}],{1.2L,L/2},{0,0},5],{Thick,Arrowheads[0.023],Arrow[{1.2L,L/2}+Inverse[record[[-1,1]]].#&/@{{0,0},{1.5,0}}],Arrow[{1.2L,L/2}+Inverse[record[[-1,1]]].#&/@{{0,0},{0,0.9}}]}}]]

Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],Graphics[{Thick,Arrowheads[0.023],MapIndexed[{If[MemberQ[record[[-1,3]],#2[[1]]],Red,Black],Arrow[0.5+ConstantArray[{Mod[#2[[1]]-1,L],L-1-Quotient[#2[[1]]-1,L]},2]+0.45{-#1,#1}]}&,ss]}],Graphics[{Inset[PolarPlot[{1,1+0.1 Cos[5(ArcTan@@(Inverse[rr].{1,0})-θ)]},{θ,0,2π},PlotStyle->{{Dashed,Black},{Black}},Axes->False,PlotRange->{{-1.2,1.2},{-1.2,1.2}}],{1.2L,L/2},{0,0},5],{Thick,Arrowheads[0.023],Arrow[{1.2L,L/2}+Inverse[rr].#&/@{{0,0},{1.5,0}}],Arrow[{1.2L,L/2}+Inverse[rr].#&/@{{0,0},{0,0.9}}]}}]]

fks1=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],Graphics[{Thick,Arrowheads[0.025],MapIndexed[Arrow[0.5+ConstantArray[{Mod[#2[[1]]-1,L],L-1-Quotient[#2[[1]]-1,L]},2]+0.6{-#1,#1}]&,ss]}]]

fks2=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],Graphics[{Red,Thick,Line[0.5+ConstantArray[{Mod[#-1,L],L-1-Quotient[#-1,L]},2]+0.6{-{Cos[1.2+π/2],Sin[1.2+π/2]},{Cos[1.2+π/2],Sin[1.2+π/2]}}]}&/@Range[Length[ss]]],Graphics[{Thick,Arrowheads[0.025],MapIndexed[Arrow[0.5+ConstantArray[{Mod[#2[[1]]-1,L],L-1-Quotient[#2[[1]]-1,L]},2]+0.6{-#1,#1}]&,ss]}]]

fks3=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[#.{Cos[1.2+π],Sin[1.2+π]}&/@ss,L],ColorFunction->(If[#>0,White,Black]&),ColorFunctionScaling->False]]

test=Flatten[If[#[[1]]≠0,With[{ΔE=1/2(ss[[#[[1]]]].ss[[#[[2]]]]-ss[[#[[1]]]].(ss[[#[[2]]]]-2 (ss[[#[[2]]]].{Cos[1.2+π],Sin[1.2+π]}){Cos[1.2+π],Sin[1.2+π]}))},If[ΔE>0&&RandomReal[]>Exp[-2 ΔE/(0.9)],#,{}]],{}]&/@EdgeList[g]];

clusters=Partition[(If[Length[#]>0,#[[1,1]],RandomInteger[{L^2+1,10^9}]]&@Position[VertexList/@ConnectedGraphComponents[Graph[test]],#])&/@Range[L^2],L];

fks4=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[#.{Cos[1.2+π],Sin[1.2+π]}&/@ss,L],ColorFunction->(If[#>0,White,Black]&),ColorFunctionScaling->False],Graphics[Thread[{Thickness[0.008],ColorData[97]/@Range[Length[#]],#}]&@({edgeLine[32]/@#}&/@(Select[#,#[[1]]≠0&&#[[2]]≠0&]&/@EdgeList/@ConnectedGraphComponents[Graph[test]]))]]

fks5=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[clusters,ColorFunction->ColorData[97],ColorFunctionScaling->False]]

fks6=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],Graphics[{Red,Thick,Line[0.5+ConstantArray[{Mod[#-1,L],L-1-Quotient[#-1,L]},2]+0.6{-{Cos[1.2+π/2],Sin[1.2+π/2]},{Cos[1.2+π/2],Sin[1.2+π/2]}}]}&/@Range[Length[ss]]],Graphics[{Thick,Arrowheads[0.025],MapIndexed[Arrow[0.5+ConstantArray[{Mod[#2[[1]]-1,L],L-1-Quotient[#2[[1]]-1,L]},2]+0.6{-#1,#1}]&,MapIndexed[If[OddQ[#1],ss[[#2[[1]]]],(ss[[#2[[1]]]]-2 (ss[[#2[[1]]]].{Cos[1.2+π],Sin[1.2+π]}){Cos[1.2+π],Sin[1.2+π]})]&,Flatten@clusters]]}]]

fks7=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],Graphics[{Thick,Arrowheads[0.025],MapIndexed[Arrow[0.5+ConstantArray[{Mod[#2[[1]]-1,L],L-1-Quotient[#2[[1]]-1,L]},2]+0.6{-#1,#1}]&,MapIndexed[If[OddQ[#1],ss[[#2[[1]]]],(ss[[#2[[1]]]]-2 (ss[[#2[[1]]]].{Cos[1.2+π],Sin[1.2+π]}){Cos[1.2+π],Sin[1.2+π]})]&,Flatten@clusters]]}]]

fks1=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],Graphics[{Thick,Arrowheads[0.025],MapIndexed[Arrow[0.5+ConstantArray[{Mod[#2[[1]]-1,L],L-1-Quotient[#2[[1]]-1,L]},2]+0.6{-#1,#1}]&,ss]}]]

Export["~/doc/research/pres/statphys27/figs/ising_fks_0_1.pdf",fks1];

Export["~/doc/research/pres/statphys27/figs/ising_fks_0_2.pdf",fks2];

Export["~/doc/research/pres/statphys27/figs/ising_fks_0_3.pdf",fks3];

Export["~/doc/research/pres/statphys27/figs/ising_fks_0_4.pdf",fks4];

Export["~/doc/research/pres/statphys27/figs/ising_fks_0_5.pdf",fks5];

Export["~/doc/research/pres/statphys27/figs/ising_fks_0_6.pdf",fks6];

Export["~/doc/research/pres/statphys27/figs/ising_fks_0_7.pdf",fks7];

ss=ConstantArray[0,(L^2)];rr={False,0};

record={};

{rr,ss}=Nest[wolffStep[g,ZPotts[{1,0,0},0.05{1,1,0}],rotGenPotts[3],1/Log[1+(Sqrt[3])]+0.1],{rr,ss},100];

rr

dAct[3][1,rr]

potts1=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],Graphics[{Thick,White,Dashed,Line[ConstantArray[{9L/8,L/2},2]+3{{Sin[2π 1/3],Cos[2π 1/3]},-{Sin[2π 1/3],Cos[2π 1/3]}}]}],plotPottsCluster[L][rr,ss,{}],pottsPoly[3][rr,False,2{1,1,1},{9L/8,L/2},0.04]]

potts2=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],plotPottsCluster[L][rr,ss,{}],pottsPoly[3][rr,False,2{1,1,1,1,1},{9L/8,L/2},0.04],Graphics[{Thick,Red,Dashed,Line[ConstantArray[{9L/8,L/2},2]+3{{Sin[2π 1/3],Cos[2π 1/3]},-{Sin[2π 1/3],Cos[2π 1/3]}}]}]]

potts3=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[ss,L],ColorRules->{0->Gray,1->Black,2->White}],pottsPoly[3][rr,False,2{1,1,1},{9L/8,L/2},0.04],Graphics[{Thick,Red,Dashed,Line[ConstantArray[{9L/8,L/2},2]+3.5{{Sin[2π 1/3],Cos[2π 1/3]},-{Sin[2π 1/3],Cos[2π 1/3]}}]}]]

zz={Sin[2π #/5],Cos[2π #/5]}&/@(Range[5]-1);

test=Flatten[With[{ΔE=(1/2)(ZPotts[Cos[2π #/5]&/@(Range[5]-1),0.1{1,1,0,0,0}][rr,ss][#[[1]],#[[2]]]-ZPotts[Cos[2π #/5]&/@(Range[5]-1),0.1{1,1,0,0,0}][rr,ReplacePart[ss,#[[2]]->dAct[5][2,ss[[#[[2]]]]]]][#[[1]],#[[2]]])},If[ΔE>0&&RandomReal[]>Exp[-2 ΔE/1],#,{}]]&/@EdgeList[g]];

clusters=Partition[(If[Length[#]>0,#[[1,1]],RandomInteger[{L^2+1,10^9}]]&@Position[VertexList/@ConnectedGraphComponents[Graph[test]],#])&/@Range[L^2],L];

potts4=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[Partition[ss,L],ColorRules->{0->Black,1->Gray,2->White,3->White,4->Black}],pottsPoly[5][rr,False,2{1,1,1,1,1},{9L/8,L/2},0.04,Black,ColorData[97][1]],Graphics[{Thick,Red,Dashed,Line[ConstantArray[{9L/8,L/2},2]+3.5{{Sin[2π 1/5],Cos[2π 1/5]},-{Sin[2π 1/5],Cos[2π 1/5]}}]}],Graphics[Thread[{Thickness[0.008],ColorData[97]/@Range[Length[#]],#}]&@({edgeLine[32]/@#}&/@(Select[#,#[[1]]≠0&&#[[2]]≠0&]&/@EdgeList/@ConnectedGraphComponents[Graph[test]]))],Graphics[{EdgeForm[Directive[Black,Thickness[0.005]]],ColorData[97][1],Disk[0.5+{Mod[#-1,L],L-1-Quotient[#-1,L]},0.25]}&/@Cases[test,0\[UndirectedEdge]x_:>x]]]

potts5=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],ArrayPlot[clusters,ColorFunction->ColorData[97],ColorFunctionScaling->False],pottsPoly[5][rr,False,2{1,1,1,1,1},{9L/8,L/2},0.04,ColorData[97][1],ColorData[97][1]],Graphics[{Thick,Red,Dashed,Line[ConstantArray[{9L/8,L/2},2]+3.5{{Sin[2π 1/5],Cos[2π 1/5]},-{Sin[2π 1/5],Cos[2π 1/5]}}]}]]

ssnew=MapIndexed[If[OddQ[#1],dAct[5][2,ss[[#2[[1]]]]],ss[[#2[[1]]]]]&,Flatten@clusters];

potts6=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],plotPottsCluster[L][rr,ssnew,{}],pottsPoly[5][dAct[5][2,rr],False,2{1,1,1,1,1},{9L/8,L/2},0.04],Graphics[{Thick,Red,Dashed,Line[ConstantArray[{9L/8,L/2},2]+3.5{{Sin[2π 1/5],Cos[2π 1/5]},-{Sin[2π 1/5],Cos[2π 1/5]}}]}]]

potts7=Show[Graphics[{White,Rectangle[{-1,-1},{L+1,L+1}]}],Graphics[{Thick,White,Dashed,Line[ConstantArray[{9L/8,L/2},2]+3.5{{Sin[2π 1/5],Cos[2π 1/5]},-{Sin[2π 1/5],Cos[2π 1/5]}}]}],plotPottsCluster[L][rr,ssnew,{}],pottsPoly[5][dAct[5][2,rr],False,2{1,1,1,1,1},{9L/8,L/2},0.04]]

Export["~/doc/research/pres/statphys27/figs/potts_fk_h_1.pdf",potts1];

Export["~/doc/research/pres/statphys27/figs/potts_fk_h_2.pdf",potts2];

Export["~/doc/research/pres/statphys27/figs/potts_fk_h_3.pdf",potts3];

Export["~/doc/research/pres/statphys27/figs/potts_fk_h_4.pdf",potts4];

Export["~/doc/research/pres/statphys27/figs/potts_fk_h_5.pdf",potts5];

Export["~/doc/research/pres/statphys27/figs/potts_fk_h_6.pdf",potts6];

Export["~/doc/research/pres/statphys27/figs/potts_fk_h_7.pdf",potts7];

Part[Range[3],{1,3,2}]

test=Grid[{{pottsPoly[3][#1,MemberQ[{},0],{1,1.5,0.5}],pottsPoly[3][{False,0},MemberQ[{},0],{1,1.5,0.5}]},{plotPottsCluster[L][#1,#2,{}],plotPottsCluster[L][#1,dInverse[3][#1]/@#2,{}]}}]&@@@record;

Manipulate[test[[i]],{i,1,Length[test],1}]

1+dInverse[3][record[[4,1]]]/@(Range[3]-1)

record[[3,1]]

test=Grid[{{pottsPoly[3][#1,MemberQ[#3,0],{1,1,1.5}],pottsPoly[3][{False,0},MemberQ[#3,0],{1,1,1.5}]},{plotPottsCluster[L][#1,#2,#3],plotPottsCluster[L][#1,dInverse[3][#1]/@#2,#3]}}]&@@@Flatten[(Thread[{#1,#2,Reverse@NestList[Most,#3,Length[#3]]},List,{3}]&@@@record),1][[;;;;L]];

test[[100]]

1

Cycles[{{1,3}}]\[PermutationProduct]Cycles[{{3,2}}]

ZPotts[{1,0,0},{0,1,0}][Cycles[{{1,3}}]\[PermutationProduct]Cycles[{{3,2}}],ss][0,4]

record[[All,1]]

MemberQ[#,0]&/@record[[All,3]]

Histogram[Total[Flatten[#1 #2]/(L^2)]&@@@record]

ss=ConstantArray[{1,0},(L^2)];rr=IdentityMatrix[2];

record={};

{rr,ss}=Nest[wolffStep[g,ZOrderN[Identity,0.01Cos[3ArcTan@@#]&],rotGenOrderN[2],0.9],{rr,ss},100];

rr//MatrixForm

ZOrderN[Identity,100{1,0}.#&][-IdentityMatrix[2],{{1,0},{-1,0}}][2,0]

test=Grid[{{ParametricPlot[Evaluate[#1.((1+0.5Cos[3θ]){Cos[θ],Sin[θ]})],{θ,0,2π},Axes->False,PlotStyle->{Thick,If[MemberQ[#3,0],Red,Black]},ImageSize->100,PlotRange->{{-1.7,1.7},{-1.7,1.7}}],ParametricPlot[(1+0.5Cos[3θ]){Cos[θ],Sin[θ]},{θ,0,2π},Axes->False,PlotStyle->{Thick,If[MemberQ[#3,0],Red,Black]},ImageSize->100,PlotRange->{{-1.7,1.7},{-1.7,1.7}}]},{plotVectorCluster[L][#1,#2,#3],plotVectorCluster[L][#1,(x|->Transpose[#1].x)/@#2,#3]}}]&@@@Flatten[(Thread[{#1,#2,Reverse@NestList[Most,#3,Length[#3]]},List,{3}]&@@@record),1][[;;;;L]];

test[[400]]

Export["/tmp/test/test-"<>IntegerString[#,10,4]<>".png",test[[#]]]&/@Range[Length[test]];

((Transpose[#1].Total[#2]/(L^2)))[[1]]&@@@record

Histogram[((Transpose[#1].Total[#2]/(L^2)))[[2]]&@@@record[[50;;]],{-1,1,2/9}]

Show[Histogram[(ArcTan@@(Transpose[#1].Total[#2]))&@@@record,{-π,π,2π/17},"PDF"],Plot[(1+Cos[3θ])/2,{θ,-π,π}]]

record={};ss=Nest[wolffStep[g,ZPotts[{1,Cos[2π/3],Cos[4π/3]},0.01{0,Cos[π/6],Cos[2π/3+π/6]}],rotGenPotts[3],1/Log[1+(Sqrt[3])]],ss,10];

record={};ss=Nest[metropolisSweep[g,J[0],2/Log[1+(Sqrt[2])]],ss,30];

test=Flatten[(n|->((trans|->Grid[{{ArrayPlot[Partition[Rest[trans[[1]]],L],ColorRules->{0->Black,2->White,1->Gray,100->Red},ImageSize->2 160],ArrayPlot[{{First[trans[[1]]]}},ColorRules->{0->Black,1->Gray,2->White,100->Red},ImageSize->2 10]},{ArrayPlot[Partition[Rest[trans[[2]]],L],ColorRules->{0->Black,2->White,1->Gray,100->Red},ImageSize->2 160],ArrayPlot[{{First[trans[[2]]]}},ColorRules->{0->Black,1->Gray,2->White,100->Red},ImageSize->2 10]}}])@{ReplacePart[record[[n,1]],{#+1}&/@record[[n,2,;;#]]->100],ReplacePart[Mod[record[[n,1]]-record[[n,1,1]],3],{#+1}&/@record[[n,2,;;#]]->100]})&/@(Range[Length[record[[n,2]]]+1]-1))/@Range[Length[record]]][[;;;;L]];

test[[1]]

test=Flatten[(n|->((trans|->Row[{ArrayPlot[Partition[Rest[trans],L],ColorRules->{0->Black,2->White,1->Gray,100->Red},ImageSize->2 160],ArrayPlot[{{First[trans]}},ColorRules->{0->Black,1->Gray,2->White,100->Red},ImageSize->2 10]},Spacer[30]])@ReplacePart[Mod[record[[n,1]]-record[[n,1,1]],3],{#+1}&/@record[[n,2,;;#]]->100])&/@(Range[Length[record[[n,2]]]+1]-1))/@Range[Length[record]]][[;;;;L]];

Row[{ArrayPlot[Partition[Rest[ss],L],ColorRules->{-1->Black,1->White,2->Red},ImageSize->2 160],ArrayPlot[{{First[ss]}},ColorRules->{-1->Black,1->White,2->Red},ImageSize->2 10]},Spacer[30]]

test[[1]]

test=Flatten[(n|->ArrayPlot[Partition[ReplacePart[Rest[record[[n,1]]],List/@record[[n,2,;;#]]->2],L],ColorRules->{-1->Black,1->White,2->Red}]&/@(Range[Length[record[[n,2]]]+1]-1))/@Range[Length[record]]][[;;;;64]];

test=Flatten[(n|->ArrayPlot[Partition[Rest[record[[n,1]]],L],ColorRules->{-1->Black,1->White,2->Red}])/@Range[Length[record]]][[;;;;64]];

Length[test]/8/30/60//N

Range[16][[;;;;8]]

Export["/tmp/test.avi",test,FrameRate->30];

v2=Row[{VectorPlot[{0,1},{x,0,1},{y,0,1},FrameLabel->None,FrameTicks->False,ImageSize->2 160,VectorStyle->{Black,Arrowheads[0.04]}],Graphics[{Thick,Arrowheads[.3],Arrow[{{0,-1},{0,1}}]},ImageSize->2 20]},Spacer[30]]

v1=Row[{VectorPlot[{Sin[2],Cos[2]},{x,0,1},{y,0,1},FrameLabel->None,FrameTicks->False,ImageSize->2 160,VectorStyle->{Black,Arrowheads[0.04]}],Graphics[{Thick,Arrowheads[.3],Arrow[{{-Sin[θ],-Cos[θ]},{Sin[θ],Cos[θ]}}/.θ->2]},ImageSize->2 20]},Spacer[30]]

Export["~/doc/research/sethna/pres/aps_mm_2018/figs/vector-1.svg",v1];

p1=Row[{Graphics[{Thick,Arrowheads[.03],Table[{Arrow[{{n,m},{n,m+1}}],Arrow[{{n,m},{n+Sin[2π/3]/Cos[2π/6],m+Cos[2π/3]/Cos[2π/6]}}],Arrow[{{n,m},{n+Sin[4 π/3] Cos[2 π/6],m+Cos[4 π/3] Cos[2 π/6]}}]},{n,-10,10,2},{m,-10,10,2}]},ImageSize->2 160],Graphics[{Thick,Arrowheads[.3],Arrow[{{-1,0},{1,0}}]},ImageSize->2 20]},Spacer[30]]

Export["~/doc/research/sethna/pres/aps_mm_2018/figs/potts.svg",p1];