Catastrophes in Complex Systems

Simulating Experiences: 
Excursions in Programming

Mathematica code as it appeared in Mathematica in Education,
Volume 2 Number 1, Fall 1992

Richard J. Gaylord
Department of Materials Science
University of Illinois, Champaign
Champaign, IL 61801
gaylord@ux1.cso.uiuc.edu

(Mathematica version 2.1)

Graphics set up

<<Graphics`Graphics3D`

Color catastrophe (animation)

catastrophe[s_Integer] := Module[{},
		initconfig = Table[Random[Integer,{0,3}], {s},{s}];
		initconfig[[Random[Integer,{1,s}],Random[Integer,{1,s}]]] = 4;

		absorbingBC =
			(Prepend[Append[Map[Prepend[Append[#,0],0]&,#],
				Table[0,{Length[#]+2}]],Table[0,{Length[#]+2}]])&;

		topples = (Map[(If[#>3,#-4,#])&,#,{2}])&; 

		nbHgts = (Count[Flatten[#][[{2,4,6,8}]],4|5|6|7])&;

		increments = (Map[nbHgts,Partition[absorbingBC[#],{3,3},{1,1}],{2}])&;

		frames = FixedPointList[(topples[#]+increments[#])&,initconfig];

		Map[(BarChart3D[frames[[#]],
			PlotRange->{{0,s+1},{0,s+1},{0,7}}])&,Range[Length[frames]]]
];

SeedRandom[1]

catastrophe[8]

Color catastrophe (GraphicsArray)

catastropheG[s_Integer] := Module[{},
		initconfig = Table[Random[Integer,{0,3}], {s},{s}];
		initconfig[[Random[Integer,{1,s}],Random[Integer,{1,s}]]] = 4;

		absorbingBC =
			(Prepend[Append[Map[Prepend[Append[#,0],0]&,#],
				Table[0,{Length[#]+2}]],Table[0,{Length[#]+2}]])&;

		topples = (Map[(If[#>3,#-4,#])&,#,{2}])&; 

		nbHgts = (Count[Flatten[#][[{2,4,6,8}]],4|5|6|7])&;

		increments = (Map[nbHgts,Partition[absorbingBC[#],{3,3},{1,1}],{2}])&;

		frames = FixedPointList[(topples[#]+increments[#])&,initconfig];

	p1 = Table[
	 BarChart3D[frames[[j]],PlotRange->{{0,s+1},{0,s+1},{0,7}},
	 	DisplayFunction->Identity],
	 	{j,1,6}];
  Show[GraphicsArray[Partition[p1,3]]]
];

SeedRandom[1]

catastropheG[8]

ListDensityPlot catastrophe (animation)

catastropheD[s_Integer] := Module[{},
		initconfig = Table[Random[Integer,{0,3}], {s},{s}];
		initconfig[[Random[Integer,{1,s}],Random[Integer,{1,s}]]] = 4;

		absorbingBC =
			(Prepend[Append[Map[Prepend[Append[#,0],0]&,#],
				Table[0,{Length[#]+2}]],Table[0,{Length[#]+2}]])&;

		topples = (Map[(If[#>3,#-4,#])&,#,{2}])&; 

		nbHgts = (Count[Flatten[#][[{2,4,6,8}]],4|5|6|7])&;

		increments = (Map[nbHgts,Partition[absorbingBC[#],{3,3},{1,1}],{2}])&;

		frames = FixedPointList[(topples[#]+increments[#])&,initconfig];

		Map[(ListDensityPlot[7 - frames[[#]] ])&,
			Range[Length[frames]]]
		];

catastropheD[16]

ListDensityPlot catastrophe (GraphicsArray)

catastropheDGG[s_Integer] := Module[{},
		initconfig = Table[Random[Integer,{0,3}], {s},{s}];
		initconfig[[Random[Integer,{1,s}],Random[Integer,{1,s}]]] = 4;

		absorbingBC =
			(Prepend[Append[Map[Prepend[Append[#,0],0]&,#],
				Table[0,{Length[#]+2}]],Table[0,{Length[#]+2}]])&;

		topples = (Map[(If[#>3,#-4,#])&,#,{2}])&; 

		nbHgts = (Count[Flatten[#][[{2,4,6,8}]],4|5|6|7])&;

		increments = (Map[nbHgts,Partition[absorbingBC[#],{3,3},{1,1}],{2}])&;

		frames = FixedPointList[(topples[#]+increments[#])&,initconfig];

		p2 = Table[ListDensityPlot[7-frames[[j]],DisplayFunction->Identity],
			  {j,1,9}];
		Show[GraphicsArray[ Partition[p2,3] ]]
	]

catastropheDGG[16]