14 files changed, 457 insertions, 1 deletions

diff --git a/Makefile.am b/Makefile.am
index f1a2592..441b145 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -25,7 +25,18 @@ bin_SCRIPTS =					\
   scripts/bonnie-bee
 
 SOURCES = 					\
+  bonnie-bee/common.scm				\
+  bonnie-bee/assets.scm				\
+  bonnie-bee/actor.scm				\
+  bonnie-bee/player.scm				\
+  bonnie-bee/bullet.scm				\
+  bonnie-bee/pollen.scm				\
+  bonnie-bee/game.scm				\
   bonnie-bee/splash.scm
 
+fontsdir = $(pkgdatadir)/assets/fonts
+dist_fonts_DATA =				\
+  assets/fonts/Chonkly.otf
+
 EXTRA_DIST += 					\
   COPYING
diff --git a/assets/fonts/Chonkly.otf b/assets/fonts/Chonkly.otf
new file mode 100644
index 0000000..fc64a65
--- /dev/null
+++ b/assets/fonts/Chonkly.otf
diff --git a/assets/images/bee.png b/assets/images/bee.png
new file mode 100644
index 0000000..7fec5ef
--- /dev/null
+++ b/assets/images/bee.png
diff --git a/assets/images/bee.xcf b/assets/images/bee.xcf
new file mode 100644
index 0000000..b6c7e9e
--- /dev/null
+++ b/assets/images/bee.xcf
diff --git a/assets/images/bullets.png b/assets/images/bullets.png
new file mode 100644
index 0000000..917ac17
--- /dev/null
+++ b/assets/images/bullets.png
diff --git a/assets/images/bullets.xcf b/assets/images/bullets.xcf
new file mode 100644
index 0000000..c7209a9
--- /dev/null
+++ b/assets/images/bullets.xcf
diff --git a/bonnie-bee/actor.scm b/bonnie-bee/actor.scm
new file mode 100644
index 0000000..db49372
--- /dev/null
+++ b/bonnie-bee/actor.scm
@@ -0,0 +1,67 @@
+(define-module (bonnie-bee actor)
+  #:use-module (chickadee data quadtree)
+  #:use-module (chickadee math rect)
+  #:use-module (chickadee math vector)
+  #:use-module (oop goops)
+  #:use-module (starling node)
+  #:use-module (starling node-2d)
+  #:export (<actor>
+            velocity
+            hitbox
+            world-hitbox
+            quadtree
+            on-collide))
+
+(define-class <actor> (<node-2d>)
+  (velocity #:getter velocity #:init-form (vec2 0.0 0.0))
+  (hitbox #:getter hitbox #:init-keyword #:hitbox)
+  (world-hitbox #:getter world-hitbox #:init-form (make-rect 0.0 0.0 0.0 0.0))
+  (quadtree #:accessor quadtree #:init-keyword #:quadtree))
+
+(define-method (add-to-quadtree (actor <actor>))
+  (quadtree-insert! (quadtree actor) (world-hitbox actor) actor))
+
+(define-method (remove-from-quadtree (actor <actor>))
+  (quadtree-delete! (quadtree actor) (world-hitbox actor) actor))
+
+(define-method (refresh-world-hitbox (actor <actor>))
+  (let ((p (position actor))
+        (h (hitbox actor))
+        (wh (world-hitbox actor)))
+    (set-rect-x! wh (+ (vec2-x p) (rect-x h)))
+    (set-rect-y! wh (+ (vec2-y p) (rect-y h)))
+    (set-rect-width! wh (rect-width h))
+    (set-rect-height! wh (rect-height h))))
+
+(define-method (on-collide a b)
+  (pk 'unhandled-collision a b)
+  #f)
+
+(define-method (on-enter (actor <actor>))
+  (refresh-world-hitbox actor)
+  (add-to-quadtree actor))
+
+(define-method (update (actor <actor>) dt)
+  (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))))
diff --git a/bonnie-bee/assets.scm b/bonnie-bee/assets.scm
new file mode 100644
index 0000000..3c71bcc
--- /dev/null
+++ b/bonnie-bee/assets.scm
@@ -0,0 +1,16 @@
+(define-module (bonnie-bee assets)
+  #:use-module (chickadee audio)
+  #:use-module (chickadee graphics font)
+  #:use-module (chickadee graphics texture)
+  #:use-module (starling asset)
+  #:export (chonkly-font
+            bee-atlas
+            bullet-atlas))
+
+(define (scope-datadir file-name)
+  (let ((prefix (or (getenv "BONNIE_BEE_DATADIR") (getcwd))))
+    (string-append prefix "/" file-name)))
+
+(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))
diff --git a/bonnie-bee/bullet.scm b/bonnie-bee/bullet.scm
new file mode 100644
index 0000000..ecf7b53
--- /dev/null
+++ b/bonnie-bee/bullet.scm
@@ -0,0 +1,168 @@
+(define-module (bonnie-bee bullet)
+  #:use-module (bonnie-bee actor)
+  #:use-module (bonnie-bee assets)
+  #:use-module (chickadee data quadtree)
+  #:use-module (chickadee graphics sprite)
+  #:use-module (chickadee graphics texture)
+  #:use-module (chickadee math matrix)
+  #:use-module (chickadee math rect)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee utils)
+  #:use-module (oop goops)
+  #:use-module (starling asset)
+  #:use-module (starling node)
+  #:use-module (starling node-2d)
+  #:export (<bullet>
+            type
+            pollen-pickup
+            <bullets>
+            add-bullet))
+
+(define-class <bullet> ()
+  (type #:getter type #:init-keyword #:type)
+  (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)))
+
+(define pollen-pickup
+  (make <bullet> #:type 'pollen #:atlas-index 6
+        #:hitbox (make-rect -10.0 -10.0 20.0 20.0)))
+
+(define (make-bullet-sprite-batch)
+  (make-sprite-batch
+   (texture-parent
+    (texture-atlas-ref (asset-ref bullet-atlas) 0))))
+
+(define (make-vector* size thunk)
+  (let ((v (make-vector size)))
+    (for-range ((i size))
+      (vector-set! v i (thunk)))
+    v))
+
+(define (make-null-vec2)
+  (vec2 0.0 0.0))
+
+(define (make-null-rect)
+  (make-rect 0.0 0.0 0.0 0.0))
+
+(define %max-bullets 2048)
+(define %identity-matrix (make-identity-matrix4))
+
+(define-class <bullets> (<node-2d>)
+  (quadtree #:getter quadtree #:init-keyword #:quadtree)
+  (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)
+  (let ((i (size bullets)))
+    (when (< i (capacity bullets))
+      (let ((bh (hitbox bullet))
+            (v (vector-ref (velocities bullets) i))
+            (h (vector-ref (hitboxes bullets) i))
+            (r (vector-ref (regions bullets) i)))
+        (vector-set! (descriptors bullets) i bullet)
+        (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)))
+        (set-rect-width! h (rect-width bh))
+        (set-rect-height! h (rect-height bh))
+        (set-rect-x! r (- (vec2-x position) 8.0))
+        (set-rect-y! r (- (vec2-y position) 8.0))
+        (set-rect-width! r 16.0)
+        (set-rect-height! r 16.0)
+        (set! (size bullets) (+ i 1))
+        (quadtree-insert! (quadtree bullets) r bullet)))))
+
+(define-method (remove-bullet (bullets <bullets>) i)
+  (let* ((s (- (size bullets) 1))
+         (ds (descriptors bullets))
+         (rs (regions bullets))
+         (vs (velocities bullets))
+         (hs (hitboxes bullets))
+         (q (quadtree bullets))
+         (d (vector-ref ds i))
+         (r (vector-ref rs i))
+         (v (vector-ref vs i))
+         (h (vector-ref hs i)))
+    (when (or (> i s) (< i 0))
+      (error "bullet index out of bounds" 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))
+    (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)))
+
+(define-method (render (bullets <bullets>) alpha)
+  (let ((ds (descriptors bullets))
+        (rs (regions bullets))
+        (b (batch bullets)))
+    (sprite-batch-clear! b)
+    (for-range ((i (size bullets)))
+      (let ((d (vector-ref ds i))
+            (r (vector-ref rs i)))
+        (sprite-batch-add* b r %identity-matrix
+                           #:texture-region (bullet-texture d))))
+    (draw-sprite-batch* b (world-matrix bullets))))
+
+(define-method (update (bullets <bullets>) dt)
+  (let ((ds (descriptors bullets))
+        (rs (regions bullets))
+        (vs (velocities bullets))
+        (hs (hitboxes bullets))
+        (q (quadtree bullets)))
+    (let loop ((i 0))
+      (when (< i (size bullets))
+        (let ((d (vector-ref ds i))
+              (r (vector-ref rs i))
+              (v (vector-ref vs i))
+              (h (vector-ref hs i)))
+          (cond
+           ((or (< (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)
+             (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)
+             (loop (+ i 1)))))))))
diff --git a/bonnie-bee/common.scm b/bonnie-bee/common.scm
new file mode 100644
index 0000000..fa9f14a
--- /dev/null
+++ b/bonnie-bee/common.scm
@@ -0,0 +1,24 @@
+(define-module (bonnie-bee common)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee graphics viewport)
+  #:use-module (chickadee math vector)
+  #:use-module (oop goops)
+  #:use-module (starling scene)
+  #:use-module (starling node-2d)
+  #:export (%window-width
+            %window-height
+            %game-width
+            %game-height
+            set-cameras!))
+
+(define %window-width 960)
+(define %window-height 720)
+(define %game-width 320)
+(define %game-height 240)
+
+(define-method (set-cameras! (scene <scene-2d>))
+  (set! (cameras scene)
+        (list (make <camera-2d>
+                #:resolution (vec2 %game-width %game-height)
+                #:viewport (make-viewport 0 0 %window-width %window-height
+                                          #:clear-color black)))))
diff --git a/bonnie-bee/game.scm b/bonnie-bee/game.scm
new file mode 100644
index 0000000..5290ab8
--- /dev/null
+++ b/bonnie-bee/game.scm
@@ -0,0 +1,79 @@
+(define-module (bonnie-bee game)
+  #:use-module (bonnie-bee actor)
+  #:use-module (bonnie-bee assets)
+  #:use-module (bonnie-bee bullet)
+  #:use-module (bonnie-bee common)
+  #:use-module (bonnie-bee player)
+  #:use-module (chickadee data quadtree)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee math rect)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee scripting)
+  #:use-module (oop goops)
+  #:use-module (starling kernel)
+  #:use-module (starling node)
+  #:use-module (starling node-2d)
+  #:use-module (starling scene)
+  #:export (<game>))
+
+(define %game-bounds (make-rect 0.0 0.0 %game-width %game-height))
+
+(define-class <game> (<scene-2d>)
+  (quadtree #:getter quadtree #:init-form (make-quadtree %game-bounds)))
+
+(define-method (on-boot (game <game>))
+  (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))
+
+(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))
+
+(define-method (on-key-press (game <game>) key modifiers repeat?)
+  (case key
+    ((q)
+     (pop-scene (current-kernel)))
+    ((left)
+     (set! (move-left? (player game)) #t))
+    ((right)
+     (set! (move-right? (player game)) #t))
+    ((down)
+     (set! (move-down? (player game)) #t))
+    ((up)
+     (set! (move-up? (player game)) #t))
+    ((z)
+     (set! (shoot? (player game)) #t))))
+
+(define-method (on-key-release (game <game>) key modifiers)
+  (case key
+    ((left)
+     (set! (move-left? (player game)) #f))
+    ((right)
+     (set! (move-right? (player game)) #f))
+    ((down)
+     (set! (move-down? (player game)) #f))
+    ((up)
+     (set! (move-up? (player game)) #f))
+    ((z)
+     (set! (shoot? (player game)) #f))))
diff --git a/bonnie-bee/player.scm b/bonnie-bee/player.scm
new file mode 100644
index 0000000..6e8f7fb
--- /dev/null
+++ b/bonnie-bee/player.scm
@@ -0,0 +1,44 @@
+(define-module (bonnie-bee player)
+  #:use-module (bonnie-bee actor)
+  #:use-module (bonnie-bee assets)
+  #:use-module (chickadee math vector)
+  #:use-module (oop goops)
+  #:use-module (starling node)
+  #:use-module (starling node-2d)
+  #:export (<player>
+            move-left?
+            move-right?
+            move-down?
+            move-up?
+            shoot?
+            speed
+            lives
+            pollen))
+
+(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)
+  (speed #:accessor speed #:init-value 2.0)
+  (lives #:accessor lives #:init-value 3)
+  (pollen #:accessor pollen #:init-value 0))
+
+(define-method (on-boot (player <player>))
+  (attach-to player
+             (make <atlas-sprite>
+               #:atlas bee-atlas
+               #:index 12
+               #:origin (vec2 16.0 16.0))))
+
+(define-method (update (player <player>) dt)
+  (let ((v (velocity player)))
+    (set-vec2! v
+               (+ (if (move-left? player) -1.0 0.0)
+                  (if (move-right? player) 1.0 0.0))
+               (+ (if (move-down? player) -1.0 0.0)
+                  (if (move-up? player) 1.0 0.0)))
+    (vec2-normalize! v)
+    (vec2-mult! v (speed player)))
+  (next-method))
diff --git a/bonnie-bee/pollen.scm b/bonnie-bee/pollen.scm
new file mode 100644
index 0000000..97aaf0e
--- /dev/null
+++ b/bonnie-bee/pollen.scm
@@ -0,0 +1,11 @@
+(define-module (bonnie-bee pollen)
+  #:use-module (bonnie-bee actor)
+  #:use-module (bonnie-bee assets)
+  #:use-module (chickadee math rect)
+  #:use-module (chickadee math vector)
+  #:use-module (oop goops)
+  #:use-module (starling node)
+  #:use-module (starling node-2d)
+  #:export (<pollen>))
+
+(define-class <pollen> (<actor>))
diff --git a/bonnie-bee/splash.scm b/bonnie-bee/splash.scm
index 0c2a507..292fd05 100644
--- a/bonnie-bee/splash.scm
+++ b/bonnie-bee/splash.scm
@@ -1,5 +1,41 @@
 (define-module (bonnie-bee splash)
+  #:use-module (bonnie-bee assets)
+  #:use-module (bonnie-bee common)
+  #:use-module (bonnie-bee game)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee scripting)
+  #:use-module (oop goops)
+  #:use-module (starling kernel)
+  #:use-module (starling node)
+  #:use-module (starling node-2d)
+  #:use-module (starling scene)
   #:export (launch-game))
 
+(define-class <splash> (<scene-2d>))
+
+(define-method (on-boot (splash <splash>))
+  (set-cameras! splash)
+  (attach-to splash
+             (make <label>
+               #:name 'label
+               #:font chonkly-font
+               #:color black
+               #:align 'center
+               #:vertical-align 'center
+               #:position (vec2 (/ %game-width 2.0) (/ %game-height 2.0)))))
+
+(define-method (on-enter (splash <splash>))
+  (unless (getenv "SKIP_SPLASH")
+    (run-script splash
+      (set! (text (& splash label)) "made with chickadee")
+      (sleep 30)
+      (replace-scene (current-kernel) (make <game>)))))
+
 (define (launch-game)
-  (display "hi I don't do anything yet!\n"))
+  (boot-kernel (make <kernel>
+                 #:window-config (make <window-config>
+                                   #:title "Bonnie Bee and the Pesticidal Tendencies - Autumn Lisp Game Jam 2021"
+                                   #:width %window-width
+                                   #:height %window-height))
+               (lambda () (make <splash>))))