From 13479fde47ce622a473eee876484c2fad74cb4a0 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Tue, 27 Dec 2022 12:24:28 -0500
Subject: 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.
---
 catbird/node-2d.scm | 38 ++++++++++++++++++--------------------
 catbird/node.scm    |  6 ++++++
 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))))))
-- 
cgit v1.2.3