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 (starling asset)
  #:use-module (starling gui)
  #:use-module (starling kernel)
  #:use-module (starling node)
  #:use-module (starling node-2d)
  #: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 scanner-texture (load-image "assets/images/scanner.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
;;;

;; 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 (on-change (device <device>) slot-name old new)
  (case slot-name
    ((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
      #:texture (texture 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 #:getter click-channel #:init-thunk make-channel))

(define-method (detach-all (game <game>))
  (for-each detach (children game)))

(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 . ,(lambda (widget button)
                       (if (eq? button 'left)
                           (begin
                             (input n)
                             #t)
                           #f)))))))
    (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.
                 (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 . ,(lambda (widget button)
                                                  (if (eq? button 'left)
                                                      (begin
                                                        (clear)
                                                        #t)
                                                      #f))))))
                                 (margin
                                  (make <button>
                                    #:name 'submit
                                    #:text "ENTER"
                                    #:width 64.0
                                    #:height 32.0
                                    #:listeners
                                    `((click . ,(lambda (widget button)
                                                  (if (eq? button 'left)
                                                      (begin
                                                        (submit)
                                                        #t)
                                                      #f))))))))))))
    (let ((pin (channel-get pin-channel)))
      (pk 'pin pin)
      (detach (& game blocker) (& game pin-pad))
      (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))
  (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))))
  (attach-to game
             (make <sprite>
              #:name 'room-background
              #:texture room-background)
             (make <device>
               #:name 'scanner
               #:rank 1
               #:texture scanner-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))))))
  (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
            #: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 game-width
                    #:height 50.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 (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>))))