# HG changeset patch # User Steve Losh # Date 1462753137 0 # Node ID 29b2d3f28208cedc1910ec25e4dd7370a4914390 # Parent fcb933aa4e5d0e9a7db3266960dbec4d031ad21e Episode 20: More Bezier Curves (A) diff -r fcb933aa4e5d -r 29b2d3f28208 coding-math.asd --- a/coding-math.asd Fri May 06 18:40:23 2016 +0000 +++ b/coding-math.asd Mon May 09 00:18:57 2016 +0000 @@ -25,6 +25,7 @@ (:file "fps") (:file "vectors") (:file "particles") + (:file "points") (:file "main") (:file "ballistics") )))) diff -r fcb933aa4e5d -r 29b2d3f28208 make-quickutils.lisp --- a/make-quickutils.lisp Fri May 06 18:40:23 2016 +0000 +++ b/make-quickutils.lisp Mon May 09 00:18:57 2016 +0000 @@ -8,5 +8,9 @@ :ensure-boolean :with-gensyms :once-only + :iota + :curry + :rcurry + :compose ) :package "CODING-MATH.QUICKUTILS") diff -r fcb933aa4e5d -r 29b2d3f28208 package.lisp --- a/package.lisp Fri May 06 18:40:23 2016 +0000 +++ b/package.lisp Mon May 09 00:18:57 2016 +0000 @@ -116,6 +116,7 @@ (defpackage #:coding-math.points (:use #:cl + #:sketch #:coding-math.math #:coding-math.vectors #:coding-math.quickutils @@ -124,6 +125,8 @@ #:quadratic-bezier #:fast-quadratic-bezier #:cubic-bezier + #:quadratic-bezier-curve + #:draw-function )) (defpackage #:coding-math.fps diff -r fcb933aa4e5d -r 29b2d3f28208 quickutils.lisp --- a/quickutils.lisp Fri May 06 18:40:23 2016 +0000 +++ b/quickutils.lisp Mon May 09 00:18:57 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) :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) :ensure-package T :package "CODING-MATH.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "CODING-MATH.QUICKUTILS") @@ -16,7 +16,9 @@ (setf *utilities* (union *utilities* '(:DEFINE-CONSTANT :STRING-DESIGNATOR :WITH-GENSYMS :EXTRACT-FUNCTION-NAME :SWITCH :UNTIL :WHILE :ENSURE-BOOLEAN - :MAKE-GENSYM-LIST :ONCE-ONLY)))) + :MAKE-GENSYM-LIST :ONCE-ONLY :IOTA + :ENSURE-FUNCTION :CURRY :RCURRY + :COMPOSE)))) (defun %reevaluate-constant (name value test) (if (not (boundp name)) @@ -213,8 +215,100 @@ names-and-forms gensyms) ,@forms))))) + + (declaim (inline iota)) + (defun iota (n &key (start 0) (step 1)) + "Return a list of `n` numbers, starting from `start` (with numeric contagion +from `step` applied), each consequtive number being the sum of the previous one +and `step`. `start` defaults to `0` and `step` to `1`. + +Examples: + + (iota 4) => (0 1 2 3) + (iota 3 :start 1 :step 1.0) => (1.0 2.0 3.0) + (iota 3 :start -1 :step -1/2) => (-1 -3/2 -2)" + (declare (type (integer 0) n) (number start step)) + (loop repeat n + ;; KLUDGE: get numeric contagion right for the first element too + for i = (+ (- (+ start step) step)) then (+ i step) + collect i)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;;; To propagate return type and allow the compiler to eliminate the IF when + ;;; it is known if the argument is function or not. + (declaim (inline ensure-function)) + + (declaim (ftype (function (t) (values function &optional)) + ensure-function)) + (defun ensure-function (function-designator) + "Returns the function designated by `function-designator`: +if `function-designator` is a function, it is returned, otherwise +it must be a function name and its `fdefinition` is returned." + (if (functionp function-designator) + function-designator + (fdefinition function-designator))) + ) ; eval-when + + (defun curry (function &rest arguments) + "Returns a function that applies `arguments` and the arguments +it is called with to `function`." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (let ((fn (ensure-function function))) + (lambda (&rest more) + (declare (dynamic-extent more)) + ;; Using M-V-C we don't need to append the arguments. + (multiple-value-call fn (values-list arguments) (values-list more))))) + + (define-compiler-macro curry (function &rest arguments) + (let ((curries (make-gensym-list (length arguments) "CURRY")) + (fun (gensym "FUN"))) + `(let ((,fun (ensure-function ,function)) + ,@(mapcar #'list curries arguments)) + (declare (optimize (speed 3) (safety 1) (debug 1))) + (lambda (&rest more) + (apply ,fun ,@curries more))))) + + + (defun rcurry (function &rest arguments) + "Returns a function that applies the arguments it is called +with and `arguments` to `function`." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (let ((fn (ensure-function function))) + (lambda (&rest more) + (declare (dynamic-extent more)) + (multiple-value-call fn (values-list more) (values-list arguments))))) + + + (defun compose (function &rest more-functions) + "Returns a function composed of `function` and `more-functions` that applies its ; +arguments to to each in turn, starting from the rightmost of `more-functions`, +and then calling the next one with the primary value of the last." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (reduce (lambda (f g) + (let ((f (ensure-function f)) + (g (ensure-function g))) + (lambda (&rest arguments) + (declare (dynamic-extent arguments)) + (funcall f (apply g arguments))))) + more-functions + :initial-value function)) + + (define-compiler-macro compose (function &rest more-functions) + (labels ((compose-1 (funs) + (if (cdr funs) + `(funcall ,(car funs) ,(compose-1 (cdr funs))) + `(apply ,(car funs) arguments)))) + (let* ((args (cons function more-functions)) + (funs (make-gensym-list (length args) "COMPOSE"))) + `(let ,(loop for f in funs for arg in args + collect `(,f (ensure-function ,arg))) + (declare (optimize (speed 3) (safety 1) (debug 1))) + (lambda (&rest arguments) + (declare (dynamic-extent arguments)) + ,(compose-1 funs)))))) + (eval-when (:compile-toplevel :load-toplevel :execute) (export '(define-constant switch eswitch cswitch while ensure-boolean - with-gensyms with-unique-names once-only))) + with-gensyms with-unique-names once-only iota curry rcurry compose))) ;;;; END OF quickutils.lisp ;;;; diff -r fcb933aa4e5d -r 29b2d3f28208 src/main.lisp --- a/src/main.lisp Fri May 06 18:40:23 2016 +0000 +++ b/src/main.lisp Mon May 09 00:18:57 2016 +0000 @@ -39,22 +39,59 @@ :debug :scancode-d) ((ready) (mouse) - (particles) - (pen (make-pen :fill (gray 0.2))) + (p0) + (p1) + (p2) + (cp) + (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))) + (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 + :curve-steps 80)) + (curve-pen (make-pen :stroke (rgb 0.5 0 0) + :weight 1 + :curve-steps 60 + :fill (rgb 0.5 0.0 0.0))) ) (with-fps (background (gray 1)) ;; (when ready - (with-pen pen - (loop :for p :in particles :do - (particle-update! p) - (if (oob-p (particle-pos p)) - (setf particles (remove p particles)) - (draw-circle (particle-pos p) 3))) - ) - + (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) + + )) ) ;; @@ -67,18 +104,14 @@ (defun reset (game) (setf (slot-value game 'ready) nil) - (setf (slot-value game 'particles) - (loop :repeat 200 - :collect (make-particle *center-x* - *center-y* - :speed (random 2.0) - :direction (random tau) - ) - - - ) - - ) + (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*) + ) (setf (slot-value game 'ready) t)) diff -r fcb933aa4e5d -r 29b2d3f28208 src/points.lisp --- a/src/points.lisp Fri May 06 18:40:23 2016 +0000 +++ b/src/points.lisp Mon May 09 00:18:57 2016 +0000 @@ -18,7 +18,7 @@ (+ (* (square (- 1 n)) fy) (* 2 (- 1 n) n cy) (* n n ty)))) - (values)) + destination) (defun cubic-bezier (from to control-1 control-2 n) @@ -29,3 +29,26 @@ (vec-lerp control-2 to n) n) n)) + + +(declaim (inline draw-function)) +(defun draw-function (fn &key (start 0.0) (end 1.0)) + (let ((steps (sketch::pen-curve-steps (sketch::env-pen sketch::*env*)))) + (apply #'polyline + (mapcan (compose (rcurry #'coerce 'list) fn) + (iota (1+ steps) + :start 0.0 + :step (/ (- end start) steps)))))) + +(defun quadratic-bezier-curve (from to control) + (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) +; ) + +; )