1 files changed, 243 insertions, 0 deletions
diff --git a/lisparuga/bullets.scm b/lisparuga/bullets.scm
new file mode 100644
index 0000000..e241694
--- /dev/null
+++ b/lisparuga/bullets.scm
@@ -0,0 +1,243 @@
+;;; Lisparuga
+;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; Lisparuga is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published
+;;; by the Free Software Foundation, either version 3 of the License,
+;;; or (at your option) any later version.
+;;;
+;;; Lisparuga is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Lisparuga.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Bullet state and logic.
+;;
+;;; Code:
+
+(define-module (lisparuga bullets)
+  #:use-module (chickadee math matrix)
+  #:use-module (chickadee math rect)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee render color)
+  #:use-module (chickadee render sprite)
+  #:use-module (chickadee render texture)
+  #:use-module (lisparuga actor)
+  #:use-module (lisparuga asset)
+  #:use-module (lisparuga node)
+  #:use-module (lisparuga node-2d)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:export (make-bullet
+            bullet-name
+            bullet-hitbox-rect
+            bullet-tile
+            ikaruga-bullet
+            ikaruga-missle
+            small-dot
+            medium-dot
+            large-dot
+            tapered-shot
+            big-laser
+
+            <bullet-field>
+            spawn-bullet
+            collision?
+            size
+            capacity
+            texture-atlas))
+
+
+;;;
+;;; Bullet Identifiers
+;;;
+
+(define-record-type <bullet>
+  (make-bullet name hitbox-rect tile-white tile-black)
+  bullet?
+  (name bullet-name)
+  ;; *NOT* a <hitbox> instance, those are just for actors.
+  (hitbox-rect bullet-hitbox-rect)
+  (tile-white bullet-tile-white)
+  (tile-black bullet-tile-black))
+
+(define ikaruga-bullet
+  (make-bullet 'ikaruga (make-rect 0.0 0.0 0.0 0.0) 0 1))
+(define ikaruga-missile
+  (make-bullet 'ikaruga-missile (make-rect 0.0 0.0 0.0 0.0) 0 1))
+(define small-dot
+  (make-bullet 'small-dot (make-rect 0.0 0.0 0.0 0.0) 0 1))
+(define medium-dot
+  (make-bullet 'medium-dot (make-rect 0.0 0.0 0.0 0.0) 0 1))
+(define large-dot
+  (make-bullet 'large-dot (make-rect 0.0 0.0 0.0 0.0) 0 1))
+(define tapered-shot
+  (make-bullet 'tapered-shot (make-rect 0.0 0.0 0.0 0.0) 0 1))
+;; Do lasers need a special data type? maybe I won't even get around
+;; to implementing them...
+(define big-laser
+  (make-bullet 'big-laser (make-rect 0.0 0.0 0.0 0.0) 0 1))
+
+
+;;;
+;;; Mass bullet management
+;;;
+
+(define-class <bullet-field> (<node-2d>)
+  (batch #:getter batch #:init-form (make-sprite-batch #f))
+  (size #:accessor size #:init-form 0)
+  (capacity #:getter capacity #:init-form 1000 #:init-keyword #:capacity)
+  (ids #:accessor ids)
+  (polarities #:accessor polarities)
+  (positions #:accessor positions)
+  (velocities #:accessor velocities)
+  (hitboxes #:accessor hitboxes)
+  (texture-atlas #:accessor texture-atlas #:init-keyword #:texture-atlas)
+  (scratch-rect #:getter scratch-rect #:init-form (make-rect 0.0 0.0 0.0 0.0)))
+
+(define-method (initialize (bullets <bullet-field>) initargs)
+  (next-method)
+  (let ((capacity (capacity bullets)))
+    (define (seed-vector thunk)
+      (let ((v (make-vector capacity #f)))
+        (let loop ((i 0))
+          (when (< i capacity)
+            (vector-set! v i (thunk))
+            (loop (+ i 1))))
+        v))
+    (set! (ids bullets) (make-vector capacity))
+    (set! (polarities bullets) (make-vector capacity))
+    (set! (positions bullets) (seed-vector (lambda () #v(0.0 0.0))))
+    (set! (velocities bullets) (seed-vector (lambda () #v(0.0 0.0))))
+    (set! (hitboxes bullets) (seed-vector (lambda () (make-rect 0.0 0.0 0.0 0.0))))))
+
+(define-method (spawn-bullet (bullets <bullet-field>) id polarity x y dx dy)
+  (let* ((i (size bullets))
+         (p (vector-ref (positions bullets) i))
+         (v (vector-ref (velocities bullets) i))
+         (h (vector-ref (hitboxes bullets) i))
+         (r (bullet-hitbox-rect id)))
+    (set! (size bullets) (+ i 1))
+    (vector-set! (ids bullets) i id)
+    (vector-set! (polarities bullets) i polarity)
+    (set-vec2! p x y)
+    (set-vec2! v dx dy)
+    (set-rect-x! h (rect-x r))
+    (set-rect-y! h (rect-y r))
+    (set-rect-width! h (rect-width r))
+    (set-rect-height! h (rect-height r))))
+
+(define-method (move-bullet (bullets <bullet-field>) from to)
+  (let ((ids (ids bullets))
+        (polarities (polarities bullets))
+        (positions (positions bullets))
+        (velocities (velocities bullets))
+        (hitboxes (hitboxes bullets)))
+    (vector-set! ids to (vector-ref ids from))
+    (vector-set! polarities to (vector-ref polarities from))
+    (vec2-copy! (vector-ref positions from) (vector-ref positions to))
+    (vec2-copy! (vector-ref velocities from) (vector-ref velocities to))
+    (rect-copy! (vector-ref hitboxes from) (vector-ref hitboxes to))))
+
+(define-method (kill-bullet (bullets <bullet-field>) i)
+  (let ((new-size (- (size bullets) 1)))
+    (set! (size bullets) new-size)
+    (move-bullet bullets new-size i)))
+
+(define-method (clear-bullets (bullets <bullet-field>))
+  (set! (size bullets) 0))
+
+(define-method (update (bullets <bullet-field>) dt)
+  (let ((l (size bullets))
+        (positions (positions bullets))
+        (velocities (velocities bullets))
+        (hitboxes (hitboxes bullets))
+        ;; Delete bullets that go too far off the screen.
+        (min-x -32.0)
+        (min-y -32.0)
+        (max-x (+ 160.0 32.0))
+        (max-y (+ 240.0 32.0)))
+    (define (delete i)
+      (let ((new-l (- l 1)))
+        (set! l new-l)
+        (move-bullet bullets new-l i)))
+    (let loop ((i 0))
+      (when (< i l)
+        (let ((p (vector-ref positions i))
+              (v (vector-ref velocities i))
+              (h (vector-ref hitboxes i)))
+          (vec2-add! p v)
+          ;; Remove bullets that go out of bounds of the play area.
+          (if (or (< (vec2-x p) min-x)
+                  (> (vec2-x p) max-x)
+                  (< (vec2-y p) min-y)
+                  (> (vec2-y p) max-y))
+              (begin
+                (delete i)
+                (loop i))
+              (begin
+                ;; Adjust hitbox.
+                (set-rect-x! h (+ (rect-x h) (vec2-x v)))
+                (set-rect-y! h (+ (rect-y h) (vec2-y v)))
+                (loop (+ i 1)))))))
+    (set! (size bullets) l)))
+
+;; Actor-bullet collision event.
+(define-method (on-collision (actor <actor>) bullet bullet-polarity hitbox)
+  #t)
+
+(define-method (collide (bullets <bullet-field>) (actor <actor>))
+  (let ((l (size bullets))
+        (ids (ids bullets))
+        (polarities (polarities bullets))
+        (hitboxes (hitboxes bullets)))
+    (let loop ((i 0))
+      (when (< i l)
+        (let* ((id (vector-ref ids i))
+               (h (vector-ref hitboxes i))
+               (wh (find (lambda (wh)
+                           (world-hitbox-collision? wh h))
+                         (world-hitboxes actor))))
+          (if (and wh
+                   (on-collision actor id (vector-ref polarities i)
+                                 (world-hitbox-parent wh)))
+              (kill-bullet bullets i)
+              (loop (+ i 1))))))))
+
+(define %identity-matrix (make-identity-matrix4))
+
+(define-method (render (bullets <bullet-field>) alpha)
+  (let ((l (size bullets))
+        (batch (batch bullets))
+        (ids (ids bullets))
+        (polarities (polarities bullets))
+        (positions (positions bullets))
+        (atlas (asset-ref (texture-atlas bullets)))
+        (r (scratch-rect bullets)))
+    (set-sprite-batch-texture! batch (texture-atlas-texture atlas))
+    (sprite-batch-clear! batch)
+    (let loop ((i 0))
+      (when (< i l)
+        (let* ((p (vector-ref positions i))
+               (id (vector-ref ids i))
+               (polarity (vector-ref polarities i))
+               (tile (if (eq? polarity 'white)
+                         (bullet-tile-white id)
+                         (bullet-tile-black id)))
+               (texture (texture-atlas-ref atlas tile))
+               (tw (texture-width texture))
+               (th (texture-height texture)))
+          (set-rect-x! r (- (vec2-x p) (/ tw 2.0)))
+          (set-rect-y! r (- (vec2-y p) (/ th 2.0)))
+          (set-rect-width! r tw)
+          (set-rect-height! r th)
+          (sprite-batch-add* batch r %identity-matrix
+                             #:texture-region texture))
+        (loop (+ i 1))))
+    (draw-sprite-batch* batch (world-matrix bullets))))