diff options
| -rw-r--r-- | Makefile.am | 5 | ||||
| -rw-r--r-- | assets/images/background.png | bin | 0 -> 678 bytes | |||
| -rw-r--r-- | assets/images/background.xcf | bin | 0 -> 8943 bytes | |||
| -rw-r--r-- | assets/images/clouds.png | bin | 0 -> 42047 bytes | |||
| -rw-r--r-- | assets/images/db32.png | bin | 0 -> 35384 bytes | |||
| -rw-r--r-- | assets/images/player-bullets.png | bin | 0 -> 417 bytes | |||
| -rw-r--r-- | assets/images/player-bullets.xcf | bin | 0 -> 1415 bytes | |||
| -rw-r--r-- | assets/images/player.png | bin | 0 -> 733 bytes | |||
| -rw-r--r-- | assets/images/player.xcf | bin | 0 -> 2867 bytes | |||
| -rw-r--r-- | boot.scm | 3 | ||||
| -rw-r--r-- | lisparuga.scm | 93 | ||||
| -rw-r--r-- | lisparuga/actor.scm | 113 | ||||
| -rw-r--r-- | lisparuga/asset.scm | 10 | ||||
| -rw-r--r-- | lisparuga/bullets.scm | 243 | ||||
| -rw-r--r-- | lisparuga/config.scm | 2 | ||||
| -rw-r--r-- | lisparuga/enemy.scm | 65 | ||||
| -rw-r--r-- | lisparuga/game.scm | 82 | ||||
| -rw-r--r-- | lisparuga/kernel.scm | 69 | ||||
| -rw-r--r-- | lisparuga/node-2d.scm | 5 | ||||
| -rw-r--r-- | lisparuga/player.scm | 192 |
20 files changed, 849 insertions, 33 deletions
diff --git a/Makefile.am b/Makefile.am index 886295f..d0adf2e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -47,6 +47,11 @@ SOURCES = \ lisparuga/kernel.scm \ lisparuga/node-2d.scm \ lisparuga/transition.scm \ + lisparuga/actor.scm \ + lisparuga/bullets.scm \ + lisparuga/player.scm \ + lisparuga/enemy.scm \ + lisparuga/game.scm \ lisparuga.scm EXTRA_DIST += \ diff --git a/assets/images/background.png b/assets/images/background.png Binary files differnew file mode 100644 index 0000000..c19c477 --- /dev/null +++ b/assets/images/background.png diff --git a/assets/images/background.xcf b/assets/images/background.xcf Binary files differnew file mode 100644 index 0000000..895d445 --- /dev/null +++ b/assets/images/background.xcf diff --git a/assets/images/clouds.png b/assets/images/clouds.png Binary files differnew file mode 100644 index 0000000..ef20e9c --- /dev/null +++ b/assets/images/clouds.png diff --git a/assets/images/db32.png b/assets/images/db32.png Binary files differnew file mode 100644 index 0000000..f7bd27f --- /dev/null +++ b/assets/images/db32.png diff --git a/assets/images/player-bullets.png b/assets/images/player-bullets.png Binary files differnew file mode 100644 index 0000000..8a3a990 --- /dev/null +++ b/assets/images/player-bullets.png diff --git a/assets/images/player-bullets.xcf b/assets/images/player-bullets.xcf Binary files differnew file mode 100644 index 0000000..402a9bc --- /dev/null +++ b/assets/images/player-bullets.xcf diff --git a/assets/images/player.png b/assets/images/player.png Binary files differnew file mode 100644 index 0000000..e29b4a2 --- /dev/null +++ b/assets/images/player.png diff --git a/assets/images/player.xcf b/assets/images/player.xcf Binary files differnew file mode 100644 index 0000000..4ce0366 --- /dev/null +++ b/assets/images/player.xcf @@ -1,3 +1,4 @@ (use-modules (lisparuga)) -(launch-lisparuga) +(launch-lisparuga #:window-width 960 + #:window-height 720) diff --git a/lisparuga.scm b/lisparuga.scm index 2a700a2..828ba58 100644 --- a/lisparuga.scm +++ b/lisparuga.scm @@ -1,18 +1,99 @@ +;;; 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: +;; +;; Main scene. +;; +;;; Code: + (define-module (lisparuga) + #:use-module ((chickadee) #:select (key-pressed?)) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) + #:use-module (chickadee render color) + #:use-module (chickadee render texture) + #:use-module (ice-9 match) + #:use-module (lisparuga asset) + #:use-module (lisparuga config) + #:use-module (lisparuga game) #:use-module (lisparuga kernel) + #:use-module (lisparuga node) + #:use-module (lisparuga node-2d) #:use-module (lisparuga scene) #:use-module (oop goops) #:export (launch-lisparuga)) -(define %window-width 640) -(define %window-height 480) +(define %framebuffer-width 320) +(define %framebuffer-height 240) + +(define-asset background (load-image (scope-asset "images/background.png"))) + +(define-class <lisparuga> (<scene-2d>)) + +(define-method (on-boot (lisparuga <lisparuga>)) + ;; Scale a small framebuffer up to the window size. + (set! (views lisparuga) + (list (make <view-2d> + #:camera (make <camera-2d> + #:width %framebuffer-width + #:height %framebuffer-height) + #:area (let ((wc (window-config (current-kernel)))) + (make-rect 0 0 (window-width wc) (window-height wc)))))) + ;; This 160x240 canvas is where the actual game actors will get + ;; rendered. + (let ((actor-canvas (make <canvas> + #:name 'actor-canvas + #:views (list (make <view-2d> + #:camera (make <camera-2d> + #:width 160 + #:height 240) + #:area (make-rect 80 0 160 240) + #:clear-color (make-color 0.0 0.0 0.0 1.0)))))) + (attach-to actor-canvas (make <game> #:name 'game)) + (attach-to lisparuga + (make <sprite> + #:name 'background + #:texture background) + actor-canvas))) + +(define-method (update (lisparuga <lisparuga>) dt) + (steer-player (& lisparuga actor-canvas game) + (key-pressed? 'up) + (key-pressed? 'down) + (key-pressed? 'left) + (key-pressed? 'right))) + +(define-method (on-key-press (lisparuga <lisparuga>) key scancode modifiers repeat?) + (unless repeat? + (match key + ('z (start-player-shooting (& lisparuga actor-canvas game))) + ('x (toggle-player-polarity (& lisparuga actor-canvas game))) + ('c (fire-player-homing-missiles (& lisparuga actor-canvas game))) + (_ #t)))) -(define-class <lisparuga> (<scene>)) +(define-method (on-key-release (lisparuga <lisparuga>) key scancode modifiers) + (match key + ('z (stop-player-shooting (& lisparuga actor-canvas game))) + (_ #t))) -(define (launch-lisparuga) +(define* (launch-lisparuga #:key (window-width 640) (window-height 480)) (boot-kernel (make <kernel> #:window-config (make <window-config> #:title "Lisparuga" - #:width %window-width - #:height %window-height)) + #:width window-width + #:height window-height)) (lambda () (make <lisparuga>)))) 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))) |
