;;; Copyright (C) 2024 David Thompson ;;; ;;; 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. ;;; Commentary: ;;; ;;; Example game showing off several common game programming things. ;;; ;;; Code: (use-modules (dom canvas) (dom document) (dom element) (dom event) (dom image) (dom media) (dom window) (game actors) (game level) (game levels level-1) (game levels level-2) (game levels level-3) (game tileset) (goblins core) (hoot bytevectors) (hoot ffi) (hoot hashtables) (ice-9 match) (math) (math rect) (math vector)) (define game-width 320.0) (define game-height 240.0) (define tile-width 16.0) (define tile-height 16.0) (define level-width (inexact->exact (floor (/ game-width tile-width)))) (define level-height (inexact->exact (floor (/ game-height tile-height)))) (define *canvas-scale* 0.0) (define *canvas-width* 0) (define *canvas-height* 0) ;; Assets (define tileset (make-tileset (make-image "assets/images/cirkoban.png") 320 240 (inexact->exact tile-width) (inexact->exact tile-height))) (define* (load-sound-effect name #:key (volume 0.25)) (let ((audio (make-audio (string-append "assets/sounds/" name ".wav")))) (set-media-volume! audio volume) audio)) (define audio:bump (load-sound-effect "bump")) (define audio:push (load-sound-effect "push")) (define audio:undo (load-sound-effect "undo")) (define audio:no (load-sound-effect "no")) (define audio:exit (load-sound-effect "exit")) ;; Game state (define *state* #f) (define *actormap* (make-whactormap)) (define (call-with-goblins thunk) (actormap-churn-run! *actormap* thunk)) (define-syntax-rule (with-goblins body ...) (call-with-goblins (lambda () body ...))) (define levels (vector load-level-1 load-level-2 load-level-3)) (define *level-idx* #f) (define *level* #f) ;; Latest representation of all actors in level (define *grid* #f) (define *snapshots* '()) (define (clear-snapshots!) (set! *snapshots* '())) (define (save-snapshot!) (set! *snapshots* (cons (copy-whactormap *actormap*) *snapshots*))) (define (rollback-snapshot!) (match *snapshots* (() (media-play audio:no)) ((snapshot . older-snapshots) (set! *actormap* snapshot) (set! *snapshots* older-snapshots) (media-play audio:undo)))) (define (update-grid!) (set! *grid* ($ (level-actor *level*) 'describe))) (define (next-level!) (clear-snapshots!) (let ((idx (+ *level-idx* 1))) (set! *level-idx* idx) (if (< idx (vector-length levels)) (set! *level* ((vector-ref levels idx))) (set! *state* 'win)))) (define (reset-game!) (set! *state* 'play) (set! *actormap* (make-whactormap)) (clear-snapshots!) (set! *level-idx* -1) (with-goblins (next-level!) (update-grid!))) ;; Update loop (define (move-player dir) (save-snapshot!) (with-goblins (match ($ (level-actor *level*) 'move-player dir) ('bump (media-play audio:bump)) ('push (media-play audio:push)) ('exit (media-play audio:exit) (next-level!)) (_ #f)) (update-grid!))) (define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz (define (update) ;; TODO: what kind of work do we need to do each frame? (timeout update-callback dt)) (define update-callback (procedure->external update)) ;; Render loop (define number->string* (let ((cache (make-eq-hashtable))) ; assuming fixnums only (lambda (x) (or (hashtable-ref cache x) (let ((str (number->string x))) (hashtable-set! cache x str) str))))) (define (draw-player x y) (draw-tile context tileset 0 x y)) (define (draw-exit x y) (draw-tile context tileset 27 x y)) (define (draw-wall type x y) (match type ('brick (draw-tile context tileset 22 x y)) (_ (draw-tile context tileset 2 x y))) (match type ('electron-head (draw-tile context tileset 4 x y)) ('electron-tail (draw-tile context tileset 5 x y)) (_ #f))) (define (draw-block type x y) (match type ('crate (draw-tile context tileset 29 x y)) ('copper (draw-tile context tileset 3 x y))) (match type ('electron-head (draw-tile context tileset 4 x y)) ('electron-tail (draw-tile context tileset 5 x y)) (_ #f))) (define (draw-clock-emitter x y) (draw-tile context tileset 48 x y)) (define (draw-object x y obj) (and obj (let ((x (* x tile-width)) (y (* y tile-height))) (match obj (#f #f) (('player) (draw-player x y)) (('exit) (draw-exit x y)) (('wall type) (draw-wall type x y)) (('block type) (draw-block type x y)) (('clock-emitter) (draw-clock-emitter x y)))))) (define (draw-background) (let* ((bv (level-background *level*)) (len (bytevector-length bv))) (let lp ((i 0)) (when (< i len) (let ((x (bytevector-ieee-single-native-ref bv i)) (y (bytevector-ieee-single-native-ref bv (+ i 4))) (idx (bytevector-u16-native-ref bv (+ i 8)))) (draw-tile context tileset idx x y) (lp (+ i 10))))))) (define (draw-level) (draw-background) (let ((grid *grid*)) (let y-loop ((y 0)) (when (< y level-height) (let x-loop ((x 0)) (when (< x level-width) (draw-object x y (vector-ref grid (+ (* y level-width) x))) (x-loop (1+ x)))) (y-loop (1+ y)))))) (define (draw-win) (set-fill-color! context "#x000000") (fill-text context "OMG YOU DID IT WOW CONGRATS" 32.0 120.0)) (define (draw prev-time) (clear-rect context 0.0 0.0 *canvas-width* *canvas-height*) (set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0) (set-scale! context *canvas-scale* *canvas-scale*) (match *state* ('play (draw-level)) ('win (draw-win))) (request-animation-frame draw-callback)) (define draw-callback (procedure->external draw)) ;; Input (define key:left "ArrowLeft") (define key:right "ArrowRight") (define key:down "ArrowDown") (define key:up "ArrowUp") (define key:confirm "Enter") (define key:undo "KeyZ") (define (on-key-down event) (let ((key (keyboard-event-code event))) (pk 'key-down key) (match *state* ('play (cond ((string=? key key:left) (move-player 'left)) ((string=? key key:right) (move-player 'right)) ((string=? key key:up) (move-player 'up)) ((string=? key key:down) (move-player 'down)) ((string=? key key:undo) (rollback-snapshot!) (with-goblins (update-grid!))) ((string=? key key:confirm) (reset-game!)))) ('win (cond ((string=? key key:confirm) (reset-game!))))))) ;; Canvas and event loop setup (define canvas (get-element-by-id "canvas")) (define context (get-context canvas "2d")) (define (resize-canvas) (let* ((win (current-window)) (w (window-inner-width win)) (h (window-inner-height win)) (gw (inexact->exact game-width)) (gh (inexact->exact 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* (exact->inexact scale)) (set! *canvas-width* (* game-width *canvas-scale*)) (set! *canvas-height* (* game-height *canvas-scale*)) (pk 'resize-canvas *canvas-scale* *canvas-width* *canvas-height*))) (set-element-width! canvas (inexact->exact game-width)) (set-element-height! canvas (inexact->exact game-height)) (add-event-listener! (current-window) "resize" (procedure->external (lambda (_) (resize-canvas)))) (add-event-listener! (current-document) "keydown" (procedure->external on-key-down)) (resize-canvas) (request-animation-frame draw-callback) (timeout update-callback dt) (reset-game!)