oftenpaper.net

Module[{options = {
     Axiom -> None, Rules -> {}, Iterations -> 1, Definitions -> {},
     DrawStyle -> {}, HatStyle -> {}, Primitive -> Tube, TraceHat -> False,
     HatWorldplaneStyle -> Directive[EdgeForm[None], Opacity[.2]],
     HatPrimitive -> Composition[Arrow, Tube], Angle -> 2. Pi/6,
     RandomStuff -> Sphere[{0, 0, 0}, .05]}},

  SetAttributes[Draw, Orderless];

  Draw[commands : {Except[_Rule | _RuleDelayed] ..},
    rules : {(_Rule | _RuleDelayed) ..}, rest___] := Draw[Axiom -> commands, Rules -> rules, rest];                
  Draw[rules : {(_Rule | _RuleDelayed) ..}, rest___] := Draw[Rules -> rules, rest];
  Draw[commands : {Except[_Rule | _RuleDelayed] ..}, rest___] := Draw[Axiom -> commands, rest];
  Draw[opts : OptionsPattern[Join[Options[Graphics3D], options]]] :=
   Module[{commands, reshape, states, points, hatTrace, hatWorldplane,
     forwardP, leftP, frontflipP, tacoleftP, flipoutP, pushI, popI, definitionsI},

    (*basic parameterized state transfer functions*)
    forwardP[p_][{z_, face_, hat_}] := {z + p face, face, hat};
    leftP[p_][{z_, face_, hat_}] := {z, RotationTransform[p, hat][face], hat};
    tacoleftP[p_][{z_, face_, hat_}] := {z, face, RotationTransform[p, face][hat]};
    frontflipP[p_][{z_, face_, hat_}] := Module[{rot},
      rot = RotationTransform[p, Cross[hat, face]];
      {z, rot[face], rot[hat]}];
    flipoutP[p1_, p2_] := Composition[frontflipP[-p2], tacoleftP[-p1]];

    (*general function. fit elements of l1 into structure of l2*)
    reshape[l1_, l2_] := Module[{i = 1, length = Length[l1]},
      Map[l1[[Mod[i++, length, 1]]] &, l2, {-1}]];

    (*LIFO stack*)
    {pushI, popI} = Module[{stack = {}},
      {(AppendTo[stack, #]; #) &,
       Module[{val = Last[stack]},
         stack = Most[stack];
         val] &}];

    With[{vars = First /@ options},
     Module[vars, vars = OptionValue[vars];



     

      If[Axiom === None && Rules =!= {}, Axiom = Rules[[1, 1]]];(*default axiom*)
      Axiom = Flatten[{Axiom}];(*normalize to list/directive*)
      {DrawStyle, HatStyle, HatWorldplaneStyle} = Directive /@ {DrawStyle, HatStyle, HatWorldplaneStyle};

      Definitions = Join[Definitions, {
         F -> forward, B -> backward, L -> left, R -> right, FO -> flipout, FO[p_] :> flipout[p],
         FF -> frontflip, BF -> backflip, TL -> tacoleft, TR -> tacoright}];

      definitionsI = {
        forward[p_] :> forwardP[p], backward[p_] :> forwardP[-p], left[p_] :> leftP[p],
        right[p_] :> leftP[-p], tacoleft[p_] :> tacoleftP[-p], tacoright[p_] :> tacoleftP[p],
        frontflip[p_] :> frontflipP[p], backflip[p_] :> frontflipP[-p], forward -> forwardP[1],
        backward -> forwardP[-1], left -> leftP[Angle], right -> leftP[-Angle], tacoleft -> tacoleftP[-Angle],
        tacoright -> tacoleftP[Angle], frontflip -> frontflipP[Angle], backflip -> frontflipP[-Angle],
        flipout -> flipoutP[Angle, Angle], flipout[p1_] :> flipoutP[p1, Angle],
        flipout[p1_, p2_] :> flipoutP[p1, p2], push -> pushI,
        pop -> Sequence[popI, Identity](*preadjustment for reshape*)};

      (*note no memoization. if you try, keep in mind case of RuleDelayed*)
      commands = Nest[Flatten[Replace[#, Rules, {1}]] &, Axiom, Iterations];
      commands = Flatten[((# /. Definitions) /. definitionsI) & /@ commands];
      states = ComposeList[commands, N@{{0, 0, 0}, {0, 1, 0}, {0, 0, 1}}];

      points = reshape[First /@ states, Split[popI === # & /@ Join[{0}, commands]]];(*pop is turtle teleportation*)
      points = Composition[First /@ # &, Split] /@ points;(*delete duplicate points*)

      Graphics3D[{
        {RandomStuff /. None -> {}, {DrawStyle, Primitive[points]}},
        If[TraceHat,
         hatTrace = {#1, #1 + 2 #3/5} & @@@ states;
         hatTrace = First /@ Split[hatTrace];(*delete duplicate hats*)

         hatWorldplane = Polygon[{#1, #2, #4, #3} & @@ Flatten[#, 1]] & /@ Partition[hatTrace, 2, 1];
         {{HatStyle, HatPrimitive[hatTrace]}, {HatWorldplaneStyle, hatWorldplane}}, {}]},
       Quiet@FilterRules[{opts}, Options[Graphics3D]], Boxed -> False]]]]];

Draw[
 {X, push, BF, L, X, R, R, X, pop, R, X, L, TL, L, X, R, F},
 {F -> {F, BF, push, L, X, R, R, X, pop, R, X, L, L, X, R, F},
  X -> {F, BF, push, L, F, R, R, R, F, pop, R, F, L, L, F, R, F}},
 Iterations -> 3, DrawStyle -> {Opacity[.65], Glow[Darker[Red, 2/3]]},
 Definitions -> {X -> Identity}, Angle -> Pi/8]