;;; Lisparuga ;;; Copyright © 2020 David Thompson ;;; ;;; 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 . ;;; 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 spawn-bullet size capacity texture-atlas)) ;;; ;;; Bullet Identifiers ;;; (define-record-type (make-bullet name hitbox-rect tile-white tile-black) bullet? (name bullet-name) ;; *NOT* a 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 -2.0 -2.0 4.0 4.0) 6 7)) (define large-dot (make-bullet 'large-dot (make-rect -7.0 -7.0 14.0 14.0) 10 11)) ;; (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 () (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 ) 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 ) 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 ) 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 ) 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 ) i) (let ((new-size (- (size bullets) 1))) (set! (size bullets) new-size) (move-bullet bullets new-size i))) (define-method (clear-bullets (bullets )) (set! (size bullets) 0)) (define-method (update (bullets ) 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 ) bullet bullet-polarity hitbox) #t) (define-method (collide (bullets ) (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 ) 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))))