(defun l-system (start rules depth)
  (when (> depth 0)
    (let ((rule-table (make-hash-table :test 'equal)))
      (loop for rule in rules do
            (destructuring-bind (key replacement) rule
              (setf (gethash key rule-table) replacement)))
      (loop for i from 1 to depth do
            (let ((next '()))
              (loop for key in start do
                    (let ((replacement (gethash key rule-table)))
                      (unless replacement
                        (setf replacement (list key)))
                      (setf next (concatenate 'list next replacement))))
              (setf start next)))))
  start)

(defun create-snow (depth)
  (let ((commands (l-system
                   '(
                     k7 + k7 + k7 + k7 + k7 + k7
                     )
                   '(
                     (k (d fff ++++ fff ++++ fff u))
                     (k2 (d fff + fff + fff + fff + fff + fff u))
                     (fff (fff + fff -- fff + fff))
                     (mf (mf mf mf))
                     (k6 (k2 +++ mf k +++ mf k +++ mf k +++ mf k +++ mf k +++ mf k mf))
                     (k7 (k6 k6 k6 k6 k6 k6 mf))
                     )
                   depth)))
    (string-downcase 
     (with-output-to-string (s)
       (loop for i in commands do (princ i s))))))

(defun execute-commands (commands line-function)
  (let ((x 0)
        (y 0)
        (angle 270)
        (pen nil))
    (loop for command across commands do
          (cond
           ((char= #\d command)
            (setf pen t))
           ((char= #\u command)
            (setf pen nil))
           ((char= #\f command)
            (let ((rad (* (/ angle 180) pi)))
              (let ((x2 (+ x (sin rad)))
                    (y2 (+ y (cos rad))))
                (when pen
                  (funcall line-function x y x2 y2))
                (setf x x2
                      y y2))))
           ((char= #\+ command)
            (incf angle 60)
            (when (>= angle 360)
              (decf angle 360)))
           ((char= #\- command)
            (decf angle 60)
            (when (< angle 0)
              (incf angle 360)))))))

(defun get-bounding-box (commands)
  (let ((min-x 0)
        (min-y 0)
        (max-x 0)
        (max-y 0))
    (execute-commands
     commands
     (lambda (x y x2 y2)
       (when (< x min-x)
         (setf min-x x))
       (when (< y min-y)
         (setf min-y y))
       (when (> x max-x)
         (setf max-x x))
       (when (> y max-y)
         (setf max-y y))
       (when (< x2 min-x)
         (setf min-x x2))
       (when (< y2 min-y)
         (setf min-y y2))
       (when (> x2 max-x)
         (setf max-x x2))
       (when (> y2 max-y)
         (setf max-y y2))))
    (values min-x min-y max-x max-y)))

(defun test ()
  (let ((snow (create-snow 4)))
    (with-open-file (s "c:/tmp/test.ps" 
                       :direction :output :if-exists :supersede)
      (format s "300 300 scale~%")
      (format s "0.7 1.2 translate~%")
      (format s "0 setlinewidth~%")
      (multiple-value-bind (min-x min-y max-x max-y) (get-bounding-box snow)
        (let ((scale-x (- max-x min-x))
              (scale-y (- max-y min-y)))
          (let ((scale (max scale-x scale-y)))
            (when (zerop scale)
              (setf scale 1))
            (setf scale (/ scale))
            (execute-commands
             snow
             (lambda (x y x2 y2)
               (decf x min-x)
               (decf y min-y)
               (decf x2 min-x)
               (decf y2 min-y)
               (format s "~f ~f moveto~%"
                       (float (* x scale))
                       (float (* y scale)))
               (format s "~f ~f lineto~%"
                       (float (* x2 scale))
                       (float (* y2 scale)))
               (format s "closepath~%")
               (format s "stroke~%"))))))
      (format s "showpage~%"))
    #+:lispworks (sys:call-system "\"c:/program files/gs/gs8.71/bin/gswin32.exe\" c:/tmp/test.ps")))