--- 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
--- 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")
--- 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)))))
-
--- /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.
--- /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))))
--- /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))))
+
--- 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))
--- 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))
--- 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))
--- 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))