;;; Catbird Game Engine
;;; Copyright © 2022 David Thompson <davet@gnu.org>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;
;; 2D game nodes.
;;
;;; Code:
(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) #:prefix 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
            center
            center-in-parent
            center-horizontal
            center-horizontal-in-parent
            center-vertical
            center-vertical-in-parent
            default-height
            default-width
            expire-local-matrix
            fit-to-children
            follow-bezier-path
            local-bounding-box
            local-height
            local-matrix
            local-origin-x
            local-origin-y
            local-width
            local-x
            local-y
            move-by
            move-to
            on-child-resize
            origin
            origin-x
            origin-y
            place-above
            place-at
            place-at-x
            place-at-y
            place-below
            place-left
            place-right
            position-x
            position-y
            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
            world->local

            <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 (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 the parent isn't a 2D node, then we consider this to be a
    ;; root node, which means the world matrix is the same as the
    ;; local matrix.
    (if (is-a? p <node-2d>)
        (matrix4-mult! world local (world-matrix p))
        (matrix4-copy! local world))
    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 ((z (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 z)))
          (set-rect-height! bb (* (rect-height s) (vec2-y z))))
        ;; 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
         #:observe? #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
          #:observe? #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.
  (let ((r (size node)))
    (set-rect-width! r (or (get-keyword #:width args)
                           (default-width node)))
    (set-rect-height! r (or (get-keyword #:height args)
                            (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 (local-x (node <node-2d>))
  (rect-x (local-bounding-box node)))

(define-method (local-y (node <node-2d>))
  (rect-y (local-bounding-box node)))

(define-method (local-width (node <node-2d>))
  (rect-width (local-bounding-box node)))

(define-method (local-height (node <node-2d>))
  (rect-height (local-bounding-box node)))

(define-method (local-origin-x (node <node-2d>))
  (matrix4-transform-x (local-matrix node) 0.0 0.0))

(define-method (local-origin-y (node <node-2d>))
  (matrix4-transform-y (local-matrix node) 0.0 0.0))

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

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

(define-method (resize (node <node-2d>) w h)
  ;; No-op if the size is the same.
  (unless (and (= (width node) w)
               (= (height node) h))
    (set! (width node) w)
    (set! (height node) h)
    (expire-local-bounding-box node)
    (on-child-resize (parent node) node)))

(define-method (resize (node <node-2d>))
  (resize node (default-width node) (default-height 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)
  ;; No-op if the node wouldn't be moved at all.
  (unless (and (= dx 0.0) (= dy 0.0))
    (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)
  ;; No-op if the node wouldn't be moved at all.
  (unless (and (= dx 0.0) (= dy 0.0))
    (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 (world->local (node <node-2d>) p)
  (matrix4-transform-vec2 (inverse-world-matrix node) p))

(define-method (pick (node <node-2d>) p)
  (let loop ((kids (reverse (children node))))
    (match kids
      (()
       ;; Multiply the cursor position by the inverse world matrix to
       ;; translate world coordinates into node-local coordinates.
       (let* ((p* (world->local node p))
              (x (vec2-x p*))
              (y (vec2-y p*)))
         (and (>= x 0.0)
              (< x (width node))
              (>= y 0.0)
              (< y (height node))
              node)))
      ((child . rest)
       (let ((o (origin node)))
         (or (pick child p)
             (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)))
      (unless (and (vec2= rp p) (vec2= lp p))
        (let ((beta (- 1.0 alpha)))
          (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)))


;;;
;;; Placement and alignment
;;;

(define (place-at-x node x)
  "Adjust position of NODE so that its left edge is at X on the x-axis."
  (set! (position-x node)
        (+ x (- (local-origin-x node) (local-x node)))))

(define (place-at-y node y)
  "Adjust position of NODE so that its bottom edge is at Y on the
y-axis."
  (set! (position-y node)
        (+ y (- (local-origin-y node) (local-y node)))))

(define (place-at node x y)
  "Adjust position of NODE so that its bottom-left corner is at (X, Y)."
  (place-at-x node x)
  (place-at-y node y))

;; Relative 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)
        (+ (local-x a) (local-width a) padding
           (- (local-origin-x b) (local-x b)))))

(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)
        (- (local-x a) (local-width b) padding
           (- (local-x b) (local-origin-x b)))))

(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)
        (+ (local-y a) (local-height a) padding
           (- (local-origin-y b) (local-y b)))))

(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)
        (- (local-y a) (local-height b) padding
           (- (local-y b) (local-origin-y b)))))

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

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

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

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

(define (center-horizontal a b)
  "Move the x position of A so that it is centered with B."
  (set! (position-x b)
        (+ (local-x a)
           (/ (- (local-width a) (local-width b)) 2.0)
           (- (local-x b) (local-origin-x b)))))

(define (center-vertical a b)
  "Move the y position of A so that it is centered with B."
  (set! (position-y b)
        (+ (local-y a)
           (/ (- (local-height a) (local-height b)) 2.0)
           (- (local-y b) (local-origin-y b)))))

(define (center a b)
  "Center B within A."
  (center-horizontal a b)
  (center-vertical a b))

(define (center-horizontal-in-parent node)
  "Center x position of NODE within its parent."
  (set! (position-x node)
        (+ (/ (- (width (parent node)) (local-width node)) 2.0)
           (- (local-origin-x node) (local-x node)))))

(define (center-vertical-in-parent node)
  "Center y position of NODE within its parent."
  (set! (position-y node)
        (+ (/ (- (height (parent node)) (local-height node)) 2.0)
           (- (local-origin-y node) (local-y node)))))

(define (center-in-parent node)
  "Center NODE within its parent."
  (center-horizontal-in-parent node)
  (center-vertical-in-parent node))


;;;
;;; Sizing
;;;

(define* (fit-to-children node #:optional (padding 0.0))
  "Resize NODE to fit the current size of its visible children, with
PADDING on all sides."
  (let ((bb (make-null-rect)))
    ;; Compute bounding box of all children.
    (for-each-child (lambda (child)
                      (when (visible? child)
                        (rect-union! bb (local-bounding-box child))))
                    node)
    ;; Adjust all children so that there is the desired padding.
    (let ((dx (- padding (rect-x bb)))
          (dy (- padding (rect-y bb))))
      (for-each-child (lambda (child)
                        (when (visible? child)
                          (move-by child dx dy)))
                      node))
    ;; Finally, resize ourselves.
    (let ((w (+ (rect-width bb) (* padding 2.0)))
          (h (+ (rect-height bb) (* padding 2.0))))
      (resize node w h))))


;;;
;;; 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>))
  (let ((t (texture sprite)))
    (if t (texture-width t) 0.0)))

(define-method (default-height (sprite <sprite>))
  (let ((t (texture sprite)))
    (if t (texture-height t) 0.0)))

(define-method (on-change (sprite <sprite>) slot-name old new)
  (case slot-name
    ((texture)
     (let ((new (artifact (->asset new))))
       (resize sprite
               (texture-width new)
               (texture-height new)))))
  (next-method))

(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 (initialize (sprite <atlas-sprite>) initargs)
  (next-method)
  (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 path:make-empty-canvas))

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

;; Width and height of canvas nodes default to the size of their
;; initial painter, or 0 if there isn't one.
(define-method (default-width (c <canvas>))
  (let ((p (painter c)))
    (if p (rect-width (path:painter-bounding-box p)) 0.0)))

(define-method (default-height (c <canvas>))
  (let ((p (painter c)))
    (if p (rect-height (path:painter-bounding-box p)) 0.0)))

(define-method (refresh-painter (c <canvas>))
  (define (close? x y)
    (<= (abs (- x y)) 0.01))
  (let* ((p (painter c)))
    (when p
      ;; Scale the original painter within the vector path rendering
      ;; system so that it fills the canvas nodes bounding box.
      (let* ((bb (path:painter-bounding-box p))
             (pw (rect-width bb))
             (ph (rect-height bb))
             (w (width c))
             (h (height c))
             (p* (if (and (close? w pw) (close? h ph))
                     p ; width/height the same
                     ;; Scale by the factor that makes the painter's
                     ;; size stretch/shrink to occupy the entire
                     ;; bounding box.
                     (path:scale (vec2 (/ w pw) (/ h ph)) p))))
        (path:set-canvas-painter! (canvas c) p*)))))

(define-method ((setter canvas) (c <canvas>))
  (next-method)
  (path:set-canvas-painter! (canvas c) (painter c)))

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

(define-method (render (c <canvas>) alpha)
  (path: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 (initialize (label <label>) initargs)
  (next-method)
  (refresh-label label)
  (realign label))

(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)))
      (resize label (rect-width bb) (rect-height bb)))
    (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 (default-width (particles <particles>))
  32.0)

(define-method (default-height (particles <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)))