;;; Copyright (C) 2024 David Thompson ;;; Copyright (C) 2024 Juliana Sims ;;; ;;; 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 gamepad) (dom image) (dom media) (dom window) (game actors) (game animation) (game audio) (game effects) (game level) (game levels tutorial-1) (game levels tutorial-2) (game levels tutorial-3) (game levels tutorial-4) (game levels tutorial-5) (game levels tutorial-6) (game levels tutorial-7) (game levels tutorial-8) (game levels tutorial-9) (game levels tutorial-10) (game levels rat-1) (game levels rat-2) (game levels rat-3) (game levels catboss-1) (game levels catboss-2) (game levels catboss-3) (game levels credits) (game particles) (game scripts) (game tileset) (game time) (goblins core) (hoot bytevectors) (hoot ffi) (hoot hashtables) (ice-9 match) (local-storage) (math) (math rect) (math vector) (scheme base)) (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-onesheet.png") 320 240 (inexact->exact tile-width) (inexact->exact tile-height))) (define* (load-sound-effect name #:key (volume 0.75)) (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:emitter-on (load-sound-effect "emitter-on")) (define audio:emitter-off (load-sound-effect "emitter-off")) (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")) (define audio:explosion (load-sound-effect "explosion")) (define* (load-music name #:key (volume 0.3)) (let ((music (make-audio (string-append "assets/music/" name ".ogg")))) (set-media-loop! music 1) (set-media-volume! music volume) music)) (define audio:bg-music (load-music "cirkoban")) ;; Game state (define *state* '(initial)) (define (push-game-state! state) (set! *state* (cons state *state*))) (define (pop-game-state!) (when (pair? *state*) (set! *state* (cdr *state*)))) (define (replace-game-state! state) (match *state* ((_ . rest) (set! *state* (cons state rest))))) (define (current-game-state) (match *state* ((state . _) state))) (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-tutorial-1 load-tutorial-2 load-tutorial-3 load-tutorial-4 load-tutorial-5 load-tutorial-6 load-tutorial-7 load-tutorial-8 load-tutorial-9 load-tutorial-10 load-rat-1 ;; load-rat-2 load-rat-3 load-catboss-1 load-catboss-2 load-catboss-3)) (define *level-idx* #f) ;; Last level for restoring after visiting credits via the menu (define *level-last* #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) (unless *current-effect* (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 (set-level! idx) (replace-game-state! 'play) (set! *actormap* (make-whactormap)) (clear-snapshots!) (with-goblins (set! *level* ((vector-ref levels idx) (collected-gem? idx))) (update-objects!))) (define (load-credits!) (replace-game-state! 'credits) (set! *actormap* (make-whactormap)) (set-vec2-y! *credits-scroll* 0.0) (clear-snapshots!) (with-goblins (set! *level* (load-credits #f)) (update-objects!))) (define (load-level! idx) ;; TODO: Maybe show a little achievement popup when all gems ;; are collected? (when (with-goblins ($ (level-actor *level*) 'gem-collected?)) (set! *gems* (cons *level-idx* *gems*))) (if (< idx (vector-length levels)) (begin (run-script (lambda () (replace-game-state! 'interstitial) (yield (lambda (k) (show-effect! (make-fade-out+in-effect 1.0 k)))) (set! *level-idx* idx) (save-game!) (set-level! idx)))) (begin (run-script (lambda () (replace-game-state! 'interstitial) (yield (lambda (k) (show-effect! (make-fade-out+in-effect 2.0 k)))) (set! *level-idx* 0) (save-game!) ;; HACK: To keep the intro level's control explanation ;; text from showing up when resetting the game, set ;; level idx to non-zero during the credits. (set! *level-idx* -1) (load-credits!)))))) (define (next-level!) (load-level! (+ *level-idx* 1))) ;; Auto-save/load to local storage. (define (save-game!) (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) (set-level! *level-idx*) (media-play audio:bg-music))))) ;; Menu types (define-record-type (make-menu name items) menu? (name menu-name) (items menu-items)) ;; Menu state (define-record-type (make-menu-state current index page history) menu-state? (current menu-state-current set-menu-state-current!) (index menu-state-index set-menu-state-index!) (page menu-state-page set-menu-state-page!) (history menu-state-history set-menu-state-history!)) (define (menu-action:submenu menu) (lambda () (push-menu-history!) (set-menu! menu) (set-menu-index! -1))) (define (menu-action:load-level level) (lambda () (hide-menu!) (load-level! level))) (define (menu-action:credits) (hide-menu!) (set! *level-last* *level-idx*) (load-level! (vector-length levels))) ;; Menu constants (define center (vec2 (* 10.0 tile-width) (* 7.0 tile-height))) (define menu:max-items 10) (define menu:level-select (let ((items (make-vector (vector-length levels)))) (do ((i 0 (1+ i))) ((= i (vector-length levels))) (vector-set! items i (cons (string-append "Level " (number->string i)) (menu-action:load-level i)))) (make-menu "Select Level" items))) (define menu:main (make-menu "Menu" (vector (cons "Select Level" (menu-action:submenu menu:level-select)) (cons "Credits" menu-action:credits)))) ;; -1 for the index means 'Back' will be indicated first (define *menu* (make-menu-state menu:main -1 0 '())) (define (current-menu) (menu-state-current *menu*)) (define (current-menu-index) (menu-state-index *menu*)) (define (current-menu-page) (menu-state-page *menu*)) (define (current-menu-history) (menu-state-history *menu*)) (define (set-menu! menu) (set-menu-state-current! *menu* menu)) (define (set-menu-index! index) (set-menu-state-index! *menu* index)) (define (set-menu-page! page) (set-menu-state-page! *menu* page)) (define (set-menu-history! history) (set-menu-state-history! *menu* history)) ;; Menu commands (define* (show-menu! #:optional (menu menu:main)) (push-game-state! 'menu) (set-menu! menu) (set-menu-index! -1) (set-menu-page! 0) (set-menu-history! '())) (define (hide-menu!) (pop-game-state!)) (define (menu-up!) (set-menu-index! (max -1 (1- (current-menu-index)))) (when (and (> (current-menu-page) 0) (= (current-menu-index) (- (* (current-menu-page) menu:max-items) (current-menu-page) 1))) (set-menu-page! (1- (current-menu-page))))) (define (menu-down!) (set-menu-index! (min (1- (vector-length (menu-items (current-menu)))) (1+ (current-menu-index)))) (when (= (current-menu-index) (- (* (1+ (current-menu-page)) menu:max-items) (current-menu-page))) (set-menu-page! (1+ (current-menu-page))))) (define (push-menu-history!) (set-menu-history! (cons (cons (current-menu) (current-menu-index)) (current-menu-history)))) (define (pop-menu-history!) (match (current-menu-history) (() (hide-menu!)) (((prev . index) . rest) (set-menu! prev) (set-menu-index! index) (set-menu-history! rest)))) (define (menu-select!) (if (= (current-menu-index) -1) ;; back button pressed (pop-menu-history!) ((cdr (vector-ref (menu-items (current-menu)) (current-menu-index)))))) (define (reset-game!) (run-script (lambda () (replace-game-state! 'interstitial) (yield (lambda (k) (show-effect! (make-fade-out+in-effect 2.0 k)))) (set! *level-idx* 0) (set-level! 0)))) (define (emit-pickup-particles x y) (run-script (lambda () (do ((i 0 (1+ i))) ((= i 24)) (let ((angle (* (random) 2.0 pi)) (r (/ tile-width 2.0))) (particle-pool-add! particles 140 2 (+ (* x tile-width) (/ tile-width 2.0) (* (cos angle) r)) (+ (* y tile-height) (/ tile-height 2.0) (* (sin angle) r)) 0.0 0.0)) (wait 1))))) (define (emit-electric-switch-particles x y) (run-script (lambda () (do ((i 0 (1+ i))) ((= i 4)) (let ((angle (+ (* (random) pi) pi)) (speed (+ (random) 3.0))) (particle-pool-add! particles 141 6 (+ (* x tile-width) (/ tile-width 2.0)) (+ (* y tile-height) 3.0) (* (cos angle) speed) (* (sin angle) speed))) (wait 1))))) (define (emit-warp-particles x y) (run-script (lambda () (do ((i 0 (1+ i))) ((= i 4)) (particle-pool-add! particles 142 6 (+ (* x tile-width) (/ tile-width 2.0) (- (* (random) 6.0) 3.0)) (+ (* y tile-height) tile-height) 0.0 (- (* (random) -2.0) 3.0)) (wait 2))))) (define (emit-explosion-particles x y) (run-script (lambda () (do ((i 0 (1+ i))) ((= i 16)) (do ((j 0 (1+ j))) ((= j 2)) (let ((dx (- (* (random) tile-width 3.0) tile-width)) (dy (- (* (random) tile-height 3.0) tile-height))) (particle-pool-add! particles 51 8 (+ (* x tile-width) dx) (+ (* y tile-height) dy) 0.0 0.0))) (wait 1))))) ;; 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 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) (emit-pickup-particles x y)) (('emit x y) (play-sound-effect audio:emit)) (('emitter-on x y) (play-sound-effect audio:emitter-on)) (('emitter-off x y) (play-sound-effect audio:emitter-off)) (('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) (emit-electric-switch-particles x y)) (('electric-switch-off x y) (play-sound-effect audio:electric-switch-off)) (('receive-electron x y) (play-sound-effect audio:warp 0.25) (emit-warp-particles x y)) (('explosion x y) (play-sound-effect audio:explosion) (show-effect! (make-screen-shake-effect 0.2)) (emit-explosion-particles x y)) (_ (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) (maybe-poll-gamepad) (scheduler-tick! (current-scheduler)) (particle-pool-update! particles) (timeout update-callback dt)) (define update-callback (procedure->external update)) ;; Rendering (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-syntax-rule (define-animation name (tile duration) ...) (define name (make-animation tileset (vector (make-frame tile duration) ...)))) (define-animation anim:player (0 6.75) (40 0.15)) (define-animation anim:electron-head (4 .25) (57 .25) (77 .25) (97 .25)) (define-animation anim:electron-tail (5 .25) (58 .25) (78 .25) (98 .25)) (define-animation anim:gem (28 .25) (55 .25) (75 .25) (95 .25)) (define-animation anim:ghost-gem (49 .25) (56 .25) (76 .25) (96 .25)) (define-animation anim:and-gate (42 .4) (115 .4) (135 .4) (155 .4)) (define-animation anim:or-gate (43 .4) (116 .4) (136 .4) (156 .4)) (define-animation anim:xor-gate (44 .4) (117 .4) (137 .4) (157 .4)) (define-animation anim:bomb-lit (53 .2) (73 .2) (93 .2) (113 .2)) (define-animation anim:bomb-uh-oh (54 .1) (74 .1) (94 .1) (114 .1)) (define particles (make-particle-pool 512 tileset)) (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-rotated-animation anim pos angle) (let ((hw (* tile-width 0.5)) (hh (* tile-height 0.5))) (save! context) (translate! context (+ (vec2-x pos) hw) (+ (vec2-y pos) hh)) (rotate! context angle) (draw-animation context anim (- hw) (- hh)) (restore! context))) (define (draw-player pos alive?) (if alive? (draw-animation context anim:player (vec2-x pos) (vec2-y pos)) (draw-tile context tileset 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-animation context anim:electron-head x y)) ('electron-tail (draw-animation context anim:electron-tail 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-brick pos) (draw-tile context tileset 22 (vec2-x pos) (vec2-y pos))) (define (draw-clock-emitter pos state) (draw-tile context tileset 48 (vec2-x pos) (vec2-y pos)) (set-global-alpha! context 0.5) (draw-wire-state pos state) (set-global-alpha! context 1.0)) (define (draw-switched-emitter pos state) (draw-tile context tileset (if state 48 47) (vec2-x pos) (vec2-y pos)) (set-global-alpha! context 0.5) (draw-wire-state pos state) (set-global-alpha! context 1.0)) (define (draw-floor-switch pos on?) (draw-tile context tileset (if on? 25 24) (vec2-x pos) (vec2-y pos))) (define (draw-bomb pos countdown) (let ((x (vec2-x pos)) (y (vec2-y pos))) (match countdown (-1 (draw-tile context tileset 50 x y)) (1 (draw-animation context anim:bomb-uh-oh x y)) (_ (draw-animation context anim:bomb-lit x y))))) (define (draw-gem pos) (draw-animation context anim:gem (vec2-x pos) (vec2-y pos))) (define (draw-ghost-gem pos) (set-global-alpha! context 0.5) (draw-animation context anim:ghost-gem (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 direction state anim) (let ((x (vec2-x pos)) (y (vec2-y pos))) (draw-tile context tileset 2 x y) (match direction ('right (draw-animation context anim x y)) ('left (draw-rotated-animation anim pos pi)) ('up (draw-rotated-animation anim pos (* pi 1.5))) ('down (draw-rotated-animation anim pos (* pi 0.5)))) (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)) (('brick pos) (draw-brick pos)) (('clock-emitter pos state) (draw-clock-emitter pos state)) (('switched-emitter pos state) (draw-switched-emitter pos state)) (('floor-switch pos on?) (draw-floor-switch pos on?)) (('bomb pos countdown) (draw-bomb pos countdown)) (('gem pos) (draw-gem pos)) (('ghost-gem pos) (draw-ghost-gem pos)) (('gate pos open?) (draw-gate pos open?)) (('and-gate pos direction state) (draw-logic-gate pos direction state anim:and-gate)) (('or-gate pos direction state) (draw-logic-gate pos direction state anim:or-gate)) (('xor-gate pos direction state) (draw-logic-gate pos direction state anim:xor-gate)) (('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-menu) ;; Height (in tiles) will be 1 for the menu title + the y padding ;; + 1 for the back button if on the first page or ellipses otherwise ;; + num menu items + 1 for ellipses if num items is too big ;; + the y padding again (let* ((padding-y 1) (text-offset-y (* 0.75 tile-height)) (width 8.0) (num-items (vector-length (menu-items (current-menu)))) (height (+ 2 ;; Menu title + back/ellipses (* 2 padding-y) ;; Padding (if (> num-items menu:max-items) (1+ menu:max-items) ;; bottom ellipses num-items))) (y-start (- (vec2-y center) (* tile-height (floor (/ height 2))))) (x-start (- (vec2-x center) (* tile-width (floor (/ width 2)))))) ;; Draw menu background (let ((w (* tile-width width)) (h (* tile-height height))) (set-fill-color! context "#000") (fill-rect context x-start y-start w h) (set-stroke-color! context "blue") (stroke-rect context x-start y-start w h)) ;; Draw menu text (set-font! context "normal 16px monogram") (set-fill-color! context "#fff") (let* (;; The first menu item is at index 0. The 'Back' or ellipses are ;; directly above the first menu item at index -1. The menu title ;; is above the 'Back' button and separated by the padding-y (r-start (- -2 padding-y)) ;; end of text (r-end (- (+ r-start height) padding-y)) ;; r will not take into account which page you are on (r-page-offset (- (* (current-menu-page) menu:max-items) (current-menu-page))) (x-gutter (+ tile-width x-start)) (x-text (+ tile-width x-gutter))) (do ((r r-start (1+ r)) (y y-start (+ tile-height y))) ((or (>= r r-end) (>= (+ r r-page-offset) num-items))) (let ((y-text (+ y text-offset-y)) (r-page (+ r r-page-offset))) ;; Draw menu title (when (= r r-start) (set-text-align! context "center") (fill-text context (menu-name (current-menu)) (vec2-x center) y-text)) (set-text-align! context "left") ;; indicator (when (= (+ r r-page-offset) (current-menu-index)) (fill-text context "▸" x-gutter y-text)) ;; Menu items (when (>= r -1) (fill-text context (cond ((= r-page -1) "Back") ((or (= r -1) (and (= r (1- r-end)) (< r-page (1- num-items)))) "...") (else (car (vector-ref (menu-items (current-menu)) r-page)))) x-text y-text))))))) (define (draw-controls) (let ((cx1 (/ game-width 4.0)) (cx2 (* game-width 0.75)) (baseline (/ game-height 2.0))) (set-fill-color! context "#ffffff") (set-text-align! context "center") (set-font! context "normal 16px monogram") (fill-text context "keyboard:" cx1 (- baseline 32.0)) (fill-text context "arrows -> move" cx1 (- baseline 16.0)) (fill-text context "Z -> undo" cx1 baseline) (fill-text context "touchscreen:" cx2 (- baseline 32.0)) (fill-text context "dpad -> move" cx2 (- baseline 16.0)) (fill-text context "A -> undo" cx2 baseline))) (define (draw-level) (draw-background) (for-each draw-object *objects*) (draw-particles context particles) (let ((alive? (with-goblins ($ (level-player *level*) 'alive?)))) (unless alive? (set-global-alpha! context 0.7) (set-fill-color! context "#222034") (fill-rect context 0.0 0.0 game-width game-height) (set-global-alpha! context 1.0) (set-font! context "normal 32px monogram") (set-fill-color! context "#ffffff") (set-text-align! context "center") (fill-text context "OUCH... x_x" (/ game-width 2.0) (/ game-height 2.0)))) (when (= *level-idx* 0) (draw-controls))) (define (draw-interstitial) (draw-level)) (define *credits-scroll* (vec2 0.0 0.0)) (define credits #("Phew, you made it!" "Time to relax." #f #f "Cirkoban was made by the" "Spritely Institute" #f "https://spritely.institute" #f "Game Design" "-----------" "Christine Lemmer-Webber" #f "Level Design" "------------" "Christine Lemmer-Webber" "Juliana Sims" "David Thompson" #f "Pixel Art" "---------" "Christine Lemmer-Webber" #f "Music" "-----" "EncryptedWhispers" "Christine Lemmer-Webber" #f "Programming" "-----------" "Juliana Sims" "David Thompson" #f "Other" "-----" "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-credits) (draw-level) (set-fill-color! context "#ffffff") (set-text-align! context "center") (set-font! context "normal 16px monogram") (set-vec2-y! *credits-scroll* (min (+ (vec2-y *credits-scroll*) 0.5) 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 *frame-time* (current-time*)) (define (draw time) (unless (and (real? time) (inexact? time)) (error "expected flonum" time)) (let* ((time (/ time 1000.0)) (dt (- time *frame-time*))) (set! *frame-time* time) ;; Prevent SUPER SPEED animations when the user switches away from ;; the browser for awhile. To my surprise, ;; blur/focus/visibilitychanged events *DO NOT* trigger when the ;; user switches to another program window, at least on my ;; machine, so they are useless to prevent this problem. Instead, ;; we hack: Don't update animations if dt is unreasonably high, ;; for some definition of unreasonable. (unless (> dt 0.2) (update-animation anim:player dt) (update-animation anim:electron-head dt) (update-animation anim:electron-tail dt) (update-animation anim:gem dt) (update-animation anim:ghost-gem dt) (update-animation anim:and-gate dt) (update-animation anim:or-gate dt) (update-animation anim:xor-gate dt) (update-animation anim:bomb-lit dt) (update-animation anim:bomb-uh-oh dt)) (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 (current-game-state) ((or 'play 'interstitial) (draw-level)) ('menu (draw-level) (draw-menu)) ('credits (draw-credits))) (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 key:menu "Space") (define (on-key-down event) (let ((key (keyboard-event-code event))) (cond ((string=? key key:left) (on-input-down 'left)) ((string=? key key:right) (on-input-down 'right)) ((string=? key key:up) (on-input-down 'up)) ((string=? key key:down) (on-input-down 'down)) ((string=? key key:undo) (on-input-down 'undo)) ((string=? key key:confirm) (on-input-down 'confirm)) ((string=? key key:menu) (on-input-down 'menu))))) (define *gamepad* #f) (define *button:left* #f) (define *button:right* #f) (define *button:up* #f) (define *button:down* #f) (define *button:undo* #f) (define *button-state* #f) (define (connect-gamepad! gamepad) (when (zero? (gamepad-index gamepad)) (set! *gamepad* gamepad) ;; These indices correspond to the "standard" gamepad mapping: ;; https://w3c.github.io/gamepad/#remapping (set! *button:left* (gamepad-button-ref gamepad 14)) (set! *button:right* (gamepad-button-ref gamepad 15)) (set! *button:up* (gamepad-button-ref gamepad 12)) (set! *button:down* (gamepad-button-ref gamepad 13)) (set! *button:undo* (gamepad-button-ref gamepad 0)) (set! *button-state* (vector #f #f #f #f #f)))) (define (disconnect-gamepad! gamepad) (when (zero? (gamepad-index gamepad)) (set! *gamepad* #f) (set! *button:left* #f) (set! *button:right* #f) (set! *button:up* #f) (set! *button:down* #f) (set! *button:undo* #f) (set! *button-state* #f))) (define (maybe-poll-gamepad) (define (press? old new) (and (not old) new)) (when *gamepad* (let ((state *button-state*)) (match *button-state* (#(prev-left prev-right prev-up prev-down prev-undo) (let ((left (gamepad-button-pressed? *button:left*)) (right (gamepad-button-pressed? *button:right*)) (up (gamepad-button-pressed? *button:up*)) (down (gamepad-button-pressed? *button:down*)) (undo (gamepad-button-pressed? *button:undo*))) (vector-set! *button-state* 0 left) (vector-set! *button-state* 1 right) (vector-set! *button-state* 2 up) (vector-set! *button-state* 3 down) (vector-set! *button-state* 4 undo) (when (press? prev-left left) (on-input-down 'left)) (when (press? prev-right right) (on-input-down 'right)) (when (press? prev-up up) (on-input-down 'up)) (when (press? prev-down down) (on-input-down 'down)) (when (press? prev-undo undo) (on-input-down 'undo)))))))) (define (on-input-down input) (match (current-game-state) ('play (match input ('left (move-player 'left)) ('right (move-player 'right)) ('up (move-player 'up)) ('down (move-player 'down)) ('undo (rollback-snapshot!) (with-goblins (update-objects!))) ;; REMOVE BEFORE RELEASE!!!! ;; ('confirm (next-level!)) ('menu (show-menu!)) (_ #f))) ('menu (match input ('up (menu-up!)) ('down (menu-down!)) ('confirm (menu-select!)) ('menu (hide-menu!)) (_ #f))) ;; Pressing any bound input resets the game. ;; If traveling to the credits via the menu, go back to '*level-last*' ('credits (cond (*level-last* (load-level! *level-last*) (set! *level-last* #f)) (else (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*)))) (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-window) "gamepadconnected" (procedure->external (lambda (e) (connect-gamepad! (gamepad-event-gamepad e))))) (add-event-listener! (current-window) "gamepaddisconnected" (procedure->external (lambda (e) (disconnect-gamepad! (gamepad-event-gamepad e))))) (add-event-listener! (current-document) "keydown" (procedure->external on-key-down)) (define (register-touch-control elem-id input-id) (add-event-listener! (get-element-by-id elem-id) "click" (procedure->external (lambda (e) (on-input-down input-id))))) (register-touch-control "dpad-left" 'left) (register-touch-control "dpad-right" 'right) (register-touch-control "dpad-down" 'down) (register-touch-control "dpad-up" 'up) (register-touch-control "button-a" 'undo) (resize-canvas) (request-animation-frame draw-callback) (timeout update-callback dt) (load-game!)