Land of Lisp: SVG Generation

svg.lisp

(defun pairs (lst)
  (loop for i on lst by #'cddr
        collect (cons (car i)
                      (cadr i))))

(defun print-tag (name attributes closing-p)
  ""
  (princ #\<)
  (when closing-p
    (princ #\/))
  (princ (string-downcase name))
  (mapc (lambda (attribute)
          (format t " ~a=\"~a\"" (string-downcase (car attribute)) (cdr attribute)))
        attributes)
  (princ #\>))

(defmacro tag (name attributes &body body)
  `(progn (print-tag ',name
                     (list ,@(mapcar (lambda (x)
                                       `(cons ',(car x) ,(cdr x)))
                                     (pairs attributes)))
                     nil)
          ,@body
          (print-tag ',name nil t)))

(defun brightness (colour amount)
  (mapcar (lambda (x)
            (min 255 (max 0 (+ x amount))))
          colour))

(defun svg-style (colour)
  (format nil "~{fill:rgb(~a,~a,~a);stroke:rgb(~a,~a,~a)~}"
          (append colour
                  (brightness colour -100))))

(defmacro svg (&body body)
  `(tag svg (xmlns "http://www.w3.org/2000/svg"
                   "xmlns:xlink" "http://www.w3.org/1999/xlink")
     ,@body))

(defun circle (centre radius colour)
  (tag circle (cx (car centre)
                  cy (cdr centre)
                  r radius
                  style (svg-style colour))))

(defun polygon (points colour)
  (tag polygon (points (format nil "~{~a,~a ~}"
                               (mapcan (lambda (p)
                                         (list (car p) (cdr p)))
                                       points))
                       style (svg-style colour))))

(defun random-walk (value length)
  (unless (zerop length)
    (cons value
          (random-walk (if (zerop (random 2))
                           (1- value)
                           (1+ value))
                       (1- length)))))

The following example creates a file containing the commands to draw a graph - very pretty it is too:

(with-open-file (*standard-output* "random-walk.svg"
                                            :direction :output
                                            :if-exists :supersede)
           (svg (loop repeat 10
                      do (polygon (append '((0 . 200))
                                          (loop for x from 0
                                                for y in (random-walk 100 400)
                                                collect (cons x y))
                                          '((400 . 200)))
                                  (loop repeat 3
                                        collect (random 256))))))