diff options
author | David Thompson <dthompson2@worcester.edu> | 2022-12-27 12:24:28 -0500 |
---|---|---|
committer | David Thompson <dthompson2@worcester.edu> | 2022-12-28 12:18:33 -0500 |
commit | 13479fde47ce622a473eee876484c2fad74cb4a0 (patch) | |
tree | aed2f2d20253260b4d1c19d17555a54dcae30a87 /catbird | |
parent | 6b422033981c2547da73d82301826f9d1bf3661e (diff) |
Make pick method more general.
Now it can work on scenes as well as 2D nodes. In the future, it
could also work on 3D nodes that don't exist yet.
Diffstat (limited to 'catbird')
-rw-r--r-- | catbird/node-2d.scm | 38 | ||||
-rw-r--r-- | catbird/node.scm | 6 | ||||
-rw-r--r-- | catbird/scene.scm | 9 |
3 files changed, 33 insertions, 20 deletions
diff --git a/catbird/node-2d.scm b/catbird/node-2d.scm index 34a7417..a81e2a6 100644 --- a/catbird/node-2d.scm +++ b/catbird/node-2d.scm @@ -80,7 +80,6 @@ origin origin-x origin-y - pick place-above place-at place-at-x @@ -603,25 +602,24 @@ (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)))))))) +(define-method (pick (node <node-2d>) p) + (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) + (loop rest))))))) ;;; diff --git a/catbird/node.scm b/catbird/node.scm index c923f94..40b8673 100644 --- a/catbird/node.scm +++ b/catbird/node.scm @@ -35,6 +35,7 @@ children for-each-child on-boot + pick reboot child-ref & attach-to @@ -189,6 +190,11 @@ (let ((p (parent node))) (and p (apply send p message args))))) +;; The base node class has no spatial awareness, so all attempts to +;; pick such a node will fail. +(define-method (pick (node <node>) p) + #f) + (define-method (blink (node <node>) times interval) (let loop ((i 0)) (when (< i times) diff --git a/catbird/scene.scm b/catbird/scene.scm index 046a8dd..46d343e 100644 --- a/catbird/scene.scm +++ b/catbird/scene.scm @@ -29,6 +29,7 @@ #:use-module (chickadee scripting) #:use-module (ice-9 exceptions) #:use-module (ice-9 format) + #:use-module (ice-9 match) #:use-module (oop goops) #:use-module (srfi srfi-1) #:export (<scene> @@ -215,3 +216,11 @@ (define-method (height (scene <scene>)) (fold (lambda (r h) (max h (height r))) 0.0 (regions scene))) + +(define-method (pick (scene <scene>) p) + (let loop ((kids (children scene))) + (match kids + (() #f) + ((node . rest) + (or (pick node p) + (loop rest)))))) |