From 44e96e43a8d98b6f4acc146b25e75a3795c10309 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Mon, 19 Apr 2021 23:08:57 -0400
Subject: Update game code.

---
 game.scm | 208 ++++++++++++++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 172 insertions(+), 36 deletions(-)

diff --git a/game.scm b/game.scm
index 7277322..edf43fc 100644
--- a/game.scm
+++ b/game.scm
@@ -7,11 +7,13 @@
   #: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)
   #:duplicates (merge-generics)
   #:export (launch-game))
@@ -35,7 +37,9 @@
 (define-asset dialog-box-texture (load-image "assets/images/dialog-box.png"))
 (define-asset darkness (load-image "assets/images/darkness.png"))
 (define-asset room-background (load-image "assets/images/room.png"))
-(define-asset scanner-texture (load-image "assets/images/scanner.png"))
+(define-asset door-lock-texture (load-image "assets/images/door-lock.png"))
+(define-asset terminal-texture (load-image "assets/images/terminal.png"))
+(define-asset terminal-background (load-image "assets/images/terminal-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))
 
@@ -75,13 +79,24 @@
 ;;; 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
@@ -94,7 +109,9 @@
   (replace device
     (make <sprite>
       #:name 'sprite
-      #:texture (texture device))))
+      #:rank 1
+      #:texture (texture device)))
+  (refresh-hover-state device))
 
 
 ;;;
@@ -111,11 +128,29 @@
   (state #:accessor state #:init-value #f)
   (friendship #:accessor friendship #:init-value 0)
   (dialog-container #:accessor dialog-container)
-  (click-channel #:getter click-channel #:init-thunk make-channel))
+  (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)))
+
+(define-method (reboot (game <game>))
+  (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))
+  (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
+          (run-script node (proc))
+          #t)
+        #f)))
+
 (define-method (dialog (game <game>) name line)
   (let ((old-state (state game))
         (c (dialog-container game)))
@@ -153,12 +188,9 @@
          #:height 32.0
          #:text (number->string n)
          #:listeners
-         `((click . ,(lambda (widget button)
-                       (if (eq? button 'left)
-                           (begin
-                             (input n)
-                             #t)
-                           #f)))))))
+         `((click . ,(run-on-left-click game
+                                        (lambda ()
+                                          (input n))))))))
     (define (input n)
       (let ((pin (& game pin-pad display pin)))
         (when (< (string-length (text pin)) 6)
@@ -172,7 +204,7 @@
     (set! (state game) 'pin-entry)
     (parameterize ((current-theme gui-theme))
       (attach-to game
-                 ;; Hack to block clicks on devices in the room.
+                 ;; Hack to block clicks on devices in the room. Not working!
                  (make <margin-container>
                    #:name 'blocker
                    #:rank 98
@@ -223,12 +255,7 @@
                                     #:width 64.0
                                     #:height 32.0
                                     #:listeners
-                                    `((click . ,(lambda (widget button)
-                                                  (if (eq? button 'left)
-                                                      (begin
-                                                        (clear)
-                                                        #t)
-                                                      #f))))))
+                                    `((click . ,(run-on-left-click game clear)))))
                                  (margin
                                   (make <button>
                                     #:name 'submit
@@ -236,21 +263,110 @@
                                     #:width 64.0
                                     #:height 32.0
                                     #:listeners
-                                    `((click . ,(lambda (widget button)
-                                                  (if (eq? button 'left)
-                                                      (begin
-                                                        (submit)
-                                                        #t)
-                                                      #f))))))))))))
+                                    `((click . ,(run-on-left-click game submit)))))))))))
     (let ((pin (channel-get pin-channel)))
-      (pk 'pin pin)
       (detach (& game blocker) (& game pin-pad))
-      (set! (state game) old-state))))
+      (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))
+    (define (prompt)
+      (if (terminal-locked? game)
+          "password: "
+          "$ "))
+    (define (passwordify-maybe str)
+      (if (terminal-locked? game)
+          (make-string (string-length str) #\*)
+          str))
+    (define (refresh-output)
+      (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)))
+                   (list (prompt)
+                         (passwordify-maybe input)))))))
+    (define (run-command command)
+      (match command
+        (("exit")
+         (ring-buffer-put! lines "logout")
+         #f)
+        (("diagnostic" level)
+         (let ((n (string->number level)))
+           (if (and (integer? n) (positive? n))
+               (begin
+                 (ring-buffer-put! lines (string-append "running level " level " diagnostic..."))
+                 (ring-buffer-put! lines "...")
+                 (ring-buffer-put! lines "complete!")
+                 (ring-buffer-put! lines "replenish dilithium crystals")
+                 #t)
+               (begin
+                 (ring-buffer-put! lines "expected an integer")
+                 #t))))
+        ((name . _)
+         (ring-buffer-put! lines "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)
+      (ring-buffer-put! lines "login"))
+    (refresh-output)
+    (let loop ()
+      (if (match (channel-get (terminal-channel game))
+            ('backspace
+             (set! input (substring input 0 (max (- (string-length input) 1) 0)))
+             #t)
+            ('return
+             (ring-buffer-put! lines (string-append (prompt) (passwordify-maybe input)))
+             (if (terminal-locked? game)
+                 (begin
+                   (if (string=? input "password")
+                       (begin
+                         (ring-buffer-put! lines "login successful")
+                         (set! (terminal-locked? game) #f))
+                       (ring-buffer-put! lines "incorrect password"))
+                   (set! input ""))
+                 (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 (explore (game <game>))
   (define (tint-all color)
     (set! (tint (& game room-background)) color)
-    (set! (tint (& game scanner sprite)) color))
+    (set! (tint (& game door-lock sprite)) color)
+    (set! (tint (& game terminal sprite)) color))
   (define (fade-in)
     (tween 60 black white tint-all
            #:interpolate color-lerp))
@@ -264,23 +380,30 @@
       (if (> (friendship game) 3)
           (good-ending game)
           (bad-ending-1 game))))
+  (define (open-door)
+    (if (string=? (pin-entry game) "314159")
+        (end-game)
+        (pk 'invalid-access-code)))
+  (define (open-terminal)
+    (terminal game))
   (attach-to game
              (make <sprite>
               #:name 'room-background
               #:texture room-background)
              (make <device>
-               #:name 'scanner
+               #:name 'door-lock
                #:rank 1
-               #:texture scanner-texture
+               #:texture door-lock-texture
                #:position (vec2 586.0 196.0)
                #:listeners
-               `((click . ,(lambda (widget button)
-                             (if (eq? button 'left)
-                                 (begin
-                                   (run-script game
-                                     (pin-entry game))
-                                   #t)
-                                 #f))))))
+               `((click . ,(run-on-left-click game open-door))))
+             (make <device>
+               #:name 'terminal
+               #:rank 1
+               #:texture terminal-texture
+               #:position (vec2 109.0 40.0)
+               #:listeners
+               `((click . ,(run-on-left-click game open-terminal)))))
   (fade-in))
 
 (define-method (good-ending (game <game>))
@@ -323,6 +446,7 @@
           (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
@@ -333,8 +457,8 @@
                             #:font monogram-font)))
                   (make <text-box>
                     #:name 'text-box
-                    #:width game-width
-                    #:height 50.0)))))
+                    #:width (round (* game-width .75))
+                    #:height 60.0)))))
   (run-script game
     (intro game)))
 
@@ -351,6 +475,18 @@
     (else
      (next-method))))
 
+(define-method (on-key-press (game <game>) key modifiers repeat?)
+  (case (state game)
+    ((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>
-- 
cgit v1.2.3