# HG changeset patch # User Steve Losh # Date 1462755695 0 # Node ID 564d579c018b65d579320f2483b5a5a5e39532be # Parent 29b2d3f28208cedc1910ec25e4dd7370a4914390 Episode 20: More Bezier Curves (B) diff -r 29b2d3f28208 -r 564d579c018b make-quickutils.lisp --- a/make-quickutils.lisp Mon May 09 00:18:57 2016 +0000 +++ b/make-quickutils.lisp Mon May 09 01:01:35 2016 +0000 @@ -12,5 +12,6 @@ :curry :rcurry :compose + :n-grams ) :package "CODING-MATH.QUICKUTILS") diff -r 29b2d3f28208 -r 564d579c018b package.lisp --- a/package.lisp Mon May 09 00:18:57 2016 +0000 +++ b/package.lisp Mon May 09 01:01:35 2016 +0000 @@ -127,6 +127,7 @@ #:cubic-bezier #:quadratic-bezier-curve #:draw-function + #:multicurve )) (defpackage #:coding-math.fps diff -r 29b2d3f28208 -r 564d579c018b quickutils.lisp --- a/quickutils.lisp Mon May 09 00:18:57 2016 +0000 +++ b/quickutils.lisp Mon May 09 01:01:35 2016 +0000 @@ -2,7 +2,7 @@ ;;;; See http://quickutil.org for details. ;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SWITCH :WHILE :ENSURE-BOOLEAN :WITH-GENSYMS :ONCE-ONLY :IOTA :CURRY :RCURRY :COMPOSE) :ensure-package T :package "CODING-MATH.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SWITCH :WHILE :ENSURE-BOOLEAN :WITH-GENSYMS :ONCE-ONLY :IOTA :CURRY :RCURRY :COMPOSE :N-GRAMS) :ensure-package T :package "CODING-MATH.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "CODING-MATH.QUICKUTILS") @@ -18,7 +18,7 @@ :SWITCH :UNTIL :WHILE :ENSURE-BOOLEAN :MAKE-GENSYM-LIST :ONCE-ONLY :IOTA :ENSURE-FUNCTION :CURRY :RCURRY - :COMPOSE)))) + :COMPOSE :TAKE :N-GRAMS)))) (defun %reevaluate-constant (name value test) (if (not (boundp name)) @@ -307,8 +307,30 @@ (declare (dynamic-extent arguments)) ,(compose-1 funs)))))) + + (defun take (n sequence) + "Take the first `n` elements from `sequence`." + (subseq sequence 0 n)) + + + (defun n-grams (n sequence) + "Find all `n`-grams of the sequence `sequence`." + (assert (and (plusp n) + (<= n (length sequence)))) + + (etypecase sequence + ;; Lists + (list (loop :repeat (1+ (- (length sequence) n)) + :for seq :on sequence + :collect (take n seq))) + + ;; General sequences + (sequence (loop :for i :to (- (length sequence) n) + :collect (subseq sequence i (+ i n)))))) + (eval-when (:compile-toplevel :load-toplevel :execute) (export '(define-constant switch eswitch cswitch while ensure-boolean - with-gensyms with-unique-names once-only iota curry rcurry compose))) + with-gensyms with-unique-names once-only iota curry rcurry compose + n-grams))) ;;;; END OF quickutils.lisp ;;;; diff -r 29b2d3f28208 -r 564d579c018b src/main.lisp --- a/src/main.lisp Mon May 09 00:18:57 2016 +0000 +++ b/src/main.lisp Mon May 09 01:01:35 2016 +0000 @@ -39,13 +39,12 @@ :debug :scancode-d) ((ready) (mouse) - (p0) - (p1) - (p2) - (cp) + (start) + (end) + (controls) (end-pen (make-pen :fill (gray 0.2))) (control-pen (make-pen :stroke (gray 0.1) :fill (gray 0.5))) - (line-pen (make-pen :stroke (gray 0.5))) + (line-pen (make-pen :stroke (gray 0.8))) (target-pen (make-pen :fill (rgb 0.5 0.0 0.0))) (fn-pen (make-pen :stroke (rgb 0.0 0 0.5) :weight 1 @@ -60,38 +59,17 @@ ;; (when ready - (with-vecs ((p0x p0y) p0 - (p1x p1y) mouse - (p2x p2y) p2) - (setf cp (make-vec - (- (* p1x 2) - (/ (+ p0x p2x) 2)) - (- (* p1y 2) - (/ (+ p0y p2y) 2)))) - (with-pen line-pen - (draw-line p0 cp) - (draw-line cp p2)) - (with-pen end-pen - (draw-circle p0 5) - (draw-circle p2 5)) - (with-pen target-pen - (draw-circle mouse 5)) - (with-pen control-pen - (draw-circle cp 5)) - (with-pen fn-pen - (draw-function - (lambda (v) - (make-vec (map-range 0.0 tau 0.0 *width* v) - (+ *center-y* (* 100.0 (sin v))))) - :start 0.0 - :end tau - ) - ) - (with-pen curve-pen - (quadratic-bezier-curve p0 p2 mouse) - (quadratic-bezier-curve p0 p2 cp) - - )) + (with-pen line-pen + (loop :for (a b) :on (append (list start) controls (list end)) + :when b :do (draw-line a b))) + (with-pen end-pen + (draw-circle start 5) + (draw-circle end 5)) + (with-pen control-pen + (mapc (rcurry #'draw-circle 5) controls)) + (with-pen curve-pen + (multicurve start controls end)) + ) ;; @@ -105,12 +83,15 @@ (defun reset (game) (setf (slot-value game 'ready) nil) (setf - (slot-value game 'p0) - (make-random-vec *width* *height*) - (slot-value game 'p1) - (make-random-vec *width* *height*) - (slot-value game 'p2) - (make-random-vec *width* *height*) + (slot-value game 'start) + (make-vec 0 *center-y*) + (slot-value game 'end) + (make-vec *width* *center-y*) + (slot-value game 'controls) + ; (loop :for x :from 100 :below *width* :by 100 + ; :collect (make-vec x (random *height*))) + (loop :repeat 8 + :collect (make-random-vec *width* *height*)) ) (setf (slot-value game 'ready) t)) diff -r 29b2d3f28208 -r 564d579c018b src/points.lisp --- a/src/points.lisp Mon May 09 00:18:57 2016 +0000 +++ b/src/points.lisp Mon May 09 01:01:35 2016 +0000 @@ -44,11 +44,13 @@ (draw-function (curry #'fast-quadratic-bezier from to control))) -; (defun multicurve (points) -; (loop :for (p0 p1 . remaining) :on points -; :when remaining -; :for midx = (/ (+ (vec-x p0) (vec-x p1)) 2) -; :for midy = (/ (+ (vec-y p0) (vec-y p1)) 2) -; ) - -; ) +(defun multicurve (from controls to) + (labels ((midpoint (pair) + (vec-lerp (car pair) (cadr pair) 0.5)) + (midpoints (points) + (mapcar #'midpoint (n-grams 2 points)))) + (let ((mids (midpoints controls))) + (loop :for start :in (cons from mids) + :for end :in (append mids (list to)) + :for control :in controls + :do (quadratic-bezier-curve start end control)))))