From 14464dee966fe415d4c8e1fb8b5205653b22003f Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Mon, 3 Oct 2022 19:22:23 -0400
Subject: Add prototype catbird modules.

---
 catbird/node-2d.scm | 939 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 939 insertions(+)
 create mode 100644 catbird/node-2d.scm

(limited to 'catbird/node-2d.scm')

diff --git a/catbird/node-2d.scm b/catbird/node-2d.scm
new file mode 100644
index 0000000..fc579ba
--- /dev/null
+++ b/catbird/node-2d.scm
@@ -0,0 +1,939 @@
+(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)))
-- 
cgit v1.2.3