--- 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)))
--- 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 -------------------------------------------------------------
--- 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))
--- 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) <>)))
--- 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))
--- 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)
--- 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)
--- 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)