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


;;;
;;; 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
  (<text-box> (background dialog-box-texture)
              (font monogram-font)))

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