# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1520278225 18000
# Node ID e70271703422e558da22f976035953a2b3e71dfc
# Parent  3e7390e1f6907c7adb050e49c0b7af1d7a50da7c
Add SVG support

diff -r 3e7390e1f690 -r e70271703422 .hgignore
--- a/.hgignore	Tue Feb 20 20:12:23 2018 -0500
+++ b/.hgignore	Mon Mar 05 14:30:25 2018 -0500
@@ -4,3 +4,4 @@
 *.pgm
 scratch.lisp
 *.png
+*.svg
diff -r 3e7390e1f690 -r e70271703422 flax.asd
--- a/flax.asd	Tue Feb 20 20:12:23 2018 -0500
+++ b/flax.asd	Mon Mar 05 14:30:25 2018 -0500
@@ -20,7 +20,10 @@
                 ((:file "base")
                  (:file "coordinates")
                  (:file "colors")
-                 (:file "drawing")
+                 (:module "drawing" :serial t
+                  :components ((:file "api")
+                               (:file "png")
+                               (:file "svg")))
                  (:module "looms" :serial nil
                   :components
                   ((:file "001-triangles")
diff -r 3e7390e1f690 -r e70271703422 src/drawing.lisp
--- a/src/drawing.lisp	Tue Feb 20 20:12:23 2018 -0500
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,248 +0,0 @@
-(in-package :flax.drawing)
-
-;;;; Utils --------------------------------------------------------------------
-(defparameter *padding* 0.03)
-(defparameter *black* (rgb 0 0 0))
-
-(defun convert-coord (value dimension)
-  (map-range (- *padding*) (1+ *padding*)
-             0 dimension
-             value))
-
-(defmacro with-coordinates (image bindings &body body)
-  (with-gensyms (width height channels)
-    `(destructuring-bind (,height ,width ,channels) (array-dimensions ,image)
-       (declare (ignore ,channels))
-       (let* ,(iterate (for (x-symbol y-symbol coord) :in bindings)
-                       (for c = (gensym "coord"))
-                       (appending
-                         (list `(,c ,coord)
-                               `(,x-symbol (convert-coord (x ,c) ,width))
-                               `(,y-symbol (convert-coord (y ,c) ,height)))))
-         ,@body))))
-
-
-;;;; Drawing Protocol ---------------------------------------------------------
-(defgeneric draw (image state drawing-object))
-
-(defclass drawable ()
-  ((opacity :type (double-float 0.0d0 1.0d0) :accessor opacity :initarg :opacity)
-   (color :type color :accessor color :initarg :color)))
-
-
-;;;; Paths --------------------------------------------------------------------
-(defclass path (drawable)
-  ((points :type list :accessor points :initarg :points)))
-
-(defun path (points &key (opacity 1.0d0) (color *black*))
-  (make-instance 'path
-    :points points
-    :color color
-    :opacity opacity))
-
-(defun coord-to-string (c)
-  (format nil "(~A, ~A)" (x c) (y c)))
-
-(defun coord-to-pair (image c)
-  (with-coordinates image ((x y c))
-    (cons x y)))
-
-(defmethod print-object ((o path) s)
-  (print-unreadable-object (o s :type t :identity nil)
-    (format s "~{~A~^ -> ~}"
-            (mapcar #'coord-to-string (points o)))))
-
-(defmethod draw (image state (p path))
-  (-<> (points p)
-    (mapcar (curry #'coord-to-pair image) <>)
-    paths:make-simple-path
-    (paths:stroke-path <> 1)
-    (vectors:update-state state <>)))
-
-
-;;;; Triangles ----------------------------------------------------------------
-(defclass triangle (drawable)
-  ((a :type coord :accessor a :initarg :a)
-   (b :type coord :accessor b :initarg :b)
-   (c :type coord :accessor c :initarg :c)))
-
-(defun triangle (a b c &key (opacity 1.0d0) (color *black*))
-  (make-instance 'triangle :a a :b b :c c :color color :opacity opacity))
-
-(defmethod print-object ((o triangle) s)
-  (print-unreadable-object (o s :type t :identity nil)
-    (format s "(~D, ~D) (~D, ~D) (~D, ~D)"
-            (x (a o))
-            (y (a o))
-            (x (b o))
-            (y (b o))
-            (x (c o))
-            (y (c o)))))
-
-(defmethod draw (image state (tri triangle))
-  (with-coordinates image
-      ((ax ay (a tri))
-       (bx by (b tri))
-       (cx cy (c tri)))
-    (-<> (list (cons ax ay)
-               (cons bx by)
-               (cons cx cy)
-               (cons ax ay))
-      paths:make-simple-path
-      (paths:stroke-path <> 1)
-      (vectors:update-state state <>))))
-
-
-;;;; Rectangles ---------------------------------------------------------------
-(defclass rectangle (drawable)
-  ((a :type coord :accessor a :initarg :a)
-   (b :type coord :accessor b :initarg :b)
-   (round-corners :type (or null integer)
-                  :accessor round-corners
-                  :initarg :round-corners)))
-
-(defun rectangle (a b &key (opacity 1.0d0) (color *black*) round-corners)
-  (make-instance 'rectangle :a a :b b
-    :color color
-    :opacity opacity
-    :round-corners round-corners))
-
-(defmethod print-object ((o rectangle) s)
-  (print-unreadable-object (o s :type t :identity nil)
-    (format s "(~D, ~D) (~D, ~D)"
-            (x (a o))
-            (y (a o))
-            (x (b o))
-            (y (b o)))))
-
-(defmethod draw (image state (rect rectangle))
-  (with-coordinates image
-      ((ax ay (a rect))
-       (bx by (b rect)))
-    (-<> (paths:make-rectangle-path ax ay bx by
-                                    :round (* (round-corners rect)
-                                              (* (- 1.0 *padding* *padding*)
-                                                 (min (array-dimension image 0)
-                                                      (array-dimension image 1)))))
-      ;; paths:make-simple-path
-      ;; (paths:stroke-path <> 1)
-      (vectors:update-state state <>))))
-
-
-;;;; Glue ---------------------------------------------------------------------
-(deftype image ()
-  '(simple-array (double-float 0.0d0 1.0d0) (* * 3)))
-
-(deftype index ()
-  `(integer 0 (,array-dimension-limit)))
-
-(deftype row-buffer ()
-  '(simple-array (integer 0 255) (*)))
-
-
-(defun-inline normalize-alpha (alpha)
-  (declare (optimize speed)
-           (type fixnum alpha))
-  (/ (min 255 (abs alpha)) 255.0d0))
-
-(defun put-pixel (image color opacity x y alpha)
-  (declare (optimize speed)
-           (type image image)
-           (type color color)
-           (type index x y)
-           (type (double-float 0.0d0 1.0d0) opacity)
-           (type fixnum alpha))
-  (let ((pixel-alpha (* opacity (normalize-alpha alpha))))
-    (zapf (aref image y x 0) (lerp % (flax.colors::r color) pixel-alpha)
-          (aref image y x 1) (lerp % (flax.colors::g color) pixel-alpha)
-          (aref image y x 2) (lerp % (flax.colors::b color) pixel-alpha))
-    (values)))
-
-
-(defun-inline prepare-sample (value)
-  (declare (optimize speed)
-           (type (double-float 0.0d0 1.0d0) value))
-  (round (* 255.0d0 value)))
-
-
-(defun make-image (width height color)
-  (let ((image (make-array (list height width 3)
-                 :element-type 'double-float
-                 :initial-element 1.0d0)))
-    (with-color (color r g b)
-      (dotimes (row height)
-        (dotimes (col width)
-          (setf (aref image row col 0) r
-                (aref image row col 1) g
-                (aref image row col 2) b))))
-    image))
-
-(defun fill-row (image row buffer)
-  (declare (optimize speed)
-           (type image image)
-           (type index row)
-           (type row-buffer buffer))
-  (iterate
-    (declare (iterate:declare-variables))
-    (with width = (length buffer))
-    (for (the fixnum i) :from (* row width))
-    (for (the fixnum j) :from 0 :below width)
-    (setf (aref buffer j)
-          (prepare-sample (row-major-aref image i)))))
-
-(defun write-file (image filename)
-  (destructuring-bind (height width channels) (array-dimensions image)
-    (declare (ignore channels))
-    (let ((png (make-instance 'zpng:pixel-streamed-png
-                 :color-type :truecolor
-                 :width width
-                 :height height))
-          (buffer (make-array (* width 3) :element-type '(integer 0 255))))
-      (with-open-file (stream filename
-                              :direction :output
-                              :if-exists :supersede
-                              :if-does-not-exist :create
-                              :element-type '(unsigned-byte 8))
-        (zpng:start-png png stream)
-        (dotimes (row height)
-          (fill-row image row buffer)
-          (zpng:write-row buffer png))
-        (zpng:finish-png png)))))
-
-
-(defun render-object (image object)
-  (let ((state (aa:make-state)))
-    (draw image state object)
-    (destructuring-bind (height width channels) (array-dimensions image)
-      (declare (ignore channels))
-      (aa:cells-sweep/rectangle
-        state 0 0 width height
-        (curry #'put-pixel image (color object) (opacity object))))))
-
-(defun render (image objects)
-  (map nil (curry #'render-object image) objects))
-
-(defun fade (image color alpha)
-  (declare (optimize speed)
-           (type image image)
-           (type color color)
-           (type (double-float 0.0d0 1.0d0) alpha))
-  (nest (with-color (color r g b))
-        (dotimes (row (array-dimension image 0)))
-        (dotimes (col (array-dimension image 1)))
-        (zapf (aref image row col 0) (lerp % r alpha)
-              (aref image row col 1) (lerp % g alpha)
-              (aref image row col 2) (lerp % b alpha))))
-
-(defmacro with-rendering
-    ((image-symbol filename width height &key
-                   (padding 0.03)
-                   (background '(rgb 1 1 1)))
-     &body body)
-  `(progn
-     (sb-ext:gc :full t)
-     (let ((,image-symbol (make-image ,width ,height ,background))
-           (*padding* ,padding))
-       (prog1 ,@body
-         (write-file ,image-symbol ,filename)))))
-
diff -r 3e7390e1f690 -r e70271703422 src/drawing/api.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/drawing/api.lisp	Mon Mar 05 14:30:25 2018 -0500
@@ -0,0 +1,160 @@
+(in-package :flax.drawing)
+
+;;;; Parameters ---------------------------------------------------------------
+(defparameter *padding* 0.03)
+(defparameter *black* (rgb 0 0 0))
+(defparameter *white* (rgb 1 1 1))
+
+
+;;;; Canvas -------------------------------------------------------------------
+(defclass* (canvas :conc-name "") ()
+  (width height))
+
+(define-with-macro (canvas :conc-name "") width height)
+
+(defgeneric make-canvas (type &key &allow-other-keys))
+
+
+;;;; Utils --------------------------------------------------------------------
+(defun convert-coord (value dimension)
+  (map-range (- *padding*) (1+ *padding*)
+             0 dimension
+             value))
+
+(defmacro with-coordinates (canvas bindings &body body)
+  (with-gensyms (width height)
+    `(with-canvas (,canvas ,width ,height)
+       (let* ,(iterate (for (x-symbol y-symbol coord) :in bindings)
+                       (for c = (gensym "coord"))
+                       (appending
+                         (list `(,c ,coord)
+                               `(,x-symbol (convert-coord (x ,c) ,width))
+                               `(,y-symbol (convert-coord (y ,c) ,height)))))
+         ,@body))))
+
+
+(defun coord-to-string (c)
+  (format nil "(~A, ~A)" (x c) (y c)))
+
+(defun coord-to-pair (canvas c)
+  (with-coordinates canvas ((x y c))
+    (cons x y)))
+
+
+;;;; Drawables ----------------------------------------------------------------
+(defclass* (drawable :conc-name "") ()
+  ((opacity :type (double-float 0.0d0 1.0d0))
+   (color :type color)))
+
+(defgeneric draw (canvas drawing-object))
+
+
+;;;; Paths --------------------------------------------------------------------
+(defclass* (path :conc-name "") (drawable)
+  ((points :type list)))
+
+(defun path (points &key (opacity 1.0d0) (color *black*))
+  (make-instance 'path
+    :points points
+    :color color
+    :opacity (coerce opacity 'double-float)))
+
+(defmethod print-object ((o path) s)
+  (print-unreadable-object (o s :type t :identity nil)
+    (format s "~{~A~^ -> ~}"
+            (mapcar #'coord-to-string (points o)))))
+
+
+;;;; Triangles ----------------------------------------------------------------
+(defclass* (triangle :conc-name "") (drawable)
+  ((a :type coord)
+   (b :type coord)
+   (c :type coord)))
+
+(defun triangle (a b c &key (opacity 1.0d0) (color *black*))
+  (make-instance 'triangle :a a :b b :c c
+                 :color color
+                 :opacity (coerce opacity 'double-float)))
+
+(defmethod print-object ((o triangle) s)
+  (print-unreadable-object (o s :type t :identity nil)
+    (format s "(~D, ~D) (~D, ~D) (~D, ~D)"
+            (x (a o))
+            (y (a o))
+            (x (b o))
+            (y (b o))
+            (x (c o))
+            (y (c o)))))
+
+
+;;;; Rectangles ---------------------------------------------------------------
+(defclass* (rectangle :conc-name "") (drawable)
+  ((a :type coord)
+   (b :type coord)
+   (round-corners :type (or null integer))))
+
+(defun rectangle (a b &key (opacity 1.0d0) (color *black*) round-corners)
+  (make-instance 'rectangle :a a :b b
+    :color color
+    :opacity (coerce opacity 'double-float)
+    :round-corners round-corners))
+
+(defmethod print-object ((o rectangle) s)
+  (print-unreadable-object (o s :type t :identity nil)
+    (format s "(~D, ~D) (~D, ~D)"
+            (x (a o))
+            (y (a o))
+            (x (b o))
+            (y (b o)))))
+
+(defun compute-corner-rounding (canvas rect)
+  (if-let ((rounding (round-corners rect)))
+    (with-canvas (canvas)
+      (* rounding
+         (* (- 1.0 *padding* *padding*)
+            (min height width))))
+    0))
+
+
+;;;; Rendering ----------------------------------------------------------------
+(defgeneric render-object (canvas object))
+
+(defun render (canvas objects)
+  (map nil (curry #'render-object canvas) objects))
+
+
+;;;; File Writing -------------------------------------------------------------
+(defgeneric write-file (canvas filename))
+
+
+;;;; Toplevel -----------------------------------------------------------------
+(defun full-filename (filename canvas-type)
+  (format nil "~A.~A" filename (string-downcase (symbol-name canvas-type))))
+
+(defmacro with-rendering
+    ((canvas-symbol canvas-type filename width height &key
+                    (padding 0.03)
+                    (background '(rgb 1 1 1)))
+     &body body)
+  (once-only (canvas-type)
+    `(progn
+       #+sbcl (sb-ext:gc :full t)
+       (let ((,canvas-symbol (make-canvas ,canvas-type
+                                          :height ,height
+                                          :width ,width
+                                          :background ,background))
+             (*padding* ,padding))
+         (prog1 ,@body
+           (write-file ,canvas-symbol (full-filename ,filename ,canvas-type)))))))
+
+
+;;;; Usage --------------------------------------------------------------------
+
+;;;; Implementations ----------------------------------------------------------
+;;; To implement a new type of canvas, you'll need to:
+;;;
+;;; * Add a new subclass of canvas.
+;;; * Implement make-canvas.
+;;; * Implement all the drawing methods for the various shapes.
+;;; * Implement render (which should call draw and maybe do other stuff).
+;;; * Implement write-file.
diff -r 3e7390e1f690 -r e70271703422 src/drawing/png.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/drawing/png.lisp	Mon Mar 05 14:30:25 2018 -0500
@@ -0,0 +1,154 @@
+(in-package :flax.drawing)
+
+;;;; Utils --------------------------------------------------------------------
+(deftype image ()
+  '(simple-array (double-float 0.0d0 1.0d0) (* * 3)))
+
+(deftype index ()
+  `(integer 0 (,array-dimension-limit)))
+
+(deftype row-buffer ()
+  '(simple-array (integer 0 255) (*)))
+
+
+(defun make-image (width height color)
+  (let ((image (make-array (list height width 3)
+                 :element-type 'double-float
+                 :initial-element 1.0d0)))
+    (with-color (color r g b)
+      (dotimes (row height)
+        (dotimes (col width)
+          (setf (aref image row col 0) r
+                (aref image row col 1) g
+                (aref image row col 2) b))))
+    image))
+
+(defun-inline normalize-alpha (alpha)
+  (declare (optimize speed)
+           (type fixnum alpha))
+  (/ (min 255 (abs alpha)) 255.0d0))
+
+(defun put-pixel (image color opacity x y alpha)
+  (declare (optimize speed)
+           (type image image)
+           (type color color)
+           (type index x y)
+           (type (double-float 0.0d0 1.0d0) opacity)
+           (type fixnum alpha))
+  (let ((pixel-alpha (* opacity (normalize-alpha alpha))))
+    (zapf (aref image y x 0) (lerp % (flax.colors::r color) pixel-alpha)
+          (aref image y x 1) (lerp % (flax.colors::g color) pixel-alpha)
+          (aref image y x 2) (lerp % (flax.colors::b color) pixel-alpha))
+    (values)))
+
+
+;;;; Canvas -------------------------------------------------------------------
+(defclass* (png-canvas :conc-name "") (canvas)
+  (image state))
+
+(defmethod make-canvas ((type (eql :png)) &key height width background)
+  (make-instance 'png-canvas
+    :height height
+    :width width
+    :image (make-image width height background)))
+
+
+;;;; Rectangles ---------------------------------------------------------------
+(defmethod draw ((canvas png-canvas) (rect rectangle))
+  (with-coordinates canvas
+      ((ax ay (a rect))
+       (bx by (b rect)))
+    (-<> (paths:make-rectangle-path
+           ax ay bx by
+           :round (compute-corner-rounding canvas rect))
+      ;; paths:make-simple-path
+      ;; (paths:stroke-path <> 1)
+      (vectors:update-state (state canvas) <>))))
+
+
+;;;; Paths --------------------------------------------------------------------
+(defmethod draw ((canvas png-canvas) (p path))
+  (-<> (points p)
+    (mapcar (curry #'coord-to-pair canvas) <>)
+    paths:make-simple-path
+    (paths:stroke-path <> 1)
+    (vectors:update-state (state canvas) <>)))
+
+
+;;;; Triangles ----------------------------------------------------------------
+(defmethod draw ((canvas png-canvas) (tri triangle))
+  (with-coordinates canvas
+      ((ax ay (a tri))
+       (bx by (b tri))
+       (cx cy (c tri)))
+    (-<> (list (cons ax ay)
+               (cons bx by)
+               (cons cx cy)
+               (cons ax ay))
+      paths:make-simple-path
+      (paths:stroke-path <> 1)
+      (vectors:update-state (state canvas) <>))))
+
+
+;;;; Rendering ----------------------------------------------------------------
+(defmethod render-object ((canvas png-canvas) object)
+  (setf (state canvas) (aa:make-state))
+  (draw canvas object)
+  (aa:cells-sweep/rectangle
+    (state canvas) 0 0 (width canvas) (height canvas)
+    (curry #'put-pixel (image canvas) (color object) (opacity object))))
+
+
+;;;; Files --------------------------------------------------------------------
+(defun-inline prepare-sample (value)
+  (declare (optimize speed)
+           (type (double-float 0.0d0 1.0d0) value))
+  (round (* 255.0d0 value)))
+
+(defun fill-row (image row buffer)
+  (declare (optimize speed)
+           (type image image)
+           (type index row)
+           (type row-buffer buffer))
+  (iterate
+    (declare (iterate:declare-variables))
+    (with width = (length buffer))
+    (for (the fixnum i) :from (* row width))
+    (for (the fixnum j) :from 0 :below width)
+    (setf (aref buffer j)
+          (prepare-sample (row-major-aref image i)))))
+
+(defmethod write-file ((canvas png-canvas) filename)
+  (let ((width (width canvas))
+        (height (height canvas))
+        (image (image canvas)))
+    (let ((png (make-instance 'zpng:pixel-streamed-png
+                 :color-type :truecolor
+                 :width width
+                 :height height))
+          (buffer (make-array (* width 3) :element-type '(integer 0 255))))
+      (with-open-file (stream filename
+                              :direction :output
+                              :if-exists :supersede
+                              :if-does-not-exist :create
+                              :element-type '(unsigned-byte 8))
+        (zpng:start-png png stream)
+        (dotimes (row height)
+          (fill-row image row buffer)
+          (zpng:write-row buffer png))
+        (zpng:finish-png png)))))
+
+
+;; todo fix this
+(defun fade (canvas color alpha)
+  (declare (optimize speed)
+           (type color color)
+           (type (double-float 0.0d0 1.0d0) alpha))
+  (nest (let ((image (image canvas)))
+          (declare (type image image)))
+        (with-color (color r g b))
+        (dotimes (row (array-dimension image 0)))
+        (dotimes (col (array-dimension image 1)))
+        (zapf (aref image row col 0) (lerp % r alpha)
+              (aref image row col 1) (lerp % g alpha)
+              (aref image row col 2) (lerp % b alpha))))
diff -r 3e7390e1f690 -r e70271703422 src/drawing/svg.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/drawing/svg.lisp	Mon Mar 05 14:30:25 2018 -0500
@@ -0,0 +1,93 @@
+(in-package :flax.drawing)
+
+;;;; Utils --------------------------------------------------------------------
+(defun web-color (color)
+  (with-color (color r g b)
+    (format nil "#~2,'0X~2,'0X~2,'0X"
+            (round (map-range 0 1 0 255 r))
+            (round (map-range 0 1 0 255 g))
+            (round (map-range 0 1 0 255 b)))))
+
+
+;;;; Canvas -------------------------------------------------------------------
+(defclass* (svg-canvas :conc-name "") (canvas)
+  (scene))
+
+(defmethod make-canvas ((type (eql :svg)) &key height width background)
+  (let ((scene (svg:make-svg-toplevel 'svg:svg-1.1-toplevel
+                                      :height height :width width)))
+    (svg:draw scene (:rect :x 0 :y 0 :width width :height height
+                     :fill (web-color background)))
+    (make-instance 'svg-canvas
+      :height height
+      :width width
+      :scene scene)))
+
+
+;;;; Rectangles ---------------------------------------------------------------
+(defmethod draw ((canvas svg-canvas) (rect rectangle))
+  (with-coordinates canvas
+      ((ax ay (a rect))
+       (bx by (b rect)))
+    (let ((rounding (compute-corner-rounding canvas rect)))
+      (svg:draw (scene canvas) (:rect
+                                :x (min ax bx)
+                                :y (min ay by)
+                                :rx rounding
+                                :ry rounding
+                                :width (abs (- ax bx))
+                                :height (abs (- ay by))
+                                :fill (web-color (color rect))
+                                :fill-opacity (opacity rect))))))
+
+
+;;;; Paths --------------------------------------------------------------------
+(defun make-svg-path-data (canvas points)
+  (destructuring-bind (first-point &rest remaining-points)
+      (mapcar (curry #'coord-to-pair canvas) points)
+    (let ((p (svg:make-path)))
+      (svg:with-path p
+        (svg:move-to (car first-point) (cdr first-point)))
+      (dolist (point remaining-points)
+        (svg:with-path p
+          (svg:line-to (car point) (cdr point))))
+      p)))
+
+(defmethod draw ((canvas svg-canvas) (path path))
+  (svg:draw (scene canvas)
+            (:path :d (make-svg-path-data canvas (points path))
+             :fill "none"
+             :stroke (web-color (color path))
+             :stroke-width 1
+             :stroke-opacity (opacity path))))
+
+
+;;;; Triangles ----------------------------------------------------------------
+(defmethod draw ((canvas svg-canvas) (tri triangle))
+  (with-coordinates canvas
+      ((ax ay (a tri))
+       (bx by (b tri))
+       (cx cy (c tri)))
+    (svg:draw (scene canvas) (:polygon
+                              :points (svg::points (list (list ax ay)
+                                                         (list bx by)
+                                                         (list cx cy)))
+                              :fill "none"
+                              :stroke-width 0.25
+                              :stroke-opacity (opacity tri)
+                              :stroke (web-color (color tri))))))
+
+
+;;;; Rendering ----------------------------------------------------------------
+(defmethod render-object ((canvas svg-canvas) object)
+  (draw canvas object))
+
+
+;;;; Files --------------------------------------------------------------------
+(defmethod write-file ((canvas svg-canvas) filename)
+  (with-open-file (stream filename
+                          :direction :output
+                          :if-exists :supersede
+                          :if-does-not-exist :create)
+    (svg:stream-out stream (scene canvas))))
+
diff -r 3e7390e1f690 -r e70271703422 src/looms/001-triangles.lisp
--- a/src/looms/001-triangles.lisp	Tue Feb 20 20:12:23 2018 -0500
+++ b/src/looms/001-triangles.lisp	Mon Mar 05 14:30:25 2018 -0500
@@ -96,9 +96,9 @@
 
 
 ;;;; Main ---------------------------------------------------------------------
-(defun loom (seed depth filename width height)
-  (flax.drawing:with-rendering (image filename width height)
-    (flax.drawing:render image (convert (generate-universe-balancing depth seed)))))
+(defun loom (seed depth filename filetype width height)
+  (flax.drawing:with-rendering (canvas filetype filename width height)
+    (flax.drawing:render canvas (convert (generate-universe-balancing depth seed)))))
 
 
-;; (time (loom 45 16 "out.png" 2000 2000))
+;; (time (loom 1964055800 17 "out" :png 1000 1000))
diff -r 3e7390e1f690 -r e70271703422 src/looms/002-wobbly-lines.lisp
--- a/src/looms/002-wobbly-lines.lisp	Tue Feb 20 20:12:23 2018 -0500
+++ b/src/looms/002-wobbly-lines.lisp	Mon Mar 05 14:30:25 2018 -0500
@@ -55,11 +55,11 @@
 
 
 ;;;; Main ---------------------------------------------------------------------
-(defun loom (seed ticks filename width height)
+(defun loom (seed ticks filename filetype width height)
   (with-seed seed
-    (flax.drawing:with-rendering (image filename width height
-                                  :padding 0.0
-                                  :background *background*)
+    (flax.drawing:with-rendering (canvas filetype filename width height
+                                         :padding 0.0
+                                         :background *background*)
       (let ((line (initial 300))
             (*hue* (random-range 0.0d0 1.0d0 #'rand))
             (*hue-increment* (/ (random-range 0.15d0 0.3d0 #'rand) ticks))
@@ -67,13 +67,13 @@
         (dotimes (tick ticks)
           (when (dividesp tick (/ (expt 10 (floor (log (1- ticks) 10))) 2))
             (print tick))
-          (when (and (eq mode :fade) (dividesp tick 10))
-            (flax.drawing:fade image *background* 0.04d0))
-          (flax.drawing:render image (convert line (if (eq mode :transparent)
-                                                     (/ 95.0d0 ticks)
-                                                     1.0d0)))
+          (when (and (eq filetype :png) (eq mode :fade) (dividesp tick 10))
+            (flax.drawing:fade canvas *background* 0.04d0))
+          (flax.drawing:render canvas (convert line (if (eq mode :transparent)
+                                                      (/ 95.0d0 ticks)
+                                                      1.0d0)))
           (tick line))
         mode))))
 
 
-;; (time (loom nil 1000 "out.png" 800 300))
+;; (time (loom nil 1000 "out" :svg 800 300))
diff -r 3e7390e1f690 -r e70271703422 src/looms/003-basic-l-systems.lisp
--- a/src/looms/003-basic-l-systems.lisp	Tue Feb 20 20:12:23 2018 -0500
+++ b/src/looms/003-basic-l-systems.lisp	Mon Mar 05 14:30:25 2018 -0500
@@ -96,15 +96,15 @@
 (defun random-anabaena-catenula-axiom (length)
   (gimme length (random-elt '(ar al br bl) #'rand)))
 
-(defun loom-anabaena-catenula (seed filename width height)
+(defun loom-anabaena-catenula (seed filename filetype width height)
   (with-seed seed
     (flax.drawing:with-rendering
-        (image filename width height :background *background*)
+        (canvas filetype filename width height :background *background*)
       (anabaena-catenula (maximum-words)
                          :axiom (random-anabaena-catenula-axiom
                                   (random-range-inclusive 1 6 #'rand))
                          :mutate #'cull
                          :callback (lambda (iteration word)
-                                     (flax.drawing:render image (convert word iteration)))))))
+                                     (flax.drawing:render canvas (convert word iteration)))))))
 
-;; (time (loom-anabaena-catenula nil "out.png" 2000 2000))
+;; (time (loom-anabaena-catenula nil "out" :svg 2000 2000))
diff -r 3e7390e1f690 -r e70271703422 src/looms/004-turtle-curves.lisp
--- a/src/looms/004-turtle-curves.lisp	Tue Feb 20 20:12:23 2018 -0500
+++ b/src/looms/004-turtle-curves.lisp	Mon Mar 05 14:30:25 2018 -0500
@@ -260,7 +260,7 @@
                 (,*tree-f* 4 7 ,(- 1/4tau)))
               #'rand))
 
-(defun loom (seed filename width height
+(defun loom (seed filename filetype width height
              &optional l-system iterations starting-angle)
   (nest
     (with-seed seed)
@@ -269,7 +269,7 @@
         (if l-system
           (list l-system iterations iterations starting-angle)
           (select-l-system)))
-    (let* ((*starting-angle* (or starting-angle (rand tau)))
+    (let* ((*starting-angle* (or (or starting-angle (rand tau))))
            (bg (hsv (rand 1.0) (rand 1.0) (random-range 0.0 0.2 #'rand)))
            (*color* (hsv (rand 1.0)
                          (random-range 0.5 0.8 #'rand)
@@ -287,15 +287,14 @@
                               (mutate-productions <>))
                             <>)))
            (*angle* (l-system-recommended-angle l-system))))
-    (flax.drawing:with-rendering (image filename width height :background bg))
+    (flax.drawing:with-rendering
+        (canvas filetype filename width height :background bg))
     (progn (-<> (run-l-system axiom productions iterations)
              (turtle-draw <>)
-             (flax.drawing:render image <>))
+             (flax.drawing:render canvas <>))
            (list (l-system-name l-system)
                  iterations
                  (if should-mutate mutation-seed nil)))))
 
 
-
-;; (time (loom nil "out.png" 1000 1000 *tree-f* 7 (- 1/4tau)))
-;; (time (loom nil "out.png" 1000 1000))
+;; (time (loom (pr (random (expt 2 31))) "out" :svg 1000 1000))