summaryrefslogtreecommitdiff
path: root/lisparuga
diff options
context:
space:
mode:
authorDavid Thompson <dthompson@vistahigherlearning.com>2020-04-10 22:42:26 -0400
committerDavid Thompson <dthompson@vistahigherlearning.com>2020-04-10 22:42:26 -0400
commitebc1c54b8f184ff485561b7c039be368b6a9d2c9 (patch)
treee7a5354a90e06758966091c181c3b5555766f4c2 /lisparuga
parent2c5b19226815a406c60cc1a49c59864922364c55 (diff)
Day 1 progress.
Diffstat (limited to 'lisparuga')
-rw-r--r--lisparuga/actor.scm113
-rw-r--r--lisparuga/asset.scm10
-rw-r--r--lisparuga/bullets.scm243
-rw-r--r--lisparuga/config.scm2
-rw-r--r--lisparuga/enemy.scm65
-rw-r--r--lisparuga/game.scm82
-rw-r--r--lisparuga/kernel.scm69
-rw-r--r--lisparuga/node-2d.scm5
-rw-r--r--lisparuga/player.scm192
9 files changed, 755 insertions, 26 deletions
diff --git a/lisparuga/actor.scm b/lisparuga/actor.scm
new file mode 100644
index 0000000..c7caab2
--- /dev/null
+++ b/lisparuga/actor.scm
@@ -0,0 +1,113 @@
+;;; 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:
+;;
+;; A class representing a scripted or player-controller object in the
+;; game world. Actors can emit bullets and have many hitboxes.
+;;
+;;; Code:
+
+
+(define-module (lisparuga actor)
+ #:use-module (chickadee math vector)
+ #:use-module (chickadee math rect)
+ #:use-module (lisparuga node)
+ #:use-module (lisparuga node-2d)
+ #:use-module (oop goops)
+ #:use-module (srfi srfi-9)
+ #:export (make-hitbox
+ hitbox?
+ hitbox-name
+ hitbox-rect
+
+ world-hitbox?
+ world-hitbox-collision?
+ world-hitbox-parent
+
+ <actor>
+ polarity
+ velocity
+ hitboxes
+ world-hitboxes
+ on-collision
+ bullet-field))
+
+
+;;;
+;;; Hitboxes
+;;;
+
+(define-record-type <hitbox>
+ (make-hitbox name rect)
+ hitbox?
+ (name hitbox-name)
+ (rect hitbox-rect))
+
+(define-record-type <world-hitbox>
+ (%make-world-hitbox parent rect)
+ world-hitbox?
+ (parent world-hitbox-parent)
+ (rect world-hitbox-rect))
+
+(define (make-world-hitbox parent)
+ (let ((r (hitbox-rect parent)))
+ (%make-world-hitbox parent
+ (make-rect 0.0 0.0 (rect-width r) (rect-height r)))))
+
+(define (sync-world-hitbox world-hitbox position)
+ (rect-move-vec2! (world-hitbox-rect world-hitbox) position))
+
+(define (world-hitbox-collision? a b)
+ (if (world-hitbox? b)
+ (rect-intersects? (world-hitbox-rect a) (world-hitbox-rect b))
+ (rect-intersects? (world-hitbox-rect a) b)))
+
+
+;;;
+;;; Actors
+;;;
+
+(define-class <actor> (<node-2d>)
+ (polarity #:accessor polarity #:init-form 'none #:init-keyword #:polarity)
+ (velocity #:getter velocity #:init-form (vec2 0.0 0.0))
+ (hitboxes #:accessor hitboxes #:init-form '() #:init-keyword #:hitboxes)
+ (world-hitboxes #:accessor world-hitboxes #:init-form '())
+ (bullet-field #:accessor bullet-field #:init-keyword #:bullet-field))
+
+(define-method (initialize (actor <actor>) initargs)
+ (next-method)
+ (set! (world-hitboxes actor)
+ (map make-world-hitbox (hitboxes actor))))
+
+(define-method (update (actor <actor>) dt)
+ (let ((v (velocity actor)))
+ (unless (and (= (vec2-x v) 0.0)
+ (= (vec2-y v) 0.0))
+ ;; Move by current velocity.
+ (vec2-add! (position actor) v)
+ ;; Sync hitboxes to world coordinates.
+ (let ((pos (position actor)))
+ (for-each (lambda (world-hitbox)
+ (sync-world-hitbox world-hitbox pos))
+ (world-hitboxes actor)))
+ ;; Mark for matrix updates.
+ (dirty! actor))))
+
+;; Actor-actor collision event.
+(define-method (on-collision (actor <actor>) (other-actor <actor>)
+ hitbox other-hitbox)
+ #t)
diff --git a/lisparuga/asset.scm b/lisparuga/asset.scm
index b4969b0..a2b0c99 100644
--- a/lisparuga/asset.scm
+++ b/lisparuga/asset.scm
@@ -22,6 +22,7 @@
;;; Code:
(define-module (lisparuga asset)
+ #:use-module (chickadee render texture)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (oop goops)
@@ -38,7 +39,8 @@
reload-modified-assets
clear-asset-cache
asset-ref
- define-asset))
+ define-asset
+ load-tile-atlas))
(define-class <asset> ()
(watch? #:allocation #:class #:init-form #f)
@@ -198,3 +200,9 @@
#:file-name file-name
#:loader loader
#:loader-args (list loader-args ...))))
+
+;; Convenience procedure for loading tilesets
+(define* (load-tile-atlas file-name tile-width tile-height
+ #:key (margin 0) (spacing 0))
+ (split-texture (load-image file-name) tile-width tile-height
+ #:margin margin #:spacing spacing))
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))))
diff --git a/lisparuga/config.scm b/lisparuga/config.scm
index 322bf78..5d6f063 100644
--- a/lisparuga/config.scm
+++ b/lisparuga/config.scm
@@ -26,7 +26,7 @@
scope-asset))
(define developer-mode?
- (equal? (getenv "LISPARGUA_DEV_MODE") "1"))
+ (equal? (getenv "LISPARUGA_DEV_MODE") "1"))
(define asset-dir (getenv "LISPARUGA_ASSETDIR"))
diff --git a/lisparuga/enemy.scm b/lisparuga/enemy.scm
new file mode 100644
index 0000000..5ecba62
--- /dev/null
+++ b/lisparuga/enemy.scm
@@ -0,0 +1,65 @@
+;;; 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:
+;;
+;; Enemy actors.
+;;
+;;; Code:
+
+(define-module (lisparuga enemy)
+ #:use-module (chickadee math rect)
+ #:use-module (chickadee math vector)
+ #:use-module (chickadee scripting)
+ #:use-module (chickadee render texture)
+ #:use-module (lisparuga actor)
+ #:use-module (lisparuga asset)
+ #:use-module (lisparuga bullets)
+ #:use-module (lisparuga config)
+ #:use-module (lisparuga node)
+ #:use-module (lisparuga node-2d)
+ #:use-module (oop goops)
+ #:export (<enemy>
+ health
+ points
+ parting-shots
+
+ make-utatsugumi))
+
+
+;;;
+;;; Base Enemy
+;;;
+(define-class <enemy> (<actor>)
+ (health #:accessor health #:init-keyword #:health)
+ (points #:getter points #:init-keyword #:points)
+ (parting-shots #:getter parting-shots #:init-keyword #:parting-shots))
+
+
+;;;
+;;; Utatsugumi
+;;;
+
+(define-class <utatsugumi> (<enemy>))
+
+(define (make-utatsugumi polarity x y)
+ (make <utatsugumi>
+ #:name (gensym "utatsugumi-")
+ #:health 1
+ #:points 20
+ #:parting-shots 5
+ #:polarity polarity
+ #:position (vec2 x y)))
diff --git a/lisparuga/game.scm b/lisparuga/game.scm
new file mode 100644
index 0000000..edd97fc
--- /dev/null
+++ b/lisparuga/game.scm
@@ -0,0 +1,82 @@
+;;; 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:
+;;
+;; Game container. Handles all the state, logic, and rendering for
+;; the game itself.
+;;
+;;; Code:
+
+(define-module (lisparuga game)
+ #:use-module (chickadee math rect)
+ #:use-module (chickadee math vector)
+ #:use-module (chickadee render color)
+ #:use-module (chickadee render texture)
+ #:use-module (lisparuga asset)
+ #:use-module (lisparuga bullets)
+ #:use-module (lisparuga config)
+ #:use-module (lisparuga node)
+ #:use-module (lisparuga node-2d)
+ #:use-module (lisparuga player)
+ #:use-module (oop goops)
+ #:export (<game>
+ steer-player
+ start-player-shooting
+ stop-player-shooting
+ toggle-player-polarity
+ fire-player-homing-missiles))
+
+(define-asset clouds (load-image (scope-asset "images/clouds.png")))
+(define-asset player-bullet-atlas
+ (load-tile-atlas (scope-asset "images/player-bullets.png") 16 16))
+
+;; nodes needed:
+;; enemies
+;; enemy bullets
+;; scrolling background
+(define-class <game> (<node-2d>))
+
+(define-method (on-boot (game <game>))
+ (let* ((player-bullets (make <bullet-field>
+ #:capacity 500
+ #:texture-atlas player-bullet-atlas))
+ (player (make-player player-bullets))
+ (enemy-bullets (make <bullet-field>
+ #:capacity 1000
+ #:texture-atlas player-bullet-atlas)))
+ (attach-to game
+ (make <sprite>
+ #:name 'clouds
+ #:texture clouds)
+ player
+ player-bullets
+ enemy-bullets)))
+
+(define-method (steer-player (game <game>) up? down? left? right?)
+ (steer (& game player) up? down? left? right?))
+
+(define-method (start-player-shooting (game <game>))
+ (start-shooting (& game player)))
+
+(define-method (stop-player-shooting (game <game>))
+ (stop-shooting (& game player)))
+
+(define-method (toggle-player-polarity (game <game>))
+ (toggle-polarity (& game player)))
+
+(define-method (fire-player-homing-missiles (game <game>))
+ (fire-homing-missiles (& game player)))
diff --git a/lisparuga/kernel.scm b/lisparuga/kernel.scm
index f94b832..36dea70 100644
--- a/lisparuga/kernel.scm
+++ b/lisparuga/kernel.scm
@@ -28,6 +28,7 @@
#:use-module (chickadee render)
#:use-module (chickadee render gpu)
#:use-module (chickadee render viewport)
+ #:use-module (gl)
#:use-module (ice-9 match)
#:use-module (oop goops)
#:use-module (sdl2)
@@ -35,7 +36,7 @@
#:use-module (sdl2 input game-controller)
#:use-module (sdl2 input joystick)
#:use-module (sdl2 input text)
- #:use-module (sdl2 video)
+ #:use-module ((sdl2 video) #:prefix sdl2:)
#:use-module (lisparuga asset)
#:use-module (lisparuga config)
#:use-module (lisparuga node)
@@ -43,10 +44,10 @@
#:use-module (lisparuga scene)
#:use-module (system repl command)
#:export (<window-config>
- width
- height
- title
- fullscreen?
+ window-width
+ window-height
+ window-title
+ window-fullscreen?
<kernel>
window-config
@@ -62,11 +63,11 @@
#:re-export (abort-game))
(define-class <window-config> ()
- (width #:accessor width #:init-form 640 #:init-keyword #:width)
- (height #:accessor height #:init-form 480 #:init-keyword #:height)
- (title #:accessor title #:init-form "Lisparuga"
+ (width #:accessor window-width #:init-form 640 #:init-keyword #:width)
+ (height #:accessor window-height #:init-form 480 #:init-keyword #:height)
+ (title #:accessor window-title #:init-form "Lisparuga"
#:init-keyword #:title)
- (fullscreen? #:accessor fullscreen? #:init-form #f
+ (fullscreen? #:accessor window-fullscreen? #:init-form #f
#:init-keyword #:fullscreen?))
(define-class <kernel> (<scene-mux>)
@@ -114,11 +115,20 @@
;; Start REPL server.
(attach-to kernel (make <repl> #:name 'repl))))
+(define-method (on-key-press (kernel <kernel>) key scancode modifiers repeat?)
+ ;; Hot keys when in dev mode
+ (when developer-mode?
+ (match key
+ ('f5 (reboot-current-scene))
+ ('escape (abort-game))
+ (_ #t)))
+ (next-method))
+
(define-method (update-tree (kernel <kernel>) dt)
(define (invert-y y)
;; SDL's origin is the top-left, but our origin is the bottom
;; left so we need to invert Y coordinates that SDL gives us.
- (match (window-size (window kernel))
+ (match (sdl2:window-size (window kernel))
((_ height)
(- height y))))
(define (process-event event)
@@ -210,6 +220,12 @@
;; Free any GPU resources that have been GC'd.
(gpu-reap!))
+(define %clear-mask
+ (logior (attrib-mask color-buffer)
+ (attrib-mask depth-buffer)
+ (attrib-mask stencil-buffer)
+ (attrib-mask accum-buffer)))
+
(define-method (render-tree (kernel <kernel>) alpha)
(let ((start-time (elapsed-time)))
;; Switch to the null viewport to ensure that
@@ -217,8 +233,9 @@
;; clear the screen.
(set-gpu-viewport! (current-gpu) null-viewport)
(with-viewport (default-viewport kernel)
+ (gl-clear %clear-mask)
(next-method))
- (swap-gl-window (window kernel))
+ (sdl2:swap-gl-window (window kernel))
;; Compute FPS.
(set! (avg-frame-time kernel)
(+ (* (- (elapsed-time) start-time) 0.1)
@@ -226,10 +243,10 @@
(define-method (on-error (kernel <kernel>) stack key args)
(if developer-mode?
- (let ((title (window-title (window kernel))))
- (set-window-title! (window kernel) (string-append "[ERROR] " title))
+ (let ((title (sdl2:window-title (window kernel))))
+ (sdl2:set-window-title! (window kernel) (string-append "[ERROR] " title))
(on-error (& kernel repl) stack key args)
- (set-window-title! (window kernel) title))
+ (sdl2:set-window-title! (window kernel) title))
(apply throw key args)))
(define-method (on-scenes-empty (kernel <kernel>))
@@ -253,18 +270,18 @@
(init-audio)
(let ((wc (window-config kernel)))
(set! (window kernel)
- (make-window #:opengl? #t
- #:title (title wc)
- #:size (list (width wc) (height wc))
- #:fullscreen? (fullscreen? wc)))
- (set! (gl-context kernel) (make-gl-context (window kernel)))
+ (sdl2:make-window #:opengl? #t
+ #:title (window-title wc)
+ #:size (list (window-width wc) (window-height wc))
+ #:fullscreen? (window-fullscreen? wc)))
+ (set! (gl-context kernel) (sdl2:make-gl-context (window kernel)))
(set! (default-viewport kernel)
- (make-viewport 0 0 (width wc) (height wc)))
+ (make-viewport 0 0 (window-width wc) (window-height wc)))
;; Attempt to activate vsync, if possible. Some systems do
;; not support setting the OpenGL swap interval.
(catch #t
(lambda ()
- (set-gl-swap-interval! 'vsync))
+ (sdl2:set-gl-swap-interval! 'vsync))
(lambda args
(display "warning: could not enable vsync\n"
(current-error-port))))
@@ -284,12 +301,13 @@
(lambda ()
(deactivate kernel)
(quit-audio)
- (delete-gl-context! (gl-context kernel))
- (close-window! (window kernel))))))
+ (sdl2:delete-gl-context! (gl-context kernel))
+ (sdl2:close-window! (window kernel))))))
(define (reboot-current-scene)
"Reboot the currently active scene being managed by the game engine
kernel. A convenient procedure for developers."
+ (display "rebooting\n")
(reboot (current-scene (current-kernel))))
(define-meta-command ((debug-game lisparuga) repl)
@@ -301,3 +319,8 @@ Enter a debugger for the current game loop error."
"resume-game
Resume the game loop without entering a debugger."
(set! (repl-debugging? (& (current-kernel) repl)) #f))
+
+(define-meta-command ((reboot lisparuga) repl)
+ "reboot
+Reboot the current scene."
+ (reboot-current-scene))
diff --git a/lisparuga/node-2d.scm b/lisparuga/node-2d.scm
index 9397c77..8dca8e1 100644
--- a/lisparuga/node-2d.scm
+++ b/lisparuga/node-2d.scm
@@ -191,6 +191,8 @@
(define-class <view-2d> ()
(camera #:accessor camera #:init-keyword #:camera)
(area #:getter area #:init-keyword #:area)
+ (clear-color #:getter clear-color #:init-keyword #:clear-color
+ #:init-value tango-light-sky-blue)
(viewport #:accessor viewport)
(projection-matrix #:accessor projection-matrix)
(sprite-rect #:accessor sprite-rect))
@@ -206,7 +208,8 @@
(make-viewport (inexact->exact x)
(inexact->exact y)
(inexact->exact w)
- (inexact->exact h)))
+ (inexact->exact h)
+ #:clear-color (clear-color view)))
(set! (sprite-rect view) (make-rect 0.0 0.0 w h))
(set! (projection-matrix view) (orthographic-projection 0 w h 0 0 1))))
diff --git a/lisparuga/player.scm b/lisparuga/player.scm
new file mode 100644
index 0000000..a810e48
--- /dev/null
+++ b/lisparuga/player.scm
@@ -0,0 +1,192 @@
+;;; 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:
+;;
+;; Player actor.
+;;
+;;; Code:
+
+(define-module (lisparuga player)
+ #:use-module (chickadee math rect)
+ #:use-module (chickadee math vector)
+ #:use-module (chickadee scripting)
+ #:use-module (chickadee render texture)
+ #:use-module (lisparuga actor)
+ #:use-module (lisparuga asset)
+ #:use-module (lisparuga bullets)
+ #:use-module (lisparuga config)
+ #:use-module (lisparuga node)
+ #:use-module (lisparuga node-2d)
+ #:use-module (oop goops)
+ #:export (<player>
+ make-player
+ score
+ lives
+ energy
+ chain
+ chain-progress
+ speed
+ steer
+ start-shooting
+ stop-shooting
+ toggle-polarity
+ fire-homing-missiles))
+
+(define-asset ship (load-image (scope-asset "images/player.png")))
+(define-asset ship-atlas (load-tile-atlas (scope-asset "images/player.png") 24 24))
+
+(define kill-hitbox (make-hitbox 'kill (make-rect 0.0 0.0 0.0 0.0)))
+(define graze-hitbox (make-hitbox 'graze (make-rect 0.0 0.0 0.0 0.0)))
+
+(define-class <player> (<actor>)
+ (score #:accessor score #:init-value 0)
+ (lives #:accessor lives #:init-value 2)
+ (energy #:accessor energy #:init-value 0)
+ (chain #:accessor chain #:init-value 0)
+ (chain-progress #:accessor chain-progress #:init-form '())
+ (speed #:accessor speed #:init-value 1.75)
+ (invincible? #:accessor invincible? #:init-value #f)
+ (shooting? #:accessor shooting? #:init-value #f)
+ (shoot-time #:accessor shoot-time #:init-value 0))
+
+(define (make-player bullet-field)
+ (make <player>
+ #:name 'player
+ #:hitboxes (list graze-hitbox kill-hitbox)
+ #:position (vec2 80.0 24.0)
+ #:bullet-field bullet-field
+ #:polarity 'white))
+
+(define-method (on-boot (player <player>))
+ (attach-to player
+ (make <atlas-sprite>
+ #:name 'ship
+ #:atlas ship-atlas
+ #:index 0
+ #:origin (vec2 12.0 12.0))))
+
+(define (shoot player ox)
+ (let ((speed 8.0)
+ (pos (position player))
+ (bullets (bullet-field player))
+ (y-offset 6.0))
+ (spawn-bullet bullets ikaruga-bullet (polarity player)
+ (+ (vec2-x pos) ox) (+ (vec2-y pos) y-offset)
+ 0.0 speed)))
+
+(define-method (update (player <player>) dt)
+ ;; Adjust velocity to force player to stay within the bounds of the
+ ;; screen.
+ (let ((p (position player))
+ (v (velocity player)))
+ (cond
+ ((< (+ (vec2-x p) (vec2-x v)) 0.0)
+ (set-vec2-x! v (- (vec2-x p))))
+ ((> (+ (vec2-x p) (vec2-x v)) 160.0)
+ (set-vec2-x! v (- 160.0 (vec2-x p)))))
+ (cond
+ ((< (+ (vec2-y p) (vec2-y v)) 0.0)
+ (set-vec2-y! v (- (vec2-y p))))
+ ((> (+ (vec2-y p) (vec2-y v)) 240.0)
+ (set-vec2-y! v (- 240.0 (vec2-y p))))))
+ ;; Shooting logic
+ (when (shooting? player)
+ (let ((t (shoot-time player)))
+ ;; Fire every n frames
+ (when (and (zero? (modulo t 2))
+ ;; can't shoot while switching polarity.
+ (not (eq? (polarity player) 'none)))
+ ;; The first shot is a single shot, everything after is double
+ ;; fire. This enables players to just tap the fire button to
+ ;; fire off precision shots.
+ (cond
+ ;; single shot
+ ((zero? t)
+ (shoot player 0.0))
+ ;; double shot. give a buffer of 4 frames so players can
+ ;; reliably fire just a single shot.
+ ((> t 4)
+ (shoot player 5.0)
+ (shoot player -5.0))))
+ (set! (shoot-time player) (+ t 1))))
+ (next-method))
+
+(define-method (steer (player <player>) up? down? left? right?)
+ (let ((v (velocity player)))
+ (set-vec2! v (+ (if left? -1.0 0.0) (if right? 1.0 0.0))
+ (+ (if up? 1.0 0.0) (if down? -1.0 0.0)))
+ (vec2-normalize! v)
+ (vec2-mult! v (speed player))))
+
+(define-method (start-shooting (player <player>))
+ (set! (shooting? player) #t)
+ (set! (shoot-time player) 0))
+
+(define-method (stop-shooting (player <player>))
+ (set! (shooting? player) #f))
+
+(define-method (toggle-polarity (player <player>))
+ (let ((old (polarity player)))
+ ;; If polarity is none it means we are already switching so ignore
+ ;; the request.
+ (unless (eq? old 'none)
+ (run-script player
+ ;; There's a brief moment when switching polarity where the
+ ;; player is vulnerable to all bullets.
+ (set! (polarity player) 'none)
+ (sleep 7)
+ (set! (polarity player) (if (eq? old 'white) 'black 'white))
+ ;; Change sprite
+ (set! (index (& player ship)) (if (eq? old 'white) 4 0))))))
+
+(define-method (fire-homing-missiles (player <player>))
+ (let* ((e (energy player))
+ (n (quotient e 10)))
+ (set! (energy player) (- e (* n 10)))
+ ;; TODO: search for nearest enemy and fire missiles
+ #t))
+
+(define-method (increment-energy (player <player>))
+ (set! (energy player) (min (+ (energy player) 1) 120)))
+
+(define-method (kill-maybe (player <player>))
+ (unless (invincible? player)
+ (set! (lives player) (- (lives player) 1))
+ ;; Give player invincibility for a bit while they recover.
+ (run-script player
+ (set! (invincible? player) #t)
+ ;; 3 seconds of blinking
+ (blink 18 5)
+ (set! (invincible? player) #f))))
+
+(define-method (on-collision (player <player>) (other <actor>)
+ hitbox other-hitbox)
+ (when (eq? hitbox kill-hitbox)
+ (kill-maybe player)))
+
+(define-method (on-collision (player <player>) bullet bullet-polarity hitbox)
+ (cond
+ ;; Absorb bullets of the same polarity.
+ ((and (eq? hitbox graze-hitbox)
+ (eq? bullet-polarity (polarity player)))
+ (increment-energy player)
+ #t)
+ ;; If a bullet makes it to the kill hitbox, lose a life.
+ ((eq? hitbox kill-hitbox)
+ (kill-maybe player)
+ #t)
+ (else #f)))