path: root/lisparuga/bullets.scm

;;; 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-missile
            small-dot
            medium-dot
            large-dot
            tapered-shot
            big-laser

            <bullet-field>
            spawn-bullet
            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 -3.0 -1.0 6.0 10.0) 0 1))
(define ikaruga-missile
  (make-bullet 'ikaruga-missile (make-rect -3.0 -1.0 6.0 10.0) 4 5))
(define small-dot
  (make-bullet 'small-dot (make-rect -1.0 -1.0 2.0 2.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)
  (procs #:accessor procs)
  (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))))
    (set! (procs bullets) (make-vector capacity))))

(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 (+ x (rect-x r)))
    (set-rect-y! h (+ y (rect-y r)))
    (set-rect-width! h (rect-width r))
    (set-rect-height! h (rect-height r))
    (vector-set! (procs bullets) i #f)))

(define-method (spawn-bullet (bullets <bullet-field>) id polarity x y dx dy proc)
  (spawn-bullet bullets id polarity x y dx dy)
  (vector-set! (procs bullets) (- (size bullets) 1) proc))

(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))
        (procs (procs 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))
    (vector-set! procs to (vector-ref procs from))))

(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))
        (procs (procs 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))
              (proc (vector-ref procs i)))
          (and (procedure? proc) (proc p v))
          (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))
      (if (< i l)
          (let* ((id (vector-ref ids i))
                 (h (vector-ref hitboxes i))
                 (collided? (find (lambda (wh)
                                    (and (world-hitbox-collision? wh h)
                                         (on-collision actor id (vector-ref polarities i)
                                                       (world-hitbox-parent wh))))
                                  (world-hitboxes actor))))
            (if collided?
                (begin
                  (kill-bullet bullets i)
                  #t)
                (loop (+ i 1))))
          #f))))

(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))))