summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--game.scm208
1 files 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>