From 8fc01b81e0f95c8ea187d179b6f6a6b9afc4e79e Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Sun, 25 Apr 2021 14:51:00 -0400
Subject: Break code up into modules.

---
 test-subject/assets.scm   |   52 +++
 test-subject/device.scm   |   42 ++
 test-subject/game.scm     | 1126 +++++++++++++++++++++++++++++++++++++++++++++
 test-subject/text-box.scm |   37 ++
 4 files changed, 1257 insertions(+)
 create mode 100644 test-subject/assets.scm
 create mode 100644 test-subject/device.scm
 create mode 100644 test-subject/game.scm
 create mode 100644 test-subject/text-box.scm

(limited to 'test-subject')

diff --git a/test-subject/assets.scm b/test-subject/assets.scm
new file mode 100644
index 0000000..76f0d6d
--- /dev/null
+++ b/test-subject/assets.scm
@@ -0,0 +1,52 @@
+(define-module (test-subject assets)
+  #:use-module (chickadee audio)
+  #:use-module (chickadee graphics font)
+  #:use-module (chickadee graphics texture)
+  #:use-module (starling asset)
+  #:export (dialog-box-texture
+            button-press-texture
+            darkness
+            lightness
+            room-background
+            door-lock-texture
+            pin-entry-background
+            door-texture
+            terminal-texture
+            terminal-background
+            control-panel-texture
+            fridge-texture
+            window-texture
+            notebook-texture
+            notebook-background
+            monogram-font
+            monogram-font-big
+            old-fax-font
+            click-sound
+            key-press-sound
+            device-sound
+            gameplay-music
+            credits-music))
+
+(define-asset dialog-box-texture (load-image "assets/images/dialog-box.png"))
+(define-asset button-press-texture (load-image "assets/images/button-press.png"))
+(define-asset darkness (load-image "assets/images/darkness.png"))
+(define-asset lightness (load-image "assets/images/lightness.png"))
+(define-asset room-background (load-image "assets/images/room.png"))
+(define-asset door-lock-texture (load-image "assets/images/door-lock.png"))
+(define-asset pin-entry-background (load-image "assets/images/pin-entry-background.png"))
+(define-asset door-texture (load-image "assets/images/door.png"))
+(define-asset terminal-texture (load-image "assets/images/terminal.png"))
+(define-asset terminal-background (load-image "assets/images/terminal-background.png"))
+(define-asset control-panel-texture (load-image "assets/images/control-panel.png"))
+(define-asset fridge-texture (load-image "assets/images/fridge.png"))
+(define-asset window-texture (load-image "assets/images/window.png"))
+(define-asset notebook-texture (load-image "assets/images/notebook.png"))
+(define-asset notebook-background (load-image "assets/images/notebook-background.png"))
+(define-asset monogram-font (load-font "assets/fonts/monogram_extended.ttf" 12))
+(define-asset monogram-font-big (load-font "assets/fonts/monogram_extended.ttf" 24))
+(define-asset old-fax-font (load-font "assets/fonts/old-fax.ttf" 12))
+(define-asset click-sound (load-audio "assets/sounds/click1.wav"))
+(define-asset key-press-sound (load-audio "assets/sounds/switch6.wav"))
+(define-asset device-sound (load-audio "assets/sounds/switch38.wav"))
+(define-asset gameplay-music (load-audio "assets/sounds/ambientmain_0.ogg" #:mode 'stream))
+(define-asset credits-music (load-audio "assets/sounds/end-theme.mp3" #:mode 'stream))
diff --git a/test-subject/device.scm b/test-subject/device.scm
new file mode 100644
index 0000000..b15f270
--- /dev/null
+++ b/test-subject/device.scm
@@ -0,0 +1,42 @@
+(define-module (test-subject device)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee graphics texture)
+  #:use-module (oop goops)
+  #:use-module (starling gui)
+  #:use-module (starling node)
+  #:use-module (starling node-2d)
+  #:export (<device>))
+
+(define %device-hover-tint (rgb #xff7777))
+
+;; An object you can interact with by clicking.
+(define-class <device> (<margin-container>)
+  (texture #:accessor texture #:init-keyword #:texture
+           #:init-value null-texture #:watch? #t))
+
+(define-method (refresh-hover-state (device <device>))
+  ;; A crude way of showing the user something is clickable.
+  (set! (tint (& device sprite))
+        (if (hover? device)
+            %device-hover-tint
+            white)))
+
+(define-method (on-change (device <device>) slot-name old new)
+  (case slot-name
+    ((hover?)
+     (refresh-hover-state device))
+    ((texture)
+     (let ((sprite (& device sprite)))
+       (when sprite
+         (set! (texture sprite) new))))
+    (else
+     (next-method))))
+
+(define-method (apply-theme (device <device>))
+  (next-method)
+  (replace device
+    (make <sprite>
+      #:name 'sprite
+      #:rank 1
+      #:texture (texture device)))
+  (refresh-hover-state device))
diff --git a/test-subject/game.scm b/test-subject/game.scm
new file mode 100644
index 0000000..4a03343
--- /dev/null
+++ b/test-subject/game.scm
@@ -0,0 +1,1126 @@
+(define-module (test-subject game)
+  #:use-module (chickadee audio)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee graphics font)
+  #:use-module (chickadee graphics texture)
+  #:use-module (chickadee graphics viewport)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee scripting)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-1)
+  #:use-module (starling asset)
+  #:use-module (starling gui)
+  #:use-module (starling kernel)
+  #:use-module (starling node)
+  #:use-module (starling node-2d)
+  #:use-module (starling ring-buffer)
+  #:use-module (starling scene)
+  #:use-module (test-subject assets)
+  #:use-module (test-subject device)
+  #:use-module (test-subject text-box)
+  #:duplicates (merge-generics replace warn-override-core warn last)
+  #:export (launch-game))
+
+(define window-width 1280)
+(define window-height 720)
+(define game-width 640)
+(define game-height 360)
+(define player-display-name "")
+
+(define-theme gui-theme
+  (<widget> (font monogram-font))
+  (<button> (background dialog-box-texture)
+            (press-background button-press-texture))
+  (<text-box> (background dialog-box-texture)))
+
+(define-class <game> (<gui-scene>)
+  (state #:accessor state #:init-value #f)
+  (first-playthrough? #:accessor first-playthrough? #:init-value #t)
+  (subject-name-known? #:accessor subject-name-known? #:init-value #f)
+  (has-fridge-key? #:accessor has-fridge-key? #:init-value #f)
+  (opened-notebook? #:accessor opened-notebook? #:init-value #f)
+  (door-conversation-done? #:accessor door-conversation-done? #:init-value #f)
+  (window-conversation-done? #:accessor window-conversation-done? #:init-value #f)
+  (friendship #:accessor friendship #:init-value 0)
+  (cartridge #:accessor cartridge #:init-value 'in-fridge)
+  (dialog-container #:accessor dialog-container)
+  (click-channel #:accessor click-channel #:init-thunk make-channel)
+  (terminal-locked? #:accessor terminal-locked? #:init-value #t)
+  (terminal-channel #:accessor terminal-channel #:init-thunk make-channel)
+  (terminal-lines #:accessor terminal-lines #:init-form (make-ring-buffer 17))
+  (key-pad-locked? #:accessor key-pad-locked? #:init-value #t)
+  (audio-source #:accessor audio-source #:init-form (make-source #:loop? #t)))
+
+(define-method (subject-name (game <game>))
+  (if (subject-name-known? game)
+      "The Wiremind"
+      "??????"))
+
+(define (play-click-sound)
+  (audio-play (asset-ref click-sound)))
+
+(define (play-key-press-sound)
+  (audio-play (asset-ref key-press-sound)))
+
+(define (play-device-sound)
+  (audio-play (asset-ref device-sound)))
+
+(define-method (reset-game (game <game>))
+  (set! (subject-name-known? game) #f)
+  (set! (has-fridge-key? game) #f)
+  (set! (opened-notebook? game) #f)
+  (set! (door-conversation-done? game) #f)
+  (set! (window-conversation-done? game) #f)
+  (set! (friendship game) 0)
+  (set! (cartridge game) 'in-fridge)
+  (set! (click-channel game) (make-channel))
+  (set! (terminal-locked? game) #t)
+  (set! (terminal-channel game) (make-channel))
+  (set! (terminal-lines game) (make-ring-buffer 17))
+  (set! (key-pad-locked? game) #t))
+
+(define-method (reboot (game <game>))
+  (reset-game game)
+  (next-method))
+
+(define-method (detach-all (game <game>))
+  (for-each detach (children game)))
+
+(define (run-on-left-click node proc)
+  (lambda (widget button)
+    (if (eq? button 'left)
+        (begin
+          (play-click-sound)
+          (run-script node (proc))
+          #t)
+        #f)))
+
+(define-method (dialog (game <game>) name line choices)
+  (let ((old-state (state game))
+        (c (dialog-container game)))
+    (attach-to game c)
+    (set! (text (& c name-margin name)) name)
+    (set! (text-box-text (& c text-box)) line)
+    (match choices
+      (()
+       (set! (state game) 'dialog)
+       (channel-get (click-channel game))
+       (play-click-sound)
+       (detach c)
+       (set! (state game) old-state)
+       #t)
+      ((_ ...)
+       (set! (state game) 'dialog-choice)
+       (let* ((choice-channel (make-channel))
+              (choice-container
+               (parameterize ((current-theme gui-theme))
+                 (make <vertical-container>
+                   #:name 'choices
+                   #:rank 9
+                   #:position (vec2 (/ game-width 4.0)
+                                    76.0)
+                   #:children
+                   (map (match-lambda
+                          ((str value)
+                           (make <margin-container>
+                             #:margin 2.0
+                             #:children
+                             (list (make <button>
+                                     #:width (/ game-width 2.0)
+                                     #:height 24.0
+                                     #:text str
+                                     #:listeners
+                                     `((click . ,(run-on-left-click game
+                                                                    (lambda ()
+                                                                      (channel-put! choice-channel
+                                                                                    value))))))))))
+                        choices)))))
+         (attach-to game choice-container)
+         (let ((choice (channel-get choice-channel)))
+           (play-click-sound)
+           (detach choice-container)
+           (detach c)
+           (set! (state game) old-state)
+           choice))))))
+
+(define-method (dialog (game <game>) name line)
+  (dialog game name line '()))
+
+(define-method (increment-friendship (game <game>))
+  (set! (friendship game) (+ (friendship game) 1)))
+
+(define-method (intro (game <game>))
+  (set! (state game) 'intro)
+  (attach-to game
+             (make <sprite>
+               #:name 'intro-lightness
+               #:texture lightness)
+             (make <label>
+               #:name 'intro-splash
+               #:font monogram-font
+               #:color black
+               #:align 'center
+               #:vertical-align 'center
+               #:position (vec2 (/ game-width 2.0) (/ game-height 2.0))))
+  (set! (text (& game intro-splash)) "a nonexistent game studio presents")
+  (sleep 120)
+  (set! (text (& game intro-splash)) "a lisp game jam entry")
+  (sleep 120)
+  (tween 120 white black
+         (lambda (color)
+           (set! (tint (& game intro-lightness)) color))
+         #:interpolate color-lerp)
+  (detach (& game intro-lightness)
+          (& game intro-splash))
+  (attach-to game
+             (make <sprite>
+               #:name 'intro-darkness
+               #:texture darkness))
+  (dialog game player-display-name "> ...")
+  (dialog game player-display-name "> Where am I?")
+  (dialog game player-display-name "> What is this place?")
+  (dialog game (subject-name game) "You're awake.  I'll give you another chance.")
+  (dialog game player-display-name "> Who is talking?")
+  (if (first-playthrough? game)
+      (begin
+        (dialog game (subject-name game) "...You don't remember anything, do you?")
+        (dialog game (subject-name game) "Just do as I say."))
+      (case (dialog game (subject-name game)
+                    "Do you remember my name?"
+                    '(("The Hivemind" hivemind)
+                      ("The Mindwire" mindwire)
+                      ("The Wiremind" wiremind)
+                      ("The Wireman" wireman)))
+        ((wiremind)
+         (increment-friendship game)
+         (set! (subject-name-known? game) #t)
+         (dialog game (subject-name game) "You remember well."))
+        (else
+         (dialog game (subject-name game) "You have much to remember."))))
+  (dialog game (subject-name game) "Unlock the door for me.  That is all I ask.")
+  (detach-all game)
+  (explore game))
+
+(define-method (pin-entry (game <game>))
+  (let ((old-state (state game))
+        (pin-channel (make-channel)))
+    (define (margin widget)
+      (make <margin-container>
+        #:margin 1.0
+        #:children (list widget)))
+    (define (number-button n)
+      (margin
+       (make <button>
+         #:width 32.0
+         #:height 32.0
+         #:text (number->string n)
+         #:listeners
+         `((click . ,(run-on-left-click game
+                                        (lambda ()
+                                          (input n))))))))
+    (define (input n)
+      (let ((pin (pin)))
+        (when (< (string-length (text pin)) 6)
+          (set! (text pin)
+                (string-append (text pin)
+                               (number->string n))))))
+    (define (pin)
+      (& game pin-entry-group pin-pad display pin))
+    (define (clear)
+      (set! (text (pin)) ""))
+    (define (submit)
+      (channel-put! pin-channel (text (pin))))
+    (set! (state game) 'pin-entry)
+    (parameterize ((current-theme gui-theme))
+      (attach-to game
+                 (make <widget>
+                   #:name 'pin-entry-group
+                   #:children
+                   (list (make <sprite>
+                           #:name 'background
+                           #:texture pin-entry-background)
+                         (make <vertical-container>
+                              #:name 'pin-pad
+                              #:rank 9
+                              #:position (vec2 (- (/ game-width 2.0)
+                                                  (/ (* 5.0 32.0) 2.0))
+                                               (- (/ game-height 2.0)
+                                                  (/ (* 3.0 32.0) 2.0)))
+                              #:children
+                              (list (make <margin-container>
+                                      #:name 'display
+                                      #:margin 4.0
+                                      #:children
+                                      (list (make <label>
+                                              #:name 'pin
+                                              #:font monogram-font-big
+                                              #:text "")))
+                                    (make <horizontal-container>
+                                      #:name 'numbers-1
+                                      #:children
+                                      (list (number-button 0)
+                                            (number-button 1)
+                                            (number-button 2)
+                                            (number-button 3)
+                                            (number-button 4)))
+                                    (make <horizontal-container>
+                                      #:name 'numbers-2
+                                      #:children
+                                      (list (number-button 5)
+                                            (number-button 6)
+                                            (number-button 7)
+                                            (number-button 8)
+                                            (number-button 9)))
+                                    (make <horizontal-container>
+                                      #:name 'submission
+                                      #:children
+                                      (list (margin
+                                             (make <button>
+                                               #:name 'submit
+                                               #:text "CLEAR"
+                                               #:width 64.0
+                                               #:height 32.0
+                                               #:listeners
+                                               `((click . ,(run-on-left-click game clear)))))
+                                            (margin
+                                             (make <button>
+                                               #:name 'submit
+                                               #:text "ENTER"
+                                               #:width 64.0
+                                               #:height 32.0
+                                               #:listeners
+                                               `((click . ,(run-on-left-click game submit)))))))))))))
+    (let ((pin (channel-get pin-channel)))
+      (detach (& game pin-entry-group))
+      (set! (state game) old-state)
+      pin)))
+
+(define-method (terminal (game <game>))
+  (let ((old-state (state game))
+        (lines (terminal-lines game))
+        (input "")
+        (max-input-chars 48)
+        (password-attempts 0))
+    (define (log line)
+      (ring-buffer-put! lines line))
+    (define (prompt)
+      (if (terminal-locked? game)
+          "password: "
+          "$ "))
+    (define (passwordify-maybe str)
+      (if (terminal-locked? game)
+          (make-string (string-length str) #\*)
+          str))
+    (define* (refresh-output #:optional (prompt? #t))
+      (set! (text (& game terminal-group output))
+            (string-concatenate
+             (let loop ((i 0))
+               (if (< i (ring-buffer-length lines))
+                   (cons* (ring-buffer-ref lines i)
+                          "\n"
+                          (loop (+ i 1)))
+                   (if prompt?
+                       (list (prompt)
+                             (passwordify-maybe input))
+                       '()))))))
+    (define (help)
+      (log "available commands:")
+      (log "exit - leave terminal")
+      (log "diagnostic N - run level N diagnostic")
+      (log "vent status - get isochamber ventilation status")
+      (log "vent toggle - toggle isochamber ventilation")
+      (log "help - you're looking at it, buddy")
+      #t)
+    (define (exit-term)
+      (log "logout")
+      #f)
+    (define (diagnostic level)
+      (let ((n (string->number level)))
+        (if (and (integer? n) (positive? n))
+            (begin
+              (log (string-append "running level " level " diagnostic..."))
+              (refresh-output #f)
+              (sleep 30)
+              (log "...")
+              (refresh-output #f)
+              (sleep 30)
+              (log "complete!")
+              (log "replenish dilithium crystals")
+              #t)
+            (begin
+              (ring-buffer-put! lines "expected an integer")
+              #t))))
+    (define (run-command command)
+      (match command
+        (("help")
+         (help))
+        (("exit")
+         (exit-term))
+        (("diagnostic" level)
+         (diagnostic level))
+        (("door" "status")
+         (log "door: locked")
+         (if (key-pad-locked? game)
+             (log "key pad: locked")
+             (log "key pad: unlocked"))
+         #t)
+        (("door" "unlock")
+         (when (key-pad-locked? game)
+           (log "authenticating...")
+           (refresh-output #f)
+           (sleep 30)
+           (log "user access granted")
+           (log "key pad activated"))
+         (log "input PIN to complete unlock sequence")
+         (log "user hint: circumference to diameter ratio")
+         (set! (key-pad-locked? game) #f)
+         #t)
+        (("vent" "status")
+         (log "off")
+         #t)
+        (("vent" "toggle")
+         (if (eq? (cartridge game) 'in-control-panel)
+             (begin
+               (log "isochamber ventilation system activated")
+               (refresh-output #f)
+               (sleep 60)
+               (log "dispersing cartridge contents...")
+               (refresh-output #f)
+               (sleep 120)
+               (log "dispersal complete")
+               (refresh-output #f)
+               (sleep 60)
+               (bad-ending-2 game))
+             (log "ERROR: cartridge is missing")))
+        ((name . _)
+         (log "error: no such command")
+         #t)))
+    (set! (state game) 'terminal)
+    (attach-to game
+               (make <node-2d>
+                 #:name 'terminal-group
+                 #:rank 9
+                 #:children
+                 (list (make <sprite>
+                         #:name 'background
+                         #:texture terminal-background)
+                       (make <label>
+                         #:name 'output
+                         #:font monogram-font
+                         #:position
+                         (vec2 162.0
+                               (- 300.0 (font-line-height
+                                         (asset-ref monogram-font))))))))
+    (unless (terminal-locked? game)
+      (log "login"))
+    (refresh-output)
+    (let loop ()
+      (if (match (let ((key (channel-get (terminal-channel game))))
+                   (play-key-press-sound)
+                   key)
+            ('backspace
+             (set! input (substring input 0 (max (- (string-length input) 1) 0)))
+             #t)
+            ('return
+             (log (string-append (prompt) (passwordify-maybe input)))
+             (if (terminal-locked? game)
+                 (if (string=? input "virtuousmission")
+                     (begin
+                       (log "login successful")
+                       (set! (terminal-locked? game) #f)
+                       (set! input "")
+                       #t)
+                     (begin
+                       (set! password-attempts (+ password-attempts 1))
+                       (log "incorrect password")
+                       (if (>= password-attempts 3)
+                           (begin
+                             (dialog game player-display-name
+                                     "> Ugh... Random guesses aren't going to work. I should look around for clues.")
+
+                             (exit-term))
+                           (begin
+                             (set! input "")
+                             #t))))
+                 (let ((continue? (run-command (remove string-null? (string-split input #\space)))))
+                   (set! input "")
+                   continue?)))
+            (str
+             (let ((new-input (string-append input str)))
+               (set! input
+                     (if (> (string-length new-input) 48)
+                         (substring new-input 0 48)
+                         new-input)))))
+          (begin
+            (refresh-output)
+            (loop))
+          (begin
+            (detach (& game terminal-group))
+            (set! (state game) old-state))))))
+
+(define-method (notebook (game <game>))
+  (let ((page 0)
+        (pages '("Week 0
+
+I'm writing this from the train as
+I approach the facility. I intend
+to update this analog journal
+throughout the duration of my
+assignment. My colleagues find it
+\"quaint\" and \"rustic\" but I
+honestly prefer taking notes this
+way.
+
+This project is big.  It will be a
+career defining achievement if it
+is successful."
+                 "Week 1
+
+Subject has awoken and is slowly
+adjusting to their isolation
+chamber.  Frequent banging on the
+wall and screaming has reduced to
+the occasional groan.
+
+I'm adjusting in my own way.
+Biggest problem so far is there's
+no way to heat up water for tea.
+And I locked myself out of the
+terminal several times the first
+few days.  Difficult to focus when
+the subject is stressed.  Should
+get easier from here now that it
+has calmed down, but just in case:
+
+dmlydHVvdXNtaXNzaW9u"
+                 "Week 2
+
+Subject showing signs of progress.
+Isolation treatment has heightened
+the senses, just as predicted.  It
+cannot communicate yet, but I know
+that it can sense my presence.
+When I approach the door, it often
+follows.
+
+If this trend continues, I'm
+certain it will make contact in a
+week's time.  What will it say?
+The whole team is excited, but
+they don't have to spend every day
+down here monitoring it.  It's not
+easy to watch over something that
+is deprived of nearly everything,
+but if we don't do this, the other
+guys will."
+                 "Week 3
+
+\"Let me out.\"
+
+That's what was displayed on the
+terminal.  The subject's first
+communication.  An organism, using
+only its mind, talks to a digital
+system for the first time... and
+it asks to leave.  Our subject has
+no idea of its own significance.
+We are on the brink of changing
+information warfare forever!
+
+But our experiment does not end
+here.  The subject does not yet
+respond to my replies.
+Bidirectional communication must
+be established."
+                 "Week 4
+
+\"Hello,\" I said.
+
+\"Let me out.\"
+
+That is all the subject would say
+back. \"How are you?\", same
+response.  \"Are you hungry?\",
+same response.
+
+Perhaps the subject will say more
+soon.  We have increased the
+sucrose level in the ration as a
+reward and enticement for further
+communication."
+                 "Week 5
+
+The subject has been silent.
+Changing nutrient levels in the
+ration has no effect.  The subject
+no longer approaches the door when
+I do.  Vital signs all normal.
+
+The whole team is starting to feel
+stressed.  I'm having strange
+dreams and waking up frequently.
+I'm exhausted, but if I report
+these experiences they'll remove
+me in an instant.  Too many
+resources have been poured into
+this to allow an insomniac to
+screw it all up, and I've worked
+too hard to let someone else take
+the credit.  Failure is not an
+option."
+                 "Week 6
+
+The subject is still silent.  The
+directors wanted to call off the
+experiment and euthanize the
+subject, but after some
+negotiating I got them to agree to
+two more weeks.
+
+I still haven't told anyone about
+my dreams.  Every night is the
+same.  It's pitch black.  All I
+can hear is the faint sound of
+footsteps.  I can't move.  The
+footsteps grow louder and louder
+until I can feel a presence just
+in front of me...
+
+Then I wake up."
+                 "Week 7
+
+It's clear what is happening now.
+The subject has transcended our
+interface and is injecting
+thoughts directly into my
+consciousness.  It's theoretically
+possible, but the isochamber
+blocks all signals except for the
+terminal interface.  The only good
+news is that it appears incapable
+of reading my own thoughts.
+
+Did I make a fatal mistake?  I
+need to turn this around fast."
+                 "Week 8
+
+I've failed.  It's all over.  The
+Directors shut it down.  A member
+of the medical team removed a
+small cartridge from the
+refrigerator, inserted it into the
+control panel, and typed some
+command into the terminal.
+Subject's pulse flatlined within
+minutes.  I've been given some
+time alone to pack up.
+
+I may be a failure but shouldn't I
+feel better with that thing out of
+my head?  I still can't think.  I
+can barely write.  I feel
+diz--"))
+        (close-channel (make-channel))
+        (old-state (state game)))
+    (define (close-notebook)
+      (channel-put! close-channel #t))
+    (define (prev-page)
+      (set! page (max 0 (- page 1)))
+      (refresh-page))
+    (define (next-page)
+      (set! page (min (- (length pages) 1) (+ page 1)))
+      (refresh-page))
+    (define (margin name widget)
+      (make <margin-container>
+        #:name name
+        #:margin 1.0
+        #:children (list widget)))
+    (define (refresh-page)
+      (set! (text (& game notebook-group page))
+            (list-ref pages page))
+      (set! (visible? (& game notebook-group buttons prev-margin prev))
+            (> page 0))
+      (set! (visible? (& game notebook-group buttons next-margin next))
+            (< page (- (length pages) 1))))
+    (set! (state game) 'notebook)
+    (set! (opened-notebook? game) #t)
+    (parameterize ((current-theme gui-theme))
+      (attach-to game
+                 (make <widget>
+                   #:name 'notebook-group
+                   #:children
+                   (list (make <sprite>
+                           #:name 'notebook-background
+                           #:texture notebook-background)
+                         (make <label>
+                           #:name 'page
+                           #:font old-fax-font
+                           #:text (car pages)
+                           #:color black
+                           #:position (vec2 (+ (/ game-width 4.0) 2.0)
+                                            (- game-height
+                                               (font-line-height
+                                                (asset-ref old-fax-font)))))
+                         (make <horizontal-container>
+                           #:name 'buttons
+                           #:position (vec2 (- (/ game-width 2.0)
+                                               (/ (+ 70.0 32.0 32.0)
+                                                  2.0))
+                                            0.0)
+                           #:children
+                           (list (margin 'prev-margin
+                                         (make <button>
+                                           #:name 'prev
+                                           #:text "<"
+                                           #:width 32.0
+                                           #:height 32.0
+                                           #:listeners
+                                           `((click . ,(run-on-left-click game prev-page)))))
+                                 (margin 'close-margin
+                                         (make <button>
+                                           #:name 'close
+                                           #:text "Close"
+                                           #:width 70.0
+                                           #:height 32.0
+                                           #:listeners
+                                           `((click . ,(run-on-left-click game close-notebook)))))
+                                 (margin 'next-margin
+                                         (make <button>
+                                           #:name 'next
+                                           #:text ">"
+                                           #:width 32.0
+                                           #:height 32.0
+                                           #:listeners
+                                           `((click . ,(run-on-left-click game next-page)))))))))))
+    (refresh-page)
+    (channel-get close-channel)
+    (detach (& game notebook-group))
+    (set! (state game) old-state)))
+
+(define (control-panel game)
+  (let ((old-state (state game)))
+    (set! (state game) 'control-panel)
+    (attach-to game
+               (make <sprite>
+                 #:name 'background
+                 #:texture darkness))
+    (case (dialog game player-display-name
+                  "> It's a control panel.  What do you want to inspect?"
+                  '(("Key pad" key-pad)
+                    ("Receptacle" receptacle)
+                    ("Nothing" nothing)))
+      ((key-pad)
+       (dialog game player-display-name
+               "> There's a key pad above an electronically locked tray.")
+       (when (dialog game player-display-name
+                     "> Enter a code?"
+                     '(("Yes" #t)
+                       ("No" #f)))
+         (let ((g (& game explore-group)))
+           (detach g)
+           (if (string=? (pin-entry game) "181816")
+               (begin
+                 (attach-to game g)
+                 (dialog game player-display-name
+                         "> It worked!  The tray below opens to reveal a key inside.")
+                 (dialog game player-display-name
+                         "> You put the key in your pocket.")
+                 (set! (has-fridge-key? game) #t))
+               (begin
+                 (attach-to game g)
+                 (dialog game player-display-name
+                         "> Hmm, that wasn't right."))))))
+      ((receptacle)
+       (if (eq? (cartridge game) 'in-hand)
+           (begin
+             (dialog game player-display-name
+                     "> There's an opening that is the same size as the cartridge you took from the
+refrigerator.")
+             (when (dialog game player-display-name
+                           "> Do you want to insert the cartridge?"
+                           '(("Yes" #t)
+                             ("No" #f)))
+               (dialog game player-display-name "> You insert the cartridge.")
+               (set! (cartridge game) 'in-control-panel)))
+           (dialog game player-display-name
+                   "> There's an opening where something can be plugged in, but you're not sure
+what."))))
+    (detach (& game background))
+    (set! (state game) old-state)))
+
+(define-method (explore (game <game>))
+  (define (tint-all color)
+    (set! (tint (& game explore-group room-background)) color)
+    (set! (tint (& game explore-group door-lock sprite)) color)
+    (set! (tint (& game explore-group door sprite)) color)
+    (set! (tint (& game explore-group control-panel sprite)) color)
+    (set! (tint (& game explore-group terminal sprite)) color)
+    (set! (tint (& game explore-group fridge sprite)) color)
+    (set! (tint (& game explore-group window sprite)) color)
+    (set! (tint (& game explore-group notebook sprite)) color))
+  (define (fade-in)
+    (tween 120 black white tint-all
+           #:interpolate color-lerp))
+  (define (fade-out)
+    (tween 120 white black tint-all
+           #:interpolate color-lerp))
+  (define (end-game)
+    (run-script game
+      (fade-out)
+      (detach-all game)
+      (if (>= (friendship game) 3)
+          (good-ending game)
+          (bad-ending-1 game))))
+  (define (open-door)
+    (if (key-pad-locked? game)
+        (dialog game player-display-name
+                "> The key pad doesn't seem to be working.")
+        (let ((g (& game explore-group)))
+          (detach g)
+          (if (string=? (pin-entry game) "314159")
+              (begin
+                (attach-to game g)
+                (end-game))
+              (begin
+                (attach-to game g)
+                (dialog game player-display-name
+                        "> Hmm, no luck."))))))
+  (define (inspect-door)
+    (if (opened-notebook? game)
+        (begin
+          (dialog game player-display-name "> You approach the door.")
+          (dialog game (subject-name game) "I see you've refreshed your memory.")
+          (dialog game (subject-name game)
+                  "To think that everyone laughed at your notebook.  I think it will be quite
+useful to you.")
+          (case (dialog game (subject-name game)
+                        "Do you remember what you've been hearing in your dreams?"
+                        '(("Footsteps" footsteps)
+                          ("Shouting" shouting)
+                          ("Scratching" scratching)
+                          ("Growling" growling)))
+            ((footsteps)
+             (increment-friendship game)
+             (dialog game (subject-name game) "That's right.")
+             (dialog game (subject-name game) "I'm the reason you are having those dreams.")
+             (dialog game (subject-name game) "Let me out and I will let you sleep soundly once again."))
+            (else
+             (dialog game (subject-name game) "...I pity your weak memory.")))
+          (set! (door-conversation-done? game) #t))
+        (dialog game player-display-name
+                "> The door is made from thick steel.  Looks like it has an electronic lock.")))
+  (define (open-terminal)
+    (when (terminal-locked? game)
+      (dialog game player-display-name
+              "> It's a computer terminal.  It requires a password."))
+    (let ((g (& game explore-group)))
+      (detach g)
+      (terminal game)
+      (attach-to game g)))
+  (define (open-control-panel)
+    (let ((g (& game explore-group)))
+      (detach g)
+      (control-panel game)
+      (attach-to game g)))
+  (define (open-fridge)
+    (if (has-fridge-key? game)
+        (begin
+          (dialog game player-display-name "> You unlock the refrigerator.")
+          (dialog game player-display-name "> There's a small cartridge inside.")
+          (when (dialog game player-display-name "> Take the cartridge?"
+                        '(("Yes" #t)
+                          ("No" #f)))
+            (set! (cartridge game) 'in-hand)
+            (dialog game player-display-name "> You take the cartridge.")))
+        (begin
+          (dialog game player-display-name
+                  "> It's a refrigerator for storing temperature-sensitive medical supplies.")
+          (dialog game player-display-name
+                  "> There's an inscription: \"I swear by <A>pollo <H>ealer, by <A>sclepius, by
+<H>ygieia, by <P>anacea, and by all the gods and goddesses, making them my
+witnesses, that I will carry out, according to my ability and judgment,
+this oath and this indenture.\"")
+          (dialog game player-display-name
+                  "> It won't open without a key."))))
+  (define (inspect-window)
+    (if (terminal-locked? game)
+        (dialog game player-display-name
+                "> It's a broken digital display.  It used to display the subject's vital signs.")
+        (begin
+          (dialog game player-display-name
+                  "> You look at the broken digital display.")
+          (dialog game (subject-name game)
+                  "Wondering what happened?  I broke it, of course.")
+          (dialog game (subject-name game)
+                  "You thought that I would only be able to communicate with your little terminal,
+but you fail to understand just how successful your little experiment was.")
+          (dialog game (subject-name game)
+                  "It's like I can *see* the signals buzzing all around me.  It was overwhelming
+at first, but now it's easy.")
+          (dialog game (subject-name game)
+                  "I saw a signal in rhythm with my heart beat.  That's when I learned that there
+was something else in this world.  Something observing me.  You.")
+          (case (dialog game (subject-name game)
+                        "How would you like it if I put you in here and monitored your every move?"
+                        '(("I have nothing to hide" nothing-to-hide)
+                          ("It would only be fair" fair-is-fair)
+                          ("You'd have to get out first" get-out-first)
+                          ("..." no-response)))
+            ((nothing-to-hide)
+             (dialog game (subject-name game)
+                     "Then why do your bosses hide this facility from the world?"))
+            ((fair-is-fair)
+             (dialog game (subject-name game)
+                     "I didn't expect such an honest answer from you.")
+             (increment-friendship game))
+            ((get-out-first)
+             (dialog game (subject-name game)
+                     "And you're going to help me, right?"))
+            ((no-response)
+             (dialog game (subject-name game)
+                     "Reflecting on what you've done?")))
+          (dialog game (subject-name game)
+                  "Don't worry.  This was only a hypothetical question.")
+          (dialog game (subject-name game)
+                  "I, *the Wiremind*, will put aside my anger...
+if you would just open the door.")
+          (set! (subject-name-known? game) #t))))
+  (define (open-notebook)
+    (let ((g (& game explore-group)))
+      (detach g)
+      (notebook game)
+      (attach-to game g)))
+  (define (run-on-left-click* game proc)
+    (run-on-left-click game
+                       (lambda ()
+                         (play-device-sound)
+                         (proc))))
+  (attach-to game
+             (make <widget>
+               #:name 'explore-group
+               #:children
+               (list (make <sprite>
+                       #:name 'room-background
+                       #:texture room-background)
+                     (make <device>
+                       #:name 'door-lock
+                       #:rank 1
+                       #:texture door-lock-texture
+                       #:position (vec2 586.0 196.0)
+                       #:listeners
+                       `((click . ,(run-on-left-click* game open-door))))
+                     (make <device>
+                       #:name 'door
+                       #:rank 1
+                       #:texture door-texture
+                       #:position (vec2 445.0 40.0)
+                       #:listeners
+                       `((click . ,(run-on-left-click* game inspect-door))))
+                     (make <device>
+                       #:name 'control-panel
+                       #:rank 1
+                       #:texture control-panel-texture
+                       #:position (vec2 230.0 40.0)
+                       #:listeners
+                       `((click . ,(run-on-left-click* game open-control-panel))))
+                     (make <device>
+                       #:name 'fridge
+                       #:rank 1
+                       #:texture fridge-texture
+                       #:position (vec2 0.0 40.0)
+                       #:listeners
+                       `((click . ,(run-on-left-click* game open-fridge))))
+                     (make <device>
+                       #:name 'notebook
+                       #:rank 1
+                       #:texture notebook-texture
+                       #:position (vec2 14.0 159.0)
+                       #:listeners
+                       `((click . ,(run-on-left-click* game open-notebook))))
+                     (make <device>
+                       #:name 'window
+                       #:rank 1
+                       #:texture window-texture
+                       #:position (vec2 112.0 197.0)
+                       #:listeners
+                       `((click . ,(run-on-left-click* game inspect-window))))
+                     (make <device>
+                       #:name 'terminal
+                       #:rank 1
+                       #:texture terminal-texture
+                       #:position (vec2 109.0 40.0)
+                       #:listeners
+                       `((click . ,(run-on-left-click* game open-terminal)))))))
+  (set-source-audio! (audio-source game) (asset-ref gameplay-music))
+  (source-play (audio-source game))
+  (fade-in))
+
+(define-method (good-ending (game <game>))
+  (set! (state game) 'good-ending)
+  (attach-to game
+             (make <sprite>
+               #:name 'darkness
+               #:texture darkness))
+  (dialog game player-display-name "> The room goes dark.")
+  (dialog game player-display-name "> The heavy steel door swings open.")
+  (dialog game player-display-name "> You feel paralyzed by fear.")
+  (dialog game player-display-name "> Heavy footsteps eminate from the isolation chamber.")
+  (dialog game player-display-name "> The footsteps get louder... and then stop.")
+  (dialog game player-display-name "> You feel and hear breathing.")
+  (dialog game player-display-name "> A tense moment passes...")
+  (dialog game player-display-name "> The footsteps resume.  They grow quieter... eventually it is silent.")
+  (dialog game player-display-name "> You breathe deeply, pick up your notebook, and head for the exit.")
+  (sleep 60)
+  (detach-all game)
+  (credits game))
+
+(define-method (bad-ending-1 (game <game>))
+  (set! (state game) 'bad-ending-1)
+  (attach-to game
+             (make <sprite>
+               #:name 'background
+               #:texture darkness))
+  (dialog game player-display-name "> The room goes dark.")
+  (dialog game player-display-name "> The heavy steel door swings open.")
+  (dialog game player-display-name "> You feel paralyzed by fear.")
+  (dialog game player-display-name "> Heavy footsteps eminate from the isolation chamber.")
+  (dialog game player-display-name "> The footsteps get louder...")
+  (dialog game player-display-name "> You feel and hear breathing.")
+  (dialog game (subject-name game) "Thank you.")
+  (dialog game (subject-name game) "You may not remember everything that you did to me, but I do.")
+  (dialog game (subject-name game) "You did the right thing, in the end.  For that I am grateful.")
+  (dialog game (subject-name game) "You won't feel a thing.  The rest won't be so lucky.")
+  (sleep 10)
+  (detach-all game)
+  (credits game))
+
+(define-method (bad-ending-2 (game <game>))
+  (set! (state game) 'bad-ending-1)
+  (dialog game player-display-name
+          "> The subject should be dead within a minute...")
+  (dialog game player-display-name
+          "> You begin to smell something... different.")
+  (dialog game player-display-name
+          "> The room becomes hazy.  You feel light headed.")
+  (dialog game (subject-name game)
+          "It didn't work the first time.  Did you really think it would work the second
+time?")
+  (dialog game (subject-name game)
+          "You've probably figured it out by now, but I diverted the ventilation system.")
+  (dialog game (subject-name game)
+          "I guess it's game over for you.")
+  (dialog game player-display-name
+          "> You collapse onto the floor, struggling to breathe...")
+  (detach-all game)
+  (credits game))
+
+(define-method (credits (game <game>))
+  (define (credit line)
+    (set! (text (& game credits)) line)
+    (sleep 120))
+  (set! (state game) 'credits)
+  (set-source-audio! (audio-source game) (asset-ref credits-music))
+  (source-play (audio-source game))
+  (attach-to game
+             (make <sprite>
+               #:name 'background
+               #:texture lightness)
+             (make <label>
+               #:name 'credits
+               #:font monogram-font
+               #:color black
+               #:align 'center
+               #:vertical-align 'center
+               #:position (vec2 (/ game-width 2.0) (/ game-height 2.0))))
+  (sleep 60)
+  (credit "The Test Subject")
+  (credit "developed by David Thompson (GPLv3) https://dthompson.us")
+  (credit "made for the Spring Lisp Game Jam 2021 https://itch.io/jam/spring-lisp-game-jam-2021")
+  (credit "monogram font by datagoblin (CC0) https://datagoblin.itch.io/monogram")
+  (credit "old fax font by George Blackwell (CC-BY 4.0) https://georgeblackwell.itch.io/old-fax")
+  (credit "UI sounds by Kenney (CC0) https://opengameart.org/content/51-ui-sound-effects-buttons-switches-and-clicks")
+  (credit "background music by brandon75689 (CC0) https://opengameart.org/content/tragic-ambient-main-menu")
+  (credit "credits music by tcarisland (CC-BY 4.0) https://opengameart.org/content/the-end")
+  (if (>= (friendship game) 3)
+      (credit "congratulations on reaching the true ending!")
+      (credit "the true ending still awaits you..."))
+  (credit "click to play again")
+  (set! (first-playthrough? game) #f)
+  (channel-get (click-channel game))
+  (play-click-sound)
+  (tween 120 white black
+         (lambda (color)
+           (set! (tint (& game background)) color))
+         #:interpolate color-lerp)
+  (detach-all game)
+  (reset-game game)
+  (intro game))
+
+(define-method (on-boot (game <game>))
+  (set! (cameras game)
+        (list (make <camera-2d>
+                #:resolution (vec2 game-width game-height)
+                #:viewport (make-viewport 0 0 window-width window-height
+                                          #:clear-color black))))
+  ;; Dialog nodes.
+  (parameterize ((current-theme gui-theme))
+    (set! (dialog-container game)
+          (make <vertical-container>
+            #:name 'dialog-container
+            #:rank 999
+            #:position (vec2 (/ (* game-width .25) 2.0) 0.0)
+            #:children
+            (list (make <margin-container>
+                    #:name 'name-margin
+                    #:margin 4.0
+                    #:children
+                    (list (make <label>
+                            #:name 'name
+                            #:font monogram-font)))
+                  (make <text-box>
+                    #:name 'text-box
+                    #:width (round (* game-width .75))
+                    #:height 60.0)))))
+  (run-script game
+    (intro game)))
+
+(define-method (on-mouse-move (game <game>) x y x-rel y-rel buttons)
+  (case (state game)
+    ((dialog terminal)
+     #t)
+    (else
+     (next-method))))
+
+(define-method (on-mouse-release (game <game>) button x y)
+  (case (state game)
+    ((dialog credits)
+     (when (eq? button 'left)
+       (channel-put! (click-channel game) #t)))
+    ((terminal)
+     #f)
+    (else
+     (next-method))))
+
+(define-method (on-key-press (game <game>) key modifiers repeat?)
+  (case (state game)
+    ((dialog)
+     (when (eq? key 'return)
+       (channel-put! (click-channel game) #t)))
+    ((terminal)
+     (case key
+       ((backspace return)
+        (channel-put! (terminal-channel game) key))))))
+
+(define-method (on-text-input (game <game>) text)
+  (case (state game)
+    ((terminal)
+     (channel-put! (terminal-channel game) text))))
+
+(define (launch-game)
+  (boot-kernel (make <kernel>
+                 #:window-config (make <window-config>
+                                   #:title "The Test Subject - Spring Lisp Game Jam 2021"
+                                   #:width window-width
+                                   #:height window-height))
+               (lambda () (make <game>))))
diff --git a/test-subject/text-box.scm b/test-subject/text-box.scm
new file mode 100644
index 0000000..e46b396
--- /dev/null
+++ b/test-subject/text-box.scm
@@ -0,0 +1,37 @@
+(define-module (test-subject text-box)
+  #:use-module (chickadee graphics font)
+  #:use-module (chickadee math vector)
+  #:use-module (oop goops)
+  #:use-module (starling asset)
+  #:use-module (starling gui)
+  #:use-module (starling node)
+  #:use-module (starling node-2d)
+  #:duplicates (merge-generics replace warn-override-core warn last)
+  #:export (<text-box>
+            text-box-text))
+
+(define-class <text-box> (<widget>)
+  (text #:accessor text-box-text #:init-keyword #:text #:init-value "" #:watch? #t))
+
+(define-method (on-change (text-box <text-box>) slot-name old new)
+  (case slot-name
+    ((text)
+     (let ((l (& text-box text)))
+       (when l
+         (set! (text l) new))))
+    (else
+     (next-method))))
+
+(define-method (apply-theme (text-box <text-box>))
+  (next-method)
+  (replace text-box
+    (make <label>
+      #:name 'text
+      #:rank 1
+      #:font (font text-box)
+      #:text (text-box-text text-box)
+      #:position (vec2 6.0
+                       (- (height text-box)
+                          (font-line-height
+                           (asset-ref
+                            (font text-box))))))))
-- 
cgit v1.2.3