# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1461424700 0
# Node ID 67072984548b9e10ccd6e4decc07bcd4eeb65ffd
# Parent  69f98eb3a1df4328392e4765b7ab78facd452909
Application 2: Ballistics Part 2

diff -r 69f98eb3a1df -r 67072984548b .lispwords
--- a/.lispwords	Fri Apr 22 23:13:31 2016 +0000
+++ b/.lispwords	Sat Apr 23 15:18:20 2016 +0000
@@ -1,1 +1,2 @@
 (1 scancode-case)
+(1 make-sketch)
diff -r 69f98eb3a1df -r 67072984548b package.lisp
--- a/package.lisp	Fri Apr 22 23:13:31 2016 +0000
+++ b/package.lisp	Sat Apr 23 15:18:20 2016 +0000
@@ -4,8 +4,9 @@
    #:sketch
    #:coding-math.quickutils)
   (:export
-   #:a
    #:in-context
+   #:make-sketch
+   #:scancode-case
    #:mulf
    #:dividesp
    #:square))
@@ -70,6 +71,8 @@
    #:particle-radius
    #:particle-mass
    #:particle-friction
+   #:particle-speed
+   #:particle-direction
    #:make-particle
    #:particle-x
    #:particle-y
@@ -106,6 +109,7 @@
    #:cl
    #:sketch
    #:coding-math.quickutils
+   #:coding-math.particles
    #:coding-math.utils
    #:coding-math.math
    #:coding-math.fps))
diff -r 69f98eb3a1df -r 67072984548b src/ballistics.lisp
--- a/src/ballistics.lisp	Fri Apr 22 23:13:31 2016 +0000
+++ b/src/ballistics.lisp	Sat Apr 23 15:18:20 2016 +0000
@@ -7,41 +7,92 @@
 (defparameter *center-x* (/ *width* 2))
 (defparameter *center-y* (/ *height* 2))
 
+
+;;;; Drawing
 (defun draw-gun (gun)
   (in-context
-    (translate (a gun 'x) (a gun 'y))
-    (with-pen (make-pen :stroke (gray 0.0) :fill (gray 0.0))
-      (circle 0 0 15)
-      (rotate (degrees (a gun 'angle)))
-      (rect 0 -4 25 8)
+    (translate (getf gun 'x) (getf gun 'y))
+    (with-pen (make-pen :stroke (gray 0.0))
+      (circle 0 0 25)
+      (rotate (degrees (getf gun 'angle)))
+      (rect 0 -8 40 16)
       )))
 
+(defun draw-ball (ball)
+  (with-pen (make-pen :stroke (gray 0.1) :fill (gray 0.6))
+     (circle (particle-x ball) (particle-y ball) (particle-radius ball))))
+
+
+;;;; Game
 (defun aim (gun x y)
-  (setf (cdr (assoc 'angle gun))
+  (setf (getf gun 'angle)
         (clamp (- (/ tau 4))
                -0.3
-               (atan (- y (a gun 'y))
-                     (- x (a gun 'x))))))
+               (atan (- y (getf gun 'y))
+                     (- x (getf gun 'x))))))
+
+(defun shoot (game)
+  (force-output)
+  (with-slots (gun cannonball can-shoot-p firedp) game
+    (let ((angle (getf gun 'angle)))
+      (setf
+        can-shoot-p nil
+        firedp t
+        (particle-x cannonball) (+ (getf gun 'x) (* 40 (cos angle)))
+        (particle-y cannonball) (+ (getf gun 'y) (* 40 (sin angle)))
+        (particle-speed cannonball) 10
+        (particle-direction cannonball) angle))))
+
+(defun update-ball (game)
+  (with-slots (cannonball firedp can-shoot-p) game
+    (particle-update! cannonball)
+    (when (> (- (particle-y cannonball)
+                (particle-radius cannonball))
+             *height*)
+      (setf can-shoot-p t
+            firedp nil))))
 
 (defsketch game (:width *width*
                  :height *height*
                  :debug :scancode-d)
-    ((frame 1)
-     (aiming nil)
-     (gun `((x . 40)
-            (y . ,*height*)
-            (angle . ,(- (/ tau 8))))))
+    ((frame)
+     (aiming)
+     (gun)
+     (cannonball)
+     (can-shoot-p)
+     (firedp)
+     )
   (background (gray 1))
   (incf frame)
   ;;
   (draw-gun gun)
-
+  (draw-ball cannonball)
+  (when firedp
+    (update-ball sketch::sketch-window))
   ;;
   (when (zerop (mod frame 20))
     (calc-fps 20))
   (draw-fps))
 
 
+(defun make-game ()
+  (make-sketch 'game
+    (frame 1)
+    (aiming nil)
+    (can-shoot-p t)
+    (firedp nil)
+    (gun `(x 40
+           y ,*height*
+           angle ,(- (/ tau 8))))
+    (cannonball (make-particle (getf gun 'x)
+                               (getf gun 'y)
+                               :speed 15
+                               :direction (getf gun 'angle)
+                               :radius 7
+                               :gravity 0.2))))
+
+
+;;;; Mouse
 (defmethod kit.sdl2:mousebutton-event
     ((game game) state timestamp button x y)
   (declare (ignore timestamp x y))
@@ -56,5 +107,29 @@
   (when (slot-value game 'aiming)
     (aim (slot-value game 'gun) x y)))
 
+
+;;;; Keyboard
+(defun keydown (game scancode)
+  (declare (ignore game))
+  (scancode-case scancode
+    (:scancode-space
+     nil)))
+
+(defun keyup (game scancode)
+  (scancode-case scancode
+    (:scancode-space
+     (when (can-shoot-p game)
+       (shoot game)))))
+
+
+(defmethod kit.sdl2:keyboard-event ((instance game) state timestamp repeatp keysym)
+  (declare (ignore timestamp repeatp))
+  (cond
+    ((eql state :keyup) (keyup instance (sdl2:scancode-value keysym)))
+    ((eql state :keydown) (keydown instance (sdl2:scancode-value keysym)))
+    (t nil)))
+
+
+
 ;;;; Run
-; (defparameter *demo* (make-instance 'game))
+(defparameter *demo* (make-game))
diff -r 69f98eb3a1df -r 67072984548b src/main.lisp
--- a/src/main.lisp	Fri Apr 22 23:13:31 2016 +0000
+++ b/src/main.lisp	Sat Apr 23 15:18:20 2016 +0000
@@ -63,17 +63,6 @@
 
 
 ;;;; Keyboard
-(defmacro scancode-case (scancode-form &rest pairs)
-  (let ((scancode (gensym "scancode")))
-    `(let ((,scancode ,scancode-form))
-      (cond
-        ,@(mapcar (lambda (pair)
-                    (destructuring-bind (key-scancode &rest body) pair
-                      `((sdl2:scancode= ,scancode ,key-scancode)
-                        ,@body)))
-                  pairs)))))
-
-
 (defun keydown (instance scancode)
   (scancode-case scancode
     (:scancode-space
@@ -87,9 +76,7 @@
 (defun keyup (instance scancode)
   (scancode-case scancode
     (:scancode-space
-     nil
-     )
-    ))
+     nil)))
 
 
 (defmethod kit.sdl2:keyboard-event ((instance cm) state timestamp repeatp keysym)
diff -r 69f98eb3a1df -r 67072984548b src/particles.lisp
--- a/src/particles.lisp	Fri Apr 22 23:13:31 2016 +0000
+++ b/src/particles.lisp	Sat Apr 23 15:18:20 2016 +0000
@@ -48,6 +48,12 @@
 (defun particle-y (particle)
   (vec-y (particle-pos particle)))
 
+(defun particle-speed (particle)
+  (vec-magnitude (particle-vel particle)))
+
+(defun particle-direction (particle)
+  (vec-direction (particle-vel particle)))
+
 (defun particle-wrap! (particle width height)
   (with-slots (radius) particle
     (setf (particle-x particle)
@@ -66,6 +72,12 @@
 (defun (setf particle-y) (new-value particle)
   (setf (vec-y (particle-pos particle)) new-value))
 
+(defun (setf particle-speed) (new-value particle)
+  (setf (vec-magnitude (particle-vel particle)) new-value))
+
+(defun (setf particle-direction) (new-value particle)
+  (setf (vec-direction (particle-vel particle)) new-value))
+
 
 (defun particle-update! (particle)
   (with-accessors ((pos particle-pos)
diff -r 69f98eb3a1df -r 67072984548b src/utils.lisp
--- a/src/utils.lisp	Fri Apr 22 23:13:31 2016 +0000
+++ b/src/utils.lisp	Sat Apr 23 15:18:20 2016 +0000
@@ -18,9 +18,6 @@
        ,store-expr)))
 
 
-(defun a (alist key) ; lol
-  (cdr (assoc key alist)))
-
 (defmacro in-context (&body body)
   `(prog1
     (push-matrix)
@@ -28,3 +25,22 @@
     (pop-matrix)))
 
 
+(defmacro make-sketch (class &rest bindings)
+  `(let*
+    (,@(loop :for (k v) :in bindings
+             :collect (list k v)))
+    (make-instance
+      ,class
+      ,@(loop :for (k) :in bindings
+              :append (list (alexandria:make-keyword k) k)))))
+
+
+(defmacro scancode-case (scancode-form &rest pairs)
+  (with-gensyms (scancode)
+    `(let ((,scancode ,scancode-form))
+      (cond
+        ,@(mapcar (lambda (pair)
+                    (destructuring-bind (key-scancode &rest body) pair
+                      `((sdl2:scancode= ,scancode ,key-scancode)
+                        ,@body)))
+           pairs)))))
diff -r 69f98eb3a1df -r 67072984548b src/vectors.lisp
--- a/src/vectors.lisp	Fri Apr 22 23:13:31 2016 +0000
+++ b/src/vectors.lisp	Sat Apr 23 15:18:20 2016 +0000
@@ -38,6 +38,9 @@
       (setf y (* magnitude (sin angle)))))
   angle)
 
+(defun (setf vec-direction) (angle vec)
+  (setf (vec-angle vec) angle))
+
 (defun (setf vec-magnitude) (magnitude vec)
   (let ((angle (vec-angle vec)))
     (with-slots (x y) vec