;;; Starling Game Engine
;;; Copyright © 2018, 2019 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 bezier)
  #:use-module (chickadee math easings)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee math rect)
  #:use-module (chickadee math vector)
  #:use-module (chickadee graphics 9-patch)
  #:use-module (chickadee graphics blend)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics engine)
  #:use-module (chickadee graphics font)
  #:use-module (chickadee graphics framebuffer)
  #:use-module (chickadee graphics particles)
  #:use-module (chickadee graphics path)
  #:use-module (chickadee graphics sprite)
  #:use-module (chickadee graphics texture)
  #:use-module (chickadee graphics tile-map)
  #:use-module (chickadee graphics viewport)
  #:use-module (chickadee scripting)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module (rnrs base)
  #:use-module (starling asset)
  #:use-module (starling node)
  #:use-module (starling scene)
  #:use-module (starling system)
  #:export (<camera-2d>
            target
            offset
            position
            resolution
            viewport
            point-within-camera-viewport?
            window-space->camera-space

            <display-2d>
            cameras
            first-camera

            <scene-2d>

            <node-2d>
            origin
            origin-x
            origin-y
            position
            position-x
            position-y
            rotation
            scale
            scale-x
            scale-y
            skew
            skew-x
            skew-y
            local-matrix
            world-matrix
            width
            height
            default-width
            default-height
            bounding-box
            on-child-resize
            dirty!
            resize
            move-by
            move-to
            teleport
            rotate-by
            rotate-to
            scale-by
            scale-to
            follow-bezier-path
            pick

            <sprite>
            texture
            source-rect
            blend-mode
            tint

            <atlas-sprite>
            atlas
            index

            <animation>
            frames
            frame-duration

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

            <9-patch>
            top-margin
            bottom-margin
            left-margin
            right-margin

            <sprite-batch>
            batch

            <canvas>
            painter

            <label>
            font
            text
            color
            align
            vertical-align

            <tile-map>
            tile-map
            layers

            <particles>
            particles))

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

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

(define (default-resolution)
  (call-with-values current-window-size
    (lambda (width height)
      (vec2 width height))))

(define (default-viewport)
  (call-with-values current-window-size
    (lambda (width height)
     (make-viewport 0 0 width height))))

(define-class <camera-2d> ()
  (target #:accessor target #:init-form #f #:init-keyword #:target)
  (offset #:accessor offset #:init-form (vec2 0.0 0.0) #:init-keyword #:offset)
  (position #:getter position #:init-form (vec2 0.0 0.0))
  (resolution #:getter resolution #:init-keyword #:resolution
              #:init-thunk default-resolution)
  (viewport #:getter viewport #:init-keyword #:viewport
            #:init-thunk default-viewport)
  (projection-matrix #:accessor projection-matrix)
  ;; Combined projection/view matrix
  (view-matrix #:getter view-matrix #:init-form (make-identity-matrix4)))

(define-method (initialize (camera <camera-2d>) initargs)
  (next-method)
  ;; Initialize orthographic projection matrix based on the resolution
  ;; of the camera.
  (let ((r (resolution camera)))
    (set! (projection-matrix camera)
      (orthographic-projection 0 (vec2-x r) (vec2-y r) 0 0 1))))

;; This method can be overridden by subclasses to create custom camera
;; movement.
(define-method (follow-target (camera <camera-2d>))
  (let ((p (position camera))
        (m (view-matrix camera))
        (w (world-matrix (target camera))))
    (set-vec2! p (matrix4-x w) (matrix4-y w))
    (vec2-mult! p -1.0)
    (vec2-add! p (offset camera))
    (matrix4-translate! m (position camera))
    (matrix4-mult! m m (projection-matrix camera))))

(define-syntax-rule (with-camera camera body ...)
  (begin
    (when (target camera)
      (follow-target camera))
    (with-graphics-state ((g:viewport (viewport camera)))
      (with-projection (if (target camera)
                           (view-matrix camera)
                           (projection-matrix camera))
        body ...))))

(define-method (point-within-camera-viewport? (camera <camera-2d>) p)
  (let* ((vp (viewport camera))
         (x (viewport-x vp))
         (y (viewport-y vp))
         (w (viewport-width vp))
         (h (viewport-height vp))
         (px (vec2-x p))
         (py (vec2-y p)))
    (and (>= px x)
         (< px (+ x w))
         (>= py y)
         (< py (+ y h)))))

(define-method (window-space->camera-space (camera <camera-2d>) p)
  ;; To translate a coordinate in window space to camera space, we
  ;; do the following:
  ;;
  ;; - transform p into viewport space by subtracting the viewport
  ;; position
  ;;
  ;; - transform the result of the previous step into camera space by
  ;; multiplying by the ratio of the viewport size / camera resolution
  ;;
  ;; - finally, translate the result of the previous step to the
  ;; correct position relative to the camera's current location by
  ;; adding the camera position
  (let* ((vp (viewport camera))
         (r (resolution camera))
         (pos (position camera)))
    (vec2 (+ (* (- (vec2-x p) (viewport-x vp))
                (/ (vec2-x r) (viewport-width vp)))
             (vec2-x pos))
          (+ (* (- (vec2-y p) (viewport-y vp))
                (/ (vec2-y r) (viewport-height vp)))
             (vec2-y pos)))))


;;;
;;; 2D Display
;;;

;; The display is the root of a 2D scene.  It handles rendering all
;; child nodes from the perspective of one or more cameras.

(define-class <display-2d> (<node>)
  (cameras #:accessor cameras #:init-form (list (make <camera-2d>))
           #:init-keyword #:cameras))

(define-method (render-tree (display <display-2d>) alpha)
  (render display alpha)
  ;; Draw scene from the viewpoint of each camera.
  (for-each (lambda (camera)
              (with-camera camera
                 (for-each-child (lambda (child)
                                   (render-tree child alpha))
                                 display)))
            (cameras display)))

(define-method (first-camera (display <display-2d>))
  (match (cameras display)
    ((camera . _) camera)
    (() #f)))

(define-method (pick (display <display-2d>) p pred)
  (let camera-loop ((cams (cameras display)))
    (match cams
      (() #f)
      ((camera . rest)
       (if (point-within-camera-viewport? camera p)
           (let ((p* (window-space->camera-space camera p)))
             (let loop ((kids (reverse (children display))))
               (match kids
                 (() #f)
                 ((child . rest)
                  (or (pick child p* pred)
                      (loop rest))))))
           (camera-loop rest))))))

(define-method (pause (display <display-2d>))
  ;; We need to set the last position of all objects in the tree to
  ;; their current position, otherwise any moving objects will
  ;; experience this weird jitter while paused because the last
  ;; position will never be updated during the duration of the pause
  ;; event.
  (next-method)
  (for-each-child remember-position/recursive display))


;;;
;;; 2D Scene
;;;

(define-class <scene-2d> (<scene> <display-2d>))

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

(define-class <node-2d> (<node>)
  ;; Transformation components: origin, position, rotation, scale, and
  ;; skew.
  (origin #:accessor origin #:init-form (vec2 0.0 0.0) #:init-keyword #:origin
          #:watch? #t)
  (origin-x #:accessor origin-x #:allocation #:virtual
            #:slot-ref (lambda (node) (vec2-x (origin node)))
            #:slot-set! (lambda (node x)
                          (set-vec2-x! (origin node) x)
                          (dirty! node)))
  (origin-y #:accessor origin-y #:allocation #:virtual
            #:slot-ref (lambda (node) (vec2-y (origin node)))
            #:slot-set! (lambda (node y)
                          (set-vec2-y! (origin node) y)
                          (dirty! node)))
  (position #:accessor position #:init-form (vec2 0.0 0.0)
            #:init-keyword #:position #:watch? #t)
  (position-x #:accessor position-x #:allocation #:virtual
              #:slot-ref (lambda (node) (vec2-x (position node)))
              #:slot-set! (lambda (node x)
                            (set-vec2-x! (position node) x)
                            (dirty! node)))
  (position-y #:accessor position-y #:allocation #:virtual
              #:slot-ref (lambda (node) (vec2-y (position node)))
              #:slot-set! (lambda (node y)
                            (set-vec2-y! (position node) y)
                            (dirty! node)))
  (rotation #:accessor rotation #:init-form 0.0 #:init-keyword #:rotation
            #:watch? #t)
  (scale #:accessor scale #:init-form (vec2 1.0 1.0) #:init-keyword #:scale
         #:watch? #t)
  (scale-x #:accessor scale-x #:allocation #:virtual
           #:slot-ref (lambda (node) (vec2-x (scale node)))
           #:slot-set! (lambda (node x)
                         (set-vec2-x! (scale node) x)
                         (dirty! node)))
  (scale-y #:accessor scale-y #:allocation #:virtual
           #:slot-ref (lambda (node) (vec2-y (scale node)))
           #:slot-set! (lambda (node y)
                         (set-vec2-y! (scale node) y)
                         (dirty! node)))
  (skew #:accessor skew #:init-form (vec2 0.0 0.0) #:init-keyword #:skew
        #:watch? #t)
  (skew-x #:accessor skew-x #:allocation #:virtual
          #:slot-ref (lambda (node) (vec2-x (skew node)))
          #:slot-set! (lambda (node x)
                        (set-vec2-x! (skew node) x)
                        (dirty! node)))
  (skew-y #:accessor skew-y #:allocation #:virtual
          #:slot-ref (lambda (node) (vec2-y (skew node)))
          #:slot-set! (lambda (node y)
                        (set-vec2-y! (skew node) y)
                        (dirty! node)))
  ;; Some extra position vectors for defeating "temporal aliasing"
  ;; when rendering.
  (last-position #:getter last-position #:init-form (vec2 0.0 0.0))
  (render-position #:getter render-position #:init-form (vec2 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)
  ;; Node dimensions.  Stored as a rectangle for convenience
  ;; elsewhere, so it can be used as a bounding box that doesn't take
  ;; any transformation matrix into consideration.
  (size #:getter size #:init-form (make-rect 0.0 0.0 0.0 0.0))
  (width #:accessor width #:init-keyword #:width #:watch? #t #:allocation #:virtual
         #:slot-ref (lambda (node) (rect-width (size node)))
         #:slot-set! (lambda (node w) (set-rect-width! (size node) w)))
  (height #:accessor height #:init-keyword #:height #:watch? #t #:allocation #:virtual
          #:slot-ref (lambda (node) (rect-height (size node)))
          #:slot-set! (lambda (node h) (set-rect-height! (size node) h)))
  ;; Bounding box for render culling, mouse selection, clipping, etc.
  ;; This bounding box incorporates the local transformation matrix.
  (bounding-box #:getter bounding-box #:init-form (make-rect 0.0 0.0 0.0 0.0))
  (dirty-bounding-box? #:accessor dirty-bounding-box? #:init-form #t))

(define-method (initialize (node <node-2d>) args)
  (next-method)
  ;; If caller doesn't specify a custom width and height, let the node
  ;; pick a reasonable default size.
  (when (= (width node) 0.0)
    (set! (width node) (default-width node)))
  (when (= (height node) 0.0)
    (set! (height node) (default-height node)))
  ;; Build an initial bounding box.
  (refresh-local-matrix node)
  (refresh-bounding-box node))

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

(define-method (refresh-local-matrix (node <node-2d>))
  (matrix4-2d-transform! (local-matrix node)
                         #:origin (origin node)
                         #:position (render-position node)
                         #:rotation (rotation node)
                         #:scale (scale node)
                         #:skew (skew node)))

(define-method (refresh-world-matrix (node <node-2d>) (parent <node-2d>))
  (matrix4-mult! (world-matrix node) (local-matrix node) (world-matrix parent)))

;; If a node has no parent or the parent is a 2D node, we simply copy
;; the local matrix as the world matrix.
(define-method (refresh-world-matrix (node <node-2d>) parent)
  (let ((world (world-matrix node)))
    (matrix4-identity! world)
    (matrix4-mult! world world (local-matrix node))))

(define-method (refresh-matrices (node <node-2d>))
  (refresh-local-matrix node)
  (refresh-world-matrix node (parent node)))

;; Size and bounding box

(define-method (default-width (node <node-2d>)) 0.0)

(define-method (default-height (node <node-2d>)) 0.0)

(define-method (on-child-resize (node <node-2d>) child)
  #t)

(define-method (refresh-bounding-box (node <node-2d>))
  (let ((bb (bounding-box node))
        (p (position node))
        (o (origin node))
        (r (rotation node))
        (k (skew node))
        (w (width node))
        (h (height node)))
    (if (and (= r 0.0)
             (= (vec2-x k) 0.0)
             (= (vec2-y k) 0.0))
        ;; Fast path: Node is axis-aligned and bounding box
        ;; calculation is easy peasy.
        (let ((s (scale node)))
          (set-rect-x! bb (- (vec2-x p) (vec2-x o)))
          (set-rect-y! bb (- (vec2-y p) (vec2-y o)))
          (set-rect-width! bb (* w (vec2-x s)))
          (set-rect-height! bb (* h (vec2-y s))))
        ;; Slow path: Node is rotated, skewed, or both.
        (let* ((m (local-matrix node))
               (x0 (- (vec2-x p) (vec2-x o)))
               (y0 (- (vec2-y p) (vec2-y o)))
               (x1 (+ x0 w))
               (y1 (+ y0 h))
               (x2 (matrix4-transform-x m x0 y0))
               (y2 (matrix4-transform-y m x0 y0))
               (x3 (matrix4-transform-x m x1 y0))
               (y3 (matrix4-transform-y m x1 y0))
               (x4 (matrix4-transform-x m x1 y1))
               (y4 (matrix4-transform-y m x1 y1))
               (x5 (matrix4-transform-x m x0 y1))
               (y5 (matrix4-transform-y m x0 y1))
               (xmin (min x2 x3 x4 x5))
               (ymin (min y2 y3 y4 y5))
               (xmax (max x2 x3 x4 x5))
               (ymax (max y2 y3 y4 y5)))
          (set-rect-x! bb xmin)
          (set-rect-y! bb ymin)
          (set-rect-width! bb (- xmax xmin))
          (set-rect-height! bb (- ymax ymin))))
    (set! (dirty-bounding-box? node) #f)))

(define-method (on-change (node <node-2d>) slot old new)
  (case slot
    ((origin position rotation scale skew)
     (set! (dirty-bounding-box? node) #t)
     (dirty! node))
    ((width height)
     (let ((np (parent node)))
       (when (is-a? np <node-2d>)
         (on-child-resize (parent node) node)))
     (set! (dirty-bounding-box? node) #t))))

(define-method (resize (node <node-2d>) w h)
  (set! (width node) w)
  (set! (height node) h))

;; Animation helpers

(define-method (move-to (node <node-2d>) x y)
  (set! (position-x node) x)
  (set! (position-y node) y))

(define-method (move-to (node <node-2d>) x y duration ease)
  (let ((p (position node)))
    (move-by node (- x (vec2-x p)) (- y (vec2-y p)) duration ease)))

(define-method (move-to (node <node-2d>) x y duration)
  (move-to node x y duration smoothstep))

(define-method (move-by (node <node-2d>) dx dy)
  (let ((p (position node)))
    (move-to node (+ (vec2-x p) dx) (+ (vec2-y p) dy))))

(define-method (move-by (node <node-2d>) dx dy duration ease)
  (let* ((p (position node))
         (start-x (vec2-x p))
         (start-y (vec2-y p)))
    (tween duration 0.0 1.0
           (lambda (n)
             (move-to node
                      (+ start-x (* dx n))
                      (+ start-y (* dy n))))
           #:ease ease)))

(define-method (move-by (node <node-2d>) dx dy duration)
  (move-by node dx dy duration smoothstep))

(define-method (teleport (node <node-2d>) x y)
  ;; When teleporting, we want to avoid position interpolation and odd
  ;; looking camera jumps.  Interpolation is avoided by setting all 3
  ;; position vectors to the same values.  This prevents a visual
  ;; artifact where the player sees 1 frame where the node is
  ;; somewhere in between its former position and the new position.
  ;; The camera jump problem occurs when a camera has a node as its
  ;; tracking target and that node teleports. Normally, the camera's
  ;; view matrix is updated before any nodes are rendered, and thus
  ;; *before* the node can recompute its world matrix based on the new
  ;; position.  This creates 1 frame where the camera is improperly
  ;; positioned at the target's old location.  This 1 frame lag is not
  ;; an issue during normal movement, but when teleporting it causes a
  ;; noticably unsmooth blip.  Forcing the matrices to be recomputed
  ;; immediately solves this issue.
  (set-vec2! (position node) x y)
  (set-vec2! (last-position node) x y)
  (set-vec2! (render-position node) x y)
  (refresh-matrices node))

(define-method (rotate-to (node <node-2d>) theta)
  (set! (rotation node) theta))

(define-method (rotate-to (node <node-2d>) theta duration ease)
  (tween duration (rotation node) theta
         (lambda (r)
           (rotate-to node r))
         #:ease ease))

(define-method (rotate-to (node <node-2d>) theta duration)
  (rotate-to node theta duration smoothstep))

(define-method (rotate-by (node <node-2d>) dtheta)
  (rotate-to node (+ (rotation node) dtheta)))

(define-method (rotate-by (node <node-2d>) dtheta duration ease)
  (rotate-to node (+ (rotation node) dtheta) duration ease))

(define-method (rotate-by (node <node-2d>) dtheta duration)
  (rotate-by node dtheta duration smoothstep))

(define-method (scale-to (node <node-2d>) sx sy)
  (set! (scale-x node) sx)
  (set! (scale-y node) sy))

(define-method (scale-to (node <node-2d>) s)
  (scale-to node s s))

(define-method (scale-to (node <node-2d>) sx sy duration ease)
  (scale-by node (- sx (scale-x node)) (- sy (scale-y node)) duration ease))

(define-method (scale-to (node <node-2d>) sx sy duration)
  (scale-to node sx sy duration smoothstep))

(define-method (scale-by (node <node-2d>) dsx dsy)
  (scale-to node (+ (scale-x node) dsx) (+ (scale-y node) dsy)))

(define-method (scale-by (node <node-2d>) ds)
  (scale-by node ds ds))

(define-method (scale-by (node <node-2d>) dsx dsy duration ease)
  (let ((start-x (scale-x node))
        (start-y (scale-y node)))
    (tween duration 0.0 1.0
           (lambda (n)
             (scale-to node
                       (+ start-x (* dsx n))
                       (+ start-y (* dsy n))))
           #:ease ease)))

(define-method (scale-by (node <node-2d>) dsx dsy duration)
  (scale-by node dsx dsy duration smoothstep))

(define-method (scale-by (node <node-2d>) ds duration (ease <procedure>))
  (scale-by node ds ds duration ease))

(define-method (follow-bezier-path (node <node-2d>) path duration forward?)
  (let ((p (position node))
        (path (if forward? path (reverse path))))
    (for-each (lambda (bezier)
                (tween duration
                       (if forward? 0.0 1.0)
                       (if forward? 1.0 0.0)
                       (lambda (t)
                         (bezier-curve-point-at! p bezier t)
                         (dirty! node))
                       #:ease linear))
              path)))

(define-method (follow-bezier-path (node <node-2d>) path duration)
  (follow-bezier-path node path duration #t))

(define-method (pick (node <node-2d>) p pred)
  (and (pred node)
       (let ((bb (bounding-box node)))
         (let loop ((kids (reverse (children node))))
           (match kids
             (()
              (and (rect-contains-vec2? bb p)
                   node))
             ((child . rest)
              (let ((o (origin node)))
                (or (pick child (vec2- p (position node)) pred)
                    (loop rest)))))))))

;; Events

(define-method (remember-position (node <node-2d>))
  (vec2-copy! (position node) (last-position node)))

(define-method (remember-position/recursive (node <node-2d>))
  (remember-position node)
  (for-each-child remember-position/recursive node))

(define-method (update-tree (node <node-2d>) dt)
  (remember-position node)
  (when (dirty-bounding-box? node)
    (refresh-bounding-box node))
  (next-method))

(define-method (render-tree (node <node-2d>) alpha)
  (when (visible? node)
    ;; 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= rp p) (vec2= lp p))
        (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)
      (refresh-matrices node)
      (set! (dirty-matrix? node) #f)
      ;; If the parent is dirty, all the children need to be marked as
      ;; dirty, too.
      (for-each-child (lambda (child)
                        (when (is-a? child <node-2d>)
                          (set! (dirty-matrix? child) #t)))
                      node)))
  (next-method))

(define-method (activate (node <node-2d>))
  (set! (dirty-matrix? node) #t)
  ;; Set the initial last position to the same as the initial position
  ;; to avoid a brief flash where the node appears at (0, 0).
  (remember-position node)
  (next-method))

(define-method (pause (node <node-2d>))
  ;; We need to set the last position of all objects in the tree to
  ;; their current position, otherwise any moving objects will
  ;; experience this weird jitter while paused because the last
  ;; position will never be updated during the duration of the pause
  ;; event.
  (next-method)
  (remember-position/recursive node))


;;;
;;; Sprite
;;;

(define-class <sprite> (<node-2d>)
  (texture #:accessor texture #:init-keyword #:texture #:asset? #t #:watch? #t)
  (tint #:accessor tint
        #:init-keyword #:tint
        #:init-form white)
  (blend-mode #:accessor blend-mode
              #:init-keyword #:blend-mode
              #:init-form blend:alpha))

(define-method (default-width (sprite <sprite>))
  (texture-width (texture sprite)))

(define-method (default-height (sprite <sprite>))
  (texture-height (texture sprite)))

(define-method (render (sprite <sprite>) alpha)
  (let* ((tex (texture sprite))
         (rect (size sprite))
         (tint (tint sprite))
         (matrix (world-matrix sprite)))
    (draw-sprite* tex rect matrix
                  #:tint tint
                  #:texcoords (texture-gl-tex-rect tex))))


;;;
;;; Texture Atlas Sprite
;;;

(define-class <atlas-sprite> (<sprite>)
  (atlas #:accessor atlas #:init-keyword #:atlas #:asset? #t #:watch? #t)
  (index #:accessor index #:init-keyword #:index #:init-value 0 #:watch? #t))

(define-method (sync-texture (sprite <atlas-sprite>))
  (set! (texture sprite) (texture-atlas-ref (atlas sprite) (index sprite))))

(define-method (on-boot (sprite <atlas-sprite>))
  (sync-texture sprite))

(define-method (on-change (sprite <atlas-sprite>) slot-name old new)
  (case slot-name
    ((atlas index)
     (sync-texture sprite))
    (else
     (next-method))))


;;;
;;; Animated Sprite
;;;

(define-class <animation> ()
  (frames #:getter frames #:init-keyword #:frames)
  (frame-duration #:getter frame-duration #:init-keyword #:frame-duration
                  #:init-form 250))

(define-class <animated-sprite> (<atlas-sprite>)
  (atlas #:accessor atlas #:init-keyword #:atlas #:asset? #t)
  (animations #:accessor animations #:init-keyword #:animations)
  (current-animation #:accessor current-animation
                     #:init-keyword #:default-animation
                     #:init-form 'default)
  (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 anim))
         (frames (frames anim))
         (anim-duration (* frame-duration (vector-length frames)))
         (time (mod (- (elapsed-time) (start-time sprite)) anim-duration))
         (frame (vector-ref frames (inexact->exact
                                    (floor (/ time frame-duration))))))
    (when (not (= frame (index sprite)))
      (set! (index sprite) frame))))

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


;;;
;;; 9-Patch
;;;

(define-class <9-patch> (<node-2d>)
  (texture #:accessor texture #:init-keyword #:texture #:asset? #t)
  (left-margin #:accessor left-margin #:init-keyword #:left)
  (right-margin #:accessor right-margin #:init-keyword #:right)
  (bottom-margin #:accessor bottom-margin #:init-keyword #:bottom)
  (top-margin #:accessor top-margin #:init-keyword #:top)
  (mode #:accessor mode #:init-keyword #:mode #:init-value 'stretch)
  (blend-mode #:accessor blend-mode #:init-keyword #:blend-mode
              #:init-value blend:alpha)
  (tint #:accessor tint #:init-keyword #:tint #:init-value white)
  (render-rect #:getter render-rect #:init-form (make-rect 0.0 0.0 0.0 0.0)))

(define-method (initialize (9-patch <9-patch>) initargs)
  (let ((default-margin (get-keyword #:margin initargs 0.0)))
    (slot-set! 9-patch 'left-margin default-margin)
    (slot-set! 9-patch 'right-margin default-margin)
    (slot-set! 9-patch 'bottom-margin default-margin)
    (slot-set! 9-patch 'top-margin default-margin))
  (next-method)
  (set-rect-width! (render-rect 9-patch) (width 9-patch))
  (set-rect-height! (render-rect 9-patch) (height 9-patch)))

(define-method (on-change (9-patch <9-patch>) slot-name old new)
  (case slot-name
    ((width)
     (set-rect-width! (render-rect 9-patch) new))
    ((height)
     (set-rect-height! (render-rect 9-patch) new)))
  (next-method))

(define-method (render (9-patch <9-patch>) alpha)
  (draw-9-patch* (texture 9-patch)
                 (render-rect 9-patch)
                 (world-matrix 9-patch)
                 #:top-margin (top-margin 9-patch)
                 #:bottom-margin (bottom-margin 9-patch)
                 #:left-margin (left-margin 9-patch)
                 #:right-margin (right-margin 9-patch)
                 #:mode (mode 9-patch)
                 #:blend-mode (blend-mode 9-patch)
                 #:tint (tint 9-patch)))


;;;
;;; Sprite Batch
;;;

(define-class <sprite-batch> (<node-2d>)
  (batch #:accessor batch #:init-keyword #:batch)
  (blend-mode #:accessor blend-mode
              #:init-keyword #:blend-mode
              #:init-form blend:alpha)
  (clear-after-draw? #:accessor clear-after-draw?
                     #:init-keyword #:clear-after-draw?
                     #:init-form #t)
  (batch-matrix #:accessor batch-matrix #:init-thunk make-identity-matrix4))

(define-method (render (sprite-batch <sprite-batch>) alpha)
  (let ((batch (batch sprite-batch)))
    (draw-sprite-batch* batch (batch-matrix sprite-batch)
                        #:blend-mode (blend-mode sprite-batch))
    (when (clear-after-draw? sprite-batch)
      (sprite-batch-clear! batch))))


;;;
;;; Vector Path
;;;

(define-class <canvas> (<node-2d>)
  (painter #:accessor painter #:init-keyword #:painter #:watch? #t)
  (canvas #:accessor canvas #:init-thunk make-empty-canvas))

(define-method (refresh-painter (c <canvas>))
  (let ((p (painter c))
        ;;(bb (painter-bounding-box p))
        )
    (set-canvas-painter! (canvas c) (painter c))
    ;; (set! (origin-x canvas) (- (rect-x bb)))
    ;; (set! (origin-y canvas) (- (rect-y bb)))
    ;; (set! (width canvas) (rect-width bb))
    ;; (set! (height canvas) (rect-height bb))
    ))

(define-method (on-boot (c <canvas>))
  (refresh-painter c))

(define-method (on-change (c <canvas>) slot-name old new)
  (case slot-name
    ((painter)
     (refresh-painter c))
    (else
     (next-method))))

(define-method (render (c <canvas>) alpha)
  (draw-canvas* (canvas c) (world-matrix c)))


;;;
;;; Label
;;;

(define-class <label> (<node-2d>)
  (font #:accessor font #:init-keyword #:font #:init-thunk default-font
        #:asset? #t #:watch? #t)
  (text #:accessor text #:init-form "" #:init-keyword #:text #:watch? #t)
  (align #:accessor align #:init-value 'left #:init-keyword #:align #:watch? #t)
  (vertical-align #:accessor vertical-align #:init-value 'bottom
                  #:init-keyword #:vertical-align #:watch? #t)
  (color #:accessor color #:init-keyword #:color #:init-value white))

(define-method (realign (label <label>))
  (set! (origin-x label)
        (match (align label)
          ('left 0.0)
          ('right (width label))
          ('center (/ (width label) 2.0))))
  (set! (origin-y label)
        (match (vertical-align label)
          ('bottom 0.0)
          ('top (height label))
          ('center (+ (/ (height label) 2.0) (font-descent (font label)))))))

(define-method (refresh-label-size (label <label>))
  (let ((f (font label))
        (t (text label)))
    (set! (width label) (font-line-width f t))
    (set! (height label) (font-line-height f))))

(define-method (on-boot (label <label>))
  (refresh-label-size label)
  (realign label))

(define-method (on-asset-reload (label <label>) slot-name asset)
  (case slot-name
    ((font)
     (refresh-label-size label))))

(define-method (on-change (label <label>) slot-name old new)
  (case slot-name
    ;; TODO: Minor performance improvement: Realignment is not
    ;; necessary when changing the text of a left-aligned label.
    ((font text)
     (refresh-label-size label)
     (realign label))
    ((align vertical-align)
     (realign label))
    (else
     (next-method))))

(define-method (render (label <label>) alpha)
  (draw-text* (font label) (text label) (world-matrix label)
              #:color (color label)))


;;;
;;; Tiled Map
;;;

(define-class <tile-map> (<node-2d>)
  (tile-map #:accessor tile-map #:init-keyword #:map #:asset? #t)
  (layers #:accessor layers #:init-keyword #:layers #:init-form #f))

(define-method (render (node <tile-map>) alpha)
  (let ((m (tile-map node)))
    (draw-tile-map* m (world-matrix node) (tile-map-rect m)
                    #:layers (layers node))))


;;;
;;; Particles
;;;

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

(define-method (on-boot (particles <particles>))
  ;; Default bounding box size.
  (when (zero? (width particles))
    (set! (width particles) 32.0))
  (when (zero? (height particles))
    (set! (height particles) 32.0)))

(define-method (update (node <particles>) dt)
  (update-particles (particles node)))

(define-method (render (node <particles>) alpha)
  (draw-particles* (particles node) (world-matrix node)))