;;; 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 audio) (game effects) (game level) (game levels level-1) (game levels level-2) (game levels level-3) (game levels level-4) (game levels credits) (game scripts) (game tileset) (goblins core) (hoot bytevectors) (hoot ffi) (hoot hashtables) (ice-9 match) (local-storage) (math) (math rect) (math vector)) (define game-width 320.0) (define game-height 240.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)) (make-sound-effect (string-append "assets/sounds/" name ".wav"))) (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")) (define audio:pickup (load-sound-effect "pickup")) (define audio:emit (load-sound-effect "emit")) (define audio:die (load-sound-effect "die")) (define audio:gate (load-sound-effect "gate")) (define audio:warp (load-sound-effect "warp")) (define audio:floor-switch (load-sound-effect "floor-switch")) (define audio:electric-switch-on (load-sound-effect "electric-switch-on")) (define audio:electric-switch-off (load-sound-effect "electric-switch-off")) ;; 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 load-level-4)) (define *level-idx* #f) (define *gems* #f) (define *level* #f) ;; Latest representation of all actors in level (define *objects* #f) (define *snapshots* '()) (define (clear-snapshots!) (set! *snapshots* '())) (define (save-snapshot!) (set! *snapshots* (cons (copy-whactormap *actormap*) *snapshots*))) (define (rollback-snapshot!) (match *snapshots* (() (play-sound-effect audio:no)) ((snapshot . older-snapshots) (set! *actormap* snapshot) (set! *snapshots* older-snapshots) (play-sound-effect audio:undo) (show-effect! (make-wipe-effect 0.25))))) (define (sort lst compare) (match lst (() '()) ((_) lst) (_ ;; Insertion sort because I am lazy! (let ((vec (list->vector lst))) (let outer ((i 1)) (when (< i (vector-length vec)) (let inner ((j i)) (when (> j 0) (let ((a (vector-ref vec j)) (b (vector-ref vec (1- j)))) (when (compare a b) (vector-set! vec j b) (vector-set! vec (1- j) a) (inner (1- j)))))) (outer (1+ i)))) (vector->list vec))))) (define (filter-map proc lst) (let lp ((lst lst)) (match lst (() '()) ((head . tail) (let ((head* (proc head))) (if head* (cons head* (lp tail)) (lp tail))))))) (define (update-objects!) (set! *objects* ;; z-sort the list so we render in the correct order. Then ;; convert tile positions to vec2s of pixel coordinates for ;; more efficient rendering. (map (match-lambda ((type #(x y _) . properties) `(,type ,(vec2 (* x tile-width) (* y tile-height)) ,@properties))) (sort ($ (level-actor *level*) 'describe) (lambda (a b) (match a ((_ #(_ _ az) . _) (match b ((_ #(_ _ bz) . _) (<= az bz)))))))))) (define (collected-gem? idx) (memq idx *gems*)) (define (load-level! idx) (set! *state* 'play) (set! *actormap* (make-whactormap)) (clear-snapshots!) (with-goblins (set! *level* ((vector-ref levels idx) (collected-gem? idx))) (update-objects!))) (define (load-credits!) (set! *state* 'win) (set! *actormap* (make-whactormap)) (set-vec2-y! *credits-scroll* 0.0) (clear-snapshots!) (with-goblins (set! *level* (load-credits #t)) (update-objects!))) (define (next-level!) (let ((idx (+ *level-idx* 1))) (pk 'next-level idx) (set! *level-idx* idx) (if (< idx (vector-length levels)) (begin (save-game!) (run-script (lambda () (set! *state* 'interstitial) (show-effect! (make-fade-out+in-effect 1.0)) (wait 30) ; ~half the effect time (load-level! idx)))) (begin (run-script (lambda () (set! *level-idx* 0) (save-game!) (set! *state* 'interstitial) (show-effect! (make-fade-out+in-effect 2.0)) (wait 60) (load-credits!))))))) ;; Auto-save/load to local storage. (define (save-game!) (pk 'save) (local-storage-set! "cirkoban-save" (call-with-output-string (lambda (port) (write (list *level-idx* *gems*) port))))) (define (load-game!) (let ((saved (match (local-storage-ref "cirkoban-save") ("" '(0 ())) ; initial save state (str (call-with-input-string str read))))) (match saved ((idx gems) (set! *level-idx* idx) (set! *gems* gems) (pk 'load *level-idx*) (load-level! *level-idx*))))) (define (reset-game!) (set! *level-idx* 0) (save-game!) (load-level! 0)) ;; Update loop (define (move-player dir) (define level-complete? #f) (with-goblins (let ((player (level-player *level*)) (level (level-actor *level*))) (cond (($ player 'alive?) (begin ($ player 'move dir) ($ level 'tick) (let lp ((events ($ level 'flush-events))) (match events (() (values)) ((event . rest) (match (pk 'event event) (('bump x y) (play-sound-effect audio:bump)) (('push x y) (play-sound-effect audio:push)) (('exit x y) (play-sound-effect audio:exit) (set! level-complete? #t)) (('player-death x y) (play-sound-effect audio:die)) (('pickup x y) (play-sound-effect audio:pickup) ;; TODO: Maybe show a little achievement popup when all gems ;; are collected? (set! *gems* (cons *level-idx* *gems*))) (('emit x y) (play-sound-effect audio:emit)) (('gate-open x y) (play-sound-effect audio:gate)) (('gate-close x y) (play-sound-effect audio:gate) (show-effect! (make-screen-shake-effect 0.05))) ((or ('floor-switch-on x y) ('floor-switch-off x y)) (play-sound-effect audio:floor-switch)) (('electric-switch-on x y) (play-sound-effect audio:electric-switch-on)) (('electric-switch-off x y) (play-sound-effect audio:electric-switch-off)) (('receive-electron x y) (play-sound-effect audio:warp 0.25)) (_ (values))) (lp rest)))) (update-objects!) (save-snapshot!))) (else (play-sound-effect audio:no))))) (when level-complete? (next-level!))) (define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz (define (update) (scheduler-tick! (current-scheduler)) (timeout update-callback dt)) (define update-callback (procedure->external update)) ;; Render loop (define *current-effect* #f) (define (show-effect! effect) (set! *current-effect* effect) (effect-start! effect)) (define (draw-current-effect type) (when (and *current-effect* (eq? type (effect-type *current-effect*))) (draw-effect context *current-effect*) (unless (effect-started? *current-effect*) (set! *current-effect* #f)))) (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 pos alive?) (draw-tile context tileset (if alive? 0 20) (vec2-x pos) (vec2-y pos))) (define (draw-exit pos) (draw-tile context tileset 27 (vec2-x pos) (vec2-y pos))) (define (draw-wire-state pos state) (let ((x (vec2-x pos)) (y (vec2-y pos))) (match state ('electron-head (draw-tile context tileset 4 x y)) ('electron-tail (draw-tile context tileset 5 x y)) (_ #f)))) (define (draw-wall pos type) (draw-wire-state pos type)) (define (draw-block pos type) (let ((x (vec2-x pos)) (y (vec2-y pos))) (match type ('crate (draw-tile context tileset 29 x y)) (_ (draw-tile context tileset 3 x y))) (draw-wire-state pos type))) (define (draw-clock-emitter pos) (draw-tile context tileset 48 (vec2-x pos) (vec2-y pos))) (define (draw-switched-emitter pos on?) (draw-tile context tileset (if on? 48 47) (vec2-x pos) (vec2-y pos))) (define (draw-floor-switch pos on?) (draw-tile context tileset (if on? 25 24) (vec2-x pos) (vec2-y pos))) (define (draw-gem pos) (draw-tile context tileset 28 (vec2-x pos) (vec2-y pos))) (define (draw-ghost-gem pos) (set-global-alpha! context 0.5) (draw-tile context tileset 49 (vec2-x pos) (vec2-y pos)) (set-global-alpha! context 1.0)) (define (draw-gate pos open?) (draw-tile context tileset (if open? 46 45) (vec2-x pos) (vec2-y pos))) (define (draw-logic-gate pos state id) (let ((x (vec2-x pos)) (y (vec2-y pos))) (draw-tile context tileset 2 x y) (draw-tile context tileset id x y) (draw-wire-state pos state))) (define (draw-electric-switch pos on?) (draw-tile context tileset (if on? 7 6) (vec2-x pos) (vec2-y pos))) (define (draw-electron-warp pos state) (draw-tile context tileset 71 (vec2-x pos) (vec2-y pos)) (draw-wire-state pos state)) (define (draw-object obj) (match obj (#f #f) (('player pos alive?) (draw-player pos alive?)) (('exit pos) #t) ; drawn via background (('wall pos type) (draw-wall pos type)) (('block pos type) (draw-block pos type)) (('clock-emitter pos) #t) ; drawn via background (('switched-emitter pos on?) (draw-switched-emitter pos on?)) (('floor-switch pos on?) (draw-floor-switch pos on?)) (('gem pos) (draw-gem pos)) (('ghost-gem pos) (draw-ghost-gem pos)) (('gate pos open?) (draw-gate pos open?)) (('and-gate pos state) (draw-logic-gate pos state 42)) (('or-gate pos state) (draw-logic-gate pos state 43)) (('xor-gate pos state) (draw-logic-gate pos state 44)) (('electric-switch pos on?) (draw-electric-switch pos on?)) (('electron-warp pos state) (draw-electron-warp pos state)))) (define (draw-background) (let ((bg (level-background *level*)) (k (* level-width level-height))) (do ((i 0 (1+ i))) ((= i k)) (let* ((tile (vector-ref bg i)) (pos (level-tile-position tile)) (id (level-tile-id tile))) (draw-tile context tileset id (vec2-x pos) (vec2-y pos)))))) (define (draw-level) (draw-background) (for-each draw-object *objects*) (let ((alive? (with-goblins ($ (level-player *level*) 'alive?)))) (unless alive? (set-fill-color! context "rgba(0,0,0,0.65)") (fill-rect context 0.0 0.0 game-width game-height) (set-fill-color! context "#ffffff") (set-text-align! context "center") (fill-text context "OUCH... x_x" (/ game-width 2.0) (/ game-height 2.0))))) (define (draw-interstitial) (draw-level)) (define *credits-scroll* (vec2 0.0 0.0)) (define credits #("Congratulations!" #f #f "Cirkoban was made by the" "Spritely Institute" #f "https://spritely.institute" #f "Programming" #f "David Thompson" "Juliana Sims" #f "Art" #f "Christine Lemmer-Webber" #f "monogram font by datagoblin" #f #f #f #f #f #f #f #f "Thank you for playing!")) (define credits-line-spacing 16.0) (define max-credits-scroll (+ game-height (* (- (vector-length credits) 9) credits-line-spacing))) (define (draw-win) (draw-level) (set-fill-color! context "#ffffff") (set-text-align! context "center") (set-font! context "bold 16px monogram") (set-vec2-y! *credits-scroll* (min (+ (vec2-y *credits-scroll*) 1.0) max-credits-scroll)) (let* ((x (* game-width 0.7)) (lines-on-screen 15) (scroll-y (vec2-y *credits-scroll*)) ;; TODO: Only render the lines on screen. (start 0) (end (vector-length credits))) (let lp ((i start) (y (- game-height scroll-y))) (when (< i end) (match (vector-ref credits i) (#f #f) (str (fill-text context str x y))) (lp (1+ i) (+ y credits-line-spacing)))))) (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) (scale! context *canvas-scale* *canvas-scale*) (draw-current-effect 'pre) (match *state* ((or 'play 'interstitial) (draw-level)) ('win (draw-win))) (draw-current-effect 'post) (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-objects!))) ;; REMOVE BEFORE RELEASE!!!! ((string=? key key:confirm) (next-level!)))) ('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) (load-game!)