(* 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 *)


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 *)

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 *)


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 *)




(* Here is code for the chaos game, for problems 4-6 *)

h1[{x_, y_}] := N[{x/3, y/3}]
h2[{x_, y_}] := N[{x/3, y/3 + 1/3}]
h3[{x_, y_}] := N[{x/3 + 1/3, y/3}]
h4[{x_, y_}] := N[{x/3 + 1/3, y/3 + 1/3}]
h5[{x_, y_}] := N[{x/3 + 2/3, y/3}]
h6[{x_, y_}] := N[{x/3 + 2/3, y/3 + 1/3}]
h7[{x_, y_}] := N[{x/3 + 2/3, y/3 + 2/3}]
functionlist := {h1, h2, h3, h4, h5, h6, h7}

(* This defines seven contraction maps to be used in the iterated function system for 4(b), and then collects them into a list *)

hch[{x_, y_}] := RandomChoice[functionlist][{x, y}]

(* This defines a function which randomly chooses one of the maps in the input list and applies it *)

(* It is also possible to code the function to make weighted choices according to a given probability list; see the documentation for RandomChoice for more information.  Weighted choices are not used on our assignments, but you may want to give them a try anyway: they're fun! *)


fracpoints := fracpoints = Drop[NestList[hch, {0.1, 0.1}, 301000], 1000] 

(* This will compute 301000 iterates of the chaos game applied to the starting point {0.1,0.1} and then delete the first 1000 terms, to clean up any slow convergence at the beginning *)

(* The double assignment causes Mathematica only to generate the list once, rather than recomputing it each time the computation is run *)


fracplot[n_] := 
 ListPlot[fracpoints[[1 ;; n]], Axes -> True, 
  PlotStyle -> Directive[Black, PointSize[0.0010]], AspectRatio -> 1, 
  PlotLabel -> StringJoin["IFS plotted with ", ToString[n], " total points"]]

ifs4bplot = fracplot[100000]

(* This will plot the first n points in the list of points, using black points with size 0.0010, and a title that displays the number of points used.  It may be advisable to change the point size if more points are plotted to create a higher-resolution picture. *)







(* For problem 7 *)


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 *)