Merge branch 'menu' into 'main'

Have menu open and close with Space

See merge request spritely/cirkoban!1

game.js

@@ -67,6 +67,7 @@ window.addEventListener("load", async () => {
           getContext: (elem, type) => elem.getContext(type),
           setGlobalAlpha: (ctx, alpha) => ctx.globalAlpha = alpha,
           setFillColor: (ctx, color) => ctx.fillStyle = color,
+          setStrokeColor: (ctx, color) => ctx.strokeStyle = color,
           setFont: (ctx, font) => ctx.font = font,
           setTextAlign: (ctx, align) => ctx.textAlign = align,
           clearRect: (ctx, x, y, w, h) => ctx.clearRect(x, y, w, h),

game.scm

@@ -61,7 +61,8 @@
              (local-storage)
              (math)
              (math rect)
-             (math vector))
+             (math vector)
+             (scheme base))
 
 (define game-width 320.0)
 (define game-height 240.0)
@@ -105,7 +106,20 @@
 (define audio:bg-music (load-music "cirkoban"))
 
 ;; Game state
-(define *state* #f)
+(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)
@@ -132,6 +146,8 @@
    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
@@ -201,8 +217,8 @@
 (define (collected-gem? idx)
  (memq idx *gems*))
 
-(define (load-level! idx)
+(define (set-level! idx)
-  (set! *state* 'play)
+  (replace-game-state! 'play)
   (set! *actormap* (make-whactormap))
   (clear-snapshots!)
   (with-goblins
@@ -210,7 +226,7 @@
    (update-objects!)))
 
 (define (load-credits!)
-  (set! *state* 'win)
+  (replace-game-state! 'credits)
   (set! *actormap* (make-whactormap))
   (set-vec2-y! *credits-scroll* 0.0)
   (clear-snapshots!)
@@ -218,8 +234,7 @@
    (set! *level* (load-credits #f))
    (update-objects!)))
 
-(define (next-level!)
+(define (load-level! idx)
-  (let ((idx (+ *level-idx* 1)))
     ;; TODO: Maybe show a little achievement popup when all gems
     ;; are collected?
     (when (with-goblins ($ (level-actor *level*) 'gem-collected?))
@@ -228,17 +243,17 @@
         (begin
           (run-script
            (lambda ()
-             (set! *state* 'interstitial)
+             (replace-game-state! 'interstitial)
              (yield
               (lambda (k)
                 (show-effect! (make-fade-out+in-effect 1.0 k))))
              (set! *level-idx* idx)
              (save-game!)
-             (load-level! idx))))
+             (set-level! idx))))
         (begin
           (run-script
            (lambda ()
-             (set! *state* 'interstitial)
+             (replace-game-state! 'interstitial)
              (yield
               (lambda (k)
                 (show-effect! (make-fade-out+in-effect 2.0 k))))
@@ -248,7 +263,10 @@
              ;; text from showing up when resetting the game, set
              ;; level idx to non-zero during the credits.
              (set! *level-idx* -1)
-             (load-credits!)))))))
+             (load-credits!))))))
+
+(define (next-level!)
+  (load-level! (+ *level-idx* 1)))
 
 ;; Auto-save/load to local storage.
 (define (save-game!)
@@ -266,18 +284,127 @@
       ((idx gems)
        (set! *level-idx* idx)
        (set! *gems* gems)
-       (load-level! *level-idx*)
+       (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 ()
-     (set! *state* 'interstitial)
+     (replace-game-state! 'interstitial)
      (yield
       (lambda (k)
         (show-effect! (make-fade-out+in-effect 2.0 k))))
      (set! *level-idx* 0)
-     (load-level! 0))))
+     (set-level! 0))))
 
 (define (emit-pickup-particles x y)
   (run-script
@@ -607,6 +734,94 @@
              (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*)
@@ -620,7 +835,9 @@
       (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)))))
+      (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))
@@ -675,7 +892,7 @@
 (define credits-line-spacing 16.0)
 (define max-credits-scroll
   (+ game-height (* (- (vector-length credits) 9) credits-line-spacing)))
-(define (draw-win)
+(define (draw-credits)
   (draw-level)
   (set-fill-color! context "#ffffff")
   (set-text-align! context "center")
@@ -726,30 +943,13 @@
     (scale! context *canvas-scale* *canvas-scale*)
     (draw-current-effect 'pre)
 
-    (match *state*
+    (match (current-game-state)
       ((or 'play 'interstitial)
+       (draw-level))
+      ('menu
        (draw-level)
-       ;; Display input mappings on the title screen/first level.
+       (draw-menu))
-       (when (= *level-idx* 0)
+      ('credits (draw-credits)))
-         (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))))
-      ('win (draw-win)))
     (draw-current-effect 'post)
     (request-animation-frame draw-callback)))
 (define draw-callback (procedure->external draw))
@@ -761,6 +961,7 @@
 (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)))
@@ -776,7 +977,9 @@
      ((string=? key key:undo)
       (on-input-down 'undo))
      ((string=? key key:confirm)
-      (on-input-down 'confirm)))))
+      (on-input-down 'confirm))
+     ((string=? key key:menu)
+      (on-input-down 'menu)))))
 
 (define *gamepad* #f)
 (define *button:left* #f)
@@ -837,7 +1040,7 @@
              (on-input-down 'undo))))))))
 
 (define (on-input-down input)
-  (match *state*
+  (match (current-game-state)
     ('play
      (match input
        ('left (move-player 'left))
@@ -849,9 +1052,23 @@
         (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.
-    ('win (reset-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"))

modules/dom/canvas.scm

@@ -25,10 +25,12 @@
   #:export (get-context
             set-global-alpha!
             set-fill-color!
+            set-stroke-color!
             set-font!
             set-text-align!
             clear-rect
             fill-rect
+            stroke-rect
             fill-text
             draw-image
             restore!
@@ -51,6 +53,9 @@
 (define-foreign set-fill-color!
   "canvas" "setFillColor"
   (ref extern) (ref string) -> none)
+(define-foreign set-stroke-color!
+  "canvas" "setStrokeColor"
+  (ref extern) (ref string) -> none)
 (define-foreign set-font!
   "canvas" "setFont"
   (ref extern) (ref string) -> none)