(* You should be able to copy and paste this text file directly into Mathematica.  These notes will be interpreted as commented code. *)




(* For problem 1: code for drawing the squared Koch curve *)


kochintervalsqu[point1_, point2_] := 
 N[{point1, (3*point1 + 2*point2)/5, (3*point1 + 2*point2)/5 + {{0, -1}, {1, 0}}.(point2 - point1)/5, (2*point1 + 3*point2)/5 + {{0, -1}, {1, 0}}.(point2 - point1)/5, (2*point1 + 3*point2)/5, point2}]

kochitersqu[pointlist_] := Flatten[Table[kochintervalsqu[pointlist[[n]], pointlist[[n + 1]]], {n, 1, Length[pointlist] - 1}], 1]

(* Here is code that will compute the successive points on the squared Koch curve fractal and store them as a list of points.  There are more refined ways of doing it, but the code takes each pair of consecutive points and computes the intermediate points in the next stage of the fractal *)

nthkochiterplotsqu[n_] := ListLinePlot[Nest[kochitersqu, {{0, 0}, {1, 0}}, n], Joined -> True, Axes -> False, PlotRange -> {{0, 1}, {-0.01, 0.25 + 0.01}}, AspectRatio -> Automatic, PlotLabel -> StringJoin["Stage ", ToString[n], " of squared Koch curve construction"]]

(* This draws the nth iterate of the squared Koch curve fractal, and puts an automatic title on it labeled with the stage number *)

nthkochiterplotsqu[6]

(* This will draw the 6th iterate of the squared Koch curve fractal *)






(* For problem 2: code for drawing Pascal's triangle modulo n *)

binomptsarray[maxval_,modulus_] := Table[Table[Mod[Binomial[n, k], modulus], {k, 0, n}], {n, 0, maxval}]

(* Here is code that will compute the binomial coefficients (n choose k), up to a given bound and modulo a given integer, and then put them into an array *)

ArrayPlot[binomptsarray[3^6, 3], ColorRules -> {0 -> Blue, 1 -> White, 2 -> Red}]

(* This will plot the binomial coefficients up to 3^6 modulo 3 according to the given rules: 0 mod 3 is blue, 1 mod 3 is white, 2 mod 3 is red.  Most standard colors can be referred to by name *)







(* For problem 3: code as given in the statement *)


Nest[Subsuperscript[#, #, #] &, x, 6]

(* This is the code from problem 3. *)

subper[x_]:= Subsuperscript[x,x,x]
Nest[subper,x,6]

(* An equivalent way of performing the same thing *)







(* For problem 4: code for drawing the Vicsek box fractal *)


vicsekbox[n_] :=
  Nest[Flatten[Table[{
       {#[[i, 1]], (2*#[[i, 1]] + #[[i, 2]])/3, (#[[i, 3]] + 2*#[[i, 1]])/3, (#[[i, 4]] + 2*#[[i, 1]])/3},
       {(#[[i, 1]] + 2*#[[i, 2]])/3, #[[i, 2]], (2*#[[i, 2]] + #[[i, 3]])/3,  (2*#[[i, 2]] + #[[i, 4]])/3}, 
       {(#[[i, 1]] + 2*#[[i, 3]])/3, ( #[[i, 2]] + 2*#[[i, 4]])/3, (2*#[[i, 1]] + #[[i, 3]])/3,  (2*#[[i, 2]] + #[[i, 4]])/3}, 
       {(2*#[[i, 4]] + #[[i, 1]])/3, (2*#[[i, 4]] + #[[i, 2]])/3, (2*#[[i, 4]] + #[[i, 3]])/3, #[[i, 4]]}, 
       {(2*#[[i, 4]] + #[[i, 1]])/3, (2*#[[i, 4]] + #[[i, 2]])/3, (2*#[[i, 4]] + #[[i, 3]])/3, #[[i, 4]]}, 
       {(2*#[[i, 3]] + #[[i, 1]])/3, (2*#[[i, 3]] + #[[i, 2]])/3, #[[i, 3]], (2*#[[i, 3]] + #[[i, 4]])/3}}, 
     {i, Length[#]}], 1] &, {{{0, 0}, {0, 1}, {1, 1}, {1, 0}}}, n]

(* Here is code that will compute the corner points of each of the cells in the Vicsek box fractal and store them as a list of quadruples {p1, p2, p3, p4}.  There are more refined ways of doing it, but the code takes each list of quadruples {p1, p2, p3, p4} corresponding to the corner points of a cell and outputs a list of 5 quadruples corresponding to the new vertices of the cells in the next iterate *)

vicsekboxplot[n_] := 
  Show[Graphics[{Pink, Map[Polygon, vicsekbox[n], 1]}, 
    AspectRatio -> 1, 
    PlotLabel -> 
     StringJoin["Stage ", ToString[n], 
      " of Vicsek box contruction"]]]

vicsekboxplot[2]

(* This will draw the second iterate of the Vicsek box fractal.  The function Map[Polygon, datapoints] will create a list of polygons corresponding to each of the cells in the Vicsek box fractal, and then Show[Graphics[...]] will plot all of these polygons *)







(* For problem 6: code for the tent map and computing its cycles *)

T[x_]:= Piecewise[{{2 x, 0 <= x < 1/2}, {2 - 2 x, 1/2 <= x <= 1}}] 

(* This defines the tent map T *)


Reduce[T[T[x]]==x && Not[T[x]==x]]

(* This will find the period-2 points of T *)


perpts4 := List[ToRules[Reduce[T[T[T[T[x]]]] == x && Not[T[T[x]] == x]]]]

(* This will produce a list of the period-4 points of T, arranged as a Boolean list of "or" statements.  Reduce takes in a logical statement and reduces it to a simpler one, which in this case will make a list of all the values of x satisfying T^4[x]==x but not T^2[x]==x *)
(* The function ToRules will convert this output into a sequence of replacement rules, which is the output format given by functions like Solve; the function List converts this sequence into a list of replacement rules *)


percycs4 := NestList[T, x, 3] /. perpts4
percycs4

(* This will generate all the 4-cycles for T, though each of them will appear several times *)


perpts5 := perpts5 = 
  List[ToRules[
    Reduce[T[T[T[T[T[x]]]]] == x && Not[T[T[x]] == x] && 
      Not[T[x] == x]]]]
percycs5 := percycs5 = NestList[T, x, 5 - 1] /. perpts5
minptslist5 := minptslist5 = 
  DeleteDuplicates[Table[Min[percycs5[[n]]], {n, 1, Length[percycs5]}]]
cyclelist5 := cyclelist5 = 
  Table[NestList[T, minptslist5[[n]] , 5 - 1], {n, 1, 
    Length[minptslist5]}]
cyclelist5

(* Here is the same code modified to compute the 5-cycles.  The perpts5 := perpts5 = ... construction tells Mathematica to remember the values it computes, to prevent it from recomputing the list repeatedly as it performs the computations. *)