path: root/scenes/game.scm

;;; The Inevitable Game
;;; Copyright © 2018, 2021, 2023 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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)
  #:use-module (chickadee audio)
  #:use-module (chickadee data grid)
  #:use-module (chickadee math)
  #:use-module (chickadee math easings)
  #:use-module (chickadee math rect)
  #:use-module (chickadee math vector)
  #:use-module ((chickadee graphics color) #:select (make-color red))
  #:use-module (chickadee graphics text)
  #:use-module (chickadee graphics path)
  #:use-module (chickadee graphics sprite)
  #:use-module (chickadee graphics texture)
  #:use-module (chickadee graphics tile-map)
  #:use-module (chickadee scripting)
  #:use-module (config)
  #:use-module (engine assets)
  #:use-module (characters lorenzo)
  #:use-module (characters reaper)
  #:use-module (utils)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:export (scene))

(define-asset game-map
  (load-tile-map "assets/maps/01.tmx"))
(define-asset vignette-image
  (load-image "assets/images/vignette.png"))
(define-asset fade-image
  (load-image "assets/images/fade.png"))
(define-asset game-font
  (load-bitmap-font "assets/fonts/good_neighbors_starling.xml"))
(define-asset music
  (load-audio "assets/sounds/birds.ogg" #:mode 'stream))
(define-asset error-sample
  (load-audio "assets/sounds/error.ogg"))

(define location
  (let ((positions
         (object-layer-objects
          (tile-map-layer-ref (asset-ref game-map) "positions")))
        (offset (vec2 0 0)))
    (lambda (name)
      "Look up the location for an object with the given NAME in the
map's positions layer."
      (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 fade-box-fill (make-color 0 0 0 1.0))

(define agenda (make-agenda))
(define *last-player-position*
  (location "player"))
(define *player-previous-keys* (list))
(define *player-talking?* #false)
(define *player-wants-to-stop-talking?* #false)
(define *player-resume-messages* (list))
(define *player* #false)
(define *reaper* #false)
(define *world* (list *player* *reaper*))
(define *layers* #false)
(define *action-key* 'space)
(define *current-message* #false)

(define grid (make-grid 16))
(define player-grid-x-offset 8)
(define player-grid-y-offset 0)

(define *background-music* #false)


(define dialog-box
  (with-style
      ((fill-color (make-color 0 0 0 0.5)))
    (fill (rectangle (vec2 0.0 0.0) %width 80))))
(define dialog-selection-indicator
  (translate (vec2 0 65)
    (with-style
        ((fill-color red))
      (fill (rectangle (vec2 0.0 0.0) 5 10)))))

(define* (render-text text #:key (y-offset 0))
  "Split TEXT into lines according to the game font dimensions and
draw the lines to the screen.  Return the number of lines."
  (let ((lines (arrange-text text (asset-ref game-font)
                             #:margin 4.0)))
    (for-each (lambda (line i)
                (draw-text line
                           (vec2 4.0
                                 (- 65 y-offset (* %line-height i)))
                           #:font (asset-ref game-font)))
              lines (iota (length lines)))
    (length lines)))

(define (render-messages messages)
  "Print all messages.  Each message is split into lines, so this
procedure keeps track of the vertical offset so far.  It returnes the
total number of lines printed."
  (fold (lambda (message n lines-so-far)
          (match message
            ((message text . flags)
             (let ((lines-printed
                    (render-text text
                                 #:y-offset
                                 (+ (* n %message-margin)
                                    (* lines-so-far %line-height)))))
               (+ lines-so-far lines-printed)))))
        0                               ; no lines printed yet
        messages
        (iota (length messages))))

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

(define (start-talking who)
  (unless (equal? *player-talking?* who)
    (set! *player-talking?* who)
    (match (available-messages)
      (()
       ;; nothing to say!  Play error sound.
       (audio-play (asset-ref error-sample))
       (stop-talking))
      (_ #true))))

(define (stop-talking)
  (when *player-talking?*
    (change-sprite-animation *player-talking?* 'idle)
    (set! *player-talking?* #false)
    (set! *player-wants-to-stop-talking?* #false)
    #true))

(define (talk who message flags)
  "Send MESSAGE to WHO and display the response.  FLAGS contain the
#:resume message."
  ;; Delete remembered resume point if it exists, because we want
  ;; to only use them once.
  (when (assoc-ref *player-resume-messages* (name who))
    (set! *player-resume-messages*
          (acons (name who) #false
                 *player-resume-messages*)))
  (and=> (member #:resume flags)
         (match-lambda
           ((#:resume (and (message text) pair))
            (set! *player-resume-messages*
                  (acons (name who) pair
                         *player-resume-messages*))
            (set! (accepted-messages who) (list message))
            (set! *player-wants-to-stop-talking?* #true))))
  (match (assoc-ref (conversations who) message)
    ((text next)
     (set! (speaking? who) #true)
     (set! *player-talking?* who)
     ;; Display new message.
     (set! *current-message* text)
     ;; Record continuations.
     (set! (accepted-messages who) next)
     (change-sprite-animation who 'talk))
    ;; This should never happen, because there should always be a
    ;; conversation matching a message.
    (oops (pk 'oops #t))))


(define* (fade direction #:key
               (duration 0.5))
  (apply tween duration
         (append (case direction
                   ((out) '(0.0 1.0))
                   ((in)  '(1.0 0.0)))
                 (list
                  (lambda (alpha)
                    (set! fade-box-fill
                          (make-color 0 0 0 alpha)))))))

(define (handle-movement player active released)
  "Process movement keys by updating character animation and
position."
  ;; If the player has released any direction key stop animating
  ;; movement in that direction.
  (unless (null? released)
    (walk player released 'stop))

  ;; If the player still presses any direction key, animate movement
  ;; in those directions.
  (walk player (match active
                 (() '(idle))
                 (_ active)))

  ;; Update player position and respond to position-dependent
  ;; events.
  (let ((vel (velocity player)))
    (unless (and (zero? (vec2-x vel))
                 (zero? (vec2-y vel)))
      (vec2-copy! (position player) *last-player-position*)
      (vec2-add! (position player) vel)

      ;; We use the grid position here to keep the initial
      ;; collision offset.
      (let* ((grid-position (grid-rect-ref grid 'player))
             (planned-grid-position
              (vec2+ (vec2 (rect-left grid-position)
                           (rect-bottom grid-position))
                     vel)))
        (grid-move grid 'player planned-grid-position
                   (lambda (a b)
                     ;; TODO: only slide if this is an obstacle
                     slide)))
      (let ((corrected-position (grid-rect-ref grid 'player)))
        (set! (position player)
              (vec2- (vec2 (rect-left corrected-position)
                           (rect-bottom corrected-position))
                     (vec2 player-grid-x-offset
                           player-grid-y-offset)))))))

(define (handle-talking keys)
  "Handle keyboard input when in a dialog with another character."
  (match keys
    ((key . rest)
     (let ((who *player-talking?*))
       ;; Use arrow keys to select a message, hit action key to
       ;; confirm the selection.
       (match (available-messages)
         ;; Nothing more to say, so just wait for the action key to
         ;; be hit to dismiss the dialogue.
         (()
          (when (eq? *action-key* key)
            (set! (speaking? who) #false)
            (stop-talking)))
         ((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))))

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

           ;; Submit selected message.
           ((and (eq? *action-key* key)
                 (not (speaking? who)))
            (talk who message flags))

           ;; Dismiss character's text.
           ((and (eq? *action-key* key)
                 (speaking? who))
            (set! (speaking? who) #false)
            (change-sprite-animation who 'pause))))
         (_ (pk 'this-should-never-happen #t)))))
    ;; Noting to be done here
    (_ #true)))

(define (teleport target-position)
  "Teleport the player to TARGET-POSITION."
  (vec2-copy! target-position (position *player*))
  (vec2-copy! target-position *last-player-position*)
  (grid-move grid 'player
             (vec2+ (vec2 player-grid-x-offset
                          player-grid-y-offset)
                    target-position)
             (const #true)))

(define (handle-action)
  "The action key was pressed and released.  Do something based on the
kind of action item the player intersects with."
  (let ((player-grid-position (grid-rect-ref grid 'player)))
    (and=> (find (lambda (action-item)
                   (rect-intersects? (cdr action-item) player-grid-position))
                 (assoc-ref *layers* "actions"))
           (lambda (action-item)
             (match (map-object-name (first action-item))
               ("enter-house"
                (fade 'out)
                ;; TODO: switch music
                (teleport (location "house"))
                (fade 'in))
               ("exit-house"
                (fade 'out)
                ;; TODO: switch music
                (teleport (location "exited-house"))
                (fade 'in))
               ("talk-to-reaper"
                (start-talking *reaper*))
               (_ (pk 'action action-item)))))))


(define (load-scene)
  (set! *background-music*
        (make-source #:audio (asset-ref music)
                     #:loop? #true))
  (source-play *background-music*)

  (set! *player* (lorenzo #:start-position
                          (location "player")))
  (update-animated-sprite *player*)
  (grid-add grid 'player
            (+ (vec2-x (position *player*)) player-grid-x-offset)
            (+ (vec2-y (position *player*)) player-grid-y-offset)
            16 16)
  (set! (walk-speed *player*) 1.5)

  (set! *reaper* (reaper #:start-position
                         (location "reaper")))
  (update-animated-sprite *reaper*)

  ;; 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*
        (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 game-map) layer-name)))))
             '("food" "positions" "actions" "collision")))

  (for-each (lambda (barrier)
              (let ((r (cdr barrier)))
                (grid-add grid (map-object-id (car barrier))
                          (rect-x r)
                          (rect-y r)
                          (rect-width r)
                          (rect-height r))))
            (assoc-ref *layers* "collision"))

  (let ((agenda (make-agenda)))
    (with-agenda agenda
     (spawn-script
      (lambda ()
        (wait-until (any key-pressed? '(escape)))

        ;; Fade out
        (fade 'out #:duration 2)
        (throw 'switch-scene
               (@ (scenes death) scene))))

     ;; Handle keyboard input
     (spawn-script
      (lambda ()
        (forever
         (let ((active (filter key-pressed? '(space left right up down)))
               (released (filter key-released? *player-previous-keys*)))
           (set! *player-previous-keys* active)

           (if *player-talking?*
               (handle-talking released)
               (begin
                 (when (member *action-key* released)
                   (handle-action))
                 (handle-movement *player*
                                  (delete *action-key* active)
                                  (delete *action-key* released)))))
         (sleep 0.01))))

     ;; Handle background noise fade in
     (spawn-script
      (lambda ()
        (tween 5 0.0 1.0
               (lambda (a)
                 (set-source-volume! *background-music* a))
               #:ease ease-out-sine)))

     (script (fade 'in #:duration 1)))
    (current-agenda agenda)))

(define (draw-scene alpha)
  (define player-render-position
    (vec2 (round (lerp (vec2-x *last-player-position*)
                       (vec2-x (position *player*))
                       alpha))
          (round (lerp (vec2-y *last-player-position*)
                       (vec2-y (position *player*))
                       alpha))))

  ;; Always centered on the player
  (define camera
    (let ((player-half 16))
      (vec2- (position *player*)
             (vec2 (- (/ %width 2) player-half)
                   (- (/ %height 2) player-half)))))

  ;; The Void
  (draw-sprite
   (asset-ref fade-image)
   (vec2 0 0)
   #:tint (make-color 0.125 0.09 0.161 1.0))

  ;; The lower layers of the world
  (draw-tile-map (asset-ref game-map)
                 #:position (vec2 0 0)
                 #:camera camera
                 #:layers (list 0 1 2))

  ;; Reaper
  (draw-animated-sprite *reaper*
                        (vec2* camera -1.0))

  ;; Player
  (draw-animated-sprite *player*
                        (vec2* camera -1.0))

  ;; The upper layer hiding items and the player.
  (draw-tile-map (asset-ref game-map)
                 #:position (vec2 0 0)
                 #:camera camera
                 #:layers (list 3))

  ;; Text bubble for dialog
  (when *player-talking?*
    (let ((who *player-talking?*))
      (if (speaking? who)
          (begin
            (draw-canvas (make-canvas dialog-box))
            (when *current-message*
              (render-text *current-message*)))
          (begin
            ;; Show the dialog selector when it's the player's turn to
            ;; speak.
            (draw-canvas (make-canvas
                          (superimpose dialog-box
                                       dialog-selection-indicator)))
            (render-messages (available-messages))))))

  ;; Vignette
  (draw-sprite (asset-ref vignette-image) (vec2 0 0))

  ;; Box for fading in/out everything
  (draw-sprite
   (asset-ref fade-image)
   (vec2 0 0)
   #:tint fade-box-fill))

(define (update-scene dt)
  (update-agenda dt)
  (update-animated-sprite *player*)
  (update-animated-sprite *reaper*))


(define scene
  (list
   #:name "game"
   #:load load-scene
   #:draw draw-scene
   #:update update-scene
   #:quit
   (lambda ()
     (and *background-music*
          (source-stop *background-music*)))))