# HG changeset patch # User Steve Losh # Date 1462906309 0 # Node ID 4760ced86a2cea6e3be4e69ae1145907580367f3 # Parent 45d7df1f48f332b466de4e1271a57032d6956738 Mini 11: Drag and Drop diff -r 45d7df1f48f3 -r 4760ced86a2c package.lisp --- a/package.lisp Mon May 09 21:22:44 2016 +0000 +++ b/package.lisp Tue May 10 18:51:49 2016 +0000 @@ -90,6 +90,7 @@ (:use #:cl #:sketch + #:coding-math.2d.vectors #:coding-math.math #:coding-math.quickutils #:coding-math.utils) @@ -99,6 +100,8 @@ #:hitbox-radius #:hitbox-width #:hitbox-height + #:drag-requested-p + #:drag-location-vec #:circles-collide-p #:circle-point-collide-p #:rect-point-collide-p @@ -165,6 +168,7 @@ #:coding-math.math #:coding-math.2d.vectors #:coding-math.2d.points + #:coding-math.2d.hitboxes #:coding-math.2d.particles)) (defpackage #:coding-math.2d.ballistics diff -r 45d7df1f48f3 -r 4760ced86a2c src/2d/demo.lisp --- a/src/2d/demo.lisp Mon May 09 21:22:44 2016 +0000 +++ b/src/2d/demo.lisp Tue May 10 18:51:49 2016 +0000 @@ -9,16 +9,17 @@ ;;;; Sketch -(defun draw-particle (p pen) - (with-pen pen - (circle (particle-x p) (particle-y p) (particle-radius p)))) +(defun draw-particle (p) + (circle (particle-x p) (particle-y p) (particle-radius p))) (defun draw-line (p1 p2) (with-vecs ((x1 y1) p1 (x2 y2) p2) (line x1 y1 x2 y2))) -(defun draw-circle (p radius) - (circle (vec-x p) (vec-y p) radius)) +(defun draw-circle (p &optional (radius 5)) + (if (listp p) + (circle (getf p :x) (getf p :y) (or (getf p :radius) radius)) + (circle (vec-x p) (vec-y p) radius))) (defun draw-square (p radius) (rect (- (vec-x p) radius) @@ -39,20 +40,20 @@ :debug :scancode-d) ((ready) (mouse) - (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.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 - :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))) + (dragging) + (p1) + (c1) + (c2) + (p2) + (handles) + (control-pen (make-pen :stroke (gray 0.1) + :weight 1 + :fill (rgb 0.5 0.5 0.9))) + (end-pen (make-pen :stroke (gray 0.1) + :weight 1 + :fill (gray 0.5))) + (line-pen (make-pen :stroke (gray 0.7))) + (curve-pen (make-pen :stroke (rgb 0.7 0.2 0.2))) ) (with-fps (background (gray 1)) @@ -60,51 +61,107 @@ (when ready (with-pen line-pen - (loop :for (a b) :on (append (list start) controls (list end)) - :when b :do (draw-line a b))) + (draw-line (particle-pos p1) + (particle-pos c1)) + (draw-line (particle-pos c1) + (particle-pos c2)) + (draw-line (particle-pos c2) + (particle-pos p2))) (with-pen end-pen - (draw-circle start 5) - (draw-circle end 5)) + (draw-particle p1) + (draw-particle p2)) (with-pen control-pen - (mapc (rcurry #'draw-circle 5) controls)) + (draw-particle c1) + (draw-particle c2)) (with-pen curve-pen - (multicurve start controls end)) + (with-vecs ((p1x p1y) (particle-pos p1) + (c1x c1y) (particle-pos c1) + (c2x c2y) (particle-pos c2) + (p2x p2y) (particle-pos p2)) + (bezier p1x p1y c1x c1y c2x c2y p2x p2y)) + ) ) ;; )) -(defun make-cm () - (make-sketch 'cm - (mouse (make-vec)))) - (defun reset (game) (setf (slot-value game 'ready) nil) - (setf - (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*)) + ;; + (let ((p1 (make-particle (random *width*) (random *height*) :radius 10)) + (c1 (make-particle (random *width*) (random *height*) :radius 8)) + (c2 (make-particle (random *width*) (random *height*) :radius 8)) + (p2 (make-particle (random *width*) (random *height*) :radius 10))) + (setf + (slot-value game 'p1) p1 + (slot-value game 'c1) c1 + (slot-value game 'c2) c2 + (slot-value game 'p2) p2 + (slot-value game 'handles) (list p1 c1 c2 p2) + ) ) + ;; (setf (slot-value game 'ready) t)) ;;;; Mouse -(defmethod kit.sdl2:mousemotion-event ((window cm) ts b x y xrel yrel) - (declare (ignore ts b xrel yrel)) - (with-slots (mouse) window +(defun mousemove (instance x y) + (with-slots (dragging mouse) instance (setf (vec-x mouse) x) (setf (vec-y mouse) y) ;; + (when dragging + (destructuring-bind (thing . offset) dragging + (setf (drag-location-vec thing) + (vec-add mouse offset))) + ) ;; - )) + ) + ) + +(defun mousedown-left (instance x y) + (declare (ignorable instance x y)) + (with-slots (dragging mouse handles) instance + (loop :for handle :in handles + :when (drag-requested-p handle (make-vec x y)) + :do (setf dragging + (cons handle + (vec-sub (drag-location-vec handle) + mouse))))) + ) + +(defun mousedown-right (instance x y) + (declare (ignorable instance x y)) + ) + +(defun mouseup-left (instance x y) + (declare (ignorable instance x y)) + (setf (slot-value instance 'dragging) nil) + ) + +(defun mouseup-right (instance x y) + (declare (ignorable instance x y)) + ) + + +(defmethod kit.sdl2:mousemotion-event ((window cm) ts b x y xrel yrel) + (declare (ignore ts b xrel yrel)) + (mousemove window x y)) + +(defmethod kit.sdl2:mousebutton-event ((window cm) state ts button x y) + (declare (ignore ts)) + (funcall (case state + (:mousebuttondown + (case button + (1 #'mousedown-left) + (3 #'mousedown-right))) + (:mousebuttonup + (case button + (1 #'mouseup-left) + (3 #'mouseup-right)))) + window x y)) ;;;; Keyboard @@ -129,4 +186,10 @@ ;;;; Run +(defun make-cm () + (make-sketch 'cm + (mouse (make-vec)))) + + ; (defparameter *demo* (make-cm)) + diff -r 45d7df1f48f3 -r 4760ced86a2c src/2d/hitboxes.lisp --- a/src/2d/hitboxes.lisp Mon May 09 21:22:44 2016 +0000 +++ b/src/2d/hitboxes.lisp Tue May 10 18:51:49 2016 +0000 @@ -27,6 +27,13 @@ (getf object :height)) +(defmethod hitbox-x ((object vec)) + (vec-x object)) + +(defmethod hitbox-y ((object vec)) + (vec-y object)) + + (defun circles-collide-p (c0 c1) (let ((d (distance (hitbox-x c0) (hitbox-y c0) (hitbox-x c1) (hitbox-y c1)))) @@ -60,3 +67,8 @@ r1x (+ r1x r1w)) (ranges-overlap-p r0y (+ r0y r0h) r1y (+ r1y r1h)))))) + + +(defgeneric drag-location-vec (object)) +(defgeneric (setf drag-location-vec) (new-value object)) +(defgeneric drag-requested-p (object mouse)) diff -r 45d7df1f48f3 -r 4760ced86a2c src/2d/particles.lisp --- a/src/2d/particles.lisp Mon May 09 21:22:44 2016 +0000 +++ b/src/2d/particles.lisp Tue May 10 18:51:49 2016 +0000 @@ -146,3 +146,13 @@ (defmethod hitbox-radius ((p particle)) (particle-radius p)) + + +(defmethod drag-requested-p ((p particle) mouse) + (circle-point-collide-p p mouse)) + +(defmethod drag-location-vec ((p particle)) + (particle-pos p)) + +(defmethod (setf drag-location-vec) (new-value (p particle)) + (setf (particle-pos p) new-value)) diff -r 45d7df1f48f3 -r 4760ced86a2c src/2d/vectors.lisp --- a/src/2d/vectors.lisp Mon May 09 21:22:44 2016 +0000 +++ b/src/2d/vectors.lisp Tue May 10 18:51:49 2016 +0000 @@ -10,8 +10,7 @@ (defstruct (vec (:constructor make-vec - (&optional (x 0) (y 0))) - (:type vector)) + (&optional (x 0) (y 0)))) (x 0 :type real) (y 0 :type real))