diff options
| author | David Thompson <dthompson2@worcester.edu> | 2023-10-25 08:20:48 -0400 |
|---|---|---|
| committer | David Thompson <dthompson2@worcester.edu> | 2023-10-25 08:38:11 -0400 |
| commit | 3a1afc62724f1631f23b5aa044856f7d09db14eb (patch) | |
| tree | cbede9ae3bc131b244b99d1005b85ec5cef32df0 | |
| parent | 2f1022f1d65b148524dc8f0c824aaca6e9392996 (diff) | |
Lots of changes!
* Update reflect library
* Text alginment
* Tiled map compilation!
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Makefile | 6 | ||||
| -rw-r--r-- | audio/player-shoot.wav | bin | 35490 -> 7640 bytes | |||
| -rw-r--r-- | boot.js | 3 | ||||
| -rw-r--r-- | compile-map.scm | 565 | ||||
| -rw-r--r-- | game.scm | 2037 | ||||
| -rw-r--r-- | images/map.ase | bin | 552 -> 1090 bytes | |||
| -rw-r--r-- | images/map.png | bin | 237 -> 401 bytes | |||
| -rw-r--r-- | js-runtime/reflect.js | 1 | ||||
| -rw-r--r-- | js-runtime/reflect.wasm | bin | 4260 -> 4260 bytes | |||
| -rw-r--r-- | level.tmx | 141 | ||||
| -rw-r--r-- | manifest.scm | 58 | ||||
| -rw-r--r-- | tiles.tsx | 4 |
13 files changed, 1783 insertions, 1033 deletions
@@ -1,2 +1,3 @@ /game.wasm /algj2023.zip +/level.scm @@ -1,2 +1,8 @@ +game.wasm: game.scm level.scm + /gnu/store/i7qi9wsyhxzv3w4y992qgx5j9g5dcza0-profile/bin/guile -L $(HOME)/Code/guile-hoot/module game.scm + +level.scm: level.tmx + guile compile-map.scm > level.scm + bundle: rm algj2023.zip && zip algj2023.zip -r audio/ images/*.png js-runtime/ boot.js game.css game.wasm index.html diff --git a/audio/player-shoot.wav b/audio/player-shoot.wav Binary files differindex db38cce..4059eb7 100644 --- a/audio/player-shoot.wav +++ b/audio/player-shoot.wav @@ -95,6 +95,9 @@ async function load() { setFont(context, font) { context.font = font; }, + setTextAlign(context, align) { + context.textAlign = align; + }, clearRect(context, x, y, w, h) { context.clearRect(x, y, w, h); }, diff --git a/compile-map.scm b/compile-map.scm new file mode 100644 index 0000000..11b8d9e --- /dev/null +++ b/compile-map.scm @@ -0,0 +1,565 @@ +;;; Adapted from the Chickadee Game Toolkit +;;; Copyright © 2018, 2020, 2021, 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +(use-modules (ice-9 match) + (ice-9 pretty-print) + ((rnrs base) #:select (mod)) + (rnrs bytevectors) + (srfi srfi-1) + (srfi srfi-11) + (srfi srfi-9) + (srfi srfi-43) + (sxml simple) + (sxml xpath)) + +(define-record-type <vec2> + (make-vec2 x y) + vec2? + (x vec2-x) + (y vec2-y)) + +(define-record-type <rect> + (make-rect x y width height) + rect? + (x rect-x) + (y rect-y) + (width rect-width) + (height rect-height)) + +(define-record-type <color> + (make-color r g b a) + color? + (r color-r) + (g color-g) + (b color-b) + (a color-a)) + +(define-record-type <image> + (make-image src width height trans) + image? + (src image-src) + (width image-width) + (height image-height) + (trans image-trans)) + + +;;; +;;; Tileset +;;; + +(define-record-type <animation-frame> + (make-animation-frame id duration) + animation-frame? + (id animation-frame-id) + (duration animation-frame-duration)) + +(define-record-type <animation> + (%make-animation frames duration) + animation? + (frames animation-frames) + (duration animation-duration)) + +(define (make-animation atlas first-gid frame-spec) + (let ((frames (map (match-lambda + ((id duration) + (make-animation-frame (- id first-gid) duration))) + frame-spec))) + (%make-animation (list->vector frames) + (fold (lambda (frame memo) + (+ (animation-frame-duration frame) memo)) + 0 frames)))) + +(define (animation-frame-for-time animation time) + (let* ((time (mod time (animation-duration animation))) + (frames (animation-frames animation))) + (let loop ((i 0) + (t 0)) + (let* ((frame (vector-ref frames i)) + (d (animation-frame-duration frame))) + (if (< time (+ t d)) + frame + (loop (+ i 1) (+ t d))))))) + +(define-record-type <tile> + (make-tile id image animation properties) + tile? + (id tile-id) + (image tile-image) + (animation tile-animation) + (properties tile-properties)) + +(define (animated-tile? tile) + (animation? (tile-animation tile))) + +(define (tile-frame-for-time tile time) + (let ((animation (tile-animation tile))) + (and animation (animation-frame-for-time animation time)))) + +(define-record-type <tileset> + (%make-tileset name first-gid tile-width tile-height + margin spacing rows columns tiles properties) + tileset? + (name tileset-name) + (first-gid tileset-first-gid) + (tile-width tileset-tile-width) + (tile-height tileset-tile-height) + (margin tileset-margin) + (spacing tileset-spacing) + (rows tileset-rows) + (columns tileset-columns) + (tiles tileset-tiles) + (properties tileset-properties)) + +(define (tileset-dimensions image tile-width tile-height margin spacing) + (values (inexact->exact + (ceiling (/ (- (image-width image) margin) + (+ tile-width spacing)))) + (inexact->exact + (ceiling (/ (- (image-height image) margin) + (+ tile-height spacing)))))) + +(define* (make-tileset image tile-width tile-height #:key + (first-gid 1) (margin 0) (spacing 0) + (name "anonymous") (properties '()) + (custom-tiles '())) + (let-values (((columns rows) + (tileset-dimensions image tile-width tile-height margin spacing))) + (let* ((tiles (make-vector (* columns rows)))) + (do ((i 0 (+ i 1))) + ((= i (vector-length tiles))) + (let* ((id (+ first-gid i)) + (custom (or (assv-ref custom-tiles id) '())) + (animation (assq-ref custom 'animation)) + (properties (assq-ref custom 'properties)) + (tile (make-tile id i + (and animation + (make-animation image first-gid animation)) + (or properties '())))) + (vector-set! tiles i tile))) + (%make-tileset name first-gid tile-width tile-height margin spacing + rows columns tiles properties)))) + +(define (tileset-size tileset) + (vector-length (tileset-tiles tileset))) + +(define (tileset-ref tileset i) + (vector-ref (tileset-tiles tileset) (- i (tileset-first-gid tileset)))) + + +;;; +;;; Object Layer +;;; + +(define-record-type <object-layer> + (%make-object-layer name objects properties) + object-layer? + (name object-layer-name) + (objects object-layer-objects) + (properties object-layer-properties)) + +(define-record-type <polygon> + (make-polygon points) + polygon? + (points polygon-points)) + +(define-record-type <map-object> + (%make-map-object id name type shape properties) + map-object? + (id map-object-id) + (name map-object-name) + (type map-object-type) + (shape map-object-shape) + (properties map-object-properties)) + + +;;; +;;; Tile Layer +;;; + +(define-record-type <map-tile> + (%make-map-tile tile flipped-horizontally? flipped-vertically? + flipped-diagonally?) + map-tile? + (tile map-tile-ref) + (flipped-horizontally? map-tile-flipped-horizontally?) + (flipped-vertically? map-tile-flipped-vertically?) + (flipped-diagonally? map-tile-flipped-diagonally?)) + +(define* (make-map-tile tile #:key flipped-horizontally? + flipped-vertically? flipped-diagonally?) + (%make-map-tile tile flipped-horizontally? flipped-vertically? + flipped-diagonally?)) + +(define-record-type <tile-layer> + (%make-tile-layer name width height properties tiles) + tile-layer? + (name tile-layer-name) + (width tile-layer-width) + (height tile-layer-height) + (properties tile-layer-properties) + (tiles tile-layer-tiles)) + +(define* (make-tile-layer width height tile-width tile-height #:key + (name "anonymous") + (properties '())) + (%make-tile-layer name width height properties (make-vector (* width height)))) + +(define (tile-layer-bounds-check layer x y) + (unless (and (>= x 0) (>= y 0) + (< x (tile-layer-width layer)) + (< y (tile-layer-height layer))) + (error "tile layer coordinates out of bounds" layer x y))) + +(define (tile-layer-ref layer x y) + (vector-ref (tile-layer-tiles layer) (+ (* y (tile-layer-width layer)) x))) + +(define (tile-layer-set! layer x y tile) + (vector-set! (tile-layer-tiles layer) (+ (* y (tile-layer-width layer)) x) tile)) + + +;;; +;;; Tile Map +;;; + +(define-record-type <tile-map> + (%make-tile-map orientation width height tile-width tile-height + tilesets layers properties) + tile-map? + (orientation tile-map-orientation) + (width tile-map-width) + (height tile-map-height) + (tile-width tile-map-tile-width) + (tile-height tile-map-tile-height) + (tilesets tile-map-tilesets) + (layers tile-map-layers) + (properties tile-map-properties)) + +(define* (make-tile-map width height tile-width tile-height #:key + (orientation 'orthogonal) (tilesets '()) + (layers '()) (properties '())) + "Make a tile map that is WIDTH x HEIGHT tiles in size and each tile +is TILE-WIDTH x TILE-HEIGHT pixels in size. TILESETS is a list of +tilesets to be associated with the map. LAYERS is a list of object +and/or tile layers, sorted from bottom to top. PROPERTIES is an alist +of arbitrary custom data to associate with the map. Currently, only +the default ORIENTATION value of 'orthogonal' is supported." + (unless (eq? orientation 'orthogonal) + (error "unsupport tile map orientation" orientation)) + (%make-tile-map orientation width height tile-width tile-height + tilesets (list->vector layers) properties)) + +(define (tile-map-layer-ref tile-map name) + "Return the map layer named NAME." + (define (layer-name layer) + (if (tile-layer? layer) + (tile-layer-name layer) + (object-layer-name layer))) + (let ((layers (tile-map-layers tile-map))) + (let loop ((i 0)) + (cond + ((= i (vector-length layers)) + #f) + ((string=? name (layer-name (vector-ref layers i))) + (vector-ref layers i)) + (else + (loop (+ i 1))))))) + +(define (point->tile tile-map x y) + "Translate the pixel coordinates (X, Y) into tile coordinates." + (values (inexact->exact (floor (/ x (tile-map-tile-width tile-map)))) + (inexact->exact (floor (/ y (tile-map-tile-height tile-map)))))) + +(define* (load-tile-map file-name) + "Load the Tiled TMX formatted map in FILE-NAME." + (define map-directory + (if (absolute-file-name? file-name) + (dirname file-name) + (string-append (getcwd) "/" (dirname file-name)))) + (define (scope file-name) + (string-append map-directory "/" file-name)) + (define* (attr node name #:optional (parse identity)) + (let ((result ((sxpath `(@ ,name *text*)) node))) + (if (null? result) + #f + (parse (car result))))) + (define (parse-color-channel s start) + (/ (string->number (substring s start (+ start 2)) 16) 255.0)) + (define (parse-property node) + (let ((name (attr node 'name string->symbol)) + (type (or (attr node 'type string->symbol) 'string)) + (value (attr node 'value))) + (cons name + (match type + ((or 'string 'file) value) + ('bool (not (string=? value "false"))) + ((or 'int 'float) (string->number value)) + ('color + (make-color (parse-color-channel value 3) + (parse-color-channel value 5) + (parse-color-channel value 7) + (parse-color-channel value 1))) + (_ (error "unsupported property type" type)))))) + (define (parse-image node) + (let ((source (attr node 'source)) + (width (string->number (attr node 'width))) + (height (string->number (attr node 'height))) + (trans (attr node 'trans))) + (make-image (scope source) width height trans))) + (define (invert-tile-id id first-gid rows columns) + (let ((id* (- id first-gid))) + (+ (* (- rows (floor (/ id* columns)) 1) + columns) + (modulo id* columns) + first-gid))) + (define (parse-frame node first-gid rows columns) + (let ((tile-id (attr node 'tileid string->number)) + (duration (attr node 'duration string->number))) + (list (+ first-gid (invert-tile-id tile-id 0 rows columns)) + (/ duration 1000.0)))) + (define (parse-tiles nodes first-gid rows columns) + (let ((frames (sxpath '(animation frame))) + (properties (sxpath '(properties property)))) + (fold (lambda (node memo) + (let ((id (+ first-gid + (invert-tile-id (attr node 'id string->number) + 0 rows columns)))) + (cons `(,id . ((animation . ,(map (lambda (f) + (parse-frame f first-gid + rows columns)) + (frames node))) + (properties . ,(map parse-property + (properties node))))) + memo))) + '() + nodes))) + (define (first-gid node) + (attr node 'firstgid string->number)) + (define (parse-tileset node first-gid) + (let* ((name (attr node 'name)) + (tile-width (attr node 'tilewidth string->number)) + (tile-height (attr node 'tileheight string->number)) + (margin (or (attr node 'margin string->number) 0)) + (spacing (or (attr node 'spacing string->number) 0)) + (image (parse-image ((sxpath '(image)) node))) + ;; (tiles (call-with-values + ;; (lambda () + ;; (texture-tileset-dimensions texture + ;; tile-width + ;; tile-height + ;; #:margin margin + ;; #:spacing spacing)) + ;; (lambda (columns rows) + ;; (parse-tiles ((sxpath '(tile)) node) first-gid rows columns)))) + (properties (map parse-property + ((sxpath '(properties property)) node)))) + (make-tileset image tile-width tile-height + #:margin margin + #:spacing spacing + #:name name + #:first-gid first-gid + #:properties properties + #:custom-tiles '()))) + (define (parse-external-tileset node) + (let* ((first-gid (attr node 'firstgid string->number)) + (source (scope (attr node 'source))) + (tree (call-with-input-file source xml->sxml))) + (parse-tileset (car ((sxpath '(tileset)) tree)) first-gid))) + (define (parse-tileset* node) + (if (attr node 'source) + (parse-external-tileset node) + (parse-tileset node (first-gid node)))) + (define (tile-gid->map-tile raw-gid tilesets x y tile-width tile-height) + ;; The top 3 bits of the tile gid are flags for various types of + ;; flipping. + (let* ((flipped-horizontally? (> (logand raw-gid #x80000000) 0)) + (flipped-vertically? (> (logand raw-gid #x40000000) 0)) + (flipped-diagonally? (> (logand raw-gid #x20000000) 0)) + ;; Remove the upper 3 bits to get the true tile id. + (gid (logand raw-gid #x1FFFFFFF)) + (tileset (find (lambda (t) + (and (>= gid (tileset-first-gid t)) + (< gid (+ (tileset-first-gid t) + (tileset-size t))))) + tilesets)) + (tw (tileset-tile-width tileset)) + (th (tileset-tile-height tileset)) + (first-gid (tileset-first-gid tileset)) + (rows (tileset-rows tileset)) + (columns (tileset-columns tileset)) + (id (invert-tile-id gid first-gid rows columns))) + (make-map-tile (tileset-ref tileset id) + #:flipped-horizontally? flipped-horizontally? + #:flipped-vertically? flipped-vertically? + #:flipped-diagonally? flipped-diagonally?))) + (define (tile-gids->map-tiles gids width height tilesets) + (let ((tiles (make-vector (* width height)))) + (let y-loop ((y 0) + (rows gids)) + (when (< y height) + (match rows + ((row . rest) + (let x-loop ((x 0) + (columns row)) + (when (< x width) + (match columns + ((gid . rest) + (vector-set! tiles + (+ (* width y) x) + (if (zero? gid) + #f + (tile-gid->map-tile gid tilesets + x y width height))) + (x-loop (+ x 1) rest))))) + (y-loop (+ y 1) rest))))) + tiles)) + (define (parse-csv lines width height tilesets) + (let ((gids (map (lambda (line) + (filter-map (lambda (s) + (and (not (string-null? s)) + (string->number s))) + (string-split line #\,))) + (take (drop (string-split lines #\newline) 1) height)))) + (tile-gids->map-tiles gids width height tilesets))) + (define (parse-layer-data node width height tilesets) + (let ((encoding (attr node 'encoding string->symbol)) + (data (car ((sxpath '(*text*)) node)))) + (match encoding + ('csv (parse-csv data width height tilesets)) + (_ (error "unsupported tile layer encoding" encoding))))) + (define (parse-tile-layer node tile-width tile-height tilesets) + (let* ((name (attr node 'name)) + (width (attr node 'width string->number)) + (height (attr node 'height string->number)) + (tiles (parse-layer-data ((sxpath '(data)) node) + width height tilesets)) + (properties (map parse-property + ((sxpath '(properties property)) node))) + (layer (make-tile-layer width height tile-width tile-height + #:name name + #:properties properties))) + (do ((y 0 (+ y 1))) + ((= y height)) + (do ((x 0 (+ x 1))) + ((= x width)) + (tile-layer-set! layer x y (vector-ref tiles (+ (* y width) x))))) + layer)) + (define (parse-polygon node pixel-height) + (make-polygon + (list->vector + (map (lambda (s) + (match (string-split s #\,) + ((x y) + (make-vec2 (string->number x) (string->number y))))) + (string-split (attr node 'points) #\space))))) + (define (parse-object node pixel-height) + (let* ((id (attr node 'id string->number)) + (name (attr node 'name)) + (type (attr node 'type string->symbol)) + (x (attr node 'x string->number)) + (y (attr node 'y string->number)) + (width (attr node 'width string->number)) + (height (attr node 'height string->number)) + (shape (if (and width height) + (make-rect x y width height) + (parse-polygon (car ((sxpath '(polygon)) node)) + pixel-height))) + (properties (map parse-property + ((sxpath '(properties property)) node)))) + (%make-map-object id name type shape properties))) + (define (parse-object-layer node pixel-height) + (let ((name (attr node 'name)) + (objects (map (lambda (node) + (parse-object node pixel-height)) + ((sxpath '(object)) node))) + (properties (map parse-property + ((sxpath '(properties property)) node)))) + (%make-object-layer name objects properties))) + (let* ((tree (call-with-input-file file-name xml->sxml)) + (m ((sxpath '(map)) tree)) + (version (attr m 'version)) + (orientation (attr m 'orientation string->symbol)) + (width (attr m 'width string->number)) + (height (attr m 'height string->number)) + (tile-width (attr m 'tilewidth string->number)) + (tile-height (attr m 'tileheight string->number)) + (properties ((sxpath '(map properties property)) tree)) + (tilesets (map parse-tileset* ((sxpath '(map tileset)) tree))) + (layers ((node-or (sxpath '(map layer)) + (sxpath '(map objectgroup))) + tree))) + (make-tile-map width height tile-width tile-height + #:orientation orientation + #:tilesets tilesets + #:layers (map (lambda (node) + (match node + (('layer . _) + (parse-tile-layer node tile-width tile-height tilesets)) + (('objectgroup . _) + (parse-object-layer node (* height tile-height))))) + layers) + #:properties (map parse-property properties)))) + +(define tile-map (load-tile-map "level.tmx")) + +(define (compile-tile-layer layer) + `(vector + ,@(map (lambda (y) + (bytevector-copy + (list->f64vector + (concatenate + (filter-map (lambda (x) + (let ((tile (tile-layer-ref layer x y))) + (and tile + (list (* (exact->inexact x) 16.0) + (* (exact->inexact + (- (tile-id (map-tile-ref tile)) 1)) + 16.0))))) + (iota (tile-layer-width layer))))))) + (iota (tile-layer-height layer))))) + +(define (compile-collision-layer layer) + (u8-list->bytevector + (append-map (lambda (y) + (map (lambda (x) + (if (tile-layer-ref layer x y) 1 0)) + (iota (tile-layer-width layer)))) + (iota (tile-layer-height layer))))) + +(define (compile-object-layer layer) + (let ((table (make-hash-table)) + (tw (tile-map-tile-width tile-map)) + (th (tile-map-tile-height tile-map))) + (for-each (lambda (obj) + (let* ((type (map-object-type obj)) + (r (map-object-shape obj)) + (x (/ (rect-x r) tw)) + (y (/ (rect-y r) th))) + ;; (format (current-error-port) "obj: ~a ~a ~a ~a\n" (rect-x r) (rect-y r) x y) + (hashv-set! table y + (cons `(make-level-object ,x (quote ,type)) + (hashv-ref table y '()))))) + (object-layer-objects layer)) + `(vector + ,@(map (lambda (y) + `(list ,@(hashv-ref table y '()))) + (iota (tile-map-height tile-map)))))) + +(pretty-print + `(make-level + ,(tile-map-height tile-map) + ,(compile-tile-layer (tile-map-layer-ref tile-map "foreground")) + ,(compile-tile-layer (tile-map-layer-ref tile-map "background")) + ,(compile-collision-layer (tile-map-layer-ref tile-map "collision")) + ,(compile-object-layer (tile-map-layer-ref tile-map "objects")))) @@ -1,1077 +1,1048 @@ -(let () - ;; Host imports - (define-foreign current-window - "window" "get" - -> (ref extern)) - (define-foreign window-inner-width - "window" "innerWidth" - (ref extern) -> i32) - (define-foreign window-inner-height - "window" "innerHeight" - (ref extern) -> i32) - (define-foreign request-animation-frame - "window" "requestAnimationFrame" - (ref eq) -> none) - (define-foreign timeout - "window" "setTimeout" - (ref eq) f64 -> i32) +(use-modules (hoot compile) + (ice-9 binary-ports) + (wasm assemble)) - (define-foreign current-document - "document" "get" - -> (ref extern)) - (define-foreign document-body - "document" "body" - -> (ref extern)) - (define-foreign get-element-by-id - "document" "getElementById" - (ref string) -> (ref null extern)) - (define-foreign make-text-node - "document" "createTextNode" - (ref string) -> (ref extern)) - (define-foreign make-element - "document" "createElement" - (ref string) -> (ref extern)) +(define src + `(let () + ;; Host imports + (define-foreign current-window + "window" "get" + -> (ref extern)) + (define-foreign window-inner-width + "window" "innerWidth" + (ref extern) -> i32) + (define-foreign window-inner-height + "window" "innerHeight" + (ref extern) -> i32) + (define-foreign request-animation-frame + "window" "requestAnimationFrame" + (ref eq) -> none) + (define-foreign timeout + "window" "setTimeout" + (ref eq) f64 -> i32) - (define-foreign element-value - "element" "value" - (ref extern) -> (ref string)) - (define-foreign set-element-value! - "element" "setValue" - (ref extern) (ref string) -> none) - (define-foreign set-element-width! - "element" "setWidth" - (ref extern) i32 -> none) - (define-foreign set-element-height! - "element" "setHeight" - (ref extern) i32 -> none) - (define-foreign append-child! - "element" "appendChild" - (ref extern) (ref extern) -> (ref extern)) - (define-foreign remove! - "element" "remove" - (ref extern) -> none) - (define-foreign replace-with! - "element" "replaceWith" - (ref extern) (ref extern) -> none) - (define-foreign set-attribute! - "element" "setAttribute" - (ref extern) (ref string) (ref string) -> none) - (define-foreign remove-attribute! - "element" "removeAttribute" - (ref extern) (ref string) -> none) - (define-foreign add-event-listener! - "element" "addEventListener" - (ref extern) (ref string) (ref eq) -> none) - (define-foreign remove-event-listener! - "element" "removeEventListener" - (ref extern) (ref string) (ref eq) -> none) - (define-foreign clone-element - "element" "clone" - (ref extern) -> (ref extern)) + (define-foreign current-document + "document" "get" + -> (ref extern)) + (define-foreign document-body + "document" "body" + -> (ref extern)) + (define-foreign get-element-by-id + "document" "getElementById" + (ref string) -> (ref null extern)) + (define-foreign make-text-node + "document" "createTextNode" + (ref string) -> (ref extern)) + (define-foreign make-element + "document" "createElement" + (ref string) -> (ref extern)) - (define-foreign prevent-default! - "event" "preventDefault" - (ref extern) -> none) - (define-foreign keyboard-event-code - "event" "keyboardCode" - (ref extern) -> (ref string)) + (define-foreign element-value + "element" "value" + (ref extern) -> (ref string)) + (define-foreign set-element-value! + "element" "setValue" + (ref extern) (ref string) -> none) + (define-foreign set-element-width! + "element" "setWidth" + (ref extern) i32 -> none) + (define-foreign set-element-height! + "element" "setHeight" + (ref extern) i32 -> none) + (define-foreign append-child! + "element" "appendChild" + (ref extern) (ref extern) -> (ref extern)) + (define-foreign remove! + "element" "remove" + (ref extern) -> none) + (define-foreign replace-with! + "element" "replaceWith" + (ref extern) (ref extern) -> none) + (define-foreign set-attribute! + "element" "setAttribute" + (ref extern) (ref string) (ref string) -> none) + (define-foreign remove-attribute! + "element" "removeAttribute" + (ref extern) (ref string) -> none) + (define-foreign add-event-listener! + "element" "addEventListener" + (ref extern) (ref string) (ref eq) -> none) + (define-foreign remove-event-listener! + "element" "removeEventListener" + (ref extern) (ref string) (ref eq) -> none) + (define-foreign clone-element + "element" "clone" + (ref extern) -> (ref extern)) - (define-foreign get-context - "canvas" "getContext" - (ref extern) (ref string) -> (ref extern)) - (define-foreign set-fill-color! - "canvas" "setFillColor" - (ref extern) (ref string) -> none) - (define-foreign set-font! - "canvas" "setFont" - (ref extern) (ref string) -> none) - (define-foreign clear-rect - "canvas" "clearRect" - (ref extern) f64 f64 f64 f64 -> none) - (define-foreign fill-rect - "canvas" "fillRect" - (ref extern) f64 f64 f64 f64 -> none) - (define-foreign fill-text - "canvas" "fillText" - (ref extern) (ref string) f64 f64 -> none) - (define-foreign draw-image - "canvas" "drawImage" - (ref extern) (ref extern) f64 f64 f64 f64 f64 f64 f64 f64 -> none) - (define-foreign set-scale! - "canvas" "setScale" - (ref extern) f64 f64 -> none) - (define-foreign set-transform! - "canvas" "setTransform" - (ref extern) f64 f64 f64 f64 f64 f64 -> none) - (define-foreign set-image-smoothing-enabled! - "canvas" "setImageSmoothingEnabled" - (ref extern) i32 -> none) + (define-foreign prevent-default! + "event" "preventDefault" + (ref extern) -> none) + (define-foreign keyboard-event-code + "event" "keyboardCode" + (ref extern) -> (ref string)) - (define-foreign load-audio - "audio" "new" - (ref string) -> (ref extern)) - (define-foreign audio-play - "audio" "play" - (ref extern) -> none) - (define-foreign audio-volume - "audio" "volume" - (ref extern) -> f64) - (define-foreign set-audio-volume! - "audio" "setVolume" - (ref extern) f64 -> none) + (define-foreign get-context + "canvas" "getContext" + (ref extern) (ref string) -> (ref extern)) + (define-foreign set-fill-color! + "canvas" "setFillColor" + (ref extern) (ref string) -> none) + (define-foreign set-font! + "canvas" "setFont" + (ref extern) (ref string) -> none) + (define-foreign set-text-align! + "canvas" "setTextAlign" + (ref extern) (ref string) -> none) + (define-foreign clear-rect + "canvas" "clearRect" + (ref extern) f64 f64 f64 f64 -> none) + (define-foreign fill-rect + "canvas" "fillRect" + (ref extern) f64 f64 f64 f64 -> none) + (define-foreign fill-text + "canvas" "fillText" + (ref extern) (ref string) f64 f64 -> none) + (define-foreign draw-image + "canvas" "drawImage" + (ref extern) (ref extern) f64 f64 f64 f64 f64 f64 f64 f64 -> none) + (define-foreign set-scale! + "canvas" "setScale" + (ref extern) f64 f64 -> none) + (define-foreign set-transform! + "canvas" "setTransform" + (ref extern) f64 f64 f64 f64 f64 f64 -> none) + (define-foreign set-image-smoothing-enabled! + "canvas" "setImageSmoothingEnabled" + (ref extern) i32 -> none) - (define-foreign load-image - "image" "new" - (ref string) -> (ref extern)) + (define-foreign load-audio + "audio" "new" + (ref string) -> (ref extern)) + (define-foreign audio-play + "audio" "play" + (ref extern) -> none) + (define-foreign audio-volume + "audio" "volume" + (ref extern) -> f64) + (define-foreign set-audio-volume! + "audio" "setVolume" + (ref extern) f64 -> none) - (define-syntax-rule (define-type name - constructor - predicate - (field getter setter) ...) - (begin - (define (constructor field ...) - (vector 'name field ...)) - (define (predicate obj) - (match obj - (#('name field ...) #t) - (_ #f))) - (define (getter obj) - (match obj - (#('name field ...) - field))) - ... - (define setter - (let ((i (1+ (- (length '(field ...)) - (length (memq 'field '(field ...))))))) - (lambda (obj val) - (match obj - (#('name field ...) - (vector-set! obj i val)))))) - ...)) + (define-foreign load-image + "image" "new" + (ref string) -> (ref extern)) - ;; TODO: Add basic fmod as inline wasm function + (define-syntax-rule (define-type name + constructor + predicate + (field getter setter) ...) + (begin + (define (constructor field ...) + (vector 'name field ...)) + (define (predicate obj) + (match obj + (#('name field ...) #t) + (_ #f))) + (define (getter obj) + (match obj + (#('name field ...) + field))) + ... + (define setter + (let ((i (1+ (- (length '(field ...)) + (length (memq 'field '(field ...))))))) + (lambda (obj val) + (match obj + (#('name field ...) + (vector-set! obj i val)))))) + ...)) - ;; Hoot's exact and inexact aren't working right. These next two - ;; procedures are alternatives for now. - (define (trunc x) - ;; rational? is also borked so can't use that here. - (unless (and (number? x) (inexact? x)) - (error "expected inexact rational" x)) - (%inline-wasm - '(func (param $x (ref eq)) (result (ref eq)) - (call $s64->scm - (i64.trunc_f64_s - (struct.get $flonum $val (ref.cast $flonum (local.get $x)))))) - x)) - (define (inexact x) - (unless (exact-integer? x) - (error "expected exact integer" x)) - (%inline-wasm - '(func (param $x (ref eq)) (result (ref eq)) - (if (ref eq) - (call $fixnum? (local.get $x)) - (then - (struct.new $flonum - (i32.const 0) - (f64.convert_i32_s - (call $fixnum->i32 (ref.cast i31 (local.get $x)))))) - (else - (struct.new $flonum - (i32.const 0) - (f64.convert_i64_s - (call $bignum-get-i64 - (struct.get $bignum $val - (ref.cast $bignum (local.get $x))))))))) - x)) + ;; TODO: Add basic fmod as inline wasm function - (define s32-ref bytevector-s32-native-ref) - (define s32-set! bytevector-s32-native-set!) - (define f64-ref bytevector-ieee-double-native-ref) - (define f64-set! bytevector-ieee-double-native-set!) + ;; Hoot's exact and inexact aren't working right. These next two + ;; procedures are alternatives for now. + (define (trunc x) + ;; rational? is also borked so can't use that here. + (unless (and (number? x) (inexact? x)) + (error "expected inexact rational" x)) + (%inline-wasm + '(func (param $x (ref eq)) (result (ref eq)) + (call $s64->scm + (i64.trunc_f64_s + (struct.get $flonum $val (ref.cast $flonum (local.get $x)))))) + x)) + (define (inexact x) + (unless (exact-integer? x) + (error "expected exact integer" x)) + (%inline-wasm + '(func (param $x (ref eq)) (result (ref eq)) + (if (ref eq) + (call $fixnum? (local.get $x)) + (then + (struct.new $flonum + (i32.const 0) + (f64.convert_i32_s + (call $fixnum->i32 (ref.cast i31 (local.get $x)))))) + (else + (struct.new $flonum + (i32.const 0) + (f64.convert_i64_s + (call $bignum-get-i64 + (struct.get $bignum $val + (ref.cast $bignum (local.get $x))))))))) + x)) - (define pi (* 4.0 (atan 1.0))) - (define pi/2 (/ pi 2.0)) - (define tau (* pi 2.0)) + (define s32-ref bytevector-s32-native-ref) + (define s32-set! bytevector-s32-native-set!) + (define f64-ref bytevector-ieee-double-native-ref) + (define f64-set! bytevector-ieee-double-native-set!) - (define (clamp x min max) - (cond ((< x min) min) - ((> x max) max) - (else x))) + (define pi (* 4.0 (atan 1.0))) + (define pi/2 (/ pi 2.0)) + (define tau (* pi 2.0)) - (define-type vec2 - make-vec2 - vec2? - (bv vec2-bv set-vec2-bv!)) - (define (vec2 x y) - (let ((v (make-vec2 (make-bytevector 16)))) - (set-vec2-x! v x) - (set-vec2-y! v y) - v)) - (define (vec2-x v) - (f64-ref (vec2-bv v) 0)) - (define (vec2-y v) - (f64-ref (vec2-bv v) 8)) - (define (set-vec2-x! v x) - (f64-set! (vec2-bv v) 0 x)) - (define (set-vec2-y! v y) - (f64-set! (vec2-bv v) 8 y)) - (define (vec2-add! v w) - (set-vec2-x! v (+ (vec2-x v) (vec2-x w))) - (set-vec2-y! v (+ (vec2-y v) (vec2-y w)))) - (define (vec2-sub! v w) - (set-vec2-x! v (- (vec2-x v) (vec2-x w))) - (set-vec2-y! v (- (vec2-y v) (vec2-y w)))) - (define (vec2-mul-scalar! v x) - (set-vec2-x! v (* (vec2-x v) x)) - (set-vec2-y! v (* (vec2-y v) x))) - (define (vec2-magnitude v) - (sqrt (+ (* (vec2-x v) (vec2-x v)) (* (vec2-y v) (vec2-y v))))) - (define (vec2-normalize! v) - (unless (and (= (vec2-x v) 0.0) (= (vec2-y v) 0.0)) - (let ((m (vec2-magnitude v))) - (set-vec2-x! v (/ (vec2-x v) m)) - (set-vec2-y! v (/ (vec2-y v) m))))) - (define (vec2-clamp! v xmin ymin xmax ymax) - (set-vec2-x! v (clamp (vec2-x v) xmin xmax)) - (set-vec2-y! v (clamp (vec2-y v) ymin ymax))) + (define (clamp x min max) + (cond ((< x min) min) + ((> x max) max) + (else x))) - (define (make-rect x y w h) - (let ((r (make-bytevector (* 8 4)))) - (f64-set! r 0 x) - (f64-set! r 8 y) - (f64-set! r 16 w) - (f64-set! r 24 h) - r)) - (define (rect-x r) - (f64-ref r 0)) - (define (rect-y r) - (f64-ref r 8)) - (define (rect-w r) - (f64-ref r 16)) - (define (rect-h r) - (f64-ref r 24)) + (define-type vec2 + make-vec2 + vec2? + (bv vec2-bv set-vec2-bv!)) + (define (vec2 x y) + (let ((v (make-vec2 (make-bytevector 16)))) + (set-vec2-x! v x) + (set-vec2-y! v y) + v)) + (define (vec2-x v) + (f64-ref (vec2-bv v) 0)) + (define (vec2-y v) + (f64-ref (vec2-bv v) 8)) + (define (set-vec2-x! v x) + (f64-set! (vec2-bv v) 0 x)) + (define (set-vec2-y! v y) + (f64-set! (vec2-bv v) 8 y)) + (define (vec2-add! v w) + (set-vec2-x! v (+ (vec2-x v) (vec2-x w))) + (set-vec2-y! v (+ (vec2-y v) (vec2-y w)))) + (define (vec2-sub! v w) + (set-vec2-x! v (- (vec2-x v) (vec2-x w))) + (set-vec2-y! v (- (vec2-y v) (vec2-y w)))) + (define (vec2-mul-scalar! v x) + (set-vec2-x! v (* (vec2-x v) x)) + (set-vec2-y! v (* (vec2-y v) x))) + (define (vec2-magnitude v) + (sqrt (+ (* (vec2-x v) (vec2-x v)) (* (vec2-y v) (vec2-y v))))) + (define (vec2-normalize! v) + (unless (and (= (vec2-x v) 0.0) (= (vec2-y v) 0.0)) + (let ((m (vec2-magnitude v))) + (set-vec2-x! v (/ (vec2-x v) m)) + (set-vec2-y! v (/ (vec2-y v) m))))) + (define (vec2-clamp! v xmin ymin xmax ymax) + (set-vec2-x! v (clamp (vec2-x v) xmin xmax)) + (set-vec2-y! v (clamp (vec2-y v) ymin ymax))) - (define (within? x y rx ry rw rh) - (and (>= x rx) - (>= y ry) - (< x (+ rx rw)) - (< y (+ ry rh)))) - (define (rect-within? ax ay aw ah bx by bw bh) - (let ((ax* (+ ax aw)) - (ay* (+ ay ah))) - (or (within? ax ay bx by bw bh) - (within? ax* ay bx by bw bh) - (within? ax* ay* bx by bw bh) - (within? ax ay* bx by bw bh)))) + (define (make-rect x y w h) + (let ((r (make-bytevector (* 8 4)))) + (f64-set! r 0 x) + (f64-set! r 8 y) + (f64-set! r 16 w) + (f64-set! r 24 h) + r)) + (define (rect-x r) + (f64-ref r 0)) + (define (rect-y r) + (f64-ref r 8)) + (define (rect-w r) + (f64-ref r 16)) + (define (rect-h r) + (f64-ref r 24)) - ;; So we can play many overlapping audio samples at once. - (define (load-sound-effect src) - (let* ((k 32) - (audio (load-audio src)) - (vec (make-vector k))) - (do ((i 0 (+ i 1))) - ((= i k)) - (vector-set! vec i (clone-element audio))) - (vector 0 vec))) - (define* (sound-effect-play sound #:optional (volume 1.0)) - (match sound - (#(i vec) - (let ((audio (vector-ref vec i))) - (set-audio-volume! audio volume) - (audio-play audio) - (vector-set! sound 0 (modulo (+ i 1) (vector-length vec))))))) + (define (within? x y rx ry rw rh) + (and (>= x rx) + (>= y ry) + (< x (+ rx rw)) + (< y (+ ry rh)))) + (define (rect-within? ax ay aw ah bx by bw bh) + (let ((ax* (+ ax aw)) + (ay* (+ ay ah))) + (or (within? ax ay bx by bw bh) + (within? ax* ay bx by bw bh) + (within? ax* ay* bx by bw bh) + (within? ax ay* bx by bw bh)))) - ;; Screen size stuff - (define game-width 240.0) - (define game-height 320.0) + ;; So we can play many overlapping audio samples at once. + (define (load-sound-effect src) + (let* ((k 32) + (audio (load-audio src)) + (vec (make-vector k))) + (do ((i 0 (+ i 1))) + ((= i k)) + (vector-set! vec i (clone-element audio))) + (vector 0 vec))) + (define* (sound-effect-play sound #:optional (volume 1.0)) + (match sound + (#(i vec) + (let ((audio (vector-ref vec i))) + (set-audio-volume! audio volume) + (audio-play audio) + (vector-set! sound 0 (modulo (+ i 1) (vector-length vec))))))) - ;; Elements - (define canvas (get-element-by-id "canvas")) - (define context (get-context canvas "2d")) - (define image:background (load-image "images/background.png")) - (define image:player (load-image "images/player.png")) - (define image:player-bullet (load-image "images/player-bullet.png")) - (define image:enemy-bullets (load-image "images/enemy-bullets.png")) - (define image:map (load-image "images/map.png")) - (define image:enemies (load-image "images/enemies.png")) - (define sound:explosion (load-sound-effect "audio/explosion.wav")) - (define sound:player-shoot (load-sound-effect "audio/player-shoot.wav")) - (define sound:player-death (load-sound-effect "audio/player-death.wav")) - (define sound:enemy-shoot (load-sound-effect "audio/enemy-shoot.wav")) - (define sound:bullet-hit (load-sound-effect "audio/bullet-hit.wav")) + ;; intro, play, game-over, game-won + (define *game-state* 'play) - ;; Scripting - (define (make-scheduler max-tasks) - (vector 0 0 max-tasks (make-vector max-tasks))) - (define (scheduler-add! scheduler thunk delay) - (match scheduler - (#(ticks num-tasks max-tasks tasks) - (unless (= num-tasks max-tasks) - (vector-set! tasks num-tasks (cons (+ ticks delay) thunk)) - (vector-set! scheduler 1 (+ num-tasks 1)))))) - (define (scheduler-tick! scheduler) - (define (run-thunks thunks) - (for-each (lambda (thunk) (thunk)) thunks)) - (run-thunks - (match scheduler - (#(ticks num-tasks max-tasks tasks) - (let ((t (+ ticks 1))) - (let loop ((i 0) (k num-tasks) (to-run '())) - (if (< i k) - (match (vector-ref tasks i) - ((t* . thunk) - (if (<= t* t) - (let ((k* (- k 1))) - (vector-set! tasks i (vector-ref tasks k*)) - (vector-set! tasks k* #f) - (loop i k* (cons thunk to-run))) - (loop (+ i 1) k to-run)))) - (begin - (vector-set! scheduler 0 t) - (vector-set! scheduler 1 k) - to-run)))))))) - (define (scheduler-reset! scheduler) - (match scheduler - (#(ticks num-tasks max-tasks tasks) - (vector-set! scheduler 0 0) - (vector-set! scheduler 1 0) - (do ((i 0 (+ i 1))) - ((= i num-tasks)) - (vector-set! tasks i #f))))) - (define *scheduler* (make-scheduler 100)) - (define %script-tag (make-prompt-tag "script")) - (define-type script - %make-script - script? - (state script-state set-script-state!) - (cont script-cont set-script-cont!)) - (define (make-script thunk) - (%make-script 'pending thunk)) - (define (script-pending? script) - (eq? (script-state script) 'pending)) - (define (script-running? script) - (eq? (script-state script) 'running)) - (define (script-cancelled? script) - (eq? (script-state script) 'cancelled)) - (define (script-cancel! script) - (set-script-state! script 'cancelled)) - (define (script-run! script) - (define (run thunk) - (unless (script-cancelled? script) - (call-with-prompt %script-tag thunk handler))) - (define (handler k delay) - (when delay - (scheduler-add! *scheduler* (lambda () (run k)) delay))) - (when (script-pending? script) - (run - (lambda () - (set-script-state! script 'running) - ((script-cont script)) - ;; Nasty hack: For some reason, falling through the prompt - ;; thunk messes up the Scheme stack, resulting in an invalid - ;; ref.cast somewhere. So, we *never* fall through. Instead, - ;; we create a continuation that gets thrown away. - (abort-to-prompt %script-tag #f))))) - (define (run-script thunk) - (let ((script (make-script thunk))) - (script-run! script) - script)) - (define (wait delay) - (abort-to-prompt %script-tag delay)) + ;; Screen size stuff + (define game-width 240.0) + (define game-height 320.0) - ;; Bullets: - (define-type bullet-pool - %make-bullet-pool - bullet-pool? - (length bullet-pool-length set-bullet-pool-length!) - (capacity bullet-pool-capacity set-bullet-pool-capacity!) - (bullets bullet-pool-bullets set-bullet-pool-bullets!)) - ;; per bullet: type, x, y, dx, dy - (define %bullet-size (+ 4 8 8 8 8)) - (define (make-bullet-pool capacity) - (let ((bullets (make-bytevector (* capacity %bullet-size)))) - (%make-bullet-pool 0 capacity bullets))) - (define (bullet-pool-offset i) - (* i %bullet-size)) - (define (bullet-pool-add! pool type x y dx dy) - (match pool - (#('bullet-pool length capacity bullets) - (let ((offset (bullet-pool-offset length))) - (s32-set! bullets offset type) - (f64-set! bullets (+ offset 4) x) - (f64-set! bullets (+ offset 12) y) - (f64-set! bullets (+ offset 20) dx) - (f64-set! bullets (+ offset 28) dy) - (set-bullet-pool-length! pool (+ length 1)))))) - (define (bullet-pool-remove! pool i) - (match pool - (#('bullet-pool length capacity bullets) - (when (and (>= i 0) (< i length)) - (let ((at (bullet-pool-offset i)) - (start (bullet-pool-offset (- length 1)))) - (bytevector-copy! bullets at bullets start (+ start %bullet-size)) - (set-bullet-pool-length! pool (- length 1))))))) - (define (bullet-pool-reset! pool) - (set-bullet-pool-length! pool 0)) - (define (bullet-pool-update! pool collide) - (match pool - (#('bullet-pool length capacity bullets) - (let loop ((i 0) (k length)) - (when (< i k) - (let* ((offset (bullet-pool-offset i)) - (x (f64-ref bullets (+ offset 4))) - (y (f64-ref bullets (+ offset 12))) - (dx (f64-ref bullets (+ offset 20))) - (dy (f64-ref bullets (+ offset 28))) - (x* (+ x dx)) - (y* (+ y dy))) - (cond - ;; TODO: different bullet hitbox sizes. - ((collide x y 2.0 2.0) - (bullet-pool-remove! pool i) - (loop i (- k 1))) - (else - (f64-set! bullets (+ offset 4) x*) - (f64-set! bullets (+ offset 12) y*) - (loop (+ i 1) k))))))))) - (define (draw-bullets pool image w h) - (match pool - (#('bullet-pool length capacity bullets) - (do ((i 0 (+ i 1))) - ((= i length)) - (let* ((offset (bullet-pool-offset i)) - (type (s32-ref bullets offset)) - (x (f64-ref bullets (+ offset 4))) - (y (f64-ref bullets (+ offset 12)))) - (draw-image context image (* type w) (* type h) w h - (- x (/ w 2.0)) (- y (/ w 2.0)) w h)))))) + ;; Elements + (define canvas (get-element-by-id "canvas")) + (define context (get-context canvas "2d")) + (define image:background (load-image "images/background.png")) + (define image:player (load-image "images/player.png")) + (define image:player-bullet (load-image "images/player-bullet.png")) + (define image:enemy-bullets (load-image "images/enemy-bullets.png")) + (define image:map (load-image "images/map.png")) + (define image:enemies (load-image "images/enemies.png")) + (define sound:explosion (load-sound-effect "audio/explosion.wav")) + (define sound:player-shoot (load-sound-effect "audio/player-shoot.wav")) + (define sound:player-death (load-sound-effect "audio/player-death.wav")) + (define sound:enemy-shoot (load-sound-effect "audio/enemy-shoot.wav")) + (define sound:bullet-hit (load-sound-effect "audio/bullet-hit.wav")) - (define player-bullets (make-bullet-pool 200)) - (define enemy-bullets (make-bullet-pool 400)) + ;; Scripting + (define (make-scheduler max-tasks) + (vector 0 0 max-tasks (make-vector max-tasks))) + (define (scheduler-add! scheduler thunk delay) + (match scheduler + (#(ticks num-tasks max-tasks tasks) + (unless (= num-tasks max-tasks) + (vector-set! tasks num-tasks (cons (+ ticks delay) thunk)) + (vector-set! scheduler 1 (+ num-tasks 1)))))) + (define (scheduler-tick! scheduler) + (define (run-thunks thunks) + (for-each (lambda (thunk) (thunk)) thunks)) + (run-thunks + (match scheduler + (#(ticks num-tasks max-tasks tasks) + (let ((t (+ ticks 1))) + (let loop ((i 0) (k num-tasks) (to-run '())) + (if (< i k) + (match (vector-ref tasks i) + ((t* . thunk) + (if (<= t* t) + (let ((k* (- k 1))) + (vector-set! tasks i (vector-ref tasks k*)) + (vector-set! tasks k* #f) + (loop i k* (cons thunk to-run))) + (loop (+ i 1) k to-run)))) + (begin + (vector-set! scheduler 0 t) + (vector-set! scheduler 1 k) + to-run)))))))) + (define (scheduler-reset! scheduler) + (match scheduler + (#(ticks num-tasks max-tasks tasks) + (vector-set! scheduler 0 0) + (vector-set! scheduler 1 0) + (do ((i 0 (+ i 1))) + ((= i num-tasks)) + (vector-set! tasks i #f))))) + (define *scheduler* (make-scheduler 100)) + (define %script-tag (make-prompt-tag "script")) + (define-type script + %make-script + script? + (state script-state set-script-state!) + (cont script-cont set-script-cont!)) + (define (make-script thunk) + (%make-script 'pending thunk)) + (define (script-pending? script) + (eq? (script-state script) 'pending)) + (define (script-running? script) + (eq? (script-state script) 'running)) + (define (script-cancelled? script) + (eq? (script-state script) 'cancelled)) + (define (script-cancel! script) + (set-script-state! script 'cancelled)) + (define (script-run! script) + (define (run thunk) + (unless (script-cancelled? script) + (call-with-prompt %script-tag thunk handler))) + (define (handler k delay) + (when delay + (scheduler-add! *scheduler* (lambda () (run k)) delay))) + (when (script-pending? script) + (run + (lambda () + (set-script-state! script 'running) + ((script-cont script)) + ;; Nasty hack: For some reason, falling through the prompt + ;; thunk messes up the Scheme stack, resulting in an invalid + ;; ref.cast somewhere. So, we *never* fall through. Instead, + ;; we create a continuation that gets thrown away. + (abort-to-prompt %script-tag #f))))) + (define (run-script thunk) + (let ((script (make-script thunk))) + (script-run! script) + script)) + (define (wait delay) + (abort-to-prompt %script-tag delay)) - ;; Scrolling level: - (define *scroll* 0.0) - (define *scroll-speed* 0.5) - (define *last-row-scanned* 0) - ;; action id, sprite sheet offset, x, y - (define %tile-size (+ 4 8 8 8)) - (define tile-width 16.0) - (define tile-height 16.0) - (define level-width 15) - (define-type level - %make-level - level? - (height level-height set-level-height!) - (tiles level-tiles set-level-tiles!)) - (define (make-level tiles) - (let ((k (length tiles))) - (unless (= (modulo k level-width) 0) - (error "incomplete level data")) - (let ((bv (make-bytevector (* k %tile-size)))) - (let y-loop ((tiles tiles) (y 0)) - (match tiles - (() #t) - (tiles - (y-loop - (let x-loop ((tiles tiles) (x 0)) - (if (< x level-width) - (match tiles - ((t . rest) - (let ((n (match t - ('X 0.0) - ('\ 1.0) - ('/ 2.0) - (_ -1.0))) - (action (match t - ('A 1) - (_ 0))) - (offset (* (+ x (* y level-width)) %tile-size))) - (s32-set! bv offset action) - (f64-set! bv (+ offset 4) n) - (f64-set! bv (+ offset 12) - (* (inexact x) tile-width)) - (f64-set! bv (+ offset 20) - (* (inexact y) tile-height))) - (x-loop rest (+ x 1)))) - tiles)) - (+ y 1))))) - (%make-level (/ k level-width) bv)))) - (define-syntax-rule (define-level name tile ...) - (define name (make-level '(tile ...)))) - (define-level level - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X X X _ _ _ _ _ _ _ _ _ X X X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X X X _ _ _ _ _ _ _ _ _ X X X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X X X _ _ _ _ _ _ _ _ _ X X X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X X X A _ _ _ _ _ _ _ _ X X X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X X X _ _ _ _ _ _ _ _ A X X X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X X X A _ _ _ _ _ _ _ _ X X X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X X X _ _ _ _ _ _ _ _ A X X X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X X X A _ _ _ _ _ _ _ _ X X X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X _ _ _ _ _ X X X _ _ _ _ _ X - X _ _ _ _ _ X X X _ _ _ _ _ X - X _ _ _ _ _ X X X _ _ _ _ _ X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X \ _ _ _ _ _ _ _ _ _ _ _ / X - X X \ _ _ _ _ _ _ _ _ _ / X X - X X X \ _ _ _ _ _ _ _ / X X X) - (define (level-offset x y) - (* (+ (* level-width y) x) %tile-size)) - (define (point-collides-with-level? level x y) - (match level - (#('level height tiles) - (let ((tx (trunc (/ x tile-width))) - (ty (trunc (/ y tile-height)))) - (and (>= tx 0) (< tx level-width) - (>= ty 0) (< tx height) - (>= (f64-ref tiles (level-offset tx ty)) 0)))))) - (define (rect-collides-with-level? level x y w h) - (match level - (#('level height tiles) - (let* ((y (+ y (- (* height tile-height) game-height *scroll*))) - (tx0 (trunc (/ x tile-width))) - (ty0 (trunc (/ y tile-height))) - (tx1 (trunc (/ (+ x w) tile-width))) - (ty1 (trunc (/ (+ y h) tile-height)))) - (define (occupied? x y) - (and (>= x 0) (< x level-width) - (>= y 0) (< x height) - (>= (f64-ref tiles (+ (level-offset x y) 4)) 0.0))) - (or (occupied? tx0 ty0) - (occupied? tx1 ty0) - (occupied? tx1 ty1) - (occupied? tx0 ty1)))))) - (define (draw-tiles level) - (match level - (#('level height tiles) - (let* ((tw tile-width) - (th tile-height) - (pixel-y-offset (- (* height th) *scroll* game-height)) - (scroll-y-offset (- height (trunc (/ *scroll* tile-height)))) - (y-start (clamp (- scroll-y-offset 21) 0 height)) - (y-end (clamp scroll-y-offset 0 height))) - (do ((y y-start (+ y 1))) - ((= y y-end)) - (do ((x 0 (+ x 1))) - ((= x level-width)) - (let* ((offset (level-offset x y)) - (t (f64-ref tiles (+ offset 4))) - (tx (f64-ref tiles (+ offset 12))) - (ty (f64-ref tiles (+ offset 20)))) - (draw-image context image:map - (* t tw) 0.0 tw th - tx (- ty pixel-y-offset) tw th)))))))) - (define max-scroll (- (* (level-height level) tile-height) game-height)) - (define (level-update! level) - (match level - (#('level height tiles) - (let ((scroll (min (+ *scroll* *scroll-speed*) max-scroll))) - (set! *scroll* scroll) - (let ((row (max (- (trunc - (/ (- (* height tile-height) - game-height scroll) - tile-height)) 2) - 0))) - (do ((y row (+ y 1))) - ((= y *last-row-scanned*)) - (do ((x 0 (+ x 1))) - ((= x level-width)) - (case (s32-ref tiles (level-offset x y)) - ((0) #t) - ((1) - (spawn-enemy-a (+ (* x tile-width) - (/ tile-width 2.0)) - (+ (* (- row y 3) tile-height) - (/ tile-height 2.0))))))) - (set! *last-row-scanned* row)))))) + ;; Bullets: + (define-type bullet-pool + %make-bullet-pool + bullet-pool? + (length bullet-pool-length set-bullet-pool-length!) + (capacity bullet-pool-capacity set-bullet-pool-capacity!) + (bullets bullet-pool-bullets set-bullet-pool-bullets!)) + ;; per bullet: type, x, y, dx, dy + (define %bullet-size (+ 4 8 8 8 8)) + (define (make-bullet-pool capacity) + (let ((bullets (make-bytevector (* capacity %bullet-size)))) + (%make-bullet-pool 0 capacity bullets))) + (define (bullet-pool-offset i) + (* i %bullet-size)) + (define (bullet-pool-add! pool type x y dx dy) + (match pool + (#('bullet-pool length capacity bullets) + (let ((offset (bullet-pool-offset length))) + (s32-set! bullets offset type) + (f64-set! bullets (+ offset 4) x) + (f64-set! bullets (+ offset 12) y) + (f64-set! bullets (+ offset 20) dx) + (f64-set! bullets (+ offset 28) dy) + (set-bullet-pool-length! pool (+ length 1)))))) + (define (bullet-pool-remove! pool i) + (match pool + (#('bullet-pool length capacity bullets) + (when (and (>= i 0) (< i length)) + (let ((at (bullet-pool-offset i)) + (start (bullet-pool-offset (- length 1)))) + (bytevector-copy! bullets at bullets start (+ start %bullet-size)) + (set-bullet-pool-length! pool (- length 1))))))) + (define (bullet-pool-reset! pool) + (set-bullet-pool-length! pool 0)) + (define (bullet-pool-update! pool collide) + (match pool + (#('bullet-pool length capacity bullets) + (let loop ((i 0) (k length)) + (when (< i k) + (let* ((offset (bullet-pool-offset i)) + (x (f64-ref bullets (+ offset 4))) + (y (f64-ref bullets (+ offset 12))) + (dx (f64-ref bullets (+ offset 20))) + (dy (f64-ref bullets (+ offset 28))) + (x* (+ x dx)) + (y* (+ y dy))) + (cond + ;; TODO: different bullet hitbox sizes. + ((collide x y 2.0 2.0) + (bullet-pool-remove! pool i) + (loop i (- k 1))) + (else + (f64-set! bullets (+ offset 4) x*) + (f64-set! bullets (+ offset 12) y*) + (loop (+ i 1) k))))))))) + (define (draw-bullets pool image w h) + (match pool + (#('bullet-pool length capacity bullets) + (do ((i 0 (+ i 1))) + ((= i length)) + (let* ((offset (bullet-pool-offset i)) + (type (s32-ref bullets offset)) + (x (f64-ref bullets (+ offset 4))) + (y (f64-ref bullets (+ offset 12)))) + (draw-image context image (* type w) (* type h) w h + (- x (/ w 2.0)) (- y (/ w 2.0)) w h)))))) - ;; Enemies - (define-type enemy - make-enemy - enemy? - (type enemy-type set-enemy-type!) - (health enemy-health set-enemy-health!) - (position enemy-position set-enemy-position!) - (size enemy-size set-enemy-size!) - (stationary? enemy-stationary? set-enemy-stationary!) - (velocity enemy-velocity set-enemy-velocity!) - (script enemy-script set-enemy-script!)) - (define (enemy-x enemy) - (vec2-x (enemy-position enemy))) - (define (enemy-y enemy) - (vec2-y (enemy-position enemy))) - (define (enemy-width enemy) - (vec2-x (enemy-size enemy))) - (define (enemy-height enemy) - (vec2-y (enemy-size enemy))) - (define (enemy-dx enemy) - (vec2-x (enemy-velocity enemy))) - (define (enemy-dy enemy) - (vec2-y (enemy-velocity enemy))) - (define (enemy-damage! enemy damage) - (match enemy - (#('enemy type health _ _ _ _ _) - (set-enemy-health! enemy (- health damage))))) - (define (enemy-dead? enemy) - (<= (enemy-health enemy) 0)) - (define (enemy-out-of-bounds? enemy) - (match enemy - (#('enemy _ _ position size _ _ _) - (out-of-bounds? (vec2-x position) (vec2-y position) - (vec2-x size) (vec2-y size))))) - (define (enemy-within-rect? enemy x y w h) - (match enemy - (#('enemy _ _ position size _ _ _) - (let* ((w* (vec2-x size)) - (h* (vec2-y size)) - (x* (- (vec2-x position) (/ w* 2.0))) - (y* (- (vec2-y position) (/ h* 2.0)))) - (rect-within? x y w h x* y* w* h*))))) - (define (enemy-start! enemy) - (let ((proc (enemy-script enemy))) - (when (procedure? proc) - (set-enemy-script! enemy (run-script (lambda () (proc enemy))))))) - (define (enemy-stop! enemy) - (let ((script (enemy-script enemy))) - (when (script? script) - (script-cancel! script)))) - (define (enemy-update! enemy) - (match enemy - (#('enemy _ _ position size stationary? velocity _) - (if stationary? - (set-vec2-y! position (+ (vec2-y position) *scroll-speed*)) - (begin - (set-vec2-x! position (+ (vec2-x position) (vec2-x velocity))) - (set-vec2-y! position (+ (vec2-y position) (vec2-y velocity)))))))) - (define (enemy-draw enemy) - (match enemy - (#('enemy type _ position size _ _ _) - (let* ((t 0.0) - (x (vec2-x position)) - (y (vec2-y position)) - (hbw (vec2-x size)) - (hbh (vec2-y size)) - (w 64.0) - (h 64.0)) - (draw-image context image:enemies (* t w) (* t h) w h - (- x (/ w 2.0)) (- y (/ h 2.0)) w h) - (set-fill-color! context "#ff00ff80") - (fill-rect context - (- x (/ hbw 2.0)) - (- y (/ hbh 2.0)) - hbw hbh))))) + (define player-bullets (make-bullet-pool 200)) + (define enemy-bullets (make-bullet-pool 400)) - (define-type enemy-pool - %make-enemy-pool - enemy-pool? - (length enemy-pool-length set-enemy-pool-length!) - (capacity enemy-pool-capacity set-enemy-pool-capacity!) - (enemies enemy-pool-enemies set-enemy-pool-enemies!)) - (define (make-enemy-pool capacity) - (%make-enemy-pool 0 capacity (make-vector capacity #f))) - (define (enemy-pool-add! pool enemy) - (match pool - (#('enemy-pool length capacity enemies) - (unless (= length capacity) - (vector-set! enemies length enemy) - (set-enemy-pool-length! pool (+ length 1)) - (enemy-start! enemy))))) - (define (enemy-pool-remove! pool i) - (match pool - (#('enemy-pool length capacity enemies) - (when (and (>= i 0) (< i length)) - (let ((j (- length 1)) - (enemy (vector-ref enemies i))) - (vector-set! enemies i (vector-ref enemies j)) - (vector-set! enemies j #f) - (enemy-stop! enemy) - (set-enemy-pool-length! pool j)))))) - (define (enemy-pool-reset! pool) - (match pool - (#('enemy-pool length capacity enemies) - (do ((i 0 (+ i 1))) - ((= i length)) - (enemy-stop! (vector-ref enemies i)) - (vector-set! enemies i #f)) - (set-enemy-pool-length! pool 0)))) - (define (enemy-pool-update! pool) - (match pool - (#('enemy-pool length capacity enemies) - (let ((padding 16.0)) - (let loop ((i 0) (k length)) - (unless (= i k) - (let ((enemy (vector-ref enemies i))) - (enemy-update! enemy) - (cond - ((or (enemy-dead? enemy) - (enemy-out-of-bounds? enemy)) - (sound-effect-play sound:explosion) - (enemy-pool-remove! pool i) - (loop i (- k 1))) - (else - (loop (+ i 1) k)))))))))) - (define (draw-enemies pool) - (match pool - (#('enemy-pool length capacity enemies) - (do ((i 0 (+ i 1))) - ((= i length)) - (enemy-draw (vector-ref enemies i)))))) - (define (find-enemy pool x y w h) - (match pool - (#('enemy-pool length capacity enemies) - (let loop ((i 0)) - (and (< i length) - (let ((enemy (vector-ref enemies i))) - (if (enemy-within-rect? enemy x y w h) - enemy - (loop (+ i 1))))))))) + ;; Scrolling level: + (define *scroll* 0.0) + (define *scroll-speed* 0.5) + (define *last-row-scanned* 0) + ;; action id, sprite sheet offset, x, y + (define %tile-size (+ 4 8 8 8)) + (define tile-width 16.0) + (define tile-height 16.0) + (define level-width 15) + (define-type level-object + make-level-object + level-object? + (x level-object-x set-level-object-x!) + (type level-object-type set-level-object-type!)) + (define-type level + make-level + level? + (height level-height set-level-height!) + (foreground level-foreground set-level-foreground!) + (background level-background set-level-background!) + (collision level-collision set-level-collision!) + (objects level-objects set-level-objects!)) + (define level ,(call-with-input-file "level.scm" read)) + (define (level-offset x y) + (* (+ (* level-width y) x))) + (define (point-collides-with-level? level x y) + (match level + (#('level height foreground background collision objects) + (let ((tx (trunc (/ x tile-width))) + (ty (trunc (/ y tile-height)))) + (and (>= tx 0) (< tx level-width) + (>= ty 0) (< tx height) + (= (bytevector-u8-ref collision (level-offset tx ty)) 1)))))) + (define (rect-collides-with-level? level x y w h) + (match level + (#('level height foreground background collision objects) + (let* ((y (+ y (- (* height tile-height) game-height *scroll*))) + (tx0 (trunc (/ x tile-width))) + (ty0 (trunc (/ y tile-height))) + (tx1 (trunc (/ (+ x w) tile-width))) + (ty1 (trunc (/ (+ y h) tile-height)))) + (define (occupied? x y) + (and (>= x 0) (< x level-width) + (>= y 0) (< x height) + (= (bytevector-u8-ref collision (level-offset x y)) 1))) + (or (occupied? tx0 ty0) + (occupied? tx1 ty0) + (occupied? tx1 ty1) + (occupied? tx0 ty1)))))) + (define (draw-level-layer level layer parallax) + (match level + (#('level height _ _ _ _) + (let* ((tw tile-width) + (th tile-height) + (scroll (* *scroll* parallax)) + (pixel-y-offset (- (* height th) scroll game-height)) + (scroll-y-offset (- height (trunc (/ scroll tile-height)))) + (y-start (clamp (- scroll-y-offset 21) 0 height)) + (y-end (clamp scroll-y-offset 0 height))) + (do ((y y-start (+ y 1))) + ((= y y-end)) + (let* ((row (vector-ref layer y)) + (k (/ (bytevector-length row) 16)) + (ty (* y tile-height))) + (do ((x 0 (+ x 1))) + ((= x k)) + (let* ((offset (* x 16)) + (tx (f64-ref row offset)) + (ix (f64-ref row (+ offset 8)))) + (draw-image context image:map + ix 0.0 tw th + tx (- ty pixel-y-offset) tw th))))))))) + (define (draw-level-foreground level) + (match level + (#('level height foreground background collision objects) + (draw-level-layer level foreground 1.0)))) + (define (draw-level-background level) + (match level + (#('level height foreground background collision objects) + (draw-level-layer level background 0.75)))) + (define max-scroll (- (* (level-height level) tile-height) game-height)) + (define (level-update! level) + (match level + (#('level height foreground background collision objects) + (let ((scroll (min (+ *scroll* *scroll-speed*) max-scroll))) + (set! *scroll* scroll) + (let ((row (max (- (trunc + (/ (- (* height tile-height) + game-height scroll) + tile-height)) 2) + 0))) + (do ((y row (+ y 1))) + ((= y *last-row-scanned*)) + (for-each (lambda (obj) + (match obj + (#('level-object x type) + (match type + ('enemy-a + (spawn-enemy-a (+ (* x tile-width) + (/ tile-width 2.0)) + (+ (* (- y row 3) tile-height) + (/ tile-height 2.0)))) + (_ #t))))) + (vector-ref objects y))) + (set! *last-row-scanned* row)))))) - (define enemies (make-enemy-pool 64)) + ;; Enemies + (define-type enemy + make-enemy + enemy? + (type enemy-type set-enemy-type!) + (health enemy-health set-enemy-health!) + (position enemy-position set-enemy-position!) + (size enemy-size set-enemy-size!) + (stationary? enemy-stationary? set-enemy-stationary!) + (velocity enemy-velocity set-enemy-velocity!) + (script enemy-script set-enemy-script!)) + (define (enemy-x enemy) + (vec2-x (enemy-position enemy))) + (define (enemy-y enemy) + (vec2-y (enemy-position enemy))) + (define (enemy-width enemy) + (vec2-x (enemy-size enemy))) + (define (enemy-height enemy) + (vec2-y (enemy-size enemy))) + (define (enemy-dx enemy) + (vec2-x (enemy-velocity enemy))) + (define (enemy-dy enemy) + (vec2-y (enemy-velocity enemy))) + (define (enemy-damage! enemy damage) + (match enemy + (#('enemy type health _ _ _ _ _) + (set-enemy-health! enemy (- health damage))))) + (define (enemy-dead? enemy) + (<= (enemy-health enemy) 0)) + (define (enemy-out-of-bounds? enemy) + (match enemy + (#('enemy _ _ position size _ _ _) + (out-of-bounds? (vec2-x position) (vec2-y position) + (vec2-x size) (vec2-y size))))) + (define (enemy-within-rect? enemy x y w h) + (match enemy + (#('enemy _ _ position size _ _ _) + (let* ((w* (vec2-x size)) + (h* (vec2-y size)) + (x* (- (vec2-x position) (/ w* 2.0))) + (y* (- (vec2-y position) (/ h* 2.0)))) + (rect-within? x y w h x* y* w* h*))))) + (define (enemy-start! enemy) + (let ((proc (enemy-script enemy))) + (when (procedure? proc) + (set-enemy-script! enemy (run-script (lambda () (proc enemy))))))) + (define (enemy-stop! enemy) + (let ((script (enemy-script enemy))) + (when (script? script) + (script-cancel! script)))) + (define (enemy-update! enemy) + (match enemy + (#('enemy _ _ position size stationary? velocity _) + (if stationary? + (set-vec2-y! position (+ (vec2-y position) *scroll-speed*)) + (begin + (set-vec2-x! position (+ (vec2-x position) (vec2-x velocity))) + (set-vec2-y! position (+ (vec2-y position) (vec2-y velocity)))))))) + (define (enemy-draw enemy) + (match enemy + (#('enemy type _ position size _ _ _) + (let* ((t 0.0) + (x (vec2-x position)) + (y (vec2-y position)) + (hbw (vec2-x size)) + (hbh (vec2-y size)) + (w 64.0) + (h 64.0)) + (draw-image context image:enemies (* t w) (* t h) w h + (- x (/ w 2.0)) (- y (/ h 2.0)) w h) + (set-fill-color! context "#ff00ff80") + (fill-rect context + (- x (/ hbw 2.0)) + (- y (/ hbh 2.0)) + hbw hbh))))) + + (define-type enemy-pool + %make-enemy-pool + enemy-pool? + (length enemy-pool-length set-enemy-pool-length!) + (capacity enemy-pool-capacity set-enemy-pool-capacity!) + (enemies enemy-pool-enemies set-enemy-pool-enemies!)) + (define (make-enemy-pool capacity) + (%make-enemy-pool 0 capacity (make-vector capacity #f))) + (define (enemy-pool-add! pool enemy) + (match pool + (#('enemy-pool length capacity enemies) + (unless (= length capacity) + (vector-set! enemies length enemy) + (set-enemy-pool-length! pool (+ length 1)) + (enemy-start! enemy))))) + (define (enemy-pool-remove! pool i) + (match pool + (#('enemy-pool length capacity enemies) + (when (and (>= i 0) (< i length)) + (let ((j (- length 1)) + (enemy (vector-ref enemies i))) + (vector-set! enemies i (vector-ref enemies j)) + (vector-set! enemies j #f) + (enemy-stop! enemy) + (set-enemy-pool-length! pool j)))))) + (define (enemy-pool-reset! pool) + (match pool + (#('enemy-pool length capacity enemies) + (do ((i 0 (+ i 1))) + ((= i length)) + (enemy-stop! (vector-ref enemies i)) + (vector-set! enemies i #f)) + (set-enemy-pool-length! pool 0)))) + (define (enemy-pool-update! pool) + (match pool + (#('enemy-pool length capacity enemies) + (let ((padding 16.0)) + (let loop ((i 0) (k length)) + (unless (= i k) + (let ((enemy (vector-ref enemies i))) + (enemy-update! enemy) + (cond + ((or (enemy-dead? enemy) + (enemy-out-of-bounds? enemy)) + (sound-effect-play sound:explosion) + (enemy-pool-remove! pool i) + (loop i (- k 1))) + (else + (loop (+ i 1) k)))))))))) + (define (draw-enemies pool) + (match pool + (#('enemy-pool length capacity enemies) + (do ((i 0 (+ i 1))) + ((= i length)) + (enemy-draw (vector-ref enemies i)))))) + (define (find-enemy pool x y w h) + (match pool + (#('enemy-pool length capacity enemies) + (let loop ((i 0)) + (and (< i length) + (let ((enemy (vector-ref enemies i))) + (if (enemy-within-rect? enemy x y w h) + enemy + (loop (+ i 1))))))))) - (define (spawn-enemy-a x y) - (define (script enemy) - (let ((speed 2.0)) - (let loop ((theta 0.0)) - (let ((dx (* (cos theta) speed)) - (dy (* (sin theta) speed)) - (v (direction-to-player (enemy-position enemy)))) - (bullet-pool-add! enemy-bullets 0 - (enemy-x enemy) - (enemy-y enemy) - (* (vec2-x v) speed) - (* (vec2-y v) speed))) - (wait 30) - (loop (+ theta 0.2))))) - (let ((enemy (make-enemy 'foo 20 (vec2 x y) (vec2 16.0 16.0) - #t (vec2 0.0 0.0) script))) - (enemy-pool-add! enemies enemy))) + (define enemies (make-enemy-pool 64)) - ;; Player state: - (define player-position (vec2 (/ game-width 2.0) (- game-height 12.0))) - (define player-velocity (vec2 0.0 0.0)) - (define player-speed 2.9) - (define player-bullet-speed 12.0) - (define player-width 24.0) - (define player-height 24.0) - (define *player-fire-counter* 0) - (define player-fire-interval 3) - (define player-hitbox-position (vec2 0.0 0.0)) - (define player-hitbox-width 2.0) - (define player-hitbox-height 2.0) - (define %default-lives 3) - (define *player-lives* %default-lives) - (define *player-visible?* #t) - (define *player-invincible?* #f) - ;; left, right, down, up, fire - (define key-state (vector #f #f #f #f #f)) - (define (update-player-velocity!) - (match key-state - (#(left? right? down? up? _) - (set-vec2-x! player-velocity - (+ (if left? -1.0 0.0) - (if right? 1.0 0.0))) - (set-vec2-y! player-velocity - (+ (if down? 1.0 0.0) - (if up? -1.0 0.0))) - (vec2-normalize! player-velocity) - (vec2-mul-scalar! player-velocity player-speed)))) - (define (set-left! pressed?) - (vector-set! key-state 0 pressed?) - (update-player-velocity!)) - (define (set-right! pressed?) - (vector-set! key-state 1 pressed?) - (update-player-velocity!)) - (define (set-down! pressed?) - (vector-set! key-state 2 pressed?) - (update-player-velocity!)) - (define (set-up! pressed?) - (vector-set! key-state 3 pressed?) - (update-player-velocity!)) - (define (set-firing! pressed?) - (let ((was-firing? (firing?))) - (vector-set! key-state 4 pressed?) - (when (and pressed? (not was-firing?)) - (set! *player-fire-counter* 0)))) - (define (firing?) - (vector-ref key-state 4)) - (define (player-die!) - (unless *player-invincible?* - ;; (sound-effect-play sound:player-death) - (set! *player-lives* (max (- *player-lives* 1) 0)) - (run-script - (lambda () - (set! *player-invincible?* #t) - (let ((t 5)) - (let loop ((i 0)) - (when (< i 10) - (set! *player-visible?* #f) - (wait t) - (set! *player-visible?* #t) - (wait t) - (loop (+ i 1))))) - (set! *player-invincible?* #f))))) - (define (game-over?) - (= *player-lives* 0)) - (define (player-update!) - (vec2-add! player-position player-velocity) - (vec2-clamp! player-position 0.0 0.0 game-width game-height) - (set-vec2-x! player-hitbox-position - (- (vec2-x player-position) - (/ player-hitbox-width 2.0))) - (set-vec2-y! player-hitbox-position - (- (vec2-y player-position) - (/ player-hitbox-height 2.0))) - (when (and (let ((x (vec2-x player-hitbox-position)) - (y (vec2-y player-hitbox-position)) - (w player-hitbox-width) - (h player-hitbox-height)) - (or (rect-collides-with-level? level x y w h) - (find-enemy enemies x y w h)))) - (player-die!)) - (when (firing?) - (set! *player-fire-counter* - (modulo (+ *player-fire-counter* 1) player-fire-interval)) - (when (= *player-fire-counter* 0) - (sound-effect-play sound:player-shoot 0.5) - (bullet-pool-add! player-bullets 0 - (- (vec2-x player-position) 6.0) - (vec2-y player-position) - 0.0 (- player-bullet-speed)) - (bullet-pool-add! player-bullets 0 - (+ (vec2-x player-position) 8.0) - (vec2-y player-position) - 0.0 (- player-bullet-speed)) - (set! *player-fire-counter* 0)))) - (define (draw-player) - (draw-image context image:player - (if *player-visible?* 0.0 player-width) 0.0 - player-width player-height - (- (vec2-x player-position) - (/ player-width 2.0)) - (- (vec2-y player-position) - (/ player-height 2.0)) - player-width player-height) - (set-fill-color! context "#ff00ff80") - (fill-rect context - (vec2-x player-hitbox-position) - (vec2-y player-hitbox-position) - player-hitbox-width - player-hitbox-height)) - (define (direction-to-player v) - (let ((v* (vec2 (vec2-x player-position) (vec2-y player-position)))) - (vec2-sub! v* v) - (vec2-normalize! v*) - v*)) + (define (spawn-enemy-a x y) + (define (script enemy) + (let ((speed 2.0)) + (let loop ((theta 0.0)) + (let ((dx (* (cos theta) speed)) + (dy (* (sin theta) speed)) + (v (direction-to-player (enemy-position enemy)))) + (bullet-pool-add! enemy-bullets 0 + (enemy-x enemy) + (enemy-y enemy) + (* (vec2-x v) speed) + (* (vec2-y v) speed))) + (wait 30) + (loop (+ theta 0.2))))) + (let ((enemy (make-enemy 'foo 20 (vec2 x y) (vec2 16.0 16.0) + #t (vec2 0.0 0.0) script))) + (enemy-pool-add! enemies enemy))) - (define *canvas-scale* 0.0) - (define *canvas-width* 0) - (define *canvas-height* 0) + ;; Player state: + (define player-position (vec2 (/ game-width 2.0) (- game-height 12.0))) + (define player-velocity (vec2 0.0 0.0)) + (define player-speed 2.9) + (define player-bullet-speed 12.0) + (define player-width 24.0) + (define player-height 24.0) + (define *player-fire-counter* 0) + (define player-fire-interval 3) + (define player-hitbox-position (vec2 0.0 0.0)) + (define player-hitbox-width 2.0) + (define player-hitbox-height 2.0) + (define %default-lives 3) + (define *player-lives* %default-lives) + (define *player-visible?* #t) + (define *player-invincible?* #f) + ;; left, right, down, up, fire + (define key-state (vector #f #f #f #f #f)) + (define (update-player-velocity!) + (match key-state + (#(left? right? down? up? _) + (set-vec2-x! player-velocity + (+ (if left? -1.0 0.0) + (if right? 1.0 0.0))) + (set-vec2-y! player-velocity + (+ (if down? 1.0 0.0) + (if up? -1.0 0.0))) + (vec2-normalize! player-velocity) + (vec2-mul-scalar! player-velocity player-speed)))) + (define (set-left! pressed?) + (vector-set! key-state 0 pressed?) + (update-player-velocity!)) + (define (set-right! pressed?) + (vector-set! key-state 1 pressed?) + (update-player-velocity!)) + (define (set-down! pressed?) + (vector-set! key-state 2 pressed?) + (update-player-velocity!)) + (define (set-up! pressed?) + (vector-set! key-state 3 pressed?) + (update-player-velocity!)) + (define (set-firing! pressed?) + (let ((was-firing? (firing?))) + (vector-set! key-state 4 pressed?) + (when (and pressed? (not was-firing?)) + (set! *player-fire-counter* 0)))) + (define (firing?) + (vector-ref key-state 4)) + (define (player-die!) + (unless *player-invincible?* + ;; (sound-effect-play sound:player-death) + (set! *player-lives* (max (- *player-lives* 1) 0)) + (run-script + (lambda () + (set! *player-invincible?* #t) + (let ((t 5)) + (let loop ((i 0)) + (when (< i 10) + (set! *player-visible?* #f) + (wait t) + (set! *player-visible?* #t) + (wait t) + (loop (+ i 1))))) + (set! *player-invincible?* #f))))) + (define (game-over?) + (= *player-lives* 0)) + (define (player-update!) + (vec2-add! player-position player-velocity) + (vec2-clamp! player-position 0.0 0.0 game-width game-height) + (set-vec2-x! player-hitbox-position + (- (vec2-x player-position) + (/ player-hitbox-width 2.0))) + (set-vec2-y! player-hitbox-position + (- (vec2-y player-position) + (/ player-hitbox-height 2.0))) + (when (and (let ((x (vec2-x player-hitbox-position)) + (y (vec2-y player-hitbox-position)) + (w player-hitbox-width) + (h player-hitbox-height)) + (or (rect-collides-with-level? level x y w h) + (find-enemy enemies x y w h)))) + (player-die!)) + (when (firing?) + (set! *player-fire-counter* + (modulo (+ *player-fire-counter* 1) player-fire-interval)) + (when (= *player-fire-counter* 0) + (sound-effect-play sound:player-shoot 0.2) + (bullet-pool-add! player-bullets 0 + (- (vec2-x player-position) 6.0) + (vec2-y player-position) + 0.0 (- player-bullet-speed)) + (bullet-pool-add! player-bullets 0 + (+ (vec2-x player-position) 8.0) + (vec2-y player-position) + 0.0 (- player-bullet-speed)) + (set! *player-fire-counter* 0)))) + (define (draw-player) + (draw-image context image:player + (if *player-visible?* 0.0 player-width) 0.0 + player-width player-height + (- (vec2-x player-position) + (/ player-width 2.0)) + (- (vec2-y player-position) + (/ player-height 2.0)) + player-width player-height) + (set-fill-color! context "#ff00ff80") + (fill-rect context + (vec2-x player-hitbox-position) + (vec2-y player-hitbox-position) + player-hitbox-width + player-hitbox-height)) + (define (direction-to-player v) + (let ((v* (vec2 (vec2-x player-position) (vec2-y player-position)))) + (vec2-sub! v* v) + (vec2-normalize! v*) + v*)) - (define (resize-canvas) - (let* ((win (current-window)) - (w (window-inner-width win)) - (h (window-inner-height win)) - (gw (trunc game-width)) - (gh (trunc game-height)) - (scale (max (min (quotient w gw) (quotient h gh)) 1)) - (cw (* gw scale)) - (ch (* gh scale))) - (set-element-width! canvas cw) - (set-element-height! canvas ch) - (set-image-smoothing-enabled! context 0) - (set! *canvas-scale* (inexact scale)) - (set! *canvas-width* (* game-width *canvas-scale*)) - (set! *canvas-height* (* game-height *canvas-scale*)))) + ;; Canvas sizing/scaling. + (define *canvas-scale* 0.0) + (define *canvas-width* 0) + (define *canvas-height* 0) + (define (resize-canvas) + (let* ((win (current-window)) + (w (window-inner-width win)) + (h (window-inner-height win)) + (gw (trunc game-width)) + (gh (trunc game-height)) + (scale (max (min (quotient w gw) (quotient h gh)) 1)) + (cw (* gw scale)) + (ch (* gh scale))) + (set-element-width! canvas cw) + (set-element-height! canvas ch) + (set-image-smoothing-enabled! context 0) + (set! *canvas-scale* (inexact scale)) + (set! *canvas-width* (* game-width *canvas-scale*)) + (set! *canvas-height* (* game-height *canvas-scale*)))) - (define (clear-screen) - (clear-rect context 0.0 0.0 *canvas-width* *canvas-height*)) + (define (clear-screen) + (clear-rect context 0.0 0.0 *canvas-width* *canvas-height*)) - (define (draw-player-bullets) - (draw-bullets player-bullets image:player-bullet 8.0 8.0)) + (define (draw-player-bullets) + (draw-bullets player-bullets image:player-bullet 8.0 8.0)) - (define (draw-enemy-bullets) - (draw-bullets enemy-bullets image:enemy-bullets 16.0 16.0)) + (define (draw-enemy-bullets) + (draw-bullets enemy-bullets image:enemy-bullets 16.0 16.0)) - (define (draw-background image parallax) - (let ((scroll (remainder (* *scroll* parallax) game-height))) - ;; Bottom - (draw-image context image - 0.0 0.0 game-width (- game-height scroll) - 0.0 scroll game-width (- game-height scroll)) - ;; Top - (draw-image context image - 0.0 (- game-height scroll) game-width scroll - 0.0 0.0 game-width scroll))) + (define (draw-background image parallax) + (let ((scroll (remainder (* *scroll* parallax) game-height))) + ;; Bottom + (draw-image context image + 0.0 0.0 game-width (- game-height scroll) + 0.0 scroll game-width (- game-height scroll)) + ;; Top + (draw-image context image + 0.0 (- game-height scroll) game-width scroll + 0.0 0.0 game-width scroll))) - (define (draw-hud) - (let ((y (- game-height 8.0))) - ;; TODO: Don't strings every frame when the UI values rarely - ;; change. - (set-fill-color! context "#ffffff") - (set-font! context "bold 8px monospace") - (fill-text context (string-append "x" (number->string *player-lives*)) - (- game-width 16.0) y) - ;; TODO: Add scoring. - (fill-text context (string-append "score " (number->string 0)) - 4.0 y))) + (define (draw-hud) + (let ((y (- game-height 8.0))) + ;; TODO: Don't strings every frame when the UI values rarely + ;; change. + (set-fill-color! context "#ffffff") + (set-font! context "bold 8px monospace") + (set-text-align! context "right") + (fill-text context (string-append "x" (number->string *player-lives*)) + (- game-width 4.0) y) + ;; TODO: Add scoring. + (set-text-align! context "left") + (fill-text context (string-append "score " (number->string 0)) + 4.0 y))) - (define (draw time) - (clear-screen) - (set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0) - (set-scale! context *canvas-scale* *canvas-scale*) - (set-fill-color! context "#3f2832") - (fill-rect context 0.0 0.0 game-width game-height) - (draw-background image:background 0.75) - (draw-tiles level) - (draw-player-bullets) - (draw-enemies enemies) - (draw-player) - (draw-enemy-bullets) - (draw-hud) - (request-animation-frame draw)) + (define (draw time) + (clear-screen) + (set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0) + (set-scale! context *canvas-scale* *canvas-scale*) + (set-fill-color! context "#3f2832") + (fill-rect context 0.0 0.0 game-width game-height) + ;; (draw-level-background level) + (draw-background image:background 0.75) + (draw-level-foreground level) + (draw-player-bullets) + (draw-enemies enemies) + (draw-player) + (draw-enemy-bullets) + (draw-hud) + (match *game-state* + ('game-over + (set-fill-color! context "#ffffff") + (set-font! context "bold 24px monospace") + (set-text-align! context "center") + (fill-text context "GAME OVER" (/ game-width 2.0) (/ game-height 2.0))) + (_ #t)) + (request-animation-frame draw)) - (define (reset!) - (scheduler-reset! *scheduler*) - (set! *scroll* 0.0) - (set! *last-row-scanned* (level-height level)) - (bullet-pool-reset! player-bullets) - (bullet-pool-reset! enemy-bullets) - (enemy-pool-reset! enemies) - (set-vec2-x! player-position (/ game-width 2.0)) - (set-vec2-y! player-position (- game-height 12.0)) - (set! *player-lives* %default-lives) - (set! *player-invincible?* #f) - (set! *player-visible?* #t) - (set! *player-fire-counter* 0)) + (define (reset!) + (set! *game-state* 'play) + (scheduler-reset! *scheduler*) + (set! *scroll* 0.0) + (set! *last-row-scanned* (level-height level)) + (bullet-pool-reset! player-bullets) + (bullet-pool-reset! enemy-bullets) + (enemy-pool-reset! enemies) + (set-vec2-x! player-position (/ game-width 2.0)) + (set-vec2-y! player-position (- game-height 12.0)) + (set! *player-lives* %default-lives) + (set! *player-invincible?* #f) + (set! *player-visible?* #t) + (set! *player-fire-counter* 0)) - (define (on-key-down event) - (let ((code (keyboard-event-code event))) - (cond - ((string-=? code "ArrowLeft") - (set-left! #t) - (prevent-default! event)) - ((string-=? code "ArrowRight") - (set-right! #t) - (prevent-default! event)) - ((string-=? code "ArrowDown") - (set-down! #t) - (prevent-default! event)) - ((string-=? code "ArrowUp") - (set-up! #t) - (prevent-default! event)) - ((string-=? code "KeyZ") - (set-firing! #t) - (prevent-default! event)) - ((string-=? code "KeyR") - (reset!) - (prevent-default! event))))) + (define (on-key-down event) + (let ((code (keyboard-event-code event))) + (cond + ((string-=? code "ArrowLeft") + (set-left! #t) + (prevent-default! event)) + ((string-=? code "ArrowRight") + (set-right! #t) + (prevent-default! event)) + ((string-=? code "ArrowDown") + (set-down! #t) + (prevent-default! event)) + ((string-=? code "ArrowUp") + (set-up! #t) + (prevent-default! event)) + ((string-=? code "KeyZ") + (set-firing! #t) + (prevent-default! event)) + ((string-=? code "KeyR") + (reset!) + (prevent-default! event))) + (match *game-state* + ('game-over + (cond + ((string-=? code "Enter") + (reset!) + (prevent-default! event)))) + (_ #t)))) - (define (on-key-up event) - (let ((code (keyboard-event-code event))) - (cond - ((string-=? code "ArrowLeft") - (set-left! #f) - (prevent-default! event)) - ((string-=? code "ArrowRight") - (set-right! #f) - (prevent-default! event)) - ((string-=? code "ArrowDown") - (set-down! #f) - (prevent-default! event)) - ((string-=? code "ArrowUp") - (set-up! #f) - (prevent-default! event)) - ((string-=? code "KeyZ") - (set-firing! #f) - (prevent-default! event))))) + (define (on-key-up event) + (let ((code (keyboard-event-code event))) + (cond + ((string-=? code "ArrowLeft") + (set-left! #f) + (prevent-default! event)) + ((string-=? code "ArrowRight") + (set-right! #f) + (prevent-default! event)) + ((string-=? code "ArrowDown") + (set-down! #f) + (prevent-default! event)) + ((string-=? code "ArrowUp") + (set-up! #f) + (prevent-default! event)) + ((string-=? code "KeyZ") + (set-firing! #f) + (prevent-default! event))))) - (define (out-of-bounds? x y w h) - (let ((padding 32.0)) - (not (rect-within? x y w h (- padding) (- padding) - (+ game-width padding) (+ game-height padding))))) + (define (out-of-bounds? x y w h) + (let ((padding 32.0)) + (not (rect-within? x y w h (- padding) (- padding) + (+ game-width padding) (+ game-height padding))))) - (define (player-bullet-collide x y w h) - (let ((x* (- x (/ w 2.0))) - (y* (- y(/ h 2.0)))) - (or (out-of-bounds? x* y* w h) - (rect-collides-with-level? level x* y* w h) - (let ((enemy (find-enemy enemies x y w h))) - (and enemy + (define (player-bullet-collide x y w h) + (let ((x* (- x (/ w 2.0))) + (y* (- y(/ h 2.0)))) + (or (out-of-bounds? x* y* w h) + (rect-collides-with-level? level x* y* w h) + (let ((enemy (find-enemy enemies x y w h))) + (and enemy + (begin + (enemy-damage! enemy 1) + #t)))))) + + (define (enemy-bullet-collide x y w h) + (let ((x* (- x (/ w 2.0))) + (y* (- y(/ h 2.0)))) + (or (out-of-bounds? x* y* w h) + (rect-collides-with-level? level x* y* w h) + ;; (if (rect-collides-with-level? level x* y* w h) + ;; (begin + ;; (sound-effect-play sound:bullet-hit 0.1) + ;; #t) + ;; #f) + (if (rect-within? x y w h + (vec2-x player-hitbox-position) + (vec2-y player-hitbox-position) + player-hitbox-width + player-hitbox-height) (begin - (enemy-damage! enemy 1) - #t)))))) + (player-die!) + #t) + #f)))) - (define (enemy-bullet-collide x y w h) - (let ((x* (- x (/ w 2.0))) - (y* (- y(/ h 2.0)))) - (or (out-of-bounds? x* y* w h) - (rect-collides-with-level? level x* y* w h) - ;; (if (rect-collides-with-level? level x* y* w h) - ;; (begin - ;; (sound-effect-play sound:bullet-hit 0.1) - ;; #t) - ;; #f) - (if (rect-within? x y w h - (vec2-x player-hitbox-position) - (vec2-y player-hitbox-position) - player-hitbox-width - player-hitbox-height) - (begin - (player-die!) - #t) - #f)))) + (define dt (/ 1000.0 60.0)) + (define (update) + (match *game-state* + ('play + (scheduler-tick! *scheduler*) + (level-update! level) + (player-update!) + (bullet-pool-update! player-bullets player-bullet-collide) + (bullet-pool-update! enemy-bullets enemy-bullet-collide) + (enemy-pool-update! enemies) + (when (game-over?) + (set! *game-state* 'game-over))) + (_ #t)) + (timeout update dt)) - (define dt (/ 1000.0 60.0)) - (define (update) - (scheduler-tick! *scheduler*) - (level-update! level) - (player-update!) - (bullet-pool-update! player-bullets player-bullet-collide) - (bullet-pool-update! enemy-bullets enemy-bullet-collide) - (enemy-pool-update! enemies) - (timeout update dt)) + (add-event-listener! (current-window) "resize" (lambda (_) (resize-canvas))) + (add-event-listener! (current-document) "keydown" on-key-down) + (add-event-listener! (current-document) "keyup" on-key-up) + (resize-canvas) + (reset!) + (request-animation-frame draw) + (timeout update dt))) - (add-event-listener! (current-window) "resize" (lambda (_) (resize-canvas))) - (add-event-listener! (current-document) "keydown" on-key-down) - (add-event-listener! (current-document) "keyup" on-key-up) - (resize-canvas) - (reset!) - (request-animation-frame draw) - (timeout update dt)) +(call-with-output-file "game.wasm" + (lambda (port) + (put-bytevector port (assemble-wasm (compile src))))) diff --git a/images/map.ase b/images/map.ase Binary files differindex 4177dd5..81fed57 100644 --- a/images/map.ase +++ b/images/map.ase diff --git a/images/map.png b/images/map.png Binary files differindex 14da796..5338adf 100644 --- a/images/map.png +++ b/images/map.png diff --git a/js-runtime/reflect.js b/js-runtime/reflect.js index 0662ea5..7ba19b7 100644 --- a/js-runtime/reflect.js +++ b/js-runtime/reflect.js @@ -360,6 +360,7 @@ class SchemeModule { #io_handler; #debug_handler; static #rt = { + bignum_from_string(str) { return BigInt(str); }, bignum_from_i32(n) { return BigInt(n); }, bignum_from_i64(n) { return n; }, bignum_from_u64(n) { return n < 0n ? 0xffff_ffff_ffff_ffffn + (n + 1n) : n; }, diff --git a/js-runtime/reflect.wasm b/js-runtime/reflect.wasm Binary files differindex d2b10d7..64d1156 100644 --- a/js-runtime/reflect.wasm +++ b/js-runtime/reflect.wasm diff --git a/level.tmx b/level.tmx new file mode 100644 index 0000000..2191ef4 --- /dev/null +++ b/level.tmx @@ -0,0 +1,141 @@ +<?xml version="1.0" encoding="UTF-8"?> +<map version="1.8" tiledversion="1.8.6" orientation="orthogonal" renderorder="right-down" width="15" height="40" tilewidth="16" tileheight="16" infinite="0" nextlayerid="6" nextobjectid="13"> + <tileset firstgid="1" source="tiles.tsx"/> + <layer id="2" name="background" width="15" height="40"> + <data encoding="csv"> +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, +7,7,7,7,7,7,7,7,7,7,7,7,7,7,7 +</data> + </layer> + <layer id="1" name="foreground" width="15" height="40"> + <data encoding="csv"> +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,2,0,0,0,0,0,0,0,0,0,0,0,3,1, +1,1,2,0,0,0,0,0,0,0,0,0,3,1,1, +1,1,1,1,1,1,1,1,0,0,0,0,1,1,1, +1,1,1,1,1,1,1,1,0,0,0,0,1,1,1, +1,1,1,1,1,1,1,1,0,0,0,0,1,1,1, +1,1,1,1,1,1,1,1,0,0,0,0,1,1,1, +1,1,1,1,1,1,1,1,0,0,0,0,1,1,1, +1,1,1,1,1,1,1,0,0,0,0,3,1,1,1, +1,1,1,1,1,1,0,0,0,0,3,1,1,1,1, +1,1,1,1,1,0,0,0,0,3,1,1,1,1,1, +1,1,1,1,1,0,0,0,0,1,1,1,1,1,1, +1,1,1,1,1,0,0,0,0,1,1,1,1,1,1, +1,1,1,1,1,0,0,0,0,1,1,1,1,1,1, +1,1,1,1,1,0,0,0,0,1,1,1,1,1,1, +1,1,1,1,0,0,0,0,0,0,1,1,1,1,1, +1,1,1,0,0,0,0,0,0,0,0,1,1,1,1, +1,1,0,0,0,0,0,0,0,0,0,0,1,1,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,1,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,0,0,0,0,0,0,0,0,0,0,0,0,0,1, +1,2,0,0,0,0,0,0,0,0,0,0,0,3,1, +1,1,2,0,0,0,0,0,0,0,0,0,3,1,1 +</data> + </layer> + <layer id="5" name="collision" width="15" height="40"> + <data encoding="csv"> +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,6,0,0,0,0,0,0,0,0,0,0,0,6,6, +6,6,6,6,6,6,6,6,0,0,0,0,6,6,6, +6,6,6,6,6,6,6,6,0,0,0,0,6,6,6, +6,6,6,6,6,6,6,6,0,0,0,0,6,6,6, +6,6,6,6,6,6,6,6,0,0,0,0,6,6,6, +6,6,6,6,6,6,6,6,0,0,0,0,6,6,6, +6,6,6,6,6,6,6,0,0,0,0,0,6,6,6, +6,6,6,6,6,6,0,0,0,0,0,6,6,6,6, +6,6,6,6,6,0,0,0,0,0,6,6,6,6,6, +6,6,6,6,6,0,0,0,0,6,6,6,6,6,6, +6,6,6,6,6,0,0,0,0,6,6,6,6,6,6, +6,6,6,6,6,0,0,0,0,6,6,6,6,6,6, +6,6,6,6,6,0,0,0,0,6,6,6,6,6,6, +6,6,6,6,0,0,0,0,0,0,6,6,6,6,6, +6,6,6,0,0,0,0,0,0,0,0,6,6,6,6, +6,6,0,0,0,0,0,0,0,0,0,0,6,6,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,6,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,0,0,0,0,0,0,0,0,0,0,0,0,0,6, +6,6,0,0,0,0,0,0,0,0,0,0,0,6,6 +</data> + </layer> + <objectgroup id="3" name="objects"> + <object id="10" type="enemy-a" x="16" y="336" width="16" height="16"/> + <object id="11" type="enemy-a" x="192" y="336" width="16" height="16"/> + <object id="12" type="enemy-a" x="112" y="176" width="16" height="16"/> + </objectgroup> +</map> diff --git a/manifest.scm b/manifest.scm new file mode 100644 index 0000000..e5c2491 --- /dev/null +++ b/manifest.scm @@ -0,0 +1,58 @@ +(use-modules (guix) + (guix build-system gnu) + (guix gexp) + (guix git) + (guix git-download) + ((guix licenses) #:prefix license:) + (guix packages) + (gnu packages autotools) + (gnu packages base) + (gnu packages compression) + (gnu packages guile) + (gnu packages pkg-config) + (gnu packages texinfo)) + +(define guile-next-next + (let ((commit "79e836b8cc601a1259c934000a953a8d739ddd6f") + (revision "1")) + (package + (inherit guile-next) + (version (git-version "3.0.9" revision commit)) + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://git.savannah.gnu.org/git/guile.git") + (commit commit))) + (file-name (git-file-name "guile" version)) + (sha256 + (base32 "0s90khsdbvrkykp58izkvyxf8jciggdapm29dc3lzk3s1shajlgm"))))))) + +(define guile-hoot + (let ((commit "89b936e198b158fc4a43b43977d783f4f798f45c") + (revision "1")) + (package + (name "guile-hoot") + (version (git-version "0.0.0" revision commit)) + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://gitlab.com/spritely/guile-hoot.git") + (commit commit))) + (file-name (git-file-name "guile-hoot" version)) + (sha256 + (base32 "0bzd2a840rzl3ymaaiqm7m4xsgb6hm24fjg3ssbiqq3n6qd88fnr")))) + (build-system gnu-build-system) + (arguments + '(#:make-flags '("GUILE_AUTO_COMPILE=0") + #:tests? #f)) + (native-inputs + (list autoconf automake pkg-config texinfo)) + (inputs + (list guile-next-next)) + (synopsis "WASM compiler for Guile Scheme") + (description "Guile-hoot is an ahead-of-time WebAssembly compiler for GNU Guile.") + (home-page "https://gitlab.com/spritely/guile-hoot") + (license (list license:asl2.0 license:lgpl3+))))) + +(packages->manifest (list ;; guile-next-next guile-hoot + gnu-make zip)) diff --git a/tiles.tsx b/tiles.tsx new file mode 100644 index 0000000..9adb30c --- /dev/null +++ b/tiles.tsx @@ -0,0 +1,4 @@ +<?xml version="1.0" encoding="UTF-8"?> +<tileset version="1.8" tiledversion="1.8.6" name="tiles" tilewidth="16" tileheight="16" tilecount="7" columns="7"> + <image source="images/map.png" width="112" height="16"/> +</tileset> |
