game: Fix talk interactions.HEADmain

This concludes, I think, the migration effort to the then-latest
version of Chickadee.

1 files changed, 293 insertions, 67 deletions

diff --git a/scenes/game.scm b/scenes/game.scm
index a9235aa..0f983a5 100644
--- a/scenes/game.scm
+++ b/scenes/game.scm
@@ -1,5 +1,5 @@
 ;;; The Inevitable Game
-;;; Copyright © 2018, 2021 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2018, 2021, 2023 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This program is free software: you can redistribute it and/or
 ;;; modify it under the terms of the GNU General Public License as
@@ -23,7 +23,7 @@
   #:use-module (chickadee math easings)
   #:use-module (chickadee math rect)
   #:use-module (chickadee math vector)
-  #:use-module ((chickadee graphics color) #:select (make-color))
+  #:use-module ((chickadee graphics color) #:select (make-color red))
   #:use-module (chickadee graphics text)
   #:use-module (chickadee graphics path)
   #:use-module (chickadee graphics sprite)
@@ -49,6 +49,8 @@
   (load-bitmap-font "assets/fonts/good_neighbors_starling.xml"))
 (define-asset music
   (load-audio "assets/sounds/birds.ogg" #:mode 'stream))
+(define-asset error-sample
+  (load-audio "assets/sounds/error.ogg"))
 
 (define location
   (let ((positions
@@ -72,12 +74,19 @@ map's positions layer."
 (define fade-box-fill (make-color 0 0 0 1.0))
 
 (define agenda (make-agenda))
-(define last-player-position
+(define *last-player-position*
   (location "player"))
 (define *player-previous-keys* (list))
+(define *player-talking?* #false)
+(define *player-wants-to-stop-talking?* #false)
+(define *player-resume-messages* (list))
 (define *player* #false)
 (define *reaper* #false)
+(define *world* (list *player* *reaper*))
 (define *layers* #false)
+(define *action-key* 'space)
+(define *current-message* #false)
+
 (define grid (make-grid 16))
 (define player-grid-x-offset 8)
 (define player-grid-y-offset 0)
@@ -85,6 +94,230 @@ map's positions layer."
 (define *background-music* #false)
 
 
+(define dialog-box
+  (with-style
+      ((fill-color (make-color 0 0 0 0.5)))
+    (fill (rectangle (vec2 0.0 0.0) %width 80))))
+(define dialog-selection-indicator
+  (translate (vec2 0 65)
+    (with-style
+        ((fill-color red))
+      (fill (rectangle (vec2 0.0 0.0) 5 10)))))
+
+(define* (render-text text #:key (y-offset 0))
+  "Split TEXT into lines according to the game font dimensions and
+draw the lines to the screen.  Return the number of lines."
+  (let ((lines (arrange-text text (asset-ref game-font)
+                             #:margin 4.0)))
+    (for-each (lambda (line i)
+                (draw-text line
+                           (vec2 4.0
+                                 (- 65 y-offset (* %line-height i)))
+                           #:font (asset-ref game-font)))
+              lines (iota (length lines)))
+    (length lines)))
+
+(define (render-messages messages)
+  "Print all messages.  Each message is split into lines, so this
+procedure keeps track of the vertical offset so far.  It returnes the
+total number of lines printed."
+  (fold (lambda (message n lines-so-far)
+          (match message
+            ((message text . flags)
+             (let ((lines-printed
+                    (render-text text
+                                 #:y-offset
+                                 (+ (* n %message-margin)
+                                    (* lines-so-far %line-height)))))
+               (+ lines-so-far lines-printed)))))
+        0                               ; no lines printed yet
+        messages
+        (iota (length messages))))
+
+(define (available-messages)
+  "Return the messages that the player can choose from in the current
+conversation."
+  (let ((who *player-talking?*))
+    (cond
+     ((or (not who)
+          *player-wants-to-stop-talking?*) '())
+     ((assoc-ref *player-resume-messages* (name who)) => list)
+     (else (accepted-messages who)))))
+
+(define (start-talking who)
+  (unless (equal? *player-talking?* who)
+    (set! *player-talking?* who)
+    (match (available-messages)
+      (()
+       ;; nothing to say!  Play error sound.
+       (audio-play (asset-ref error-sample))
+       (stop-talking))
+      (_ #true))))
+
+(define (stop-talking)
+  (when *player-talking?*
+    (change-sprite-animation *player-talking?* 'idle)
+    (set! *player-talking?* #false)
+    (set! *player-wants-to-stop-talking?* #false)
+    #true))
+
+(define (talk who message flags)
+  "Send MESSAGE to WHO and display the response.  FLAGS contain the
+#:resume message."
+  ;; Delete remembered resume point if it exists, because we want
+  ;; to only use them once.
+  (when (assoc-ref *player-resume-messages* (name who))
+    (set! *player-resume-messages*
+          (acons (name who) #false
+                 *player-resume-messages*)))
+  (and=> (member #:resume flags)
+         (match-lambda
+           ((#:resume (and (message text) pair))
+            (set! *player-resume-messages*
+                  (acons (name who) pair
+                         *player-resume-messages*))
+            (set! (accepted-messages who) (list message))
+            (set! *player-wants-to-stop-talking?* #true))))
+  (match (assoc-ref (conversations who) message)
+    ((text next)
+     (set! (speaking? who) #true)
+     (set! *player-talking?* who)
+     ;; Display new message.
+     (set! *current-message* text)
+     ;; Record continuations.
+     (set! (accepted-messages who) next)
+     (change-sprite-animation who 'talk))
+    ;; This should never happen, because there should always be a
+    ;; conversation matching a message.
+    (oops (pk 'oops #t))))
+
+
+(define* (fade direction #:key
+               (duration 0.5))
+  (apply tween duration
+         (append (case direction
+                   ((out) '(0.0 1.0))
+                   ((in)  '(1.0 0.0)))
+                 (list
+                  (lambda (alpha)
+                    (set! fade-box-fill
+                          (make-color 0 0 0 alpha)))))))
+
+(define (handle-movement player active released)
+  "Process movement keys by updating character animation and
+position."
+  ;; If the player has released any direction key stop animating
+  ;; movement in that direction.
+  (unless (null? released)
+    (walk player released 'stop))
+
+  ;; If the player still presses any direction key, animate movement
+  ;; in those directions.
+  (walk player (match active
+                 (() '(idle))
+                 (_ active)))
+
+  ;; Update player position and respond to position-dependent
+  ;; events.
+  (let ((vel (velocity player)))
+    (unless (and (zero? (vec2-x vel))
+                 (zero? (vec2-y vel)))
+      (vec2-copy! (position player) *last-player-position*)
+      (vec2-add! (position player) vel)
+
+      ;; We use the grid position here to keep the initial
+      ;; collision offset.
+      (let* ((grid-position (grid-rect-ref grid 'player))
+             (planned-grid-position
+              (vec2+ (vec2 (rect-left grid-position)
+                           (rect-bottom grid-position))
+                     vel)))
+        (grid-move grid 'player planned-grid-position
+                   (lambda (a b)
+                     ;; TODO: only slide if this is an obstacle
+                     slide)))
+      (let ((corrected-position (grid-rect-ref grid 'player)))
+        (set! (position player)
+              (vec2- (vec2 (rect-left corrected-position)
+                           (rect-bottom corrected-position))
+                     (vec2 player-grid-x-offset
+                           player-grid-y-offset)))))))
+
+(define (handle-talking keys)
+  "Handle keyboard input when in a dialog with another character."
+  (match keys
+    ((key . rest)
+     (let ((who *player-talking?*))
+       ;; Use arrow keys to select a message, hit action key to
+       ;; confirm the selection.
+       (match (available-messages)
+         ;; Nothing more to say, so just wait for the action key to
+         ;; be hit to dismiss the dialogue.
+         (()
+          (when (eq? *action-key* key)
+            (set! (speaking? who) #false)
+            (stop-talking)))
+         ((and ((and (message text . flags) selected) . rest) messages)
+          (cond
+           ;; Select previous message
+           ((eq? 'up key)
+            (set! (accepted-messages who)
+                  (append (list (last messages))
+                          (drop-right messages 1))))
+
+           ;; Select next message
+           ((eq? 'down key)
+            (set! (accepted-messages who)
+                  (append rest (list selected))))
+
+           ;; Submit selected message.
+           ((and (eq? *action-key* key)
+                 (not (speaking? who)))
+            (talk who message flags))
+
+           ;; Dismiss character's text.
+           ((and (eq? *action-key* key)
+                 (speaking? who))
+            (set! (speaking? who) #false)
+            (change-sprite-animation who 'pause))))
+         (_ (pk 'this-should-never-happen #t)))))
+    ;; Noting to be done here
+    (_ #true)))
+
+(define (teleport target-position)
+  "Teleport the player to TARGET-POSITION."
+  (vec2-copy! target-position (position *player*))
+  (vec2-copy! target-position *last-player-position*)
+  (grid-move grid 'player
+             (vec2+ (vec2 player-grid-x-offset
+                          player-grid-y-offset)
+                    target-position)
+             (const #true)))
+
+(define (handle-action)
+  "The action key was pressed and released.  Do something based on the
+kind of action item the player intersects with."
+  (let ((player-grid-position (grid-rect-ref grid 'player)))
+    (and=> (find (lambda (action-item)
+                   (rect-intersects? (cdr action-item) player-grid-position))
+                 (assoc-ref *layers* "actions"))
+           (lambda (action-item)
+             (match (map-object-name (first action-item))
+               ("enter-house"
+                (fade 'out)
+                ;; TODO: switch music
+                (teleport (location "house"))
+                (fade 'in))
+               ("exit-house"
+                (fade 'out)
+                ;; TODO: switch music
+                (teleport (location "exited-house"))
+                (fade 'in))
+               ("talk-to-reaper"
+                (start-talking *reaper*))
+               (_ (pk 'action action-item)))))))
+
+
 (define (load-scene)
   (set! *background-music*
         (make-source #:audio (asset-ref music)
@@ -130,75 +363,52 @@ map's positions layer."
                           (rect-height r))))
             (assoc-ref *layers* "collision"))
 
-  (with-agenda
-   agenda
-   (spawn-script
-    (lambda ()
-      (wait-until (any key-pressed? '(escape)))
-
-      ;; Fade out
-      (tween 2 0.0 1.0
-             (lambda (alpha)
-               (set! fade-box-fill
-                     (make-color 0 0 0 alpha))))
-      (throw 'switch-scene
-             (@ (scenes death) scene))))
-   (spawn-script
-    (lambda ()
-      (forever
-       (sleep 1)
-       ;; Stop any motion in a direction when the matching key has just
-       ;; been released.
-       (let ((released (filter key-released? *player-previous-keys*)))
-         (unless (null? released)
-           (walk *player* released 'stop)))
-
-       ;; Detect newly pressed keys.
-       (let ((active (filter key-pressed? '(left right up down))))
-         (walk *player* (match active
-                          (() '(idle))
-                          (_ active)))
-         (set! *player-previous-keys* active))
-
-       ;; Update player position and respond to position-dependent
-       ;; events.
-       (let ((vel (velocity *player*)))
-         (vec2-copy! world-position last-world-position)
-         (vec2-add! world-position vel)
-
-         ;; TODO
-         ;; ;; Reset when the new position is invalid.
-         ;; (when (collides? player game "collision")
-         ;;   (vec2-sub! pos vel))
-         ;; (and=> (collides? player game (items game))
-         ;;        ;; TODO: do something to the item
-         ;;        (match-lambda
-         ;;          (() #f)
-         ;;          (items (pk items))))
-         ))))
-
-   ;; Handle background noise fade in
-   (spawn-script
-    (lambda ()
-      (tween 2 0.0 1.0
-             (lambda (a)
-               (set-source-volume! *background-music* a))
-             #:ease ease-out-sine)))
-
-   ;; Fade in
-   (script
-    (tween 1 1.0 0.0
-           (lambda (alpha)
-             (set! fade-box-fill
-                   (make-color 0 0 0 alpha))))))
-  (current-agenda agenda))
+  (let ((agenda (make-agenda)))
+    (with-agenda agenda
+     (spawn-script
+      (lambda ()
+        (wait-until (any key-pressed? '(escape)))
+
+        ;; Fade out
+        (fade 'out #:duration 2)
+        (throw 'switch-scene
+               (@ (scenes death) scene))))
+
+     ;; Handle keyboard input
+     (spawn-script
+      (lambda ()
+        (forever
+         (let ((active (filter key-pressed? '(space left right up down)))
+               (released (filter key-released? *player-previous-keys*)))
+           (set! *player-previous-keys* active)
+
+           (if *player-talking?*
+               (handle-talking released)
+               (begin
+                 (when (member *action-key* released)
+                   (handle-action))
+                 (handle-movement *player*
+                                  (delete *action-key* active)
+                                  (delete *action-key* released)))))
+         (sleep 0.01))))
+
+     ;; Handle background noise fade in
+     (spawn-script
+      (lambda ()
+        (tween 5 0.0 1.0
+               (lambda (a)
+                 (set-source-volume! *background-music* a))
+               #:ease ease-out-sine)))
+
+     (script (fade 'in #:duration 1)))
+    (current-agenda agenda)))
 
 (define (draw-scene alpha)
   (define player-render-position
-    (vec2 (round (lerp (vec2-x last-player-position)
+    (vec2 (round (lerp (vec2-x *last-player-position*)
                        (vec2-x (position *player*))
                        alpha))
-          (round (lerp (vec2-y last-player-position)
+          (round (lerp (vec2-y *last-player-position*)
                        (vec2-y (position *player*))
                        alpha))))
 
@@ -235,6 +445,22 @@ map's positions layer."
                  #:camera camera
                  #:layers (list 3))
 
+  ;; Text bubble for dialog
+  (when *player-talking?*
+    (let ((who *player-talking?*))
+      (if (speaking? who)
+          (begin
+            (draw-canvas (make-canvas dialog-box))
+            (when *current-message*
+              (render-text *current-message*)))
+          (begin
+            ;; Show the dialog selector when it's the player's turn to
+            ;; speak.
+            (draw-canvas (make-canvas
+                          (superimpose dialog-box
+                                       dialog-selection-indicator)))
+            (render-messages (available-messages))))))
+
   ;; Vignette
   (draw-sprite (asset-ref vignette-image) (vec2 0 0))