[racket] Finding a GUI containee at x,y within a container

In case it is useful to others, here is what I came up with, based on (and
thanks for) the info from Matthew.  By the way, I probably would not be
able to make a mouse-event% work for what I need, but thanks for the idea
Laurent.

In the code below, get-containee is passed a container to search, an (x,y)
coordinate relative to the origin of the container, and a z to indicate
which level to select (i.e. 0 is the most contained containee, 1 is its
parent, 2 is its grandparent, etc.). If the requested z-level exceeds the
number of levels of containment then #f is returned. Any suggestions on
improvements are gratefully received.

To aid in debugging, I also developed a dump-hierarchy function which shows
(via printf) the coordinates of each of the level of containers and their
respective containees.

To test, I include a junk GUI with several levels of containers, include
several types of GUI elements, and get (x,y) values from 'left-up and
'left-down mouse events by overriding the on-subwindow-event in the root
(frame%) container. Note that as documented elsewhere, if
on-subwindow-event requires using another thread to complete (e.g. by using
printf), then the mouse events do not get passed on to, and therefore
properly handled by, the real target component (i.e. check boxes don't get
checked, items in list boxes don't get selected, etc.).

Cheers,

Kieron.

****

#lang racket/base

(require racket/gui)

(define (dump-hierarchy-level container level x-offset y-offset)
#;  (printf "dump-hierarchy-level: ~a ~a (~a,~a)~n" container level
x-offset y-offset)
  (for-each
    (lambda (o)
      (define x1 (+ x-offset (send o get-x)))
      (define y1 (+ y-offset (send o get-y)))
      (define-values (w h) (send o get-size))
      (define x2 (+ x1 w))
      (define y2 (+ y1 h))
      (printf "~a~a (~a,~a) -> (~a,~a) ~a~n" (make-string (* level 2)
#\space) level x1 y1 x2 y2 o)
      (when (is-a? o area-container<%>)
        (dump-hierarchy-level o (+ level 1) x1 y1))
      )
    (send container get-children)
    )
  )

(define (dump-hierarchy container)
  (printf "dump-hierarchy: ~a~n" container)
  (dump-hierarchy-level container 0 0 0)
  )

(define (get-containee-hierarchy container x y x-offset y-offset)
#;  (printf "get-containee-hierarchy: ~a (~a,~a) (~a,~a)~n" container x y
x-offset y-offset)
  (flatten
    (filter-map
      (lambda (o)
        (define x1 (+ x-offset (send o get-x)))
        (define y1 (+ y-offset (send o get-y)))
        (define-values (w h) (send o get-size))
        (define x2 (+ x1 w))
        (define y2 (+ y1 h))
        (define target? (and (<= x1 x x2) (<= y1 y y2)))
        (and target?
          (if (is-a? o area-container<%>)
            (cons (get-containee-hierarchy o x y x1 y1) o)
            o)))
        (send container get-children)
      )))

(define (get-containee container x y z)
#;  (printf "get-containee: ~a (~a,~a) ~a~n" container x y z)
  (define containee-hierarchy (get-containee-hierarchy container x y 0 0))
  (and
    (< z (length containee-hierarchy))
    (list-ref containee-hierarchy z))
  )

; Test
(define f
  (new
    (class frame%
      (super-new)

      (inherit screen->client)
      (define/override (on-subwindow-event r e)
        (match (send e get-event-type)
          [(or 'left-down 'left-up)
            ; get location of click in frame% coordinates
            (define-values (screen-x screen-y) (send r client->screen (send
e get-x) (send e get-y)))
            (define-values (client-x client-y) (screen->client screen-x
screen-y))
#;            (printf "on-subwindow-event: (~a,~a) (~a,~a) (~a,~a)~n" (send
e get-x) (send e get-y) screen-x screen-y client-x client-y)
            (printf "target:~a" (get-containee this client-x client-y 0))
            (printf "  parent:~a~n" (get-containee this client-x client-y
1))
            ]
          [_ (void)]
          )
        #f
        )
      )
      [label "test window"]))

(define vp1 (new vertical-panel% [parent f]))
(define hp1 (new horizontal-panel% [parent vp1]))
(define c (new canvas% [parent hp1] [style '(border)] [min-width 300]
[min-height 400] [stretchable-width #f] [stretchable-height #f]))
(define l (new list-box% [parent hp1] [label "List Box"] [choices '("alpha"
"bravo" "charlie")] [min-width 250]))
(define cb (new check-box% [parent vp1] [label "Check Box #1"]))
(define b1 (new button% [parent vp1] [label "Button 1"]))

(define vp2 (new vertical-panel% [parent f]))
(define hp2 (new horizontal-panel% [parent vp2]))
(define b2 (new button% [parent hp2] [label "Button 1"]))
(define cb2 (new check-box% [parent hp2] [label "Check Box 2"]))

(send f show #t)

(dump-hierarchy f)
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.racket-lang.org/users/archive/attachments/20120913/195f1907/attachment.html>