foss-mmo/game.scm
Christine Lemmer-Webber 534e9c30b7
Add catboss-1 level
2024-05-25 14:54:14 -04:00

672 lines
21 KiB
Scheme

;;; Copyright (C) 2024 David Thompson <dave@spritely.institute>
;;;
;;; 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 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 level-1)
(game levels level-2)
(game levels level-3)
(game levels level-4)
(game levels catboss-1)
(game levels credits)
(game scripts)
(game tileset)
(game time)
(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 4)
(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: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"))
;; 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-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-level-1
;; load-level-2
;; load-level-3
;; load-level-4
load-catboss-1
))
(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)
(unless *current-effect*
(show-effect! (make-wipe-effect 0.15))))))
(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)
;; 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*)))
(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!)
(run-script
(lambda ()
(set! *level-idx* 0)
(save-game!)
(set! *state* 'interstitial)
(show-effect! (make-fade-out+in-effect 2.0))
(wait 60)
(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))
(('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))
(('electric-switch-off x y)
(play-sound-effect audio:electric-switch-off))
(('receive-electron x y)
(play-sound-effect audio:warp 0.25))
(('explosion x y)
(pk 'BOOM!))
(_ (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-syntax-rule (define-animation name (tile duration) ...)
(define name
(make-animation tileset (vector (make-frame tile duration) ...))))
(define-animation anim:player
(0 2.25)
(300 2.25)
(600 2.25)
(900 0.15))
(define-animation anim:electron-head
(4 .25)
(304 .25)
(604 .25)
(904 .25))
(define-animation anim:electron-tail
(5 .25)
(305 .25)
(605 .25)
(905 .25))
(define-animation anim:gem
(28 .25)
(328 .25)
(628 .25)
(928 .25))
(define-animation anim:ghost-gem
(49 .25)
(349 .25)
(649 .25)
(949 .25))
(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-tile id 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-tile context tileset id (- 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)
(draw-tile context tileset (+ 51 countdown) (vec2-x pos) (vec2-y pos)))
(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 id)
(let ((x (vec2-x pos))
(y (vec2-y pos)))
(draw-tile context tileset 2 x y)
(match direction
('right (draw-tile context tileset id x y))
('left (draw-rotated-tile id pos pi))
('up (draw-rotated-tile id pos (* pi 1.5)))
('down (draw-rotated-tile id 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 42))
(('or-gate pos direction state) (draw-logic-gate pos direction state 43))
(('xor-gate pos direction state) (draw-logic-gate pos direction 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-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)))))
(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 "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))
(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!))))
;; Pressing any bound key resets the game.
('win
(when (or
(string=? key key:left)
(string=? key key:right)
(string=? key key:up)
(string=? key key:down)
(string=? key key:undo)
(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!)