oftenpaper.net

(* minimal *)

iterate[matrix_, power_, matrix1_: {{1}}] := Module[{rules =
     {0 -> (0 # &), 1 -> (# &), T -> Transpose,
      R -> (Transpose[Reverse[#]] &), L -> (Reverse[Transpose[#]] &)}},

   Nest[Function[prev,
     ArrayFlatten[Map[#[prev] &, matrix /. rules, {2}]]],
    matrix1, power]];

draw[matrix_, power_] :=
  ArrayPlot[iterate[matrix, power],
   Frame -> False, PixelConstrained -> 1];

draw[{{1, 0}, {T, R}}, 10]

matrixInput1[Dynamic[m_], Dynamic[rot_]] :=
  Dynamic[Rotate[Deploy[MatrixForm[#, TableSpacing -> {0, 0}]], rot] &@
    Array[(*(*better performance*)Rotate[#,-rot]&@*)
     EventHandler[Checkbox[Dynamic[m[[##]]], {0, 1}],
       {"MouseDown", 2} :> (m[[##]] = 0)] &,
     Dimensions[m]], 0];

matrixInput2[Dynamic[m_], Dynamic[rules_], Dynamic[color_],
   Dynamic[rot_]] :=
  With[{
    tooltip = Tooltip[#, "Click to cycle\nRight-click to zero", TooltipDelay -> .8] &,
    eatRightClick = EventHandler[#, {"MouseDown", 2} :> {}] &,
    matrixForm = MatrixForm[#, TableSpacing -> {1, 1}] &},

   Dynamic[
    eatRightClick@Style[#, color] &@
       Rotate[#, rot] &@tooltip@Deploy@matrixForm@
        Array[
         EventHandler[Toggler[Dynamic[m[[##]]], First /@ rules],
           {"MouseDown", 2} :> (m[[##]] = 0)] &,
         Dimensions[m]]]];

bg = White;
dims = # -> If[# > 4, Style[#, Red], #] & /@ Range[4];
defaultRules = {0 -> (0 # &), 1 -> (# &), T -> Transpose,
   R -> (Transpose[Reverse[#]] &), L -> (Reverse[Transpose[#]] &)};

iterate[matrix_, matrix1_, rules_, power_] :=
  Nest[
   Function[prev, ArrayFlatten[Map[#[prev] &, matrix /. rules, {2}]]],
   matrix1, power];

controls = With[{
    m1C = Control[{{m1, 2, ""}, dims, ControlType -> PopupMenu}],
    m2C = Control[{{m2, 2, ""}, dims, ControlType -> PopupMenu}],
    matrixInput1C = matrixInput1[Dynamic[matrix1], Dynamic[rot]],
    matrixInput2C = matrixInput2[Dynamic[matrix], Dynamic[rules], Dynamic[color], Dynamic[rot]],
    rulesC = OpenerView[{"Rules", Control[{{rules, defaultRules, ""}, InputField,
         Background -> Dynamic[Lighter[background, .65]], FieldSize -> {45, 5}}]}],
    colorC = Control[{{color, Black}, ColorSlider}],
    rotC = Control[{{rot, 0, "\[Theta]"}, Pi, -Pi, Pi/16}],
    powerC = Control[{{power, 3}, 1, 4, 1, Appearance -> "Labeled"}],
    backgroundC = Row[{"background   ",
       Framed[ColorSlider[Dynamic[background, (bg = background = #) &],
         AppearanceElements -> "Swatch"], FrameStyle -> Darker[Gray]], " ",
       ColorSlider[Dynamic[background, (bg = background = #) &],
        AppearanceElements -> "Spectrum", ImageSize -> Small]}],
    opacityC = Control[{{opacity, 1}, 0, 1, ImageSize -> Small}],
    primitiveC = Control[{{primitive, Rectangle[]},
       (# -> Graphics[{color, #}, ImageSize -> 20] &) /@ {
         {PointSize[Tiny], Point[{0, 0}]},
         {EdgeForm[None], Disk[{0, 0}, .5]},
         Rotate[Scale[Rectangle[], 1/Sqrt[2]], Pi/4],
         Rectangle[]}, SetterBar}]},

   Row[{
     Column[{
       Row[{m1C, "   |", m2C}],
       Row[{"    ", matrixInput1C, "  ", matrixInput2C}]}],
     Spacer[40],
     Column[{rulesC, OpenerView[#, True] &@
        {"Style", Row[{Column[{colorC, rotC, powerC}],
           Column[{backgroundC, opacityC, primitiveC}]}]}}]}]];

bookmarks = {
   "Random" :> (
     matrix1 = RandomChoice[{0, 1}, Dimensions[matrix1]];
     matrix = RandomChoice[First /@ rules, Dimensions[matrix]]),

   "Array Print" :> With[
     {m1 = matrix1, m = matrix, r = rules, p = power, c = color, o = opacity, bg = background},
     CellPrint[ExpressionCell[Defer[
        ArrayPlot[
         iterate[m /. 0 m -> {{1}}, m1 /. 0 m1 -> {{1}}, r, p], PixelConstrained -> 1, Frame -> False,
         ColorRules -> {0 -> bg, 1 -> c /. RGBColor[r_, g_, b_] :> RGBColor[r, g, b, o]}]],
       "Input"]]],

   "Clear" :> (matrix = 0 matrix)};

Panel[#, Background -> Dynamic[bg]] &@
 Manipulate[
  If[{m1, m1} =!= Dimensions[matrix1], matrix1 = PadRight[matrix1, {m1, m1}]];
  If[{m2, m2} =!= Dimensions[matrix], matrix = PadRight[matrix, {m2, m2}]];

  (*remove rules from matrix that no longer exist*)
  Module[{matrixP, default = rules[[1, 1]]},
   matrixP = Replace[matrix, a_ /; ! MemberQ[First /@ rules, a] -> default, {2}];
   If[matrix =!= matrixP, matrix = matrixP]];

  With[{primitives =
     Rotate[Translate[primitive, Position[#, 1]], rot - Pi/2] &@
      iterate[
       matrix /. 0 matrix -> {{1}},
       matrix1 /. 0 matrix -> {{1}}, rules,
       ControlActive[Max[power - 2, 2], power]]},

   Graphics[{Dynamic[EdgeForm[{Opacity[opacity], color}]],
     Dynamic[color], Dynamic[Opacity[opacity]], primitives},
    ImageSize -> {{400, Large}, {400, Large}},
    Background -> Dynamic[background]]],

  (*declare variables here for persistence*)
  {{background, bg = White}, ControlType -> None},
  {{matrix1, {{1, 0}, {1, 1}}}, ControlType -> None},
  {{matrix, {{1, 0}, {1, 1}}}, ControlType -> None},

  Evaluate[controls],
  Bookmarks :> Evaluate[bookmarks],

  LabelStyle -> Darker[Gray], SynchronousUpdating -> Automatic,
  Paneled -> False, SaveDefinitions -> True, Alignment -> Center]