# HG changeset patch # User Steve Losh # Date 1467562361 0 # Node ID 15245c6a668a050a74c4330bdfbe76112acea0c8 # Parent 4f1e6a70e5adb5235408717af4fd88999b414176 Episode 34: Line Intersections Part 3 diff -r 4f1e6a70e5ad -r 15245c6a668a coding-math.asd --- a/coding-math.asd Sun Jul 03 13:35:34 2016 +0000 +++ b/coding-math.asd Sun Jul 03 16:12:41 2016 +0000 @@ -10,6 +10,7 @@ :depends-on (#:defstar #:optima #:sketch + #:iterate #:sb-cga #:trivial-types #:cl-arrows diff -r 4f1e6a70e5ad -r 15245c6a668a make-quickutils.lisp --- a/make-quickutils.lisp Sun Jul 03 13:35:34 2016 +0000 +++ b/make-quickutils.lisp Sun Jul 03 16:12:41 2016 +0000 @@ -4,7 +4,7 @@ "quickutils.lisp" :utilities '(:define-constant :switch - :while + ; :while :ensure-boolean :with-gensyms :once-only diff -r 4f1e6a70e5ad -r 15245c6a668a package.lisp --- a/package.lisp Sun Jul 03 13:35:34 2016 +0000 +++ b/package.lisp Sun Jul 03 16:12:41 2016 +0000 @@ -3,13 +3,17 @@ (:use #:cl #:sketch + #:iterate #:coding-math.quickutils) + (:shadowing-import-from #:iterate + #:in) (:export #:in-context #:scancode-case #:with-vals #:zap% #:% + #:pairs-of-list #:setf-slots #:symbolicate #:ensure-car @@ -215,6 +219,7 @@ (:use #:cl #:sketch + #:iterate #:coding-math.quickutils #:coding-math.utils #:coding-math.fps @@ -224,7 +229,9 @@ #:coding-math.2d.points #:coding-math.2d.lines #:coding-math.2d.hitboxes - #:coding-math.2d.particles)) + #:coding-math.2d.particles) + (:shadowing-import-from #:iterate + #:in)) (defpackage #:coding-math.2d.ballistics (:use diff -r 4f1e6a70e5ad -r 15245c6a668a quickutils.lisp --- a/quickutils.lisp Sun Jul 03 13:35:34 2016 +0000 +++ b/quickutils.lisp Sun Jul 03 16:12:41 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 :N-GRAMS) :ensure-package T :package "CODING-MATH.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SWITCH :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") @@ -15,7 +15,7 @@ (when (boundp '*utilities*) (setf *utilities* (union *utilities* '(:DEFINE-CONSTANT :STRING-DESIGNATOR :WITH-GENSYMS :EXTRACT-FUNCTION-NAME - :SWITCH :UNTIL :WHILE :ENSURE-BOOLEAN + :SWITCH :ENSURE-BOOLEAN :MAKE-GENSYM-LIST :ONCE-ONLY :IOTA :ENSURE-FUNCTION :CURRY :RCURRY :COMPOSE :TAKE :N-GRAMS)))) @@ -151,19 +151,6 @@ (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH."))) - (defmacro until (expression &body body) - "Executes `body` until `expression` is true." - `(do () - (,expression) - ,@body)) - - - (defmacro while (expression &body body) - "Executes `body` while `expression` is true." - `(until (not ,expression) - ,@body)) - - (defun ensure-boolean (x) "Convert `x` into a Boolean value." (and x t)) @@ -329,8 +316,7 @@ :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 - n-grams))) + (export '(define-constant switch eswitch cswitch ensure-boolean with-gensyms + with-unique-names once-only iota curry rcurry compose n-grams))) ;;;; END OF quickutils.lisp ;;;; diff -r 4f1e6a70e5ad -r 15245c6a668a src/2d/demo.lisp --- a/src/2d/demo.lisp Sun Jul 03 13:35:34 2016 +0000 +++ b/src/2d/demo.lisp Sun Jul 03 16:12:41 2016 +0000 @@ -42,28 +42,75 @@ (defun draw-point (p) (point (vec-x p) (vec-y p))) +(defun draw-polygon (points) + (when points + ;; why is this fucked? + (apply #'polygon + (iterate (for p :in points) + (collect (vec-x p)) + (collect (vec-y p)))))) + + +(defun move-star (star x y) + (let ((center (getf star :center))) + (setf (particle-x center) x + (particle-y center) y + + (getf star :points) + (iterate + (repeat 10) + (for a :from (getf star :angle) :by (/ tau 10)) + (for iteration :from 0) + (for r = (* (getf star :radius) + (if (evenp iteration) 1.0 0.5))) + (collect (vec-add (particle-pos center) + (make-vec-md r a))))))) + +(defun make-star (angle radius) + (let ((star (list :center (make-particle 0 0 :radius 5) + :angle angle + :radius radius + :points nil))) + (move-star star (random *width*) (random *height*)) + star)) + + +(defun draw-star (star) + (draw-particle (getf star :center)) + ; (draw-polygon (getf star :points)) + (iterate + (with points = (getf star :points)) + (for (p1 . p2) :pairs-of-list points) + (draw-circle p1 3) + (draw-line p1 p2))) (defun oob-p (p &optional (r 0.0)) (or (outsidep (- 0 r) (+ *width* r) (vec-x p)) (outsidep (- 0 r) (+ *height* r) (vec-y p)))) +(defun stars-collide-p (star-1 star-2) + (iterate + main + (for (p1 . p2) :pairs-of-list (getf star-1 :points)) + (iterate + (for (p3 . p4) :pairs-of-list (getf star-2 :points)) + (with-vecs ((x11 y11) p1 + (x12 y12) p2 + (x21 y21) p3 + (x22 y22) p4) + (in main + (thereis (xys-segments-intersection-point + x11 y11 x12 y12 x21 y21 x22 y22))))))) + + (defsketch cm ((width *width*) (height *height*) (y-axis :down) (title "Coding Math 2D") (mouse (make-vec 0 0)) ;; Data - (m1 (random-range -5 5)) - (m2 (random-range -5 5)) - (b1 (random-range -5 5)) - (b2 (random-range -5 5)) - (x11 (random-range -5 5)) - (y11 (random-range -5 5)) - (x12 (random-range -5 5)) - (y12 (random-range -5 5)) - (x21 (random-range -5 5)) - (y21 (random-range -5 5)) - (x22 (random-range -5 5)) - (y22 (random-range -5 5)) + (star-1 (make-star (random tau) (random-range 30.0 70.0))) + (star-2 (make-star (random tau) (random-range 30.0 70.0))) + (dragging nil) ;; Pens (particle-pen (make-pen :fill (gray 0.9) :stroke (gray 0.4))) (black-pen (make-pen :stroke (rgb 0 0 0) :fill (rgb 0.4 0.4 0.4) :weight 1 :curve-steps 50)) @@ -74,57 +121,14 @@ (with-setup ;; (in-context - (translate *center-x* *center-y*) (draw-axes *width* *height*) - (flet ((map-to-screen (x y) - (values (map-range -10.0 10.0 (- *center-x*) *center-x* x) - (map-range -10.0 10.0 (- *center-y*) *center-y* y))) - (valid-line-p (x1 y1 x2 y2) - (not (and (= x1 x2) - (= y1 y2)))) - (g (fn) - (graph-function - fn - :fn-start -10 :fn-end 10 - :fn-min -10 :fn-max 10 - :graph-start (- *center-x*) :graph-end *center-x* - :graph-min (- *center-y*) :graph-max *center-y*))) - (with-pen green-pen - (g (lambda (x) (+ (* m1 x) b1))) - (g (lambda (x) (+ (* m2 x) b2))) - (multiple-value-bind (x y) - (mxb-intersection-point m1 b1 m2 b2) - (when x - (draw-circle (multiple-value-call #'make-vec - (map-to-screen x y)) - 6)))) - (when (and (valid-line-p x11 y11 x12 y12) - (valid-line-p x21 y21 x22 y22)) - (with-pen red-pen - (multiple-value-call #'line - (map-to-screen x11 y11) - (map-to-screen x12 y12)) - (multiple-value-call #'line - (map-to-screen x21 y21) - (map-to-screen x22 y22)) - (draw-circle (multiple-value-call #'make-vec (map-to-screen x11 y11)) 3) - (draw-circle (multiple-value-call #'make-vec (map-to-screen x12 y12)) 3) - (draw-circle (multiple-value-call #'make-vec (map-to-screen x21 y21)) 3) - (draw-circle (multiple-value-call #'make-vec (map-to-screen x22 y22)) 3) - (multiple-value-bind (x y) - (xys-intersection-point x11 y11 x12 y12 x21 y21 x22 y22) - (when x - (draw-circle (multiple-value-call #'make-vec - (map-to-screen x y)) - 6)))) - (with-pen blue-pen - (multiple-value-bind (x y) - (xys-segments-intersection-point x11 y11 x12 y12 x21 y21 x22 y22) - (when x - (draw-circle (multiple-value-call #'make-vec - (map-to-screen x y)) - 3))))) - ) + (with-pen red-pen + (draw-star star-1)) + (with-pen blue-pen + (draw-star star-2)) + (when (stars-collide-p star-1 star-2) + (text "BOOM!" *center-x* *center-y*)) + ) ;; ) @@ -136,6 +140,11 @@ (with-slots (mouse) instance (setf mouse (make-vec x (- *height* y))) ;; + (with-slots (dragging) instance + (when dragging + (move-star dragging x y) + ) + ) ;; ) ) @@ -145,7 +154,17 @@ 300 300)) (defun mousedown-left (instance x y) - (declare (ignorable instance x y))) + (declare (ignorable instance x y)) + (with-slots (dragging star-1 star-2) instance + (let ((p1 (getf star-1 :center)) + (p2 (getf star-2 :center)) + (target (make-vec x y))) + (cond + ((circle-point-collide-p p1 target) (setf dragging star-1)) + ((circle-point-collide-p p2 target) (setf dragging star-2)) + (t nil) + ))) + ) (defun mousedown-right (instance x y) (declare (ignorable instance x y)) @@ -153,6 +172,8 @@ (defun mouseup-left (instance x y) (declare (ignorable instance x y)) + (with-slots (dragging) instance + (setf dragging nil)) ) (defun mouseup-right (instance x y) diff -r 4f1e6a70e5ad -r 15245c6a668a src/utils.lisp --- a/src/utils.lisp Sun Jul 03 13:35:34 2016 +0000 +++ b/src/utils.lisp Sun Jul 03 16:12:41 2016 +0000 @@ -104,6 +104,30 @@ :step (/ (- fn-end fn-start) steps))))))) +;;;; Iterate +(defmacro-driver (FOR var PAIRS-OF-LIST list) + (let ((kwd (if generate 'generate 'for))) + (with-gensyms (current l) + `(progn + (with ,l = ,list) + (with ,current = ,l) + (,kwd ,var next + (cond + ((null ,current) + (terminate)) + + ((null (cdr ,current)) + (prog1 + (cons (first ,current) (car ,l)) + (setf ,current nil))) + + (t + (prog1 + (cons (first ,current) (second ,current)) + (setf ,current (cdr ,current)))))))))) + + + ;; snagged from squirl (eval-when (:compile-toplevel :load-toplevel :execute) (defun symbolicate (&rest things)