--- a/package.lisp Fri Apr 06 23:37:30 2018 -0400
+++ b/package.lisp Sat Apr 14 01:12:37 2018 -0400
@@ -1,5 +1,7 @@
(defpackage :flax.base
- (:use :cl :iterate :losh :flax.quickutils)
+ (:use :cl :iterate :losh :flax.quickutils
+ :3d-vectors
+ :3d-matrices)
(:export
:rand
:with-seed
@@ -15,10 +17,23 @@
:hsv
:rgb))
+(defpackage :flax.transform
+ (:use :cl :iterate :losh :flax.base :flax.quickutils
+ :3d-vectors
+ :3d-matrices)
+ (:export
+ :transformation
+ :scale
+ :rotate
+ :translate
+ :ntransform))
+
(defpackage :flax.drawing
(:use :cl :iterate :losh :flax.base :flax.quickutils
:flax.colors
- :3d-vectors)
+ :flax.transform
+ :3d-vectors
+ :3d-matrices)
(:export
:with-rendering
:render
@@ -52,6 +67,7 @@
(defpackage :flax.looms.004-turtle-curves
(:use :cl :iterate :losh :flax.base :flax.quickutils
:flax.colors
+ :flax.transform
:3d-vectors)
(:export :loom))
--- a/src/drawing/api.lisp Fri Apr 06 23:37:30 2018 -0400
+++ b/src/drawing/api.lisp Sat Apr 14 01:12:37 2018 -0400
@@ -1,14 +1,32 @@
(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))
+ ((width :type (integer 0))
+ (height :type (integer 0))
+ (padding :type (single-float 0.0 0.5) :initform 0.03)
+ (output-transformation :type mat3)))
+
+(defun recompute-output-transformation (canvas)
+ (let* ((fw (coerce (width canvas) 'single-float))
+ (fh (coerce (height canvas) 'single-float))
+ (p (padding canvas))
+ (pw (* p fw))
+ (ph (* p fh))
+ (w (- fw pw pw))
+ (h (- fh ph ph)))
+ (setf (output-transformation canvas)
+ (transformation
+ (scale w h)
+ (translate pw ph)))))
+
+(defmethod initialize-instance :after ((canvas canvas) &key)
+ (recompute-output-transformation canvas))
(define-with-macro (canvas :conc-name "") width height)
@@ -16,35 +34,34 @@
;;;; Utils --------------------------------------------------------------------
-(defun convert-coordinate (value dimension)
- (map-range (- *padding*) (1+ *padding*)
- 0 dimension
- value))
+(defun-inline homogenize (v)
+ (vec3 (vx v) (vy v) 1))
+
+(defun convert-coordinate (canvas coordinate)
+ (let ((c (m* (output-transformation canvas) coordinate)))
+ (values (vx3 c) (vy3 c))))
(defun convert-magnitude (canvas magnitude)
- (let ((dim (min (height canvas) (width canvas))))
- (lerp 0 (- dim (* 2 *padding* dim)) magnitude)))
+ (ntransform magnitude (output-transformation canvas)))
+
+(defmacro with-coordinate (canvas-symbol binding &body body)
+ (ecase (length binding)
+ (2 (destructuring-bind (magnitude-symbol value) binding
+ `(let ((,magnitude-symbol (convert-magnitude ,canvas-symbol ,value)))
+ ,@body)))
+ (3 (destructuring-bind (x-symbol y-symbol value) binding
+ `(multiple-value-bind (,x-symbol ,y-symbol)
+ (convert-coordinate ,canvas-symbol ,value)
+ ,@body)))))
(defmacro with-coordinates (canvas bindings &body body)
(once-only (canvas)
- (with-gensyms (width height)
- (labels ((parse-coord-binding (binding)
- (with-gensyms (coord)
- (destructuring-bind (x-symbol y-symbol value) binding
- `((,coord ,value)
- (,x-symbol (convert-coordinate (vx ,coord) ,width))
- (,y-symbol (convert-coordinate (vy ,coord) ,height))))))
- (parse-magnitude-binding (binding)
- (destructuring-bind (magnitude-symbol value) binding
- `((,magnitude-symbol (convert-magnitude ,canvas ,value)))))
- (parse-binding (binding)
- (ecase (length binding)
- (2 (parse-magnitude-binding binding))
- (3 (parse-coord-binding binding)))))
- `(with-canvas (,canvas ,width ,height)
- (let* ,(mapcan #'parse-binding bindings)
- ,@body))))))
+ `(nest
+ ,@(mapcar (lambda (binding)
+ `(with-coordinate ,canvas ,binding))
+ bindings)
+ (progn ,@body))))
(defun coord-to-string (c)
@@ -69,7 +86,7 @@
(defun path (points &key (opacity 1.0d0) (color *black*))
(make-instance 'path
- :points points
+ :points (mapcar #'homogenize points)
:color color
:opacity (coerce opacity 'double-float)))
@@ -78,15 +95,20 @@
(format s "~{~A~^ -> ~}"
(mapcar #'coord-to-string (points o)))))
+(defmethod ntransform ((path path) transformation)
+ (dolist (p (points path))
+ (ntransform p transformation))
+ path)
+
;;;; Triangles ----------------------------------------------------------------
(defclass* (triangle :conc-name "") (drawable)
- ((a :type vec2)
- (b :type vec2)
- (c :type vec2)))
+ ((a :type vec3)
+ (b :type vec3)
+ (c :type vec3)))
(defun triangle (a b c &key (opacity 1.0d0) (color *black*))
- (make-instance 'triangle :a a :b b :c c
+ (make-instance 'triangle :a (homogenize a) :b (homogenize b) :c (homogenize c)
:color color
:opacity (coerce opacity 'double-float)))
@@ -100,15 +122,21 @@
(vx (c o))
(vy (c o)))))
+(defmethod ntransform ((triangle triangle) transformation)
+ (ntransform (a triangle))
+ (ntransform (b triangle))
+ (ntransform (c triangle))
+ triangle)
+
;;;; Rectangles ---------------------------------------------------------------
(defclass* (rectangle :conc-name "") (drawable)
- ((a :type vec2)
- (b :type vec2)
+ ((a :type vec3)
+ (b :type vec3)
(round-corners :type float :initform 0.0)))
(defun rectangle (a b &key (opacity 1.0d0) (color *black*) round-corners)
- (make-instance 'rectangle :a a :b b
+ (make-instance 'rectangle :a (homogenize a) :b (homogenize b)
:color color
:opacity (coerce opacity 'double-float)
:round-corners round-corners))
@@ -125,18 +153,24 @@
(if-let ((rounding (round-corners rect)))
(with-canvas (canvas)
(* rounding
- (* (- 1.0 *padding* *padding*)
+ (* (- 1.0 (* 2 (padding canvas)))
(min height width))))
0))
+(defmethod ntransform ((rectangle rectangle) transformation)
+ (ntransform (a rectangle))
+ (ntransform (b rectangle))
+ (callf (round-corners rectangle) #'ntransform)
+ rectangle)
+
;;;; Circles ------------------------------------------------------------------
(defclass* (circle :conc-name "") (drawable)
- ((center :type vec2)
+ ((center :type vec3)
(radius :type single-float)))
(defun circle (center radius &key (opacity 1.0d0) (color *black*))
- (make-instance 'circle :center center :radius radius
+ (make-instance 'circle :center (homogenize center) :radius radius
:color color
:opacity (coerce opacity 'double-float)))
@@ -147,13 +181,18 @@
(vy (center o))
(radius o))))
+(defmethod ntransform ((circle circle) transformation)
+ (ntransform (center circle))
+ (callf (radius circle) #'ntransform)
+ circle)
+
;;;; Points -------------------------------------------------------------------
(defclass* (point :conc-name "") (drawable)
- ((location :type vec2)))
+ ((location :type vec3)))
(defun point (location &key (opacity 1.0d0) (color *black*))
- (make-instance 'point :location location
+ (make-instance 'point :location (homogenize location)
:color color
:opacity (coerce opacity 'double-float)))
@@ -163,10 +202,14 @@
(vx (location o))
(vy (location o)))))
+(defmethod ntransform ((point point) transformation)
+ (ntransform (location point))
+ point)
+
;;;; Text ---------------------------------------------------------------------
(defclass* (text :conc-name "") (drawable)
- ((pos :type vec2)
+ ((pos :type vec3)
(font :type string)
(size :type single-float)
(align :type keyword)
@@ -175,7 +218,7 @@
(defun text (position size font content
&key (opacity 1.0d0) (color *black*) (align :left))
(make-instance 'text
- :pos position :size size :font font :content content
+ :pos (homogenize position) :size size :font font :content content
:align align
:color color
:opacity (coerce opacity 'double-float)))
@@ -187,6 +230,11 @@
(vx (pos o))
(vy (pos o)))))
+(defmethod ntransform ((text text) transformation)
+ (ntransform (pos text))
+ (callf (size text) #'ntransform)
+ text)
+
;;;; Rendering ----------------------------------------------------------------
(defgeneric render-object (canvas object))
@@ -221,8 +269,8 @@
(let ((,canvas-symbol (make-canvas ,canvas-type
:height ,height
:width ,width
- :background ,background))
- (*padding* ,padding))
+ :padding ,padding
+ :background ,background)))
(multiple-value-prog1 ,@body
(write-file ,canvas-symbol (full-filename ,filename ,canvas-type)))))))
--- a/src/looms/004-turtle-curves.lisp Fri Apr 06 23:37:30 2018 -0400
+++ b/src/looms/004-turtle-curves.lisp Sat Apr 14 01:12:37 2018 -0400
@@ -81,24 +81,20 @@
(minimizing (vx p2) :into min-x)
(minimizing (vy p1) :into min-y)
(minimizing (vy p2) :into min-y)
- (finally (return (list min-x min-y max-x max-y)))))
+ (finally (return (values min-x min-y max-x max-y)))))
-(defun scale (paths)
- (iterate
- ;; (with aspect = 1)
- (with (min-x min-y max-x max-y) = (find-bounds paths))
- (with factor = (min (/ (- max-x min-x))
- (/ (- max-y min-y))))
- (with x-padding = (/ (- 1.0 (* factor (- max-x min-x))) 2))
- (with y-padding = (/ (- 1.0 (* factor (- max-y min-y))) 2))
- (for path :in paths)
- (for (p1 p2) = (flax.drawing:points path))
- (zapf
- (vx p1) (map-range min-x max-x x-padding (- 1.0 x-padding) %)
- (vy p1) (map-range min-y max-y y-padding (- 1.0 y-padding) %)
- (vx p2) (map-range min-x max-x x-padding (- 1.0 x-padding) %)
- (vy p2) (map-range min-y max-y y-padding (- 1.0 y-padding) %)))
- paths)
+(defun transform-to-fit (paths)
+ (multiple-value-bind (min-x min-y max-x max-y) (find-bounds paths)
+ (let* ((x-span (- max-x min-x))
+ (y-span (- max-y min-y))
+ (factor (min (/ x-span) (/ y-span)))
+ (x-padding (/ (- 1.0 (* factor x-span)) 2.0))
+ (y-padding (/ (- 1.0 (* factor y-span)) 2.0))
+ (transform (transformation
+ (translate (- min-x) (- min-y))
+ (scale factor factor)
+ (translate x-padding y-padding))))
+ (ntransform paths transform))))
(defun encode (commands)
@@ -304,7 +300,7 @@
(progn
(-<> (run-l-system axiom productions iterations)
turtle-draw
- scale
+ transform-to-fit
(flax.drawing:render canvas <>))
(values (l-system-name l-system)
iterations
@@ -312,7 +308,7 @@
-;; (time (loom nil "out" :svg 800 800
+;; (profile (loom 1963517098 "out" :png 800 800
;; ;; :l-system *hexagonal-gosper-curve*
;; ;; :iterations 5
;; ;; :starting-angle (- 1/4tau)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/transform.lisp Sat Apr 14 01:12:37 2018 -0400
@@ -0,0 +1,50 @@
+(in-package :flax.transform)
+
+(defun id ()
+ (meye 3))
+
+(defun scale (m x y)
+ (m* (mat x 0 0
+ 0 y 0
+ 0 0 1)
+ m))
+
+(defun rotate (m angle)
+ (m* (mat (cos angle) (sin angle) 0
+ (- (sin angle)) (cos angle) 0
+ 0 0 1)
+ m))
+
+(defun translate (m x y)
+ (m* (mat 1 0 x
+ 0 1 y
+ 0 0 1)
+ m))
+
+
+(defmacro transformation (&rest transforms)
+ `(-<> (id)
+ ,@(iterate (for (name . body) :in transforms)
+ (collect `(,name <> ,@body)))))
+
+
+(defgeneric ntransform (object transformation))
+
+(defmethod ntransform ((vector vec3) transformation)
+ (nm* transformation vector)
+ vector)
+
+(defmethod ntransform ((magnitude float) transformation)
+ (with-fast-matref (m transformation 3)
+ (let* ((a (m 0 0))
+ (b (m 0 1))
+ (c (m 1 0))
+ (d (m 1 1))
+ (scale (sqrt (/ (+ (square (+ a b))
+ (square (+ c d)))
+ 2.0))))
+ (* magnitude scale))))
+
+(defmethod ntransform ((sequence sequence) transformation)
+ (map-into sequence (rcurry #'ntransform transformation) sequence))
+