(define-module (catbird node-2d)
  #:use-module (catbird asset)
  #:use-module (catbird camera)
  #:use-module (catbird cached-slots)
  #:use-module (catbird mixins)
  #:use-module (catbird node)
  #:use-module (catbird observer)
  #:use-module (chickadee)
  #:use-module (chickadee math)
  #: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 framebuffer)
  #:use-module (chickadee graphics particles)
  #:use-module (chickadee graphics path)
  #:use-module (chickadee graphics sprite)
  #:use-module (chickadee graphics text)
  #: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)
  #:export (<node-2d>
            aggregate-bounding-box
            align-bottom
            align-left
            align-right
            align-top
            default-height
            default-width
            expire-local-matrix
            follow-bezier-path
            local-bounding-box
            local-matrix
            move-by
            move-to
            on-child-resize
            origin
            origin-x
            origin-y
            pick
            place-above
            place-below
            place-left
            place-right
            position-x
            position-y
            resize
            rotate-by
            rotate-to
            rotation
            scale
            scale-by
            scale-to
            scale-x
            scale-y
            shear
            shear-x
            shear-y
            teleport
            world-bounding-box
            world-matrix

            <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)
  #:re-export (height
               position
               width))

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

(define (refresh-world-matrix node world)
  (let ((p (parent node))
        (local (local-matrix node)))
    (if (is-a? p <node-2d>)
        (matrix4-mult! world local (world-matrix (parent node)))
        (begin
          (matrix4-identity! world)
          (matrix4-mult! world world local)))
    world))

(define (refresh-inverse-world-matrix node inverse)
  (matrix4-inverse! (world-matrix node) inverse)
  inverse)

(define (refresh-local-bounding-box node bb)
  (let ((p (position node))
        (o (origin node))
        (r (rotation node))
        (k (shear node))
        (s (size 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 (* (rect-width s) (vec2-x s)))
          (set-rect-height! bb (* (rect-height s) (vec2-y s))))
        ;; Slow path: Node is rotated, sheared, or both.
        (let* ((m (local-matrix node))
               (x0 0.0)
               (y0 0.0)
               (x1 (rect-width s))
               (y1 (rect-height s))
               (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))))
    bb))

(define (refresh-world-bounding-box node bb)
  (let* ((m (world-matrix node))
         (s (size node))
         (x0 0.0)
         (y0 0.0)
         (x1 (rect-width s))
         (y1 (rect-height s))
         (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))
    bb))

(define (refresh-aggregate-bounding-box node bb)
  ;; If the node has no children then the aggregate bounding box is
  ;; the same as the world bounding box.
  (rect-copy! (world-bounding-box node) bb)
  (for-each-child (lambda (child)
                    (rect-union! bb (aggregate-bounding-box child)))
                  node)
  bb)

(define-class <node-2d> (<node> <movable-2d> <cacheable>)
  ;; Translation of the origin.  By default, the origin is at the
  ;; bottom left corner of a node.
  (origin #:accessor origin #:init-form (vec2 0.0 0.0) #:init-keyword #:origin
          #:observe? #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)
                          (expire-local-matrix 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)
                          (expire-local-matrix node)))
  ;; Translation
  (position #:accessor position #:init-keyword #:position
            #:init-form (vec2 0.0 0.0) #:observe? #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)
                            (expire-local-matrix 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)
                            (expire-local-matrix node)))
  ;; Rotation around the Z-axis.
  (rotation #:accessor rotation #:init-form 0.0 #:init-keyword #:rotation
            #:observe? #t)
  ;; Scaling
  (scale #:accessor scale #:init-form (vec2 1.0 1.0) #:init-keyword #:scale
         #:observe? #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)
                         (expire-local-matrix 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)
                         (expire-local-matrix node)))
  ;; Shearing
  (shear #:accessor shear #:init-form (vec2 0.0 0.0) #:init-keyword #:shear
        #:observe? #t)
  (shear-x #:accessor shear-x #:allocation #:virtual
          #:slot-ref (lambda (node) (vec2-x (shear node)))
          #:slot-set! (lambda (node x)
                        (set-vec2-x! (shear node) x)
                        (expire-local-matrix node)))
  (shear-y #:accessor shear-y #:allocation #:virtual
          #:slot-ref (lambda (node) (vec2-y (shear node)))
          #:slot-set! (lambda (node y)
                        (set-vec2-y! (shear node) y)
                        (expire-local-matrix 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))
  ;; Transformation matrices:
  ;;
  ;; The local matrix incorporates the node-specific translation,
  ;; rotation, scale, and shear factors.
  (local-matrix #:getter local-matrix #:init-thunk make-identity-matrix4
                #:cached? #t #:refresh refresh-local-matrix)
  ;; The world matrix is defined by the multiplication of the parent's
  ;; world matrix with the local matrix.
  (world-matrix #:getter world-matrix #:init-thunk make-identity-matrix4
                #:cached? #t #:refresh refresh-world-matrix)
  ;; The inverse world matrix is useful for translating world
  ;; coordinates into local coordinates.  Using this matrix it is
  ;; possible to detect if the mouse is over a rotated and sheared
  ;; node, for example.
  (inverse-world-matrix #:getter inverse-world-matrix
                        #:init-form (make-identity-matrix4)
                        #:cached? #t #:refresh refresh-inverse-world-matrix)
  ;; Node dimensions.  Stored as a rectangle for convenience, so it
  ;; can be used as a bounding box that doesn't take any
  ;; transformation matrix into consideration.
  (size #:getter size #:init-thunk make-null-rect)
  (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)
                       (expire-local-bounding-box node)))
  (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)
                        (expire-local-bounding-box node)))
  ;; The local bounding box is the combination of the node's
  ;; dimensions with the local transformation matrix.
  (local-bounding-box #:getter local-bounding-box #:init-thunk make-null-rect
                      #:cached? #t #:refresh refresh-local-bounding-box)
  ;; The world bounding box is the combination of the node's
  ;; dimensions with the world transformation matrix.
  (world-bounding-box #:getter world-bounding-box #:init-thunk make-null-rect
                      #:cached? #t #:refresh refresh-world-bounding-box)
  ;; The aggregate bounding box is the union of the node's world
  ;; bounding boxes and the aggregate bounding boxes of all its
  ;; children.  This bounding box is used to quickly determine if a
  ;; point in world space might be within any node in a tree.  This
  ;; bounding box can be used for render culling, mouse selection, and
  ;; render clipping.
  (aggregate-bounding-box #:getter aggregate-bounding-box
                          #:init-thunk make-null-rect #:cached? #t
                          #:refresh refresh-aggregate-bounding-box))

(define-method (initialize (node <node-2d>) args)
  (next-method)
  ;; If scale is specified as a scalar value, convert it to a vector
  ;; that applies identical scaling to both axes.
  (let ((s (scale node)))
    (when (number? s)
      (slot-set! node 'scale (vec2 s s))))
  ;; 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.
  (vec2-copy! (position node) (render-position node))
  ;; 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))

(define (expire-local-matrix node)
  (expire-slot! node 'local-matrix)
  (expire-world-matrix node)
  (expire-local-bounding-box node))

(define (expire-world-matrix node)
  (unless (slot-expired? node 'world-matrix)
    (expire-slot! node 'world-matrix)
    (expire-slot! node 'inverse-world-matrix)
    (for-each-child (lambda (child)
                      (expire-world-matrix child)
                      (expire-world-bounding-box child))
                    node)))

(define (expire-local-bounding-box node)
  (expire-slot! node 'local-bounding-box)
  (expire-world-bounding-box node))

(define (expire-world-bounding-box node)
  (expire-slot! node 'world-bounding-box)
  (expire-aggregate-bounding-box node))

(define (expire-aggregate-bounding-box node)
  (unless (slot-expired? node 'aggregate-bounding-box)
    (expire-slot! node 'aggregate-bounding-box)
    (let ((p (parent node)))
      (when (is-a? p <node-2d>)
        (expire-aggregate-bounding-box p)))))


;;;
;;; Bounding boxes
;;;

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

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

(define-method (on-child-resize node child)
  #t)

;; (define-method ((setter origin) (node <node-2d>))
;;   (dirty! node)
;;   (next-method))

(define-method (on-change (node <node-2d>) slot old new)
  (case slot
    ((origin position rotation scale shear)
     (expire-local-matrix node))))

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


;;;
;;; Animation
;;;

(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 (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)
  (expire-local-matrix 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)
                         (expire-local-matrix 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 loop ((kids (reverse (children node))))
         (match kids
           (()
            (let* ((m (inverse-world-matrix node))
                   (x (vec2-x p))
                   (y (vec2-y p))
                   (tx (matrix4-transform-x m x y))
                   (ty (matrix4-transform-y m x y)))
              (and (>= tx 0.0)
                   (< tx (width node))
                   (>= ty 0.0)
                   (< ty (height node))
                   node)))
           ((child . rest)
            (let ((o (origin node)))
              (or (pick child p pred)
                  (loop rest))))))))


;;;
;;; Updating/rendering
;;;

(define-method (update/around (node <node-2d>) dt)
  (unless (paused? node)
    (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))

(define-method (tree-in-view? (node <node-2d>))
  (rect-intersects? (aggregate-bounding-box node)
                    (view-bounding-box (current-camera))))

(define-method (in-view? (node <node-2d>))
  (rect-intersects? (world-bounding-box node)
                    (view-bounding-box (current-camera))))

(define-method (render/around (node <node-2d>) alpha)
  ;; Compute the linearly interpolated rendering position, in the case
  ;; that node has moved since the last update.
  (when (visible? node)
    (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)))
        (expire-local-matrix node)))
    (next-method)))


;;;
;;; Relative placement and alignment
;;;

;; Placement and alignment of nodes is done under the assumption that
;; the nodes are in the same local coordinate space.  If this is not
;; the case, the results will be garbage.

(define* (place-right a b #:key (padding 0.0))
  "Adjust B's x position coordinate so that it is PADDING distance to
the right of A."
  (set! (position-x b) (+ (position-x a) (width a) padding)))

(define* (place-left a b #:key (padding 0.0))
  "Adjust B's x position coordinate so that it is PADDING distance to
the left of A."
  (set! (position-x b) (- (position-x a) (width b) padding)))

(define* (place-above a b #:key (padding 0.0))
  "Adjust B's y position coordinate so that it is PADDING distance above
A."
  (set! (position-y b) (+ (position-y a) (height a) padding)))

(define* (place-below a b #:key (padding 0.0))
  "Adjust B's y position coordinate so that it is PADDING distance below
A."
  (set! (position-y b) (- (position-y a) (height b) padding)))

(define (align-left a b)
  "Align the left side of B with the left side of A."
  (set! (position-x b) (position-x a)))

(define (align-right a b)
  "Align the right side of B with the right side of A."
  (set! (position-x b) (+ (position-x a) (width a))))

(define (align-bottom a b)
  "Align the bottom of B with the bottom of A."
  (set! (position-y b) (position-y a)))

(define (align-top a b)
  "Align the top of B with the top of A."
  (set! (position-y b) (+ (position-y a) (height a))))


;;;
;;; Sprite
;;;

(define-class <sprite> (<node-2d>)
  (texture #:accessor texture #:init-keyword #:texture #:asset? #t
           #:observe? #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 (on-change (sprite <sprite>) slot-name old new)
  (case slot-name
    ((texture)
     (set! (width sprite) (texture-width new))
     (set! (height sprite) (texture-height new)))))

(define-method (render (sprite <sprite>) alpha)
  (let ((t (texture sprite)))
    (with-graphics-state ((g:blend-mode (blend-mode sprite)))
      (draw-sprite* t (size sprite) (world-matrix sprite)
                    #:tint (tint sprite)
                    #:texcoords (texture-gl-tex-rect t)))))

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

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

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

(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 #:init-value #f
           #:observe? #t)
  (canvas #:accessor canvas #:init-thunk make-empty-canvas))

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

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

(define-method ((setter canvas) (c <canvas>))
  (next-method)
  (set-canvas-painter! (canvas c) (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 #:observe? #t)
  (text #:accessor text #:init-value "" #:init-keyword #:text #:observe? #t)
  (compositor #:accessor compositor #:init-thunk make-compositor)
  (page #:accessor page #:init-thunk make-page)
  (typeset #:accessor typeset #:init-value typeset-lrtb)
  (align #:accessor align #:init-value 'left #:init-keyword #:align #:observe? #t)
  (vertical-align #:accessor vertical-align #:init-value 'bottom
                  #:init-keyword #:vertical-align #:observe? #t)
  (color #:accessor color #:init-keyword #:color #:init-value white #:observe? #t))

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

(define-method (refresh-label (label <label>))
  (let ((c (compositor label))
        (p (page label)))
    (compositor-reset! c)
    ((typeset label) c (font label) (text label) (color label))
    (page-reset! p)
    (page-write! p c)
    (let ((bb (page-bounding-box p)))
      (set! (width label) (rect-width bb))
      (set! (height label) (rect-height bb)))))

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

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

(define-method (on-change (label <label>) slot-name old new)
  (case slot-name
    ((font text)
     (refresh-label label)
     (unless (eq? (align label) 'left)
       (realign label)))
    ((color)
     (refresh-label label))
    ((align vertical-align)
     (realign label))
    (else
     (next-method))))

(define-method (render (label <label>) alpha)
  (draw-page (page label) (world-matrix 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)))