;;; The Inevitable Game
;;; Copyright © 2018 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 input keyboard)
  #:use-module (chickadee math rect)
  #:use-module (chickadee math vector)
  #:use-module (chickadee render color)
  #:use-module (chickadee render font)
  #:use-module (chickadee render shapes)
  #:use-module (chickadee render texture)
  #:use-module (chickadee render tiled)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (engine assets)
  #:use-module (engine node)
  #:use-module (engine node-2d)
  #:use-module (engine scene)
  #:use-module (oop goops)
  #:export (game))

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


(define %width 320)
(define %height 240)


(define-class <character> (<node-2d>)
  (conversations #:accessor conversations #:init-keyword #:conversations)
  (accepted-messages #:accessor accepted-messages #:init-form '(hello))
  (speaking? #:accessor speaking? #:init-form #f)
  (velocity #:getter velocity #:init-form (vec2 0.0 0.0))
  (walk-speed #:accessor walk-speed #:init-form 0.8)
  (direction #:accessor direction #:init-form '(idle))
  (hitbox #:getter hitbox #:init-form (make-rect 8.0 0.0 16.0 16.0)))

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

(define-method (walk (character <character>) directions . rest)
  (unless (equal? (direction character) directions)
    (let ((sprite (child-ref character 'sprite))
          (speed  (if (member 'stop rest) 0.0 (walk-speed character))))
      (change-animation sprite (last directions))
      (for-each (lambda (dir)
                  (case dir
                    ((right)
                     (set-vec2-x! (velocity character) speed))
                    ((left)
                     (set-vec2-x! (velocity character) (* -1.0 speed)))
                    ((up)
                     (set-vec2-y! (velocity character) speed))
                    ((down)
                     (set-vec2-y! (velocity character) (* -1.0 speed)))
                    ((idle)
                     (set-vec2-x! (velocity character) 0.0)
                     (set-vec2-y! (velocity character) 0.0)
                     (change-animation sprite (case (last (direction character))
                                                ((right) 'idle-right)
                                                ((left)  'idle-left)
                                                ((up)    'idle-back)
                                                ((down)  'idle-front))))))
                directions)
      (set! (direction character) directions))))

(define-class <player> (<character>)
  (previous-key-presses #:accessor previous-key-presses #:init-form (list))
  (selecting-message? #:accessor selecting-message? #:init-form #f)
  (action-held #:accessor action-held #:init-form #f)
  (lifetime #:accessor lifetime #:init-form 100)
  (happiness #:accessor happiness #:init-form 50)
  (weight #:accessor weight #:init-form 50)
  (music #:accessor music #:init-form 50)
  (talking? #:accessor talking? #:init-form #f))

(define (load-atlas file-name tile-width tile-height)
  (split-texture (load-image file-name) tile-width tile-height))

(define-asset player-atlas
  (load-atlas "assets/images/lorenzo.png" 32 32))

(define-method (populate (player <player>))
  (list
   (make <animated-sprite>
     #:name 'sprite
     #:atlas player-atlas
     #:animations '((idle-right . #(8 8 8 8 8 7 7 7 7 7))
                    (idle-left  . #(0 0 0 0 0 15 15 15 15 15))
                    (idle-front . #(24 24 24 24 24 32 32 32 32 32))
                    (idle-back  . #(16))
                    (left       . #(1 35 2 35))
                    (right      . #(9 34 10 34))
                    (up         . #(17 16 18 16))
                    (down       . #(25 24 26 24)))
     #:current-animation 'idle-front
     #:frame-duration 10)))


(define-class <reaper> (<character>))

(define-asset reaper-atlas
  (load-atlas "assets/images/reaper.png" 32 32))

(define-method (populate (reaper <reaper>))
  (list
   (make <animated-sprite>
     #:name 'sprite
     #:atlas reaper-atlas
     #:animations '((idle  . #(0 0 0 1 1 1 9 1 1 1 8 8 8 8 8 8 5 4 4 4 0 0 0 3 3))
                    (pause . #(4 4 4 4 4 4 4 5))
                    (talk  . #(0 3 2 7 5 4 6 5 3 2 2 2 4 4 0 0 0)))
     #:current-animation 'idle
     #:frame-duration 20)))


(define-asset test-map (load-tile-map "assets/maps/01.tmx"))

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

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

(define-asset game-font
  (load-tile-font "assets/fonts/bubblemad_8x8.png" 8 8
                  " !\"©_%❤'()*+,-./0123456789:←<=>?@abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))

(define (start-position game name)
  "Look up the start position for an object with the given NAME in the
map's object layer."
  (let ((positions
         (filter (lambda (obj)
                   (eq? 'start-position
                        (map-object-type obj)))
                 (object-layer-objects
                  (tile-map-layer-ref (asset-ref (tile-map game)) "collision"))))
        (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))
                         (+ (vec2-y offset) (rect-y shape))))))
        (vec2 0.0 0.0))))

(define-method (populate (game <game>))
  (let ((player (make <player>
                  #:name 'player
                  #:position (start-position game "player")
                  #:children
                  ;; Simple player shadow.  This should better be done
                  ;; with a single ellipse shader.
                  (let ((color (make-color 0 0 0 0.2)))
                    (map (lambda (n x w)
                           (make <filled-rect>
                             #:region (make-rect 0.0 0.0 w 1.0)
                             #:position (vec2 x (- 2 n))
                             #:color color))
                         ;; position in the stack
                         (iota 5)
                         ;; x offsets
                         (list 12 10 8 10 12)
                         ;; widths
                         (list 8 12 16 12 8))))))
    (list (make <reaper>
            #:name 'reaper
            #:position (start-position game "reaper")
            #:conversations
            '((hello
               "Salutations!"
               ((who-are-you? "Who are you?")
                (bye "I have to leave now. Bye!")))
              (who-are-you?
               "It's complicated. People have given me too many names to recount.
Paul Celan called me a master from Germany, but he must have confused
me with somebody else. Some call me a part of life, but I think that's
missing the point. Others call me the grim reaper, but do I look grim
to you?"
               ((grim-no "No, not at all.")
                (grim-yes "Well, actually you kinda do...")
                (grim-bye "I can't answer, I need to go.")))
              (grim-bye
               "Well, I guess that's a 'yes'..."
               ())
              (grim-no
               "Ah, that's a relief!"
               ((what-do-you-do?
                 "I hope you don't mind me asking: what is it you're
doing here?")
                (bye
                 "Well, it was nice meeting you. See you around!")))
              (grim-yes
               "Hmm, that's very unfortunate. I just can't figure out
why people have that impression. It's rather depressing."
               ((its-the-robe "Maybe it's the robe?")
                (dont-worry "Aww, don't feel bad about it!")
                (bye "I'm sure you'll be okay. Gotta go!")))
              (its-the-robe
               "I don't see how this comfortable robe could have that
effect. The fabric is a little coarse, I admit, but it's really
durable and doesn't chafe on my bones. Excellent quality."
               ((what-do-you-do?
                 "So... what do you do around here?")
                (bye "That's really interesting, but I'm afraid I need
to hurry. Bye!")))
              (dont-worry
               "Yeah, I guess I shouldn't. It just tears me
down. Luckily, the garden keeps me distracted."
               ((what-do-you-grow? "Oh, you have a garden? What do you
grow there?")
                (bye "That's good. Well, I should go now. Bye!")))
              (what-do-you-do?
               "Well, you may have noticed the garden behind the house.
For the past few eons I have been tending to it."
               ((eons? "Did you say 'eons'?")
                (what-do-you-grow? "Oh, that's nice! What do you grow there?")
                (bye "I see. Unfortunately, I must get going now.")))
              (eons?
               "Oh yes, I have been here long before you appeared and
I will be here long after you will have rejoined the void. You could
say that I /am/ the void, occasionally receding just enough for a
little bit of inconsequential folly before eventually and invariably
restoring equilibrium."
               ;; TODO
               ())
              (what-do-you-grow?
               "You know, this and that. I enjoy soul food, and it's
best when the ingredients are fresh."
               ())
              (bye
               "Farewell! Don't be afraid, for I'm always here for
you.  I'm sure we will meet again sooner than you expect."
               ()))
            #:children
            ;; Simple shadow.  This should better be done with a
            ;; single ellipse shader.
            (let ((color (make-color 0 0 0 0.2)))
              (map (lambda (n x w)
                     (make <filled-rect>
                       #:region (make-rect 0.0 0.0 w 1.0)
                       #:position (vec2 (+ 3 x) (- 2 n))
                       #:color color))
                   ;; position in the stack
                   (iota 5)
                   ;; x offsets
                   (list 12 10 8 10 12)
                   ;; widths
                   (list 12 16 20 16 12))))
          (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* (collides? player game #:key (layer "collision"))
  (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))

    ;; TODO: memoize objects and shapes as they don't change.
    (any (lambda (obj)
           (let* ((r-wrong (map-object-shape obj))
                  ;; TODO: chickadee parses the object layer
                  ;; incorrectly, so all objects are flipped vertically.
                  (r (make-rect (rect-x r-wrong)
                                (- (rect-y r-wrong) (rect-height r-wrong))
                                (rect-width r-wrong)
                                (rect-height r-wrong))))
             (if (rect-intersects? hitbox r)
                 (begin
                   (set-rect-x! hit-vis (+ (rect-x r) (vec2-x offset)))
                   (set-rect-y! hit-vis (+ (rect-y r) (vec2-y offset)))
                   (set-rect-width! hit-vis (rect-width r))
                   (set-rect-height! hit-vis (rect-height r))
                   obj)
                 #f)))
         (object-layer-objects
          (tile-map-layer-ref (asset-ref (tile-map game)) layer)))))

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

(define-method (update (player <player>) dt)
  ;; Check the action key separately.  We only want to act on a
  ;; state change, not when the key is held.
  (when (key-released? 'space)
    (set! (action-held player) #f))

  (or (and=> (talking? player)
             ;; Use arrow keys to select a message, hit action key to
             ;; confirm the selection.
             (lambda (who)
               (when (or (and (eq? 'up (selecting-message? player))
                              (key-released? 'up))
                         (and (eq? 'down (selecting-message? player))
                              (key-released? 'down)))
                 (set! (selecting-message? player) #f))

               (match (accepted-messages who)
                 ;; Nothing more to say, so just wait for the action key to
                 ;; be hit to dismiss the dialogue.
                 (()
                  (when (and (not (action-held player))
                             (key-pressed? 'space))
                    (set! (action-held player) #t)
                    (stop-talking player)))
                 ((and ((and (message text) selected) . rest) messages)
                  (cond
                   ;; Select previous message
                   ((and (not (eq? 'up (selecting-message? player)))
                         (key-pressed? 'up))
                    (set! (accepted-messages who)
                          (append (list (last messages))
                                  (drop-right messages 1)))
                    (set! (selecting-message? player) 'up))

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

                   ;; Submit selected message.
                   ((and (not (action-held player))
                         (key-pressed? 'space)
                         (not (speaking? who)))
                    (set! (action-held player) #t)
                    (talk player who message))

                   ;; Dismiss character's text.
                   ((and (not (action-held player))
                         (key-pressed? 'space)
                         (speaking? who))
                    (set! (action-held player) #t)
                    (set! (speaking? who) #f))))
                 (_ #t))

               ;; Render the messages in the new order once the
               ;; character's text has been dismissed.
               (unless (speaking? who)
                 (let ((bubble (child-ref (parent (parent player)) 'text-bubble))
                       (messages (accepted-messages who)))
                   (for-each (lambda (node)
                               (when (string-prefix? "dialog" (symbol->string (name node)))
                                 (detach node)))
                             (children bubble))
                   (for-each (lambda (message i)
                               (match message
                                 ((message text)
                                  (when (zero? i)
                                    (attach bubble
                                            (make <filled-rect>
                                              #:name 'dialog-selection-indicator
                                              #:region (make-rect 0.0 0.0 10 10)
                                              #:position (vec2 0 40)
                                              #:color region)))
                                  (attach bubble (make <label>
                                                   #:name (symbol-append 'dialog- message)
                                                   #:font game-font
                                                   #:text text
                                                   #:color color
                                                   #:position (vec2 16.0 (- 40 (* 16.0 i))))))))
                             messages
                             (iota (length messages)))))

               ;; Always end on #T to avoid passing through to the
               ;; motion branch.
               #t))

      ;; React to current key presses with motion.
      (begin
        ;; Stop any motion in a direction when the matching key has just
        ;; been released.
        (let ((released (filter key-released? (previous-key-presses player))))
          (unless (null? released)
            (walk player released 'stop)))

        ;; Detect newly pressed keys.
        (let ((active (fold (lambda (direction acc)
                              (if (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))
               (game (parent player)))
          (vec2-add! pos vel)
          (and=> (collides? player game #:layer "collision")
                 (lambda (obj)
                   (match (map-object-type obj)
                     ;; Reset when the new position is invalid.
                     ('obstacle
                      (vec2-sub! pos vel))
                     ('action
                      (when (and (not (action-held player))
                                 (key-pressed? 'space))
                        (set! (action-held player) #t)
                        (match (map-object-name obj)
                          ("enter-house"
                           (teleport player 560.0 1800.0)
                           ;; TODO: change music?
                           (pause-music))
                          ("exit-house"
                           (teleport player 620.0 1100.0)
                           (resume-music))
                          ("talk-to-reaper"
                           (let ((reaper (child-ref game 'reaper)))
                             (unless (equal? (talking? player) reaper)
                               (talk player reaper 'hello))))
                          (_ #t))))
                     (_ #t))))))))

(define-method (talk (player <player>) (who <character>) message)
  (let ((bubble (child-ref (parent (parent player)) 'text-bubble)))
    (when (eq? message 'hello)
      (set! (visible? bubble) #t))

    (set! (talking? player) who)

    ;; Send message, display text, record possible continuations
    (match (assoc-ref (conversations who) message)
      ((text next)
       (set! (speaking? who) #t)
       (for-each (lambda (node)
                   (when (string-prefix? "dialog" (symbol->string (name node)))
                     (detach node)))
                 (children bubble))
       ;; TODO: split text
       (attach bubble (make <label>
                        #:name 'dialog
                        #:font game-font
                        #:text text
                        #:position (vec2 16.0 40)))
       (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 (stop-talking (player <player>))
  (when (talking? player)
    (set! (visible? (child-ref (parent (parent player)) 'text-bubble)) #f)
    (set! (talking? player) #f)))

(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)))
    (for-each (lambda (property index)
                (let* ((value (property player))
                       (start (vec2 x (- y (* step index))))
                       (end-y (- y (* step index)))
                       (end   (vec2 (+ x 100) end-y)))
                  (draw-line start end
                             #:thickness thickness #:color red)
                  (when (> value 0)
                    (draw-line start (vec2 (+ x value) end-y)
                               #:thickness thickness #:color green))))
              properties
              (iota (length properties)))))

(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))))))
    (with-agenda
     (agenda game)
     (schedule-every
      120 (lambda _
            (let* ((player (child-ref game 'player))
                   (current-lifetime (lifetime player)))
              (if (< current-lifetime 0)
                  (set! (status game) 'game-over)
                  (set! (lifetime player) (- current-lifetime 1)))))))
    (make <node-2d>
      #:children
      (list game
            (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 50)
                      #:position (vec2 0 0)
                      #:rank -10 ; background
                      #:color (make-color 0 0 0 0.5))))))))