diff --git a/game.scm b/game.scm index 0347e58..1a583e0 100644 --- a/game.scm +++ b/game.scm @@ -275,20 +275,54 @@ (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* (make-menu-state #f -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)) + (define-record-type - (make-menu-item name type payload) + (_make-menu-item name type payload) menu-item? (name menu-item-name) (type menu-item-type) (payload menu-item-payload)) +(define* (make-menu-item name type #:optional payload) + (_make-menu-item name type payload)) + ;; 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)))) @@ -301,64 +335,60 @@ (define menu:main (make-menu "Menu" (vector (make-menu-item "Select Level" 'menu menu:level-select) - (make-menu-item "Credits" 'credits #f)))) - -;; Menu state -(define *menu* #f) -(define *menu:index* -1) -(define *menu:page* 0) -(define *menu:history* '()) + (make-menu-item "Credits" 'credits)))) ;; Menu commands -(define (show-menu!) - (set! *menu* menu:main) - (set! *menu:index* -1) - (set! *menu:history* '()) - (set! *menu:page* 0)) - -(define (menu-up!) - (set! *menu:index* (max -1 (1- *menu:index*))) - (if (and (> *menu:page* 0) - (= *menu:index* (- (* *menu:page* menu:max-items) *menu:page* 1))) - (set! *menu:page* (1- *menu:page*)))) - -(define (menu-down!) - (set! *menu:index* (min (1- (vector-length (menu-items *menu*))) (1+ *menu:index*))) - (if (= *menu:index* (- (* (1+ *menu:page*) menu:max-items) *menu:page*)) - (set! *menu:page* (1+ *menu:page*)))) +(define* (show-menu! #:optional menu) + (set-menu! (or menu menu:main)) + (set-menu-index! -1) + (set-menu-page! 0) + (set-menu-history! '())) (define (hide-menu!) - (set! *menu* #f)) + (set-menu! #f)) + +(define (menu-up!) + (set-menu-index! (max -1 (1- (current-menu-index)))) + (if (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)))) + (if (= (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!) - (cond - ;; Back button - ((= *menu:index* -1) - (cond - ((null? *menu:history*) - (hide-menu!)) - (else - (let ((last (car *menu:history*))) - (set! *menu* (car last)) - (set! *menu:index* (cdr last))) - (set! *menu:history* (cdr *menu:history*))))) - (else - (let* ((item (vector-ref (menu-items *menu*) *menu:index*)) - (type (menu-item-type item)) - (payload (menu-item-payload item))) - (match type - ;; Sub menu - ('menu - (set! *menu:history* (cons (cons *menu* *menu:index*) *menu:history*)) - (set! *menu* payload) - (set! *menu:index* -1)) - ('level - (hide-menu!) - (load-level! payload)) - ('credits - (hide-menu!) - (set! *level-last* *level-idx*) - (load-level! (vector-length levels)))))))) + (if (= (current-menu-index) -1) + (pop-menu-history!) + (let* ((item (vector-ref (menu-items (current-menu)) (current-menu-index))) + (type (menu-item-type item)) + (payload (menu-item-payload item))) + (match type + ('menu + (push-menu-history!) + (set-menu! payload) + (set-menu-index! -1)) + ('level + (hide-menu!) + (load-level! payload)) + ('credits + (hide-menu!) + (set! *level-last* *level-idx*) + (load-level! (vector-length levels))))))) (define (reset-game!) (run-script @@ -699,8 +729,6 @@ (draw-tile context tileset id (vec2-x pos) (vec2-y pos)))))) -(define center (vec2 (* 10.0 tile-width) (* 7.0 tile-height))) - (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 @@ -709,13 +737,12 @@ (let* ((padding-y 1) (text-offset-y (* 0.75 tile-height)) (width 8) - (num-items (vector-length (menu-items *menu*))) + (num-items (vector-length (menu-items (current-menu)))) (height (+ 2 ;; Menu title + back/ellipses (* 2 padding-y) ;; Padding - (cond ;; Num items + ellispses - ((> num-items menu:max-items) - (1+ menu:max-items)) - (else num-items)))) + (if (> num-items menu:max-items) + (1+ menu:max-items) + num-items))) (r-start (- -2 padding-y)) (r-end (- (+ r-start height) padding-y))) (let row ((r r-start) @@ -731,18 +758,19 @@ (set-text-align! context "center") (set-font! context "normal 16px monogram") (set-fill-color! context "#fff") - (let ((r-index (- (+ r (* *menu:page* menu:max-items)) *menu:page*))) - (cond - ((= r r-start) - (fill-text context (menu-name *menu*) (vec2-x center) (+ y text-offset-y))) - ((and (>= r -1) (< r-index num-items) (< r r-end)) - (let* ((item (or (and (= r -1) (or (and (= *menu:page* 0) "Back") - "...")) - (and (= r (1- r-end)) (< r-index (1- num-items)) "...") - (menu-item-name (vector-ref (menu-items *menu*) r-index)))) - (text (string-append (or (and (= r-index *menu:index*) "▸ ") " ") - item))) - (fill-text context text (vec2-x center) (+ y text-offset-y)))))) + (let ((r-index (- (+ r (* (current-menu-page) menu:max-items)) (current-menu-page)))) + (if (= r r-start) + (fill-text context (menu-name (current-menu)) (vec2-x center) (+ y text-offset-y)) + (if (and (>= r -1) (< r-index num-items) (< r r-end)) + (let* ((item (cond + ((= r -1) + (if (= (current-menu-page) 0) "Back" "...")) + ((and (= r (1- r-end)) (< r-index (1- num-items))) + "...") + (else + (menu-item-name (vector-ref (menu-items (current-menu)) r-index))))) + (text (string-append (if (= r-index (current-menu-index)) "▸ " " ") item))) + (fill-text context text (vec2-x center) (+ y text-offset-y)))))) ;; Draw next row (set! r (1+ r)) (if (< r (+ r-start height)) @@ -891,7 +919,7 @@ (fill-text context "A -> undo" cx2 baseline)))) ('win (draw-win))) - (if *menu* (draw-menu)) + (if (current-menu) (draw-menu)) (draw-current-effect 'post) (request-animation-frame draw-callback))) (define draw-callback (procedure->external draw)) @@ -982,33 +1010,31 @@ (on-input-down 'undo)))))))) (define (on-input-down input) - (cond - (*menu* - (match input - ('up (menu-up!)) - ('down (menu-down!)) - ('confirm (menu-select!)) - ('menu (hide-menu!)))) - (else - (match *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!)))) - ;; Pressing any bound input resets the game. - ('win (cond - (*level-last* - (load-level! *level-last*) - (set! *level-last* #f)) - (else (reset-game!)))))))) + (if (current-menu) + (match input + ('up (menu-up!)) + ('down (menu-down!)) + ('confirm (menu-select!)) + ('menu (hide-menu!))) + (match *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!)))) + ;; Pressing any bound input resets the game. + ('win (if *level-last* + (begin + (load-level! *level-last*) + (set! *level-last* #f)) + (reset-game!)))))) ;; Canvas and event loop setup (define canvas (get-element-by-id "canvas")) diff --git a/modules/dom/canvas.scm b/modules/dom/canvas.scm index 08bdf07..ec00c14 100644 --- a/modules/dom/canvas.scm +++ b/modules/dom/canvas.scm @@ -29,6 +29,7 @@ set-text-align! clear-rect fill-rect + ;; stroke fill-text draw-image restore! @@ -72,6 +73,9 @@ (define-foreign draw-image "canvas" "drawImage" (ref extern) (ref extern) f64 f64 f64 f64 f64 f64 f64 f64 -> none) +;; (define-foreign stroke +;; "canvas" "stroke" +;; (ref extern) -> none) (define-foreign restore! "canvas" "restore" (ref extern) -> none)