foss-mmo/game.scm

;;; Copyright (C) 2024 David Thompson <dave@spritely.institute>
;;; Copyright (C) 2024 Juliana Sims <juli@incana.org>
;;;
;;; 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 <menu>
  (make-menu name items)
  menu?
  (name menu-name)
  (items menu-items))

;; Menu state

(define-record-type <menu-state>
  (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!)