;;; Starling Game Engine
;;; 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 Starling.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; 2D game nodes.
;;
;;; Code:

(define-module (starling node-2d)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee math rect)
  #:use-module (chickadee math vector)
  #:use-module (chickadee render)
  #:use-module (chickadee render color)
  #:use-module (chickadee render font)
  #:use-module (chickadee render framebuffer)
  #:use-module (chickadee render shapes)
  #:use-module (chickadee render sprite)
  #:use-module (chickadee render texture)
  #:use-module (chickadee render viewport)
  #:use-module (chickadee scripting)
  #:use-module (oop goops)
  #:use-module (starling asset)
  #:use-module (starling kernel)
  #:use-module (starling node)
  #:export (<camera-2d>
            target
            offset
            position
            width
            height

            <view-2d>
            camera
            area

            <canvas>
            views

            <node-2d>
            origin
            position
            rotation
            skew
            pivot
            move
            move-to
            teleport
            rotate
            rotate-to
            zoom
            zoom-to

            <sprite>
            texture

            <animated-sprite>
            atlas
            animations
            frame-duration
            current-animation
            start-time
            change-animation

            <sprite-batch>

            <filled-rect>
            region
            color

            <label>
            font
            text))


;;;
;;; 2D Camera
;;;

;; Cameras define a view into the scene.  They are attached to a 2D
;; node and follow it around.

(define-class <camera-2d> ()
  (target #:accessor target #:init-form #f #:init-keyword #:target)
  (offset #:getter offset #:init-form #v(0.0 0.0) #:init-keyword #:offset)
  (position #:getter position #:init-form #v(0.0 0.0))
  (last-position #:getter last-position #:init-form #v(0.0 0.0))
  (width #:getter width #:init-keyword #:width)
  (height #:getter height #:init-keyword #:height)
  (projection-matrix #:accessor projection-matrix)
  ;; Combined projection/view matrix
  (view-matrix #:getter view-matrix #:init-form (make-identity-matrix4))
  (framebuffer #:accessor framebuffer))

(define-method (initialize (camera <camera-2d>) initargs)
  (next-method)
  ;; Initialize framebuffer and orthographic projection matrix based
  ;; on the resolution of the camera.
  (set! (framebuffer camera)
        (make-framebuffer (width camera)
                          (height camera)
                          #:min-filter 'nearest
                          #:mag-filter 'nearest))
  (set! (projection-matrix camera)
        (orthographic-projection 0 (width camera) (height camera) 0 0 1)))

;; This method can be overridden by subclasses to create custom camera
;; movement.
(define-method (follow-target (camera <camera-2d>) dt)
  (let ((pos (position camera))
        (target-pos (position (target camera)))
        (offset (offset camera)))
    (set-vec2-x! pos (- (vec2-x offset) (vec2-x target-pos)))
    (set-vec2-y! pos (- (vec2-y offset) (vec2-y target-pos)))))

(define-method (update (camera <camera-2d>) dt)
  (when (target camera)
    (let ((pos (position camera))
          (last-pos (last-position camera))
          (m (view-matrix camera)))
      (vec2-copy! pos last-pos)
      (follow-target camera dt)
      (unless (and (= (vec2-x pos) (vec2-x last-pos))
                   (= (vec2-y pos) (vec2-y last-pos)))
        (matrix4-translate! m pos)
        (matrix4-mult! m m (projection-matrix camera))))))

(define-syntax-rule (with-camera camera body ...)
  (with-framebuffer (framebuffer camera)
    (with-projection (if (target camera)
                         (view-matrix camera)
                         (projection-matrix camera))
      body ...)))



;;;
;;; 2D View
;;;

;; Views render the output of a camera to a portion of the game
;; window.

(define-class <view-2d> ()
  (camera #:accessor camera #:init-keyword #:camera)
  (area #:getter area #:init-keyword #:area))

(define %identity-matrix (make-identity-matrix4))

(define-method (render (view <view-2d>))
  (with-projection (projection-matrix (camera view))
    (draw-sprite* (framebuffer-texture (framebuffer (camera view)))
                  (area view)
                  %identity-matrix)))


;;;
;;; 2D Canvas
;;;

;; The canvas is the root of a 2D scene.  It handles rendering one or
;; more views.

(define-class <canvas> (<node>)
  (views #:accessor views #:init-form '() #:init-keyword #:views))

(define-method (update (canvas <canvas>) dt)
  (for-each (lambda (view)
              (update (camera view) dt))
            (views canvas)))

(define-method (render* (canvas <canvas>) alpha)
  ;; Draw scene from the viewpoint of each camera.
  (for-each (lambda (view)
              (with-camera (camera view)
                           (for-each (lambda (child)
                                       (render* child alpha))
                                     (children canvas))))
            (views canvas))
  (render canvas alpha))

(define-method (render (canvas <canvas>) alpha)
  (for-each render (views canvas)))


;;;
;;; 2D Game Node
;;;

(define-class <node-2d> (<node>)
  (origin #:getter origin #:init-form #v(0.0 0.0) #:init-keyword #:origin)
  (position #:getter position #:init-form #v(0.0 0.0) #:init-keyword #:position)
  (rotation #:accessor rotation #:init-form 0.0 #:init-keyword #:rotation)
  (scale #:getter scale #:init-form #v(1.0 1.0) #:init-keyword #:scale)
  (skew #:getter skew #:init-form #v(0.0 0.0) #:init-keyword #:skew)
  ;; Some extra position vectors for defeating "temporal aliasing"
  ;; when rendering.
  (last-position #:getter last-position #:init-form #v(0.0 0.0))
  (render-position #:getter render-position #:init-form #v(0.0 0.0))
  ;; Lazily computed transformation matrices.
  (local-matrix #:getter local-matrix #:init-form (make-identity-matrix4))
  (world-matrix #:getter world-matrix #:init-form (make-identity-matrix4))
  (dirty-matrix? #:accessor dirty-matrix? #:init-form #t))

(define (dirty! node)
  (set! (dirty-matrix? node) #t))

(define-method (pivot (node <node-2d>) x y)
  "Change origin of NODE to (X, Y)."
  (let ((o (origin node)))
    (set-vec2-x! o x)
    (set-vec2-y! o y)
    (dirty! node)))

(define-method (move (node <node-2d>) dx dy)
  "Move NODE by (DX, DY)."
  (let ((p (position node)))
    (set-vec2-x! p (+ (vec2-x p) dx))
    (set-vec2-y! p (+ (vec2-y p) dy))
    (dirty! node)))

(define-method (move-to (node <node-2d>) x y)
  "Move NODE to (X, Y)."
  (let ((p (position node)))
    (set-vec2-x! p x)
    (set-vec2-y! p y)
    (dirty! node)))

(define-method (teleport (node <node-2d>) x y)
  "Move NODE to (X, Y) without applying animation smoothing."
  (move-to node x y)
  (let ((lp (last-position node)))
    (set-vec2-x! lp x)
    (set-vec2-y! lp y)))

(define-method (rotate (node <node-2d>) dtheta)
  "Rotate NODE about the Z axis by DTHETA radians."
  (set! (rotation node) (+ (rotation node) dtheta))
  (dirty! node))

(define-method (rotate-to (node <node-2d>) theta)
  "Rotate NODE to THETA radians about the Z axis."
  (set! (rotation node) theta)
  (dirty! node))

(define-method (zoom (node <node-2d>) dsx dsy)
  "Scale NODE by the scaling factor (DSX, DSY)."
  (let ((s (scale node)))
    (set-vec2-x! s (+ (vec2-x s) dsx))
    (set-vec2-y! s (+ (vec2-y s) dsy))
    (dirty! node)))

(define-method (zoom (node <node-2d>) ds)
  "Scale NODE by the scaling factor (DS, DS)."
  (zoom node ds ds))

(define-method (zoom-to (node <node-2d>) sx sy)
  "Set the scaling factor for NODE to (SX, SY)."
  (let ((s (scale node)))
    (set-vec2-x! s sx)
    (set-vec2-y! s sy)
    (dirty! node)))

(define-method (zoom-to (node <node-2d>) s)
  "Set the scaling factor for node to (S, S)."
  (zoom-to node s s))

(define-method (compute-matrices! (node <node-2d>))
  (let ((local (local-matrix node))
        (world (world-matrix node)))
    (matrix4-2d-transform! local
                           #:origin (origin node)
                           #:position (render-position node)
                           #:rotation (rotation node)
                           #:scale (scale node)
                           #:skew (skew node))
    ;; Compute world matrix by multiplying by the parent node's
    ;; matrix, if there is a 2D parent node, that is.
    (if (and (parent node) (is-a? (parent node) <node-2d>))
        (matrix4-mult! world local (world-matrix (parent node)))
        (begin
          (matrix4-identity! world)
          (matrix4-mult! world world local)))))

(define-method (update* (node <node-2d>) dt)
  (vec2-copy! (position node) (last-position node))
  (next-method))

(define-method (render* (node <node-2d>) alpha)
  ;; Compute the linearly interpolated rendering position, in the case
  ;; that node has moved since the last update.
  (let ((p (position node))
        (lp (last-position node))
        (rp (render-position node))
        (beta (- 1.0 alpha)))
    (unless (and (= (vec2-x lp) (vec2-x rp))
                 (= (vec2-y lp) (vec2-y rp)))
      (set-vec2-x! rp (+ (* (vec2-x p) alpha) (* (vec2-x lp) beta)))
      (set-vec2-y! rp (+ (* (vec2-y p) alpha) (* (vec2-y lp) beta)))
      (set! (dirty-matrix? node) #t)))
  ;; Recompute dirty matrices.
  (when (dirty-matrix? node)
    (compute-matrices! node)
    (set! (dirty-matrix? node) #f)
    ;; If the parent is dirty, all the children need to be marked as
    ;; dirty, too.
    (for-each (lambda (node)
                (set! (dirty-matrix? node) #t))
              (children node)))
  (next-method))

(define-method (activate (node <node-2d>))
  (set! (dirty-matrix? node) #t))


;;;
;;; Static Sprite
;;;

(define-class <sprite> (<node-2d>)
  (texture #:accessor texture #:init-keyword #:texture))

(define-method (render (sprite <sprite>) alpha)
  (let ((tex (asset-ref (texture sprite))))
    (draw-sprite* tex (texture-gl-rect tex) (world-matrix sprite))))


;;;
;;; Animated Sprite
;;;

(define-class <animated-sprite> (<sprite>)
  (atlas #:accessor atlas #:init-keyword #:atlas)
  (animations #:accessor animations #:init-keyword #:animations)
  (frame-duration #:accessor frame-duration #:init-keyword #:frame-duration)
  (current-animation #:accessor current-animation
                     #:init-keyword #:current-animation)
  (start-time #:accessor start-time #:init-form 0))

(define-method (on-enter (sprite <animated-sprite>))
  (update sprite 0))

(define-method (update (sprite <animated-sprite>) dt)
  (let* ((anim (assq-ref (animations sprite) (current-animation sprite)))
         (frame-duration (frame-duration sprite))
         (anim-duration (* frame-duration (vector-length anim)))
         (time (modulo (- (elapsed-time) (start-time sprite)) anim-duration))
         (frame (vector-ref anim (floor (/ time frame-duration))))
         (texture-region (texture-atlas-ref (asset-ref (atlas sprite)) frame)))
    (set! (texture sprite) texture-region)
    (next-method)))

(define-method (change-animation (sprite <animated-sprite>) name)
  (set! (current-animation sprite) name)
  (set! (start-time sprite) (elapsed-time)))


;;;
;;; Sprite Batch
;;;

(define-class <sprite-batch> (<node-2d>))

(define-method (render* (batch <sprite-batch>) alpha)
  (with-batched-sprites (next-method)))


;;;
;;; Filled Rectangle
;;;

(define-class <filled-rect> (<node-2d>)
  (region #:accessor region #:init-keyword #:region)
  (color #:accessor color #:init-form black #:init-keyword #:color))

(define-method (render (r <filled-rect>) alpha)
  (draw-filled-rect (region r) (color r) #:matrix (world-matrix r)))


;;;
;;; Text
;;;

(define-class <label> (<node-2d>)
  (font #:accessor font #:init-keyword #:font)
  (text #:accessor text #:init-form "" #:init-keyword #:text))

(define-method (render (label <label>) alpha)
  (draw-text* (asset-ref (font label)) (text label) (world-matrix label)))