LSystems in Shem

gistfile1.txt

Rules (type (Map Char String))
System (record angle: Num base: (List Char) rules: Rules)

tree (fn [angle] (System angle
    {\M}
    (Map
      \M "N[-M][+M][NM]"
      \N "NN"
      \[ "["
      \] "]"
      \+ "+"
      \- "-")))

l-system (fn [system n]
  (trace
    (expand-one mapper
      (expand (System.rules system) (System.base system) n))
    (System.angle system)
    [1 0.7 0.5]))

lookup-char (fn [char from]
  (chars (get char from)))

expand-one (fn [rules base]
  (concat-map (lookup-char from: rules) base))

expand (fn [rules base n]
  (reapply (expand-one rules) base n))

reapply (fn [what input n]
  (match n
    0 input
    else (reapply what (what input) (- 1 n))))

Vertex (type [Num Num])
Angle (type Num)
TurtleState (type [Vertex Angle])

move (fn [command state rotation]
  (match command
    \F [[(+ x (cos a)) (+ y (sin a))] angle]
    \L [pos (+ rotation angle)]
    \R [pos (- rotation angle)])
  [x y] pos
  a (radians angle)
  [pos angle] state)

Color (type [Num Num Num])
ColoredLine (type [Vertex Vertex Color])

trace (fn [commands rotation color]
  lines
  [end empty lines] (fold step [initial {} {}] commands)
  step (fn [current command]
    (match command
      \[ [state (& state stack) lines]
      \] [(head stack) (tail stack) lines]
      dir (do-move dir))
    [state stack lines] current
    do-move (fn [command]
      [next stack (& [from to color] lines)]
      [to _] next
      [from _] state
      next (move command state rotation)
      c [(/ 300 (length lines)) 0.5 0])
    [r g b] color)
  initial [[0 0] 270])

mapper (Map
  \M "F"
  \N "F"
  \+ "R"
  \- "L"
  \[ "["
  \] "]")

canvas (fn [contents]
  (tag "svg" {
      width: "500"
      height: "500"}
    (implode contents)))

svg-line (fn [line]
  (tag "line" {
      x1: (x x1)
      y1: (y y1)
      x2: (x x2)
      y2: (y y2)
      stroke: (css-color color)
      stroke-width: "3"} "")
  [[x1 y1] [x2 y2] color] line
  x (fn [x] (format "%i" (round (+ 250 (* 5 x)))))
  y (fn [x] (format "%i" (round (+ 400 (* 5 x))))))

css-color (fn [color]
  (format "rgb(%i, %i, %i)" (byte r) (byte g) (byte b))
  [r g b] color
  byte (* 255))

tag (fn [tag-name attrs content]
  (format "<%s%s>%s</%s>"
    tag-name
    (implode-map (uncurry attr) (entry-list attrs))
    content
    tag-name)
  attr (fn [name value]
    (format " %s=\"%s\"" name value)))