diff options
Diffstat (limited to 'game.scm')
| -rw-r--r-- | game.scm | 208 |
1 files changed, 172 insertions, 36 deletions
@@ -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> |