Skip to content

Instantly share code, notes, and snippets.

Created March 13, 2015 11:55
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
What would you like to do?
LSystems in Shem
Rules (type (Map Char String))
System (record angle: Num base: (List Char) rules: Rules)
tree (fn [angle] (System angle
\M "N[-M][+M][NM]"
\N "NN"
\[ "["
\] "]"
\+ "+"
\- "-")))
l-system (fn [system n]
(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]
[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>"
(implode-map (uncurry attr) (entry-list attrs))
attr (fn [name value]
(format " %s=\"%s\"" name value)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment