diff options
Diffstat (limited to 'catbird/node-2d.scm')
| -rw-r--r-- | catbird/node-2d.scm | 939 |
1 files changed, 939 insertions, 0 deletions
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))) |