diff --git a/game.js b/game.js index 47780a6..6d59abb 100644 --- a/game.js +++ b/game.js @@ -81,7 +81,12 @@ window.addEventListener("load", async () => { translate: (ctx, x, y) => ctx.translate(x, y), rotate: (ctx, angle) => ctx.rotate(angle), setTransform: (ctx, a, b, c, d, e, f) => ctx.setTransform(a, b, c, d, e, f), - setImageSmoothingEnabled: (ctx, enabled) => ctx.imageSmoothingEnabled = (enabled == 1) + setImageSmoothingEnabled: (ctx, enabled) => ctx.imageSmoothingEnabled = (enabled == 1), + measureText: (ctx, text) => ctx.measureText(text), + }, + textMetrics: { + actualBoundingBoxAscent: (metrics) => metrics.actualBoundingBoxAscent, + actualBoundingBoxDescent: (metrics) => metrics.actualBoundingBoxDescent, }, math: { random: () => Math.random() diff --git a/game.scm b/game.scm index 493aa18..d51b675 100644 --- a/game.scm +++ b/game.scm @@ -20,6 +20,7 @@ ;;; Code: (use-modules (dom canvas) + (dom text-metrics) (dom document) (dom element) (dom event) @@ -62,7 +63,8 @@ (math) (math rect) (math vector) - (scheme base)) + (scheme base) + (srfi srfi-1)) (define game-width 320.0) (define game-height 240.0) @@ -225,14 +227,6 @@ (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 @@ -287,6 +281,8 @@ (set-level! *level-idx*) (media-play audio:bg-music))))) +(define text-offset-y (* 0.75 tile-height)) + ;; Menu types (define-record-type @@ -396,6 +392,251 @@ (pop-menu-history!) ((cdr (vector-ref (menu-items (current-menu)) (current-menu-index)))))) + +;; Credits + +(define credits-margin 0.0) ;; lines +(define credits-pace 15.0) ;; ticks per line (inverse speed) +(define credits-start (+ game-height text-offset-y)) +(define credits-end text-offset-y) + +(define line-height + (let ((lh #f)) + (lambda () + (unless lh + (set-font! context "normal 16px monogram") + (let ((metrics (measure-text context "Aj"))) + (set! lh + (* (+ (text-metrics-actual-bounding-box-ascent metrics) + (text-metrics-actual-bounding-box-descent metrics)) + 1.25)))) + lh))) + +(define-record-type + (_make-credit lines draw update on-enter on-leave) + credit? + (lines credit-lines) + (draw credit-draw) + (update credit-update) + (on-enter credit-on-enter) + (on-leave credit-on-leave)) + +(define* (make-credit #:key (lines 1) + (draw (lambda (y) #f)) + (update (lambda (t) #f)) + (on-enter (lambda () #f)) + (on-leave (lambda () #f))) + (_make-credit lines draw update on-enter on-leave)) + +(define* (make-credit-group #:rest credits) + (let ((accumulate (lambda* (accessor #:key (init 0.0) preproc) + (fold (lambda (c sum) + (when preproc ((preproc c) sum)) + (+ sum (accessor c))) + init credits))) + (call (lambda (proc) + (lambda () + (map (lambda (c) ((proc c))) credits))))) + (make-credit + #:lines (accumulate credit-lines) + #:draw (lambda (top) + (accumulate credit-height #:init top #:preproc credit-draw)) + #:update (lambda (top) + (accumulate credit-height #:init top #:preproc credit-update)) + #:on-enter (call credit-on-enter) + #:on-leave (call credit-on-leave)))) + +(define (make-credit-text text) + (make-credit + #:draw + (lambda (y) + (set-fill-color! context "#fff") + (set-text-align! context "center") + (set-font! context "normal 16px monogram") + (fill-text context text + (* 0.7 game-width) y)))) + +(define (make-credit-underline text) + (make-credit-group + (make-credit-text text) + (make-credit-text (make-string (string-length text) #\-)))) + +(define* (make-credit-centering credit #:key (padding 6.0) (easing 4.0) + (on-enter-center (lambda () #f)) + (on-leave-center (lambda () #f))) + (let* ((pi 3.14159) + (offset 0.0) + (speed (/ (line-height) credits-pace)) + (center (/ (- (+ credits-start credits-end) (credit-height credit)) 2.0)) + (ease-height (* (line-height) easing)) + (ease-speed (lambda (y) (* speed (sin (/ y ease-height))))) + ;; Amount that credits scroll up during easing + (ease-travel (* ease-height (/ pi 2.0))) + ;; Start below center so that it eases right into the center + (beg (+ center (- ease-travel ease-height))) + (beg-mid (- beg ease-travel)) + (end-mid (- beg-mid (* (line-height) padding))) + (end (- end-mid ease-travel))) + (make-credit + #:lines (+ padding (* 2 easing) (credit-lines credit)) + #:draw (lambda (y) ((credit-draw credit) (+ y offset))) + #:update + ;; Remember that y is decreasing as credits rise up the screen + ;; toward y=0, so the comparators might seem to be flipped but + ;; that's how they need to be. + (lambda (y) + (when (and (<= y beg) (> y end)) + (cond + ((> y beg-mid) + ;; Accelerate + (set! offset (+ offset (ease-speed (- beg y))))) + ((> y end-mid) + ;; Match speed + (set! offset (+ offset speed)) + (when on-enter-center + (on-enter-center) + (set! on-enter-center #f))) + (else + ;; Decelerate + (when on-leave-center + (on-leave-center) + (set! on-leave-center #f)) + (set! offset (+ offset (ease-speed (- y end))))))) + ;; Call on-leave-center even if no easing is used + (when (and (<= y end) on-leave-center) + (on-leave-center) + (set! on-leave-center #f)) + ((credit-update credit) (+ y offset))) + #:on-enter (credit-on-enter credit) + #:on-leave (credit-on-leave credit)))) + +(define (make-credits) + (vector (make-credit-centering + (make-credit-group + (make-credit-text "Phew, you made it!") + (make-credit-text "Time to relax."))) + (make-credit-centering + (make-credit-group + (make-credit-text "Cirkoban was made by the") + (make-credit-text "Spritely Institute"))) + (make-credit-centering + (make-credit-text "https://spritely.institute")) + (make-credit-centering + (make-credit-group + (make-credit-underline "Game Design") + (make-credit-text "Christine Lemmer-Webber"))) + (make-credit-centering + (make-credit-group + (make-credit-underline "Level Design") + (make-credit-text "Christine Lemmer-Webber") + (make-credit-text "Juliana Sims") + (make-credit-text "David Thompson")) + #:on-enter-center (lambda () (pk "Level Design centering!!")) + #:on-leave-center (lambda () (pk "Level Design leaving center!!"))) + (make-credit-centering + (make-credit-group + (make-credit-underline "Pixel Art") + (make-credit-text "Christine Lemmer-Webber")) + #:easing 0 + #:on-enter-center (lambda () (pk "Pixel Art centering!!")) + #:on-leave-center (lambda () (pk "Pixel Art leaving center!!"))) + (make-credit-centering + (make-credit-group + (make-credit-underline "Music") + (make-credit-text "EncryptedWhispers") + (make-credit-text "Christine Lemmer-Webber"))) + (make-credit-centering + (make-credit-group + (make-credit-underline "Programming") + (make-credit-text "Juliana Sims") + (make-credit-text "David Thompson") + (make-credit-text "Amy Grinn"))) + (make-credit-centering + (make-credit-group + (make-credit-underline "Other") + (make-credit-text "monogram font by datagoblin"))) + (make-credit-centering + (make-credit-text "Thank you for playing!")))) + +(define-record-type + (make-credits-state credits top first-visible-index next-visible-index) + credits-state? + (credits credits-state-credits) + (top credits-state-top set-credits-state-top!) + (first-visible-index + credits-state-first-visible-index + set-credits-state-first-visible-index!) + (next-visible-index + credits-state-next-visible-index + set-credits-state-next-visible-index!)) + +(define *credits* #f) + +(define (credits) + (credits-state-credits *credits*)) +(define (credits-top) + (credits-state-top *credits*)) +(define (credits-first-visible-index) + (credits-state-first-visible-index *credits*)) +(define (credits-next-visible-index) + (credits-state-next-visible-index *credits*)) +(define (set-credits-top! top) + (set-credits-state-top! *credits* top)) +(define (set-credits-first-visible-index! index) + (set-credits-state-first-visible-index! *credits* index)) +(define (set-credits-next-visible-index! index) + (set-credits-state-next-visible-index! *credits* index)) +(define (credits-reset!) + (set! *credits* (make-credits-state (make-credits) credits-start 0 -1))) + +(define (load-credits!) + (credits-reset!) + (replace-game-state! 'credits) + (set! *actormap* (make-whactormap)) + (clear-snapshots!) + (with-goblins + (set! *level* (load-credits #f)) + (update-objects!))) + +(define (credit-height credit) + (* (credit-lines credit) (line-height))) + +(define (draw-credits) + (draw-level) + (let lp ((i (credits-first-visible-index)) + (y (credits-top))) + (when (and (< i (vector-length (credits))) + (<= y credits-start)) + (let ((c (vector-ref (credits) i))) + ((credit-draw c) y) + (lp (1+ i) (+ y (credit-height c) (* (line-height) + credits-margin))))))) + +(define (update-credits!) + (let ((i (credits-first-visible-index))) + (when (< i (vector-length (credits))) + ;; Update credits + (let lp ((i i) + (y (credits-top))) + (when (and (< i (vector-length (credits))) + (<= y credits-start)) + (let ((c (vector-ref (credits) i))) + ;; Call on-enter as credits enter the screen + (when (> i (credits-next-visible-index)) + ((credit-on-enter c)) + (set-credits-next-visible-index! i)) + ((credit-update c) y) + (lp (1+ i) (+ y (credit-height c) (* (line-height) credits-margin)))))) + ;; Remove credits as they leave the screen + (let* ((c (vector-ref (credits) i)) + (bottom (+ (credits-top) (credit-height c)))) + (when (< bottom credits-end) + (set-credits-top! (+ bottom (* (line-height) credits-margin))) + (set-credits-first-visible-index! (1+ i)) + ((credit-on-leave c)))) + ;; Advance credits + (set-credits-top! (- (credits-top) (/ (line-height) credits-pace)))))) + (define (reset-game!) (run-script (lambda () @@ -533,7 +774,9 @@ (maybe-poll-gamepad) (scheduler-tick! (current-scheduler)) (particle-pool-update! particles) - (timeout update-callback dt)) + (timeout update-callback dt) + (when (equal? (current-game-state) 'credits) + (update-credits!))) (define update-callback (procedure->external update)) ;; Rendering @@ -741,7 +984,6 @@ ;; + 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 @@ -786,7 +1028,7 @@ (vec2-x center) y-text)) (set-text-align! context "left") ;; indicator - (when (= (+ r r-page-offset) (current-menu-index)) + (when (= r-page (current-menu-index)) (fill-text context "▸" x-gutter y-text)) ;; Menu items (when (>= r -1) @@ -842,77 +1084,6 @@ (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)) diff --git a/modules/dom/canvas.scm b/modules/dom/canvas.scm index a75fc09..266eeda 100644 --- a/modules/dom/canvas.scm +++ b/modules/dom/canvas.scm @@ -39,7 +39,8 @@ translate! rotate! set-transform! - set-image-smoothing-enabled!)) + set-image-smoothing-enabled! + measure-text)) ;; HTMLCanvasElement (define-foreign get-context @@ -98,3 +99,6 @@ (define-foreign set-image-smoothing-enabled! "canvas" "setImageSmoothingEnabled" (ref extern) i32 -> none) +(define-foreign measure-text + "canvas" "measureText" + (ref extern) (ref string) -> (ref extern)) diff --git a/modules/dom/text-metrics.scm b/modules/dom/text-metrics.scm new file mode 100644 index 0000000..e5dce2d --- /dev/null +++ b/modules/dom/text-metrics.scm @@ -0,0 +1,34 @@ +;;; Copyright (C) 2025 Amy Grinn +;;; +;;; 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: +;;; +;;; HTML canvas TextMetrics interface bindings +;;; +;;; Code: + +(define-module (dom text-metrics) + #:pure + #:use-module (scheme base) + #:use-module (hoot ffi) + #:export (text-metrics-actual-bounding-box-ascent + text-metrics-actual-bounding-box-descent)) + +(define-foreign text-metrics-actual-bounding-box-ascent + "textMetrics" "actualBoundingBoxAscent" + (ref extern) -> i32) + +(define-foreign text-metrics-actual-bounding-box-descent + "textMetrics" "actualBoundingBoxDescent" + (ref extern) -> i32) diff --git a/modules/srfi/srf-1.scm b/modules/srfi/srf-1.scm new file mode 100644 index 0000000..26f8376 --- /dev/null +++ b/modules/srfi/srf-1.scm @@ -0,0 +1,3 @@ +(define-module (srfi srfi-1) + #:use-module ((scheme base) #:select (fold)) + #:re-export (fold))