--- 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")
))))
--- 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")
--- 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
--- 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 ;;;;
--- 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))
--- 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)
+; )
+
+; )