Re: Neujahrsraetsel 2003

[su.krause@XXXXXXX.ch]

Liebe Freunde von Mathematica,

weil niemand auf das Neujahrsraetsel geantwortet hatte, ist hier die
offizielle Loesung:

In[6]:=
(* in an equilateral triangular lattice one applies in each of the three
\
directions (edges) a cellular automaton rule,
  not necessarily the same one. *)

Remove[triangularCA, getLine, setLine, applyRule, makeTriangles];

getLine[llc_List, nr_Integer?NonNegative] :=
  Module[{ls, o},
    ls = {};
    Switch[Mod[nr, 3],
      0, ls = Last[llc],
      1, For[o = 1, o \[LessEqual] Length[llc], o++,
        If[o \[Equal] 1, ls = First[llc],
          ls = {ls, llc[[o, 2]], llc[[o, 1]]}]],
      2, For[o = Length[llc], o > 0, o--,
        If[o \[Equal] 1, ls = {ls, First[llc]},
          ls = {ls, llc[[o,-1]], llc[[o,-2]]}]]
      ];
    Flatten[ls]
    ]

setLine[ls_List, llc_List, nr_Integer?NonNegative] :=
  Module[{lr, o},
    Switch[Mod[nr, 3],
      0, lr = Append[llc, ls],
      1, lr = {{First[ls]}}; For[o = 1, o \[LessEqual] Length[llc], o++,

        lr = Append[lr, Flatten[{ls[[2 o + 1]], ls[[2 o]], llc[[o]]}]]],

      2, lr = {};
      For[o = Length[llc], o > 0, o--,
        lr = Prepend[lr, Flatten[{llc[[o]], ls[[-2 o]], ls[[-2o -
1]]}]]];
      lr = Prepend[lr, {Last[ls]}]
      ];
    lr
    ]

applyRule[r_Integer?Positive, ls_List] :=
  Module[{},
    Part[IntegerDigits[r, 2,
            8], #]& /@ (1 + (FromDigits[#, 2]& /@
              Partition[Join[{0, 0}, ls, {0, 0}],3, 1]))
    ]

makeTriangles[llc_List] :=
  Module[{l0 = 1, shift, v, sp3 = Sin[Pi/3], triL, ll, o, oo},
    v = {{{l0, 0}, l0 {1/2, sp3}}, {l0 {-1/2, sp3}, l0 {1/2, sp3}}};
    (* the first element in the first List of lcc is printed as
equilateral \
triangle with a horizontal edge of length l0 and the top corner at the
co-
        ordinate origin *)
    triL = {};
    For [o = 1, o \[LessEqual] Length[llc], o++,
      ll = llc[[o]];
      For[oo = 1, oo \[LessEqual] Length[ll], oo++,
        shift = l0(-o {1/2, sp3} + Floor[oo/2] {1, 0});
        If[ll[[oo]] \[Equal] 0, (* then *)
          triL ={triL,
              Line[{shift, shift + v[[If[OddQ[oo],1, 2], 1]],
                  shift +v[[If[OddQ[oo], 1, 2], 2]], shift}]}, (* else
*)

          triL = { triL,
              Polygon[{shift, shift + v[[If[OddQ[oo], 1, 2], 1]],
                  shift + v[[If[OddQ[oo], 1, 2], 2]]}]}
          ]
        ]
      ];
    Flatten[triL]
    ]

triangularCA[{r1_Integer?Positive, r2_Integer?Positive,
r3_Integer?Positive},
    nr_Integer?Positive] :=
  Module[{llc, o, car},
      car = {r1, r2, r3};
      llc = {{1}};
      For[o = 0, o < nr, o++,
        ls = applyRule[car[[Mod[o, 3] + 1]], getLine[llc, o]];
        llc = setLine[ls, llc, o]
        ];
      Show[Graphics[makeTriangles[llc]],
        Frame \[Rule] True, PlotRange \[Rule] All,
        PlotLabel \[Rule]
          "CA Rules: "<> ToString[car] <> " Iterations: " <>
ToString[nr],
        AspectRatio \[Rule] 2 Sin[Pi/3] Length[llc]/(1 +
Length[Last[llc]])
        ]
      ] /; r1 < 256 && r2 < 256 && r3 < 256

Mit den besten Gruessen
Udo.