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 replace warn-override-core warn last)
  #:export (launch-game))


;;;
;;; Constants
;;;

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


;;;
;;; Assets
;;;

(define-asset dialog-box-texture (load-image "assets/images/dialog-box.png"))
(define-asset button-press-texture (load-image "assets/images/button-press.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 pin-entry-background (load-image "assets/images/pin-entry-background.png"))
(define-asset door-texture (load-image "assets/images/door.png"))
(define-asset terminal-texture (load-image "assets/images/terminal.png"))
(define-asset terminal-background (load-image "assets/images/terminal-background.png"))
(define-asset control-panel-texture (load-image "assets/images/control-panel.png"))
(define-asset fridge-texture (load-image "assets/images/fridge.png"))
(define-asset window-texture (load-image "assets/images/window.png"))
(define-asset notebook-texture (load-image "assets/images/notebook.png"))
(define-asset notebook-background (load-image "assets/images/notebook-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))
(define-asset old-fax-font (load-font "assets/fonts/old-fax.ttf" 12))


;;;
;;; 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 button-press-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 (reset-game (game <game>))
  (set! (friendship game) 0)
  (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)))

(define-method (reboot (game <game>))
  (reset-game game)
  (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 choices)
  (let ((old-state (state game))
        (c (dialog-container game)))
    (attach-to game c)
    (set! (text (& c name-margin name)) name)
    (set! (text (& c text-box)) line)
    (match choices
      (()
       (set! (state game) 'dialog)
       (channel-get (click-channel game))
       (detach c)
       (set! (state game) old-state)
       #t)
      ((_ ...)
       (set! (state game) 'dialog-choice)
       (let* ((choice-channel (make-channel))
              (choice-container
               (parameterize ((current-theme gui-theme))
                 (make <vertical-container>
                   #:name 'choices
                   #:rank 9
                   #:position (vec2 (/ game-width 4.0)
                                    76.0)
                   #:children
                   (map (match-lambda
                          ((str value)
                           (make <margin-container>
                             #:margin 2.0
                             #:children
                             (list (make <button>
                                     #:width (/ game-width 2.0)
                                     #:height 24.0
                                     #:text str
                                     #:listeners
                                     `((click . ,(run-on-left-click game
                                                                    (lambda ()
                                                                      (channel-put! choice-channel
                                                                                    value))))))))))
                        choices)))))
         (attach-to game choice-container)
         (let ((choice (channel-get choice-channel)))
           (detach choice-container)
           (detach c)
           (set! (state game) old-state)
           choice))))))

(define-method (dialog (game <game>) name line)
  (dialog game name line '()))

(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?")
  (let ((choice (dialog game thing-display-name
                        "Coke or Pepsi?"
                        '(("Coke" coke)
                          ("Pepsi" pepsi)))))
    (if (eq? choice 'coke)
        (begin
          (set! (friendship game) 3)
          (dialog game thing-display-name "Excellent choice!"))
        (dialog game thing-display-name "Ew gross")))
  (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 (pin)))
        (when (< (string-length (text pin)) 6)
          (set! (text pin)
                (string-append (text pin)
                               (number->string n))))))
    (define (pin)
      (& game pin-entry-group pin-pad display pin))
    (define (clear)
      (set! (text (pin)) ""))
    (define (submit)
      (channel-put! pin-channel (text (pin))))
    (set! (state game) 'pin-entry)
    (parameterize ((current-theme gui-theme))
      (attach-to game
                 (make <widget>
                   #:name 'pin-entry-group
                   #:children
                   (list (make <sprite>
                           #:name 'background
                           #:texture pin-entry-background)
                         (make <vertical-container>
                              #:name 'pin-pad
                              #:rank 9
                              #: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 <margin-container>
                                      #:name 'display
                                      #:margin 4.0
                                      #: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 pin-entry-group))
      (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)
        (password-attempts 0))
    (define (log line)
      (ring-buffer-put! lines line))
    (define (prompt)
      (if (terminal-locked? game)
          "password: "
          "$ "))
    (define (passwordify-maybe str)
      (if (terminal-locked? game)
          (make-string (string-length str) #\*)
          str))
    (define* (refresh-output #:optional (prompt? #t))
      (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)))
                   (if prompt?
                       (list (prompt)
                             (passwordify-maybe input))
                       '()))))))
    (define (help)
      (when (zero? (random 2))
        (log "quit wasting time!! open the door!!"))
      (log "available commands:")
      (log "exit - leave terminal")
      (log "diagnostic N - run level N diagnostic")
      (log "help - you're looking at it, buddy")
      #t)
    (define (exit-term)
      (log "logout")
      #f)
    (define (diagnostic level)
      (let ((n (string->number level)))
        (if (and (integer? n) (positive? n))
            (begin
              (log (string-append "running level " level " diagnostic..."))
              (refresh-output #f)
              (sleep 30)
              (log "...")
              (refresh-output #f)
              (sleep 30)
              (log "complete!")
              (log "replenish dilithium crystals")
              #t)
            (begin
              (ring-buffer-put! lines "expected an integer")
              #t))))
    (define (run-command command)
      (match command
        (("help")
         (help))
        (("exit")
         (exit-term))
        (("diagnostic" level)
         (diagnostic level))
        ((name . _)
         (log "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)
      (log "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
             (log (string-append (prompt) (passwordify-maybe input)))
             (if (terminal-locked? game)
                 (if (string=? input "password")
                     (begin
                       (log "login successful")
                       (set! (terminal-locked? game) #f)
                       (set! input "")
                       #t)
                     (begin
                       (set! password-attempts (+ password-attempts 1))
                       (log "incorrect password")
                       (if (>= password-attempts 3)
                           (begin
                             (dialog game player-display-name
                                     "> Ugh... Random guesses aren't going to work. I should look around for clues.")

                             (exit-term))
                           (begin
                             (set! input "")
                             #t))))
                 (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 (notebook (game <game>))
  (let ((page 0)
        (pages '("Captain's log: Stardate 2404.26
How many characters can I put on a
line before I need to wrap it?"
                 "This is a test"
                 "Also a test"))
        (close-channel (make-channel))
        (old-state (state game)))
    (define (close-notebook)
      (channel-put! close-channel #t))
    (define (prev-page)
      (set! page (max 0 (- page 1)))
      (refresh-page))
    (define (next-page)
      (set! page (min (- (length pages) 1) (+ page 1)))
      (refresh-page))
    (define (margin name widget)
      (make <margin-container>
        #:name name
        #:margin 1.0
        #:children (list widget)))
    (define (refresh-page)
      (set! (text (& game notebook-group page))
            (list-ref pages page))
      (set! (visible? (& game notebook-group buttons prev-margin prev))
            (> page 0))
      (set! (visible? (& game notebook-group buttons next-margin next))
            (< page (- (length pages) 1))))
    (set! (state game) 'notebook)
    (parameterize ((current-theme gui-theme))
      (attach-to game
                 (make <widget>
                   #:name 'notebook-group
                   #:children
                   (list (make <sprite>
                           #:name 'notebook-background
                           #:texture notebook-background)
                         (make <label>
                           #:name 'page
                           #:font old-fax-font
                           #:text (car pages)
                           #:color black
                           #:position (vec2 (+ (/ game-width 4.0) 2.0)
                                            (- game-height
                                               (font-line-height
                                                (asset-ref old-fax-font)))))
                         (make <horizontal-container>
                           #:name 'buttons
                           #:position (vec2 (- (/ game-width 2.0)
                                               (/ (+ 70.0 32.0 32.0)
                                                  2.0))
                                            0.0)
                           #:children
                           (list (margin 'prev-margin
                                         (make <button>
                                           #:name 'prev
                                           #:text "<"
                                           #:width 32.0
                                           #:height 32.0
                                           #:listeners
                                           `((click . ,(run-on-left-click game prev-page)))))
                                 (margin 'close-margin
                                         (make <button>
                                           #:name 'close
                                           #:text "Close"
                                           #:width 70.0
                                           #:height 32.0
                                           #:listeners
                                           `((click . ,(run-on-left-click game close-notebook)))))
                                 (margin 'next-margin
                                         (make <button>
                                           #:name 'next
                                           #:text ">"
                                           #:width 32.0
                                           #:height 32.0
                                           #:listeners
                                           `((click . ,(run-on-left-click game next-page)))))))))))
    (refresh-page)
    (channel-get close-channel)
    (detach (& game notebook-group))
    (set! (state game) old-state)))

(define-method (explore (game <game>))
  (define (tint-all color)
    (set! (tint (& game explore-group room-background)) color)
    (set! (tint (& game explore-group door-lock sprite)) color)
    (set! (tint (& game explore-group door sprite)) color)
    (set! (tint (& game explore-group control-panel sprite)) color)
    (set! (tint (& game explore-group terminal sprite)) color)
    (set! (tint (& game explore-group fridge sprite)) color)
    (set! (tint (& game explore-group window sprite)) color)
    (set! (tint (& game explore-group
                   notebook 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)
    (let ((g (& game explore-group)))
      (detach g)
      (if (string=? (pin-entry game) "314159")
          (end-game)
          (begin
            (attach-to game g)
            (dialog game player-display-name
                    "> Hmm, no luck.")))))
  (define (inspect-door)
    (dialog game player-display-name
            "> The door is made from thick steel. Looks like it has an electronic lock."))
  (define (open-terminal)
    (let ((g (& game explore-group)))
      (detach g)
      (terminal game)
      (attach-to game g)))
  (define (open-control-panel)
    (dialog game player-display-name
            "> Oooh, knobs and blinking lights."))
  (define (open-fridge)
    (dialog game player-display-name
            "> Any leftovers in here?"))
  (define (inspect-window)
    (dialog game player-display-name
            "> The window is covered in some sort of film and I can't see through it."))
  (define (open-notebook)
    (let ((g (& game explore-group)))
      (detach g)
      (notebook game)
      (attach-to game g)))
  (attach-to game
             (make <widget>
               #:name 'explore-group
               #:children
               (list (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 'door
                       #:rank 1
                       #:texture door-texture
                       #:position (vec2 445.0 40.0)
                       #:listeners
                       `((click . ,(run-on-left-click game inspect-door))))
                     (make <device>
                       #:name 'control-panel
                       #:rank 1
                       #:texture control-panel-texture
                       #:position (vec2 230.0 40.0)
                       #:listeners
                       `((click . ,(run-on-left-click game open-control-panel))))
                     (make <device>
                       #:name 'fridge
                       #:rank 1
                       #:texture fridge-texture
                       #:position (vec2 0.0 40.0)
                       #:listeners
                       `((click . ,(run-on-left-click game open-fridge))))
                     (make <device>
                       #:name 'notebook
                       #:rank 1
                       #:texture notebook-texture
                       #:position (vec2 14.0 159.0)
                       #:listeners
                       `((click . ,(run-on-left-click game open-notebook))))
                     (make <device>
                       #:name 'window
                       #:rank 1
                       #:texture window-texture
                       #:position (vec2 112.0 197.0)
                       #:listeners
                       `((click . ,(run-on-left-click game inspect-window))))
                     (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-move (game <game>) x y x-rel y-rel buttons)
  (case (state game)
    ((dialog terminal)
     #t)
    (else
     (next-method))))

(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)
       (reset-game game)
       (run-script game
         (intro game))))
    ((terminal)
     #f)
    (else
     (next-method))))

(define-method (on-key-press (game <game>) key modifiers repeat?)
  (case (state game)
    ((dialog)
     (when (eq? key 'return)
       (channel-put! (click-channel game) #t)))
    ((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>))))