# HG changeset patch # User Steve Losh # Date 1560112697 14400 # Node ID 09e9069036625810c131244e25ec309a46936fe4 # Parent 425689e66be84600f3f5c4d7d46ac9b9c6a4a1d5 Add Bezier curve support diff -r 425689e66be8 -r 09e906903662 src/base.lisp --- a/src/base.lisp Sun Jun 09 12:45:59 2019 -0400 +++ b/src/base.lisp Sun Jun 09 16:38:17 2019 -0400 @@ -36,3 +36,12 @@ " (* precision (round number precision))) + +;;;; Utils -------------------------------------------------------------------- +(defun map-curried (function param sequence) + (loop :for x :in sequence + :do (funcall function param x))) + +(defun mapcar-curried (function param sequence) + (loop :for x :in sequence + :collect (funcall function param x))) diff -r 425689e66be8 -r 09e906903662 src/drawing/api.lisp --- a/src/drawing/api.lisp Sun Jun 09 12:45:59 2019 -0400 +++ b/src/drawing/api.lisp Sun Jun 09 16:38:17 2019 -0400 @@ -66,6 +66,9 @@ (with-coordinates canvas ((x y c)) (cons x y))) +(defun coords-to-pairs (canvas cs) + (loop :for c :in cs :collect (coord-to-pair canvas c))) + ;;;; Drawables ---------------------------------------------------------------- (defclass* drawable () @@ -79,20 +82,29 @@ (defclass* path (drawable) ((points :type list))) +(defun normalize-point (point) + (if (listp point) + point + (list point))) + +(defun normalize-points (points) + (mapcar #'normalize-point points)) + (defun path (points &key (opacity 1.0d0) (color *black*)) (make-instance 'path - :points (mapcar #'homogenize points) + :points (mapcar-curried #'mapcar #'homogenize (normalize-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))))) + (mapcar (compose #'coord-to-string #'first) (points o))))) (defmethod ntransform ((path path) transformation) - (dolist (p (points path)) - (ntransform p transformation)) + (dolist (ps (points path)) + (dolist (p ps) + (ntransform p transformation))) path) @@ -243,7 +255,7 @@ (defgeneric render-object (canvas object)) (defun render (canvas objects) - (map nil (curry #'render-object canvas) objects)) + (map-curried #'render-object canvas objects)) ;;;; File Writing ------------------------------------------------------------- diff -r 425689e66be8 -r 09e906903662 src/drawing/plot.lisp --- a/src/drawing/plot.lisp Sun Jun 09 12:45:59 2019 -0400 +++ b/src/drawing/plot.lisp Sun Jun 09 16:38:17 2019 -0400 @@ -21,8 +21,8 @@ (defmethod draw ((canvas plot-canvas) (p point)) (svg:draw (scene canvas) - (:path :d (make-svg-path-data canvas (list (location p) - (location p))) + (:path :d (make-svg-path-data canvas (list (list (location p) + (location p)))) :stroke-linecap "round" :fill "none" :stroke (web-color (color p)) diff -r 425689e66be8 -r 09e906903662 src/drawing/png.lisp --- a/src/drawing/png.lisp Sun Jun 09 12:45:59 2019 -0400 +++ b/src/drawing/png.lisp Sun Jun 09 16:38:17 2019 -0400 @@ -82,10 +82,56 @@ ;;;; Paths -------------------------------------------------------------------- +(defun pair-to-vec (pair) + (vec (car pair) (cdr pair))) + +(defun vec-to-pair (vec) + (cons (vx vec) (vy vec))) + +(defun reflect-control (control loc) + (let* ((l (pair-to-vec loc)) + (c (pair-to-vec control)) + (cv (v- c l))) + (vec-to-pair (v+ l (v- cv))))) + +(defun fill-missing-control-points (points) + (iterate + ;; Unfortunately cl-vectors doesn't seem to have anything like the nice + ;; convenient omit-the-starting-control-point-for-a-smooth-curve feature of + ;; SVG, so we'll have to implement it ourselves. + (with previous-ctrl2) + (for point :in points) + (for (p ctrl1 ctrl2) = point) + (for previous-p :previous p) + (cond + (ctrl2 (collect point)) + (ctrl1 (psetf ctrl1 (reflect-control previous-ctrl2 previous-p) + ctrl2 ctrl1) + (collect (list p ctrl1 ctrl2))) + (t (collect point))) + (setf previous-ctrl2 ctrl2))) + +(defun convert-point (canvas point) + (destructuring-bind (x . y) (coord-to-pair canvas point) + (paths:make-point x y))) + +(defun convert-points (canvas points) + (mapcar-curried #'convert-point canvas points)) + +(defun make-vector-path (points) + (destructuring-bind (first-point &rest remaining-points) points + (let ((p (paths:create-path :open-polyline))) + (paths:path-reset p (first first-point)) + (dolist (next-point remaining-points) + (destructuring-bind (loc &rest control-points) next-point + (paths:path-extend p (paths:make-bezier-curve control-points) loc))) + p))) + (defmethod draw ((canvas png-canvas) (p path)) (-<> (points p) - (mapcar (curry #'coord-to-pair canvas) <>) - paths:make-simple-path + (mapcar-curried #'convert-points canvas <>) + fill-missing-control-points + make-vector-path (paths:stroke-path <> 1) (vectors:update-state (state canvas) <>))) diff -r 425689e66be8 -r 09e906903662 src/drawing/svg.lisp --- a/src/drawing/svg.lisp Sun Jun 09 12:45:59 2019 -0400 +++ b/src/drawing/svg.lisp Sun Jun 09 16:38:17 2019 -0400 @@ -77,15 +77,31 @@ ;;;; Paths -------------------------------------------------------------------- +(defun points-to-pairs (canvas points) + (loop :for ps :in points :collect (coords-to-pairs canvas ps))) + +(defun process-path-point (path point &optional first) + (destructuring-bind (loc &optional ctrl1 ctrl2) point + (cond + (first (svg:with-path path + (svg:move-to (car loc) (cdr loc)))) + (ctrl2 (svg:with-path path + (svg:curve-to (car ctrl1) (cdr ctrl1) + (car ctrl2) (cdr ctrl2) + (car loc) (cdr loc)))) + (ctrl1 (svg:with-path path + (svg:smooth-curve-to (car ctrl1) (cdr ctrl1) + (car loc) (cdr loc)))) + (t (svg:with-path path + (svg:line-to (car loc) (cdr loc))))))) + (defun make-svg-path-data (canvas points) (destructuring-bind (first-point &rest remaining-points) - (mapcar (curry #'coord-to-pair canvas) points) + (points-to-pairs 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)))) + (process-path-point p first-point t) + (loop :for next-point :in remaining-points + :do (process-path-point p next-point)) p))) (defmethod draw ((canvas svg-canvas) (path path)) diff -r 425689e66be8 -r 09e906903662 src/looms/004-turtle-curves.lisp --- a/src/looms/004-turtle-curves.lisp Sun Jun 09 12:45:59 2019 -0400 +++ b/src/looms/004-turtle-curves.lisp Sun Jun 09 16:38:17 2019 -0400 @@ -79,7 +79,7 @@ (defun find-bounds (paths) (iterate (for path :in paths) - (for (p1 p2) = (flax.drawing:points path)) + (for ((p1) (p2)) = (flax.drawing:points path)) (maximizing (vx p1) :into max-x) (maximizing (vx p2) :into max-x) (maximizing (vy p1) :into max-y) diff -r 425689e66be8 -r 09e906903662 src/package.lisp --- a/src/package.lisp Sun Jun 09 12:45:59 2019 -0400 +++ b/src/package.lisp Sun Jun 09 16:38:17 2019 -0400 @@ -7,7 +7,9 @@ :with-seed :random-or :randomly-initialize - :round-to)) + :round-to + :map-curried + :mapcar-curried)) (defpackage :flax.colors (:use :cl :iterate :losh :flax.base :flax.quickutils) diff -r 425689e66be8 -r 09e906903662 test/test.lisp --- a/test/test.lisp Sun Jun 09 12:45:59 2019 -0400 +++ b/test/test.lisp Sun Jun 09 16:38:17 2019 -0400 @@ -17,6 +17,7 @@ (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 interactive #'flax.looms.007-stipple:loom) + (losh:pr 'ok)) (check-all)