path: root/scenes/game.scm

;;; The Inevitable Game
;;; Copyright © 2018, 2019, 2021 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 David Thompson <davet@gnu.org>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (scenes game)
  #:use-module (chickadee math easings)
  #:use-module (chickadee math rect)
  #:use-module (chickadee math vector)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics font)
  #:use-module ((chickadee graphics path) #:hide (move-to))
  #:use-module (chickadee graphics texture)
  #:use-module (chickadee graphics tiled)
  #:use-module ((sdl2 input keyboard) #:prefix sdl2:)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (engine assets)
  #:use-module (engine audio)
  #:use-module (engine node)
  #:use-module (engine node-2d)
  #:use-module (engine scene)
  #:use-module (engine shell)
  #:use-module (oop goops)
  ;; Game modules
  #:use-module ((scenes death) #:select (death))
  #:use-module (characters)
  #:use-module (characters lorenzo)
  #:use-module (characters reaper)
  #:use-module (utils)
  #:use-module (config)
  #:export (game))

(use-modules (chickadee)
             (chickadee scripting))


(define-class <stats> (<node-2d>)
  (object #:accessor object #:init-form #f #:init-keyword #:object))


(define-asset test-map (load-tile-map "assets/maps/01.tmx"))
(define-asset error-sample (load-sample "assets/sounds/error.ogg"))
(define-asset vignette-image (load-image "assets/images/vignette.png"))

(define-class <game> (<scene>)
  (status #:accessor status #:init-form 'playing)
  (tile-map #:accessor tile-map #:init-form test-map)
  (collision-hitbox #:getter collision-hitbox #:init-form (make-rect 0.0 0.0 0.0 0.0))
  ;; List of layers containing the shapes of objects
  (layers #:accessor layers #:init-form '()))

(define-class <top-layer> (<node-2d>)
  (tile-map #:accessor tile-map #:init-form test-map))

(define-asset game-font
  (load-bitmap-font "assets/fonts/good_neighbors_starling.xml"))

(define (location game name)
  "Look up the location for an object with the given NAME in the map's
positions layer."
  (let ((positions
         (object-layer-objects
          (tile-map-layer-ref (asset-ref (tile-map game)) "positions")))
        (offset (origin game)))
    (or (and=> (find (lambda (obj)
                       (equal? (map-object-name obj) name))
                     positions)
               (lambda (obj)
                 (let ((shape (map-object-shape obj)))
                   (vec2 (- (+ (vec2-x offset) (rect-x shape))
                            (/ (rect-width shape) 2))
                         (- (+ (vec2-y offset) (rect-y shape))
                            (/ (rect-height shape) 2))))))
        (vec2 0.0 0.0))))

(define-method (populate (game <game>))
  ;; XXX: Chickadee parses the object layer incorrectly, so all
  ;; objects are flipped vertically.  We use this to compute the
  ;; corrected shapes of layer objects only once.
  (set! (layers game)
        (map (lambda (layer-name)
               (cons layer-name
                     (map (lambda (obj)
                            (let ((r-wrong (map-object-shape obj)))
                              (cons obj
                                    (make-rect (rect-x r-wrong)
                                               (- (rect-y r-wrong) (rect-height r-wrong))
                                               (rect-width r-wrong)
                                               (rect-height r-wrong)))))
                          (object-layer-objects
                           (tile-map-layer-ref (asset-ref (tile-map game)) layer-name)))))
             '("food" "positions" "actions" "collision")))
  (let ((player (lorenzo #:position (location game "player"))))
    (list (reaper (location game "reaper"))
          (make <filled-rect>
            #:name 'hit
            #:region (make-rect 0.0 0.0 0.0 0.0)
            #:position (vec2 0 0)
            #:color (transparency 0.2))
          player
          (make <top-layer>
            #:name 'top-layer
            #:position (vec2 0.0 0.0))
          (make <stats>
            #:name 'stats #:object player
            #:position (vec2 10.0 (- %height 10.0))))))

(define-method (collides? (player <player>) (game <game>) layer-name)
  (let* ((pos (position player))
         (offset (origin game))
         (player-hitbox (hitbox player))
         (hitbox (collision-hitbox game))
         (hit-vis (region (child-ref game 'hit))))
    (set-rect-x! hitbox (+ (- (vec2-x offset)) (vec2-x pos) (rect-x player-hitbox)))
    (set-rect-y! hitbox (+ (- (vec2-y offset)) (vec2-y pos) (rect-y player-hitbox)))
    (set-rect-width! hitbox (rect-width player-hitbox))
    (set-rect-height! hitbox (rect-height player-hitbox))
    (any (match-lambda
           ((obj . rect)
            (and (rect-intersects? hitbox rect)
                 (begin
                   (set-rect-x! hit-vis (+ (rect-x rect) (vec2-x offset)))
                   (set-rect-y! hit-vis (+ (rect-y rect) (vec2-y offset)))
                   (set-rect-width! hit-vis (rect-width rect))
                   (set-rect-height! hit-vis (rect-height rect))
                   obj))))
         (assoc-ref (layers game) layer-name))))


(define-method (update (game <game>) dt)
  ;; Keep the player in the centre
  (let* ((player (child-ref game 'player))
         (pos (position player)))
    (move-to game
             (- 0 (vec2-x pos))
             (- 0 (vec2-y pos)))
    (move-to (child-ref game 'top-layer)
             (- 0 (vec2-x pos))
             (- 0 (vec2-y pos)))

    (or (and=> (talking? player)
               ;; Use arrow keys to select a message, hit action key to
               ;; confirm the selection.
               (lambda (who)
                 ;; Render the player messages in the selected order.
                 (unless (speaking? who)
                   (let ((bubble (child-ref (parent (parent player)) 'text-bubble))
                         (messages (available-messages player)))
                     (clear-messages bubble)
                     (fold (lambda (message n lines)
                             (match message
                               ((message text . flags)
                                (when (zero? n)
                                  (attach bubble
                                          (make <filled-rect>
                                            #:name 'dialog-selection-indicator
                                            #:region (make-rect 0.0 0.0 5 10)
                                            #:position (vec2 0 65)
                                            #:color red)))
                                (+ lines
                                   (render-text bubble text
                                                #:suffix message
                                                #:y-offset
                                                (+ (* n %message-margin)
                                                   (* lines %line-height)))))))
                           0
                           messages
                           (iota (length messages)))))
                 ;; Always end on #T to avoid passing through to the
                 ;; motion branch.
                 #t))

        ;; React to current key presses with motion.  We don't use the
        ;; on-key-press handler here, because it does not seem to behave
        ;; right when two keys are pressed at the same time (e.g. left
        ;; and up).
        (begin
          ;; Stop any motion in a direction when the matching key has just
          ;; been released.
          (let ((released (filter sdl2:key-released? (previous-key-presses player))))
            (unless (null? released)
              (walk player released 'stop)))

          ;; Detect newly pressed keys.
          (let ((active (fold (lambda (direction acc)
                                (if (sdl2:key-pressed? direction)
                                    (cons direction acc)
                                    acc))
                              '()
                              '(left right up down))))
            (if (null? active)
                (walk player '(idle))
                (walk player active))
            (set! (previous-key-presses player) active))

          ;; Update player position and respond to position-dependent
          ;; events.
          (let* ((pos (position player))
                 (vel (velocity player)))
            (vec2-add! pos vel)
            ;; Reset when the new position is invalid.
            (when (collides? player game "collision")
              (vec2-sub! pos vel)))))))

(define-method (die (game <game>))
  "Fade out and switch to death scene."
  (let ((fade (child-ref (parent game) 'fade-box)))
    (set! (status game) 'dying)
    (script
     (tween 60 0.0 1.0
            (lambda (alpha)
              (set! (color fade)
                    (make-color 0 0 0 alpha))))
     (switch-scene (root-node) (death)))))

(define-method (on-key-press (game <game>) key modifiers repeat?)
  (when (eq? (status game) 'playing)
    (let ((player (child-ref game 'player)))
      (when (eq? key 'q) (die game))
      (let ((who (talking? player)))
        (cond
         ((and (not who) (eq? 'space key) (not repeat?))
          (handle-action player))
         ((and who (not repeat?))
          (handle-talking player key)))))))

(define (handle-action player)
  "Check if the PLAYER is on any region of the map where an action can
be executed; if so, perform the action."
  (let* ((game (parent player))
         (fade (child-ref (parent game) 'fade-box)))
    (and=> (collides? player game "actions")
           (lambda (obj)
             (match (map-object-name obj)
               ("enter-house"
                (let ((house-pos (location game "house")))
                  (script
                   (tween 15 0.0 1.0
                          (lambda (alpha)
                            (set! (color fade)
                                  (make-color 0 0 0 alpha))))
                   (teleport player
                             (vec2-x house-pos)
                             (vec2-y house-pos))
                   ;; TODO: change music?
                   (pause-music)
                   (tween 15 1.0 0.0
                          (lambda (alpha)
                            (set! (color fade)
                                  (make-color 0 0 0 alpha)))))))
               ("exit-house"
                (let ((exited-house-pos (location game "exited-house")))
                  (script
                   (tween 15 0.0 1.0
                          (lambda (alpha)
                            (set! (color fade)
                                  (make-color 0 0 0 alpha))))
                   (teleport player
                             (vec2-x exited-house-pos)
                             (vec2-y exited-house-pos))
                   (resume-music)
                   (tween 15 1.0 0.0
                          (lambda (alpha)
                            (set! (color fade)
                                  (make-color 0 0 0 alpha)))))))
               ("talk-to-reaper"
                (start-talking player
                               (child-ref game 'reaper)))
               (_ #t))))))

(define (available-messages player)
  "Return the messages that PLAYER can choose from in the current
conversation."
  (let ((who (talking? player)))
    (cond
     ((or (not who)
          (wants-to-stop-talking? player)) '())
     ((assoc-ref (resume-messages player) (name who)) => list)
     (else (accepted-messages who)))))

(define (handle-talking player key)
  (define who (talking? player))
  ;; Use arrow keys to select a message, hit action key to
  ;; confirm the selection.
  (match (available-messages player)
    ;; Nothing more to say, so just wait for the action key to
    ;; be hit to dismiss the dialogue.
    (()
     (when (eq? 'space key)
       (set! (speaking? who) #f)
       (stop-talking player)))
    ((and ((and (message text . flags) selected) . rest) messages)
     (cond
      ;; Select previous message
      ((eq? 'up key)
       (set! (accepted-messages who)
             (append (list (last messages))
                     (drop-right messages 1)))
       (set! (selecting-message? player) 'up))

      ;; Select next message
      ((eq? 'down key)
       (set! (accepted-messages who)
             (append rest (list selected)))
       (set! (selecting-message? player) 'down))

      ;; Submit selected message.
      ((and (eq? 'space key)
            (not (speaking? who)))
       ;; Delete remembered resume point if it exists, because we want
       ;; to only use them once.
       (when (assoc-ref (resume-messages player) (name who))
         (set! (resume-messages player)
               (acons (name who) #f
                      (resume-messages player))))
       (and=> (member #:resume flags)
              (match-lambda
                ((#:resume (and (message text) pair))
                 (set! (resume-messages player)
                       (acons (name who) pair
                              (resume-messages player)))
                 (set! (accepted-messages who) (list message))
                 (set! (wants-to-stop-talking? player) #t))))
       (talk player who message))

      ;; Dismiss character's text.
      ((and (eq? 'space key)
            (speaking? who))
       (set! (speaking? who) #f)
       (change-animation (child-ref who 'sprite) 'pause))))
    (_ (pk 'this-should-never-happen #t))))

(define-method (talk (player <player>) (who <character>) message)
  "Send MESSAGE to WHO and display the response."
  (let ((bubble (child-ref (parent (parent player)) 'text-bubble)))
    (match (assoc-ref (conversations who) message)
      ((text next)
       (set! (speaking? who) #t)
       (set! (talking? player) who)
       (change-animation (child-ref who 'sprite) 'talk)

       ;; Clear any shown messages.
       (clear-messages bubble)

       ;; Display new message.
       (render-text bubble text)

       ;; Record continuations.
       (set! (accepted-messages who) next))
      ;; This should never happen, because there should always be a
      ;; conversation matching a message.
      (oops (pk 'oops #t)))))

(define-method (start-talking (player <player>) (who <character>))
  (unless (equal? (talking? player) who)
    (set! (talking? player) who)
    (if (null? (available-messages player))
        ;; nothing to say!  Play error sound.
        (begin
          (play-sample (asset-ref error-sample))
          (stop-talking player))
        ;; Prepare empty text bubble
        (let ((bubble (child-ref (parent (parent player)) 'text-bubble)))
          (clear-messages bubble)
          (set! (visible? bubble) #t)))))

(define-method (stop-talking (player <player>))
  (and=> (talking? player)
         (lambda (who)
           (let ((sprite (child-ref who 'sprite)))
             (change-animation sprite 'idle))
           (set! (visible? (child-ref (parent (parent player)) 'text-bubble)) #f)
           (set! (talking? player) #f)
           (set! (wants-to-stop-talking? player) #f))))

(define* (render-text bubble text #:key (y-offset 0) (suffix '-text))
  "Fill the bubble with lines of text.  Return the number of lines."
  (let ((lines (arrange-text text (asset-ref game-font)
                             #:margin 4.0)))
    (for-each (lambda (line i)
                (attach bubble (make <label>
                                 #:name (symbol-append 'dialog-line-
                                                       (string->symbol
                                                        (number->string i))
                                                       suffix)
                                 #:font game-font
                                 #:text line
                                 #:position (vec2 4.0
                                                  (- 65 y-offset (* %line-height i))))))
              lines
              (iota (length lines)))
    (length lines)))

(define (clear-messages bubble)
  "Remove all dialog labels and markers from the text bubble."
  (for-each (lambda (node)
              (when (string-prefix? "dialog" (symbol->string (name node)))
                (detach node)))
            (children bubble)))


(define-method (draw (stats <stats>) alpha)
  (let* ((pos (position stats))
         (x (vec2-x pos))
         (y (vec2-y pos))
         (step 5)
         (thickness 2)
         (properties (list lifetime
                           happiness
                           weight
                           music))
         (player (object stats)))
    (let ((painters
           (map (lambda (property index)
                  (let* ((value (property player))
                         (start (vec2 x (- y (* step index))))
                         (end-y (- y (* step index)))
                         (end   (vec2 (+ x 100) end-y)))
                    (with-style
                     ((stroke-color red)
                      (stroke-width thickness))
                     (stroke
                      (line start end)))
                    (when (> value 0)
                      (with-style
                       ((stroke-color green)
                        (stroke-width thickness))
                       (stroke
                        (line start (vec2 (+ x value) end-y)))))))
                properties
                (iota (length properties)))))
      (draw-canvas
       (make-canvas (apply superimpose painters))))))

(define-method (draw (game <game>) alpha)
  (draw-tile-map (asset-ref (tile-map game))
                 #:position (position game)
                 #:layers (list 0 1 2)))

(define-method (draw (top-layer <top-layer>) alpha)
  (draw-tile-map (asset-ref (tile-map top-layer))
                 #:position (position top-layer)
                 ;; NOTE: this is the 4th tile layer; object layers
                 ;; are ignored.
                 #:layers (list 3)))


(define (game)
  (let ((game (make <game>
                #:origin (vec2 (- (/ %width 2))
                               (- (/ %height 2))))))
    (set-music-volume! 1.0)
    (set-sample-volume! 1.0)
    (play-music (load-music "assets/sounds/birds.ogg") #:loop? #t)
    (with-agenda
     (agenda game)
     (schedule-every
      120 (lambda _
            (let* ((player (child-ref game 'player))
                   (current-lifetime (lifetime player)))
              (if (< current-lifetime 0)
                  (die game)
                  (set! (lifetime player) (- current-lifetime 1))))))
     (script
      (tween 60 0.0 1.0
             (lambda (a)
               (set-music-volume! a)
               (sleep 10))
             #:ease ease-out-sine)))
    (let ((container
           (make <node-2d>
             #:children
             (list game
                   (make <filled-rect>
                     #:name 'fade-box
                     #:region (make-rect 0.0 0.0 %width %height)
                     #:color (make-color 0 0 0 0))
                   (make <sprite>
                     #:name 'vignette
                     #:texture (asset-ref vignette-image))
                   (make <node-2d>
                     #:name 'text-bubble
                     #:position (vec2 0 0)
                     #:visible? #f
                     #:children
                     (list (make <filled-rect>
                             #:name 'text-bubble-box
                             #:region (make-rect 0.0 0.0 %width 80)
                             #:position (vec2 0 0)
                             #:rank -10 ; background
                             #:color (make-color 0 0 0 0.5))))))))
      (with-agenda
       (agenda container)
       (let ((fade (child-ref container 'fade-box)))
         (script
          (tween 15 1.0 0.0
                 (lambda (alpha)
                   (set! (color fade)
                         (make-color 0 0 0 alpha)))))))
      container)))