;;; 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 render sprite)
             (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))
  (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>)
  (talking #:accessor talking #:init-form #f))

(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 (vec2 720.0 1100.0)
            #: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
                   ((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))
                   ((and (not (eq? 'down (selecting-message? player)))
                         (key-pressed? 'down))
                    (set! (accepted-messages who)
                          (append rest (list selected)))
                    (set! (selecting-message? player) 'down))
                   ((and (not (action-held player))
                         (key-pressed? 'space))
                    (set! (action-held player) #t)
                    (talk player who message))))
                 (_ #t))

               ;; TODO: render the messages in the new order.

               ;; 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)
  (unless (talking? player)
    (let ((bubble (child-ref (parent (parent player)) 'text-bubble)))
      (set! (visible? bubble) #t))
    (set! (talking? player) who)))

(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 <filled-rect>
              #:name 'text-bubble
              #:region (make-rect 0.0 0.0 %width 50)
              #:position (vec2 0 0)
              #:visible? #f
              #:color (make-color 0 0 0 0.5))))))