Let's Do It Again

MonthName Day, Year

Ed Pegg Jr, Scientific Information Group

Iteration usually increases complexity. For example, ponder the following "Fractal Maze". The green lines mark the boundaries of a frame that shows the black paths of a maze. Copies of that frame and the paths are copied inside. With 4 levels of nested frames, it is possible to get from 1 to 8 on the outer frame. When pictures are repeated inside themselves, it's usually called the Droste effect.

sqr = Table[{{-2,-2},{-2,-1},{-2,1},{-2,2},{-1,2},{1,2},{2,2},{2,1},{2,-1},{2,-2},{1,-2},{-1,-2},{-2,-2}}/(2^n),{n,0,8}];
splines =Table[{
{{-1,2},{-1,3/2},{-4/3,1},{-4/3,1/2},{-1,(1/2)}},
{{-2,1},{ -5/3,1 },{ -3/2, 0},{ -4/3,-1/2 },{-1,-(1/2)}},
{{-2,-1},{ -3/2,-1 },{ -3/2,-4/3 },{ -1, -4/3},{ -1/2,-4/3 },{-(1/2),-1}},
{{(1/2),-1},{ 1/2,-4/3 },{ 1,-4/3 },{4/3,-4/3},{4/3,-1 },{4/3,-1/2 },{1,-(1/2)}},
{{2,1},{ 5/3,1 },{3/2 ,0 },{ 5/3,-1 },{2,-1}},
{{1,2},{ 1, 3/2},{4/3,1 },{ 4/3,1/2 },{1,(1/2)}},
{{-(1/2),1},{-1/2,4/3},{0,3/2},{1/2,4/3},{(1/2),1}},
{{-1,-2},{-1,-4/3}},
{{1,-2},{1,-4/3}}}/(2^n),{n,0,8}];
text = {{1,2},{2,1},{2,-1},{1,-2},{-1,-2},{-2,-1},{-2,1},{-1,2}};
fractalmaze[a_]:= {(Subscript[1, a])-> (Subscript[2, a+1]), (Subscript[2, a])-> (Subscript[3, a]), (Subscript[3, a+1])-> (Subscript[4, a+1]),(Subscript[3, a+1])-> (Subscript[4, a]),(Subscript[4, a])-> (Subscript[4, a+1]),(Subscript[5, a])-> (Subscript[5, a+1]), (Subscript[5, a])-> (Subscript[6, a]), (Subscript[5, a+1])-> (Subscript[6, a]), (Subscript[6, a+1])-> (Subscript[7, a]), (Subscript[8, a])-> (Subscript[7, a+1]), (Subscript[1, a+1])-> (Subscript[8, a+1])};
Manipulate[If[maze,Graphics[{Green,Line/@Take[sqr,level+1],AbsoluteThickness[2],Black,Table[BSplineCurve[#]&/@splines[[n]],{n,1,level}] , 
Black,MapIndexed[Style[Text[#2[[1]],1.05#1],16]&,text] },ImageSize-> {390,390}, PlotRange-> {{-2.2,2.2},{-2.2,2.2}}/zoom],
TreePlot[Flatten[Table[fractalmaze[a],{a,0,level}]],VertexLabeling-> True, ImageSize-> {390,390}]],
{{level,2,"levels to n"},1,8,1, Appearance-> "Labeled"},
{{zoom,1,"zoom in"},1,20,Enabled:>maze},
{{maze,True,""},{  True-> " maze ", False-> " solution "},ControlType-> Setter},
SaveDefinitions->True]

Another simple experiment involves rolling a box around, each time toppling it over an edge. Where can the box wind up? "Box Toppling Patterns" shows how complicated moving a box can get.

Topples[{{p_,q_,r_},{x_,y_,z_}}] :=
With[{a=x-p,b=y-q,c=z-r}, {
{{p+a,q,r},{p+a+c,q+b,r+a}},
{{p-c,q,r},{p,q+b,r+a}},
{{p,q+b,r},{p+a,q+b+c,r+b}},
{{p,q-c,r},{p+a,q,r+b}}}];
Manipulate[Graphics3D[Take[{
Cuboid[{{0,0,0},{a,b,c}}],
Cuboid/@Topples[{{0,0,0},{a,b,c}}],
Cuboid/@Flatten[Topples/@Topples[{{0,0,0},{a,b,c}}],1],
Cuboid/@Flatten[Topples/@Flatten[Topples/@Topples[{{0,0,0},{a,b,c}}],1],1],
Cuboid/@Flatten[Topples/@Flatten[Topples/@Flatten[Topples/@Topples[{{0,0,0},{a,b,c}}],1],1],1]
},stage+1],SphericalRegion-> True,ImageSize->{350,350},Boxed->False, Method-> {"ShrinkWrap"-> True}],
Style["box dimensions",Bold],
{{a,3},2,12,.1,Appearance->"Labeled",ImageSize->Tiny},
{{b,4},2,12,.1,Appearance->"Labeled",ImageSize->Tiny},
{{c,5},2,12,.1,Appearance->"Labeled",ImageSize->Tiny},
{{stage,4},0,4,1,Appearance->"Labeled",ControlPlacement->Top},SaveDefinitions-> True]

A New Kind of Science discusses what a simple program can do at length. Cellular automata, Turing machines, and substitution systems are some of the simple programs that show interesting behavior when iterated. Here is "Turing Machines with Cyclic Tapes" (Stephen Wolfram and Kovas Boguta).

Manipulate[ArrayPlot[If[head,MapAt[Blend[{GrayLevel[#],Red}]&,#[[2]],#[[1,2]]]&,Last]/@TuringMachine[rn,{1,Join[{1},Table[0,{t-1}]]},t c][[;;;;t]],ImageSize->{390,390}],
{{rn,2289,"machine number"},0,4095,1,Appearance->"Labeled"},
{{t,62,"width of tape"},10,200,1,Appearance->"Labeled"},
{{c,66,"number of cycles"},5,100,1,Appearance->"Labeled"},
{{head,True,"show head"},{True,False}},
AutorunSequencing->{{1,20}}]

"Reduce, Replicate, Rebuild" (Stephen Face) does just that with a single square, and interesting patterns emerge as the simple operations are repeated.

rotlist={#&,Reverse[Transpose[#]]&,Reverse[#,{1,2}]&,Reverse[Transpose[#],2]&,Reverse[#,2]&,Reverse[#]&,Reverse[Transpose[#],{1,2}]&,Transpose[#]&};
setlist={1->"0°",2->"90°",3->"180°",4->"270°",5->"Horizontal Flip",6->"Vertical Flip",7->"Flip across y=x",8->"Flip across y=-x"};
Manipulate[
frac=Nest[ArrayFlatten[{{rotlist[[tl]][#],0},{rotlist[[bl]][#],rotlist[[br]][#]}}]&,{{1}},n];
ArrayPlot[frac,PixelConstrained-> True,ImageSize->{260,260},Frame->False],
{{n,8,"iterations"},0,9,1,Appearance->"Labeled",ImageSize->Tiny},
{{tl,2,"top-left"},setlist},
{{bl,8,"bottom-left"},setlist},
{{br,1,"bottom-right"},setlist},
SaveDefinitions->True,TrackedSymbols->Manipulate]

In "Orbit Diagram of the Logistic Map", a more classic example of patterns in a repeated figure is shown.

orbitgraphic = Graphics[Show[ListPlot[orbitdata,PlotStyle-> PointSize[0],AspectRatio->1]]];

orbitdata = Flatten[Table[Map[{k,#}&,Drop[NestList[If[#^2 +k>10,0,#^2 +k]&,0,100],50]],{k,-2,0,.01}],1];

Quiet[Manipulate[Show[{orbitgraphic,Graphics[Inset[ListPlot[Flatten[Table[Map[{x,#}&,Drop[NestList[If[#^2 +x>10,0,#^2 +x]&,0,Round[30 mag]],50]],{x,a[[1]]-.5/mag,a[[1]]+.5/mag,.005/mag}],1],PlotStyle-> PointSize[0],AspectRatio->1/2,Frame->True,FrameStyle->Blue, FrameTicks->None,AspectRatio->Automatic,Background->White,Axes->False,PlotRange-> {a[[2]]-.5/mag,a[[2]]+.5/mag},PerformanceGoal->"Speed"],{-.8,1.4},Automatic,1.3]]}],{{a,{-1.5,-.1}},{-2,-2},{-.2,2},Locator, Appearance->Graphics[{Blue,Line[{{0,0},{0,.5},{1,.5},{1,0},{0,0}}]},ImageSize->Round[200/mag]]},
{{mag,3,"magnification"},2,10,Appearance->"Labeled"},ContinuousAction->False,SaveDefinitions->True]]

So, obviously, when faced with thousands of calculations, using a computer can help a lot. But therein lies a danger. Most textbooks list as a property of logarithms that log(a b)=log(a)+log(b). Most of the time that's correct, but unfortunately, there is a branch cut with logarithms. For negative integers, logarithms are discontinuous. More pictures are available at "Surface with Branch Cuts" (Yu-Sung Chang) or "The Monodromy Group of an Algebraic Function" (Maxim Rytin).

Plot3D[Im[Log[a +b I]],{a,-1,1},{b,-1,1}]

Many programming languages ignore branch cuts. Mathematica does not have that luxury—when released in 1988, there were various function combinations that could make nonsensical results. Eventually, most of these errors were resolved by being exceedingly careful with branch cuts. For example, here is a correct method for handling the Log function. Thousands of other examples for how to be careful are given at The Wolfram Functions Site. Many of the most crucial functions have been available for a decade now.

Log[(Subscript[z, 1]) (Subscript[z, 2])]==Log[(Subscript[z, 1])]+Log[(Subscript[z, 2])]+2 I π Floor[((π-Arg[(Subscript[z, 1])]-Arg[(Subscript[z, 2])])/(2 π))]

If you're a fan of fractals, you've probably seen pictures of the Mandelbrot set and the like. The popular fractals are built on continuous functions, such as (x^2). When a discontinuous function is used as the basis of a fractal, the result is a chaotic soup of discontinuities, which tends to be ugly to the human eye.

Why do I mention all this? Financial formulas tend to use many mathematical functions that have discontinuities. They can have bifurcations, which are the basis of catastrophe theory. When such a function is iterated outside of a careful program like Mathematica, the results can be meaningless. Making big financial decisions based on something utterly meaningless billions of times a second can be highly dangerous. Here's a chart of the stock market on May 6, 2010 from Wikipedia.

If lives or fortunes depend on the functions you're combining and iterating, at least make sure that extreme caution went into their construction. Wolfram Research learned the hard way, two decades ago, how combined functions could misbehave. In Mathematica, these dangerous errors have been fixed for a long time. Iterate cautiously.