From 2870a88536d2b515e8113b9ea96cdf6aaca381ab Mon Sep 17 00:00:00 2001
From: Amy Grinn <grinn.amy@gmail.com>
Date: Fri, 10 Jan 2025 12:36:55 -0500
Subject: [PATCH] Created update script in 'load-credits'
---
game.scm | 144 +++++++++++++++++++++++++++++++------------------------
1 file changed, 82 insertions(+), 62 deletions(-)
diff --git a/game.scm b/game.scm
index b130f73..e57b27d 100644
--- a/game.scm
+++ b/game.scm
@@ -227,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))
- (clear-snapshots!)
- (set! *credits-top* credits-start)
- (with-goblins
- (set! *level* (load-credits #f))
- (update-objects!)))
(define (load-level! idx)
;; TODO: Maybe show a little achievement popup when all gems
@@ -402,55 +394,46 @@
;; Credits
(define credits-margin 40.0) ;; pixels
-
-(define credits-speed 30.0) ;; frames per line (inverse speed)
-
+(define credits-pace 30.0) ;; frames per line (inverse speed)
(define credits-start (+ game-height (* 0.75 tile-height)))
(define credits-end (* 0.75 tile-height))
-(define *credits-top* credits-start)
-
-(define _line-height #f)
-(define (line-height)
- (unless _line-height
- (set-font! context "normal 16px monogram")
- (let ((metrics (measure-text context "Aj")))
- (set! _line-height
- (* (+ (text-metrics-actual-bounding-box-ascent metrics)
- (text-metrics-actual-bounding-box-descent metrics))
- 1.2))))
- _line-height)
+(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.2))))
+ lh)))
(define-record-type <credit>
- (_make-credit height draw)
+ (_make-credit lines draw)
credit?
- (height credit-height)
+ (lines credit-lines)
(draw credit-draw))
-(define* (make-credit #:key height draw)
- (_make-credit height draw))
+(define* (make-credit #:key (lines 1)
+ (draw (lambda (y) #f)))
+ (_make-credit lines draw))
(define* (make-credit-group #:rest credits)
(make-credit
- #:height (fold (lambda (c prev)
- (+ prev (credit-height c)))
- 0 credits)
+ #:lines (fold (lambda (c lines)
+ (+ lines (credit-lines c)))
+ 0 credits)
#:draw
(lambda (top)
- (do ((i 0 (1+ i))
- (y top (+ y (* (credit-height (list-ref credits i))
- (line-height)))))
- ((= i (length credits)))
- ((credit-draw (list-ref credits i)) y)))))
-
-(define* (make-credit-space #:optional (lines 1))
- (make-credit
- #:height lines
- #:draw (lambda (y) #f)))
+ (fold (lambda (c y)
+ ((credit-draw c) y)
+ (+ y (* (credit-lines c) (line-height))))
+ top credits))))
(define (make-credit-text text)
(make-credit
- #:height 1
#:draw
(lambda (y)
(set-fill-color! context "#fff")
@@ -462,8 +445,7 @@
(define (make-credit-underline text)
(make-credit-group
(make-credit-text text)
- (make-credit-text (make-string (string-length text)
- #\-))))
+ (make-credit-text (make-string (string-length text) #\-))))
(define credits
(vector (make-credit-group
@@ -472,8 +454,7 @@
(make-credit-group
(make-credit-text "Cirkoban was made by the")
(make-credit-text "Spritely Institute"))
- (make-credit-group
- (make-credit-text "https://spritely.institute"))
+ (make-credit-text "https://spritely.institute")
(make-credit-group
(make-credit-underline "Game Design")
(make-credit-text "Christine Lemmer-Webber"))
@@ -497,27 +478,66 @@
(make-credit-group
(make-credit-underline "Other")
(make-credit-text "monogram font by datagoblin"))
- (make-credit-space 4)
+ (make-credit #:lines 4)
(make-credit-text "Thank you for playing!")))
+(define-record-type <credits-state>
+ (make-credits-state top first-visible-index)
+ credits-state?
+ (top credits-state-top set-credits-state-top!)
+ (first-visible-index
+ credits-state-first-visible-index
+ set-credits-state-first-visible-index!))
+
+(define *credits* (make-credits-state credits-start 0))
+
+(define (credits-top)
+ (credits-state-top *credits*))
+(define (credits-first-visible-index)
+ (credits-state-first-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 (credit-height credit)
+ (+ (* (credit-lines credit) (line-height))
+ credits-margin))
+
(define (draw-credits)
(draw-level)
- (let ((height (lambda (c)
- (+ (* (credit-height c) (line-height))
- credits-margin)))
- (i 0)
- (y *credits-top*))
- ;; Ignore credits that are higher than the top of the game
- (while (and (< i (vector-length credits))
- (< y (- (height (vector-ref credits i))) credits-end))
- (set! y (+ y (height (vector-ref credits i))))
- (set! i (1+ i)))
- ;; Draw credits that are higher than the bottom of the game
- (while (and (< i (vector-length credits)) (<= y credits-start))
- ((credit-draw (vector-ref credits i)) y)
- (set! y (+ y (height (vector-ref credits i))))
- (set! i (1+ i))))
- (set! *credits-top* (- *credits-top* (/ (line-height) credits-speed))))
+ (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)))))))
+
+(define (load-credits!)
+ (replace-game-state! 'credits)
+ (set! *actormap* (make-whactormap))
+ (clear-snapshots!)
+ (with-goblins
+ (set! *level* (load-credits #f))
+ (update-objects!))
+ ;; Update function
+ (run-script
+ (lambda ()
+ (set-credits-top! credits-start)
+ (set-credits-first-visible-index! 0)
+ (while (< (credits-first-visible-index) (vector-length credits))
+ ;; Remove credits as they leave the screen and become invisible
+ (let ((bottom (+ (credits-top)
+ (credit-height (vector-ref
+ credits
+ (credits-first-visible-index))))))
+ (when (< bottom credits-end)
+ (set-credits-top! bottom)
+ (set-credits-first-visible-index! (1+ (credits-first-visible-index)))))
+ ;; Advance credits
+ (set-credits-top! (- (credits-top) (/ (line-height) credits-pace)))
+ (wait 1)))))
(define (reset-game!)
(run-script