From de833c9d524d2e47b3812612995290795d2e7b84 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Sat, 16 Oct 2021 16:22:08 -0400
Subject: Allow player to shoot and add flowers to harvest pollen from.

---
 bonnie-bee/actor.scm  |  60 ++++++++++++++++-----------
 bonnie-bee/assets.scm |   4 +-
 bonnie-bee/bullet.scm | 109 ++++++++++++++++++++++++++++++--------------------
 bonnie-bee/flower.scm |  37 +++++++++++++++++
 bonnie-bee/game.scm   |  50 +++++++++++++++--------
 bonnie-bee/player.scm |  35 +++++++++++++++-
 6 files changed, 209 insertions(+), 86 deletions(-)
 create mode 100644 bonnie-bee/flower.scm

(limited to 'bonnie-bee')

diff --git a/bonnie-bee/actor.scm b/bonnie-bee/actor.scm
index db49372..a734d6a 100644
--- a/bonnie-bee/actor.scm
+++ b/bonnie-bee/actor.scm
@@ -10,7 +10,11 @@
             hitbox
             world-hitbox
             quadtree
-            on-collide))
+            on-collide
+            <damageable>
+            dead?
+            damage
+            on-death))
 
 (define-class <actor> (<node-2d>)
   (velocity #:getter velocity #:init-form (vec2 0.0 0.0))
@@ -41,27 +45,37 @@
   (refresh-world-hitbox actor)
   (add-to-quadtree actor))
 
-(define-method (update (actor <actor>) dt)
+(define-method (collision-check (actor <actor>))
   (let ((p (position actor))
-        (v (velocity actor))
         (r (world-hitbox actor)))
-    (unless (and (= (vec2-x v) 0.0) (= (vec2-y v) 0.0))
-      (remove-from-quadtree actor)
-      (vec2-add! p v)
-      (refresh-world-hitbox actor)
-      (quadtree-find
-       (quadtree actor) r
-       (lambda (other)
-         ;; Calculate overlap.
-         (let* ((ro (world-hitbox other))
-                (xo (max (- (min (rect-right r) (rect-right ro))
-                            (max (rect-left r) (rect-left ro)))
-                         0.0))
-                (yo (max (- (min (rect-top r) (rect-top ro))
-                            (max (rect-bottom r) (rect-bottom ro)))
-                         0.0)))
-           (if (or (= xo 0.0) (= yo 0.0))
-               #f ; no collision
-               (on-collide actor other)))))
-      (add-to-quadtree actor)
-      (dirty! actor))))
+    (quadtree-find
+     (quadtree actor) r
+     (lambda (other)
+       (and (not (eq? other actor))
+            (rect-intersects? r (world-hitbox other))
+            (on-collide actor other))))))
+
+(define-method (update (actor <actor>) dt)
+  (let ((p (position actor))
+        (v (velocity actor)))
+    (if (and (= (vec2-x v) 0.0) (= (vec2-y v) 0.0))
+        (collision-check actor)
+        (begin
+          (remove-from-quadtree actor)
+          (vec2-add! p v)
+          (refresh-world-hitbox actor)
+          (collision-check actor)
+          (add-to-quadtree actor)
+          (dirty! actor)))))
+
+(define-class <damageable> ()
+  (health #:accessor health #:init-keyword #:health))
+
+(define-method (dead? (d <damageable>))
+  (= (health d) 0))
+
+(define-method (damage (d <damageable>) x)
+  (set! (health d) (max (- (health d) x) 0)))
+
+(define-method (on-death (d <damageable>) bullets)
+  #t)
diff --git a/bonnie-bee/assets.scm b/bonnie-bee/assets.scm
index 3c71bcc..5337215 100644
--- a/bonnie-bee/assets.scm
+++ b/bonnie-bee/assets.scm
@@ -5,7 +5,8 @@
   #:use-module (starling asset)
   #:export (chonkly-font
             bee-atlas
-            bullet-atlas))
+            bullet-atlas
+            flower-image))
 
 (define (scope-datadir file-name)
   (let ((prefix (or (getenv "BONNIE_BEE_DATADIR") (getcwd))))
@@ -14,3 +15,4 @@
 (define-asset chonkly-font (load-font (scope-datadir "assets/fonts/Chonkly.otf") 16))
 (define-asset bee-atlas (load-tileset (scope-datadir "assets/images/bee.png") 32 32))
 (define-asset bullet-atlas (load-tileset (scope-datadir "assets/images/bullets.png") 16 16))
+(define-asset flower-image (load-image (scope-datadir "assets/images/flower.png")))
diff --git a/bonnie-bee/bullet.scm b/bonnie-bee/bullet.scm
index ecf7b53..0fb351b 100644
--- a/bonnie-bee/bullet.scm
+++ b/bonnie-bee/bullet.scm
@@ -9,25 +9,36 @@
   #:use-module (chickadee math vector)
   #:use-module (chickadee utils)
   #:use-module (oop goops)
+  #:use-module (srfi srfi-9)
   #:use-module (starling asset)
   #:use-module (starling node)
   #:use-module (starling node-2d)
-  #:export (<bullet>
-            type
+  #:export (<bullet-type>
+            name
+            player-primary-bullet
             pollen-pickup
             <bullets>
+            <bullet>
+            type
+            kill-bullet
             add-bullet))
 
-(define-class <bullet> ()
-  (type #:getter type #:init-keyword #:type)
+(define-class <bullet-type> ()
+  (name #:getter name #:init-keyword #:name)
   (atlas-index #:getter atlas-index #:init-keyword #:atlas-index)
   (hitbox #:getter hitbox #:init-keyword #:hitbox))
 
 (define (bullet-texture bullet)
-  (texture-atlas-ref (asset-ref bullet-atlas) (atlas-index bullet)))
+  (texture-atlas-ref (asset-ref bullet-atlas)
+                     (atlas-index (type bullet))))
 
+(define player-primary-bullet
+  (make <bullet-type> #:name 'player-primary #:atlas-index 4
+        #:hitbox (make-rect -7.0 -7.0 14.0 14.0)))
+
+;; Yeah... pollen is a bullet.  Didn't you know that??
 (define pollen-pickup
-  (make <bullet> #:type 'pollen #:atlas-index 6
+  (make <bullet-type> #:name 'pollen #:atlas-index 6
         #:hitbox (make-rect -10.0 -10.0 20.0 20.0)))
 
 (define (make-bullet-sprite-batch)
@@ -35,16 +46,16 @@
    (texture-parent
     (texture-atlas-ref (asset-ref bullet-atlas) 0))))
 
-(define (make-vector* size thunk)
+(define (make-vector* size proc)
   (let ((v (make-vector size)))
     (for-range ((i size))
-      (vector-set! v i (thunk)))
+      (vector-set! v i (proc i)))
     v))
 
-(define (make-null-vec2)
+(define (make-null-vec2 i)
   (vec2 0.0 0.0))
 
-(define (make-null-rect)
+(define (make-null-rect i)
   (make-rect 0.0 0.0 0.0 0.0))
 
 (define %max-bullets 2048)
@@ -55,22 +66,48 @@
   (batch #:getter batch #:init-thunk make-bullet-sprite-batch)
   (capacity #:getter capacity #:init-value %max-bullets)
   (size #:accessor size #:init-value 0)
-  (descriptors #:getter descriptors #:init-form (make-vector %max-bullets #f))
-  (velocities #:getter velocities
-              #:init-form (make-vector* %max-bullets make-null-vec2))
-  (hitboxes #:getter hitboxes
-            #:init-form (make-vector* %max-bullets make-null-rect))
-  (regions #:getter regions
-           #:init-form (make-vector* %max-bullets make-null-rect)))
-
-(define-method (add-bullet (bullets <bullets>) bullet position velocity)
+  (descriptors #:accessor descriptors)
+  (velocities #:accessor velocities)
+  (hitboxes #:accessor hitboxes)
+  (regions #:accessor regions))
+
+(define-method (initialize (bullets <bullets>) args)
+  (define (make-descriptor i)
+    (make <bullet> #:parent bullets #:index i))
+  (next-method)
+  (set! (descriptors bullets) (make-vector* %max-bullets make-descriptor))
+  (set! (velocities bullets) (make-vector* %max-bullets make-null-vec2))
+  (set! (hitboxes bullets) (make-vector* %max-bullets make-null-rect))
+  (set! (regions bullets) (make-vector* %max-bullets make-null-rect)))
+
+(define-class <bullet> ()
+  (parent #:getter parent #:init-keyword #:parent)
+  (type #:accessor type)
+  (index #:accessor index #:init-keyword #:index)
+  (alive? #:accessor alive? #:init-value #f))
+
+(define-method (dead? (bullet <bullet>))
+  (not (alive? bullet)))
+
+(define-method (kill-bullet (bullet <bullet>))
+  (set! (alive? bullet) #f))
+
+(define-method (velocity (bullet <bullet>))
+  (vector-ref (velocities (parent bullet)) (index bullet)))
+
+(define-method (world-hitbox (bullet <bullet>))
+  (vector-ref (hitboxes (parent bullet)) (index bullet)))
+
+(define-method (add-bullet (bullets <bullets>) bullet-type position velocity)
   (let ((i (size bullets)))
     (when (< i (capacity bullets))
-      (let ((bh (hitbox bullet))
+      (let ((bh (hitbox bullet-type))
+            (d (vector-ref (descriptors bullets) i))
             (v (vector-ref (velocities bullets) i))
             (h (vector-ref (hitboxes bullets) i))
             (r (vector-ref (regions bullets) i)))
-        (vector-set! (descriptors bullets) i bullet)
+        (set! (type d) bullet-type)
+        (set! (alive? d) #t)
         (vec2-copy! velocity (vector-ref (velocities bullets) i))
         (set-rect-x! h (+ (vec2-x position) (rect-x bh)))
         (set-rect-y! h (+ (vec2-y position) (rect-y bh)))
@@ -81,7 +118,7 @@
         (set-rect-width! r 16.0)
         (set-rect-height! r 16.0)
         (set! (size bullets) (+ i 1))
-        (quadtree-insert! (quadtree bullets) r bullet)))))
+        (quadtree-insert! (quadtree bullets) h d)))))
 
 (define-method (remove-bullet (bullets <bullets>) i)
   (let* ((s (- (size bullets) 1))
@@ -96,16 +133,18 @@
          (h (vector-ref hs i)))
     (when (or (> i s) (< i 0))
       (error "bullet index out of bounds" i))
+    (set! (index (vector-ref ds s)) i)
     (vector-set! ds i (vector-ref ds s))
     (vector-set! rs i (vector-ref rs s))
     (vector-set! vs i (vector-ref vs s))
     (vector-set! hs i (vector-ref hs s))
+    (set! (index d) s)
     (vector-set! ds s d)
     (vector-set! rs s r)
     (vector-set! vs s v)
     (vector-set! hs s h)
     (set! (size bullets) s)
-    (quadtree-delete! q r d)))
+    (quadtree-delete! q h d)))
 
 (define-method (render (bullets <bullets>) alpha)
   (let ((ds (descriptors bullets))
@@ -132,37 +171,21 @@
               (v (vector-ref vs i))
               (h (vector-ref hs i)))
           (cond
-           ((or (< (rect-left h) -16.0)
+           ((or (dead? d)
+                (< (rect-left h) -16.0)
                 (> (rect-right h) 336.0)
                 (< (rect-bottom h) -16.0)
                 (> (rect-top h) 256.0))
-            (pk 'remove i)
             (remove-bullet bullets i)
             (loop i))
            ((and (= (vec2-x v) 0.0)
                  (= (vec2-y v) 0.0))
             (loop (+ i 1)))
            (else
-             (quadtree-delete! q r d)
+             (quadtree-delete! q h d)
              (set-rect-x! r (+ (rect-x r) (vec2-x v)))
              (set-rect-y! r (+ (rect-y r) (vec2-y v)))
              (set-rect-x! h (+ (rect-x h) (vec2-x v)))
              (set-rect-y! h (+ (rect-y h) (vec2-y v)))
-             (quadtree-find
-              (quadtree bullets) r
-              (lambda (other)
-                ;; Calculate overlap.
-                (if (is-a? other <actor>)
-                    (let* ((ro (world-hitbox other))
-                           (xo (max (- (min (rect-right r) (rect-right ro))
-                                       (max (rect-left r) (rect-left ro)))
-                                    0.0))
-                           (yo (max (- (min (rect-top r) (rect-top ro))
-                                       (max (rect-bottom r) (rect-bottom ro)))
-                                    0.0)))
-                      (if (or (= xo 0.0) (= yo 0.0))
-                          #f          ; no collision
-                          (on-collide d other)))
-                    #f)))
-             (quadtree-insert! q r d)
+             (quadtree-insert! q h d)
              (loop (+ i 1)))))))))
diff --git a/bonnie-bee/flower.scm b/bonnie-bee/flower.scm
new file mode 100644
index 0000000..cafa4f8
--- /dev/null
+++ b/bonnie-bee/flower.scm
@@ -0,0 +1,37 @@
+(define-module (bonnie-bee flower)
+  #:use-module (bonnie-bee actor)
+  #:use-module (bonnie-bee assets)
+  #:use-module (bonnie-bee bullet)
+  #:use-module (chickadee math)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee scripting)
+  #:use-module (chickadee utils)
+  #:use-module (oop goops)
+  #:use-module (starling node)
+  #:use-module (starling node-2d)
+  #:export (<flower>))
+
+(define-class <flower> (<actor> <damageable>))
+
+(define-method (on-boot (flower <flower>))
+  (attach-to flower
+             (make <sprite>
+               #:texture flower-image
+               #:origin (vec2 32.0 32.0))))
+
+(define-method (on-collide (flower <flower>) (bullet <bullet>))
+  (if (eq? (type bullet) player-primary-bullet)
+      (begin
+        (damage flower 1)
+        (kill-bullet bullet)
+        #t)
+      #f))
+
+(define-method (on-death (flower <flower>) bullets)
+  (let ((p (position flower)))
+    (for-range ((i 16))
+      (let ((theta (- (* (random:uniform) (/ pi -2.0)) (/ pi 4.0)))
+            (speed (+ (* (random:uniform) 1.0) 1.0)))
+        (add-bullet bullets pollen-pickup p
+                    (vec2 (* (cos theta) speed)
+                          (* (sin theta) speed)))))))
diff --git a/bonnie-bee/game.scm b/bonnie-bee/game.scm
index 5290ab8..ad1d9c3 100644
--- a/bonnie-bee/game.scm
+++ b/bonnie-bee/game.scm
@@ -3,6 +3,7 @@
   #:use-module (bonnie-bee assets)
   #:use-module (bonnie-bee bullet)
   #:use-module (bonnie-bee common)
+  #:use-module (bonnie-bee flower)
   #:use-module (bonnie-bee player)
   #:use-module (chickadee data quadtree)
   #:use-module (chickadee graphics color)
@@ -21,34 +22,36 @@
 (define-class <game> (<scene-2d>)
   (quadtree #:getter quadtree #:init-form (make-quadtree %game-bounds)))
 
+(define-method (spawn (game <game>) (actor <actor>))
+  (set! (quadtree actor) (quadtree game))
+  (attach-to game actor))
+
+(define-method (player (game <game>))
+  (& game player))
+
+(define-method (bullets (game <game>))
+  (& game bullets))
+
 (define-method (on-boot (game <game>))
+  (set! *random-state* (random-state-from-platform))
   (set-cameras! game)
   (attach-to game
              (make <bullets>
                #:name 'bullets
-               #:quadtree (quadtree game)))
-  (let loop ((i 0))
-    (when (< i 100)
-      (add-bullet (& game bullets) pollen-pickup
-                  (vec2 (* (random:uniform) 320.0)
-                        (* (random:uniform) 240.0))
-                  (vec2 (random:uniform)
-                        (random:uniform)))
-      (loop (+ i 1)))))
-
-(define-method (spawn (game <game>) (actor <actor>))
-  (set! (quadtree actor) (quadtree game))
-  (attach-to game actor))
+               #:quadtree (quadtree game))))
 
 (define-method (on-enter (game <game>))
   (spawn game
          (make <player>
            #:name 'player
            #:position (vec2 (/ %game-width 2.0) 20.0)
-           #:hitbox (make-rect -2.0 -2.0 4.0 4.0))))
-
-(define-method (player (game <game>))
-  (& game player))
+           #:hitbox (make-rect -2.0 -2.0 4.0 4.0)))
+  (spawn game
+         (make <flower>
+           #:position (vec2 (/ %game-width 2.0)
+                            (/ %game-height 2.0))
+           #:hitbox (make-rect -32.0 -32.0 64.0 64.0)
+           #:health 10)))
 
 (define-method (on-key-press (game <game>) key modifiers repeat?)
   (case key
@@ -77,3 +80,16 @@
      (set! (move-up? (player game)) #f))
     ((z)
      (set! (shoot? (player game)) #f))))
+
+(define-method (update (game <game>) dt)
+  (next-method)
+  (shoot-maybe (player game) (bullets game))
+  (for-each-child (lambda (child)
+                    (when (and (is-a? child <damageable>)
+                               (dead? child))
+                      (on-death child (bullets game))
+                      (quadtree-delete! (quadtree game)
+                                        (world-hitbox child)
+                                        child)
+                      (detach child)))
+                  game))
diff --git a/bonnie-bee/player.scm b/bonnie-bee/player.scm
index 6e8f7fb..9a5da1c 100644
--- a/bonnie-bee/player.scm
+++ b/bonnie-bee/player.scm
@@ -1,7 +1,9 @@
 (define-module (bonnie-bee player)
   #:use-module (bonnie-bee actor)
   #:use-module (bonnie-bee assets)
+  #:use-module (bonnie-bee bullet)
   #:use-module (chickadee math vector)
+  #:use-module (chickadee scripting)
   #:use-module (oop goops)
   #:use-module (starling node)
   #:use-module (starling node-2d)
@@ -13,14 +15,17 @@
             shoot?
             speed
             lives
-            pollen))
+            pollen
+            shoot-maybe))
 
 (define-class <player> (<actor>)
   (move-left? #:accessor move-left? #:init-value #f)
   (move-right? #:accessor move-right? #:init-value #f)
   (move-down? #:accessor move-down? #:init-value #f)
   (move-up? #:accessor move-up? #:init-value #f)
-  (shoot? #:accessor shoot? #:init-value #f)
+  (shoot? #:accessor shoot? #:init-value #f #:watch? #t)
+  (last-shot #:accessor last-shot #:init-value 0)
+  (shot-interval #:getter shot-interval #:init-value 2)
   (speed #:accessor speed #:init-value 2.0)
   (lives #:accessor lives #:init-value 3)
   (pollen #:accessor pollen #:init-value 0))
@@ -32,6 +37,12 @@
                #:index 12
                #:origin (vec2 16.0 16.0))))
 
+(define-method (on-change (player <player>) slot-name old new)
+  (case slot-name
+    ((shoot?)
+     (when (and new (not (and old new)))
+       (set! (last-shot player) 0)))))
+
 (define-method (update (player <player>) dt)
   (let ((v (velocity player)))
     (set-vec2! v
@@ -42,3 +53,23 @@
     (vec2-normalize! v)
     (vec2-mult! v (speed player)))
   (next-method))
+
+(define-method (on-collide (player <player>) (bullet <bullet>))
+  (if (eq? (type bullet) pollen-pickup)
+      (begin
+        (kill-bullet bullet)
+        (set! (pollen player) (+ (pollen player) 1))
+        #t)
+      #f))
+
+(define-method (shoot-maybe (player <player>) bullets)
+  (with-agenda (agenda player)
+    (when (and (shoot? player)
+               (>= (- (agenda-time) (last-shot player))
+                   (shot-interval player)))
+      (let ((p (position player)))
+        (set! (last-shot player) (agenda-time))
+        (add-bullet bullets
+                    player-primary-bullet
+                    (vec2 (vec2-x p) (+ (vec2-y p) 14.0))
+                    (vec2 0.0 6.0))))))
-- 
cgit v1.2.3