path: root/game.scm

(define-module (game)
  #: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)
  #:duplicates (merge-generics)
  #:export (launch-game))


;;;
;;; Constants
;;;

(define window-width 1280)
(define window-height 720)
(define game-width 640)
(define game-height 360)
(define player-display-name "")


;;;
;;; Assets
;;;

(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 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))


;;;
;;; Text Box
;;;

(define-class <text-box> (<widget>)
  (text #:accessor 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 text-box)
      #:position (vec2 6.0
                       (- (height text-box)
                          (font-line-height
                           (asset-ref
                            (font text-box))))))))


;;;
;;; 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))


;;;
;;; Game
;;;

(define-theme gui-theme
  (<widget> (font monogram-font))
  (<button> (background dialog-box-texture)
            (press-background dialog-box-texture))
  (<text-box> (background dialog-box-texture)))

(define-class <game> (<gui-scene>)
  (state #:accessor state #:init-value #f)
  (friendship #:accessor friendship #:init-value 0)
  (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)))

(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)))
    (set! (state game) 'dialog)
    (attach-to game c)
    (set! (text (& c name-margin name)) name)
    (set! (text (& c text-box)) line)
    (channel-get (click-channel game))
    (detach c)
    (set! (state game) old-state)))

(define-method (intro (game <game>))
  (set! (state game) 'intro)
  (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?")
  (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 (& game pin-pad display pin)))
        (when (< (string-length (text pin)) 6)
          (set! (text pin)
                (string-append (text pin)
                               (number->string n))))))
    (define (clear)
      (set! (text (& game pin-pad display pin)) ""))
    (define (submit)
      (channel-put! pin-channel (text (& game pin-pad display pin))))
    (set! (state game) 'pin-entry)
    (parameterize ((current-theme gui-theme))
      (attach-to game
                 ;; Hack to block clicks on devices in the room. Not working!
                 (make <margin-container>
                   #:name 'blocker
                   #:rank 98
                   #:width game-width
                   #:height game-height
                   #:listeners
                   `((click . ,(lambda (widget button)
                                 (pk 'hi)
                                 #t))))
                 (make <vertical-container>
                   #:name 'pin-pad
                   #:rank 99
                   #: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 <horizontal-container>
                           #:name 'display
                           #: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 blocker) (& game pin-pad))
      (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 door-lock sprite)) color)
    (set! (tint (& game terminal sprite)) color))
  (define (fade-in)
    (tween 60 black white tint-all
           #:interpolate color-lerp))
  (define (fade-out)
    (tween 60 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 (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 '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 '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>))
  (set! (state game) 'good-ending)
  (attach-to game
             (make <sprite>
               #:name 'darkness
               #:texture darkness)
             (make <label>
               #:name 'message
               #:font monogram-font
               #:text "this is the good ending. I am so proud of you. congratulations."
               #:align 'center
               #:vertical-align 'center
               #:position (vec2 (/ game-width 2.0) (/ game-height 2.0)))))

(define-method (bad-ending-1 (game <game>))
  (set! (state game) 'bad-ending-1)
  (attach-to game
             (make <sprite>
               #:name 'darkness
               #:texture darkness)
             (make <label>
               #:name 'message
               #:font monogram-font
               #:text "uh oh this is the bad ending. sorry, bucko."
               #:align 'center
               #:vertical-align 'center
               #:position (vec2 (/ game-width 2.0) (/ game-height 2.0)))))

(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-release (game <game>) button x y)
  (case (state game)
    ((dialog)
     (when (eq? button 'left)
       (channel-put! (click-channel game) #t)))
    ((good-ending bad-ending-1)
     (when (eq? button 'left)
       (detach-all game)
       (run-script game
         (intro game))))
    (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>
                                   #:title "Spring Lisp Game Jam 2021"
                                   #:width window-width
                                   #:height window-height))
               (lambda () (make <game>))))