Simulating Experiences:
 Excursions in Programming

Percolation Clustering

Mathematica in Education
Vol.2 No.2
(Winter 1992/93)

by

Richard J. Gaylord
Department of Materials Science
University of Illinois at Urbana Champaign
gaylord@ux1.cso.uiuc.edu

Figure 1

sitePercolation[p_, m_Integer] := 
	Table[Floor[1 + p - Random[]], {m}, {m}]

SeedRandom[2]
r = sitePercolation[0.35, 9];

Fig1.eps (color)

Show[Graphics[RasterArray[
   Reverse[r]/.{1->RGBColor[1,0,0],0->RGBColor[0,1,0]}]],	
   AspectRatio->1]

Fig1.eps (B&W)

Show[Graphics[RasterArray[
   Reverse[r]/.{1->GrayLevel[.67],0->GrayLevel[.33]}]],	
   AspectRatio->1]

Figure 2

Fig2.eps (color)

clusterLabel[p_, m_Integer, n_Integer] := 
 	Block[{up := u[[q-1, k]], back := u[[q, k-1]], 
			 ulup := ul[[q-1, k]], ulback := ul[[q, k-1]]}, 
 
 r = Reverse[Transpose[Map[(Floor[1 + p - #])&, Table[Random[], {i, m}, {j, n}]]]];
 AddZeroRow[w_] := Prepend[w, Table[0, {Length[w[[1]]]}]];
 u = Transpose[AddZeroRow[Transpose[AddZeroRow[r]]]];
 Print[ MatrixForm[Reverse[u]]];
 ul = Table[0, {n +1}, {m+1}];
 ulp = {};
 
 Do[ 
 Which[u[[q, k]] ==1 && up == 1 && back ==1 && ulup =!= ulback,
 ul[[q, k]] = Min[ulp[[ulback]], ulp[[ulup]] ];
 ulp[[Max[ulp[[ulback]], ulp[[ulup]]] ]] =
Min[ulp[[ulback]], ulp[[ulup]]],
 u[[q, k]] == 1 && up == 1, ul[[q, k]] = ulup,
 u[[q, k]] == 1 && back == 1, ul[[q, k]] = ulback,
u[[q, k]] == 1, ul[[q, k]] = Max[ul] + 1; AppendTo[ulp, Max[ul]]], 
 {q, 2, n+1}, {k, 2, m+1}];

new = Range[Length[ulp]];
relabelrules1 = Thread[ new->ulp];
correctlabels = ulp//.relabelrules1;
relabelrules2 = Thread[ new->correctlabels];
ufinal = ul/.relabelrules2;
Print["ufinal"];
Print[MatrixForm[Reverse[ufinal]]];
clusternumbers = Union[ Flatten[ufinal]];

Show[Graphics[RasterArray[ufinal/.Thread[clusternumbers->
 Map[RGBColor, Table[{Random[],Random[],Random[]},
 {Length[clusternumbers]}]]/.RGBColor[{x__}]->RGBColor[x]] ]], 
 Axes->None, AspectRatio->1]
 ]

SeedRandom[0]
clusterLabel[ 0.54, 9, 9]

Fig2.eps (B&W)

clusterLabel[p_, m_Integer, n_Integer] := 
	Block[{up := u[[q-1, k]], back := u[[q, k-1]], 
			 ulup := ul[[q-1, k]], ulback := ul[[q, k-1]]}, 
		r = Reverse[Transpose[Map[(Floor[1 + p - #])&, 
																							Table[Random[], {i, m}, {j, n}]]]];
 AddZeroRow[w_] := Prepend[w, Table[0, {Length[w[[1]]]}]];
u = Transpose[AddZeroRow[Transpose[AddZeroRow[r]]]];
Print[ MatrixForm[Reverse[u]]]; 
ul = Table[0, {n +1}, {m+1}];
ulp = {};
Do[ 
Which[u[[q, k]] ==1 && up == 1 && back ==1 && ulup =!= ulback, 
  			ul[[q, k]] = Min[ulp[[ulback]], ulp[[ulup]] ]; 
 			 ulp[[Max[ulp[[ulback]], ulp[[ulup]]] ]] =
 																					Min[ulp[[ulback]], ulp[[ulup]]],                     
               	
   			u[[q, k]] == 1 && up == 1, ul[[q, k]] = ulup,
      		 u[[q, k]] == 1 && back == 1, ul[[q, k]] = ulback,
 		 		 u[[q, k]] == 1, ul[[q, k]] = Max[ul] + 1; 
 		 		 																AppendTo[ulp, Max[ul]]], 
 		 {q, 2,n+1}, {k, 2, m+1}];
new = Range[Length[ulp]];
relabelrules1 = Thread[ new->ulp];
correctlabels = ulp//.relabelrules1;
relabelrules2 = Thread[ new->correctlabels];
ufinal = ul/.relabelrules2;
Print["ufinal"];  
Print[MatrixForm[Reverse[ufinal]]];
clusternumbers = Union[ Flatten[ufinal]];
Show[Graphics[RasterArray[
     	ufinal/.Thread[clusternumbers->
   		Map[GrayLevel, Table[{Random[]},
   		{Length[clusternumbers]}]]/.GrayLevel[{x__}]->
   			GrayLevel[x]] ]], Axes->None, AspectRatio->1]
     ]

SeedRandom[0]
clusterLabel[ 0.54, 9, 9]