# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1523682757 14400
# Node ID 386728efe61ce516e2112744721ec6b1f7fc7eef
# Parent  ebe16cb914fbc13e81da9d27686d72cb66cde49b
Finish switching to 3d-vectors (really!)

diff -r ebe16cb914fb -r 386728efe61c flax.asd
--- a/flax.asd	Fri Apr 06 23:37:30 2018 -0400
+++ b/flax.asd	Sat Apr 14 01:12:37 2018 -0400
@@ -31,6 +31,7 @@
     :components
     ((:file "base")
      (:file "colors")
+     (:file "transform")
      (:module "drawing" :serial t
       :components ((:file "api")
                    (:file "png")
diff -r ebe16cb914fb -r 386728efe61c package.lisp
--- 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))
 
diff -r ebe16cb914fb -r 386728efe61c src/drawing/api.lisp
--- 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)))))))
 
diff -r ebe16cb914fb -r 386728efe61c src/looms/001-triangles.lisp
--- a/src/looms/001-triangles.lisp	Fri Apr 06 23:37:30 2018 -0400
+++ b/src/looms/001-triangles.lisp	Sat Apr 14 01:12:37 2018 -0400
@@ -106,5 +106,5 @@
       (values depth))))
 
 
-;; (declaim (optimize (debug 3)))
-;; (time (loom nil "out" :svg 800 800 :depth 12))
+;; (declaim (optimize (speed 1)))
+;; (time (loom nil "out" :svg 800 800 :depth 16))
diff -r ebe16cb914fb -r 386728efe61c src/looms/004-turtle-curves.lisp
--- 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)
diff -r ebe16cb914fb -r 386728efe61c src/transform.lisp
--- /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))
+
diff -r ebe16cb914fb -r 386728efe61c test/test.lisp
--- a/test/test.lisp	Fri Apr 06 23:37:30 2018 -0400
+++ b/test/test.lisp	Sat Apr 14 01:12:37 2018 -0400
@@ -1,18 +1,22 @@
 (ql:quickload '(:flax :losh))
 
-(defun check (loom)
+(defun check (interactive loom)
   (terpri)
   (losh:pr 'checking loom)
   (mapcar (lambda (output)
             (funcall loom nil "out" output 500 500)
             (losh:pr output 'OK))
-          '(:png :svg :plot)))
+          '(:png :plot :svg))
+  (when interactive
+    (break "Finished run of loom ~A" loom)))
 
-(progn
-  (check #'flax.looms.001-triangles:loom)
-  (check #'flax.looms.002-wobbly-lines:loom)
-  (check #'flax.looms.003-basic-l-systems:loom)
-  (check #'flax.looms.004-turtle-curves:loom)
-  (check #'flax.looms.005-simple-triangulations:loom)
-  (check #'flax.looms.006-tracing-lines:loom)
-  (check #'flax.looms.007-stipple:loom))
+(defun check-all (&key interactive)
+  (check interactive #'flax.looms.001-triangles:loom)
+  (check interactive #'flax.looms.002-wobbly-lines:loom)
+  (check interactive #'flax.looms.003-basic-l-systems:loom)
+  (check interactive #'flax.looms.004-turtle-curves:loom)
+  (check interactive #'flax.looms.005-simple-triangulations:loom)
+  (check interactive #'flax.looms.006-tracing-lines:loom)
+  (check interactive #'flax.looms.007-stipple:loom))
+
+(check-all)