From 7a2809cff923b95f56887557e8b527525061318e Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Tue, 27 Sep 2016 17:08:45 -0400
Subject: [PATCH] Use coordinate-map to align "start" menu nicely

---
 gui.rkt | 21 +++++++++++++--------
 1 file changed, 13 insertions(+), 8 deletions(-)

diff --git a/gui.rkt b/gui.rkt
index 613457d..b88a01c 100644
--- a/gui.rkt
+++ b/gui.rkt
@@ -6,6 +6,7 @@
 (require (prefix-in i: 2htdp/image))
 (require (prefix-in p: pict))
 (require syndicate-gl/2d)
+(require syndicate-gl/affine)
 (require "layout/main.rkt")
 (require "hsv.rkt")
 
@@ -44,7 +45,7 @@
         [(p:pict? x) (p:pict-height x)]
         [else (error '*height "Neither an image nor a pict: ~v" x)]))
 
-(define (costume #:id [id #f] #:parent [parent-id #f] i)
+(define (costume #:id [id #f] #:parent [parent-id #f] #:coordinate-map-id [coordinate-map-id #f] i)
   (define iw (*width i))
   (define ih (*height i))
   (define iaspect (/ iw ih))
@@ -65,6 +66,9 @@
                            ,@(if id
                                  `((touchable ,id ,in-unit-square?))
                                  `())
+                           ,@(if coordinate-map-id
+                                 `((coordinate-map ,coordinate-map-id))
+                                 `())
                            (texture ,i
                                     ,(- (/ translate-x scale-w))
                                     ,(- (/ translate-y scale-h))
@@ -390,11 +394,12 @@
   (define (pushbutton label-str x y [w #f] [h #f]
                       #:shrink-x [shrink-x 0]
                       #:id id
+                      #:coordinate-map-id [coordinate-map-id #f]
                       #:parent parent-id
                       #:trigger-event [trigger-event 'left-up])
     (define label (system-text label-str (theme-button-color)))
     (define i (i:overlay/align "middle" "middle" label (button-underlay label)))
-    (define c (costume #:id id #:parent parent-id i))
+    (define c (costume #:id id #:parent parent-id #:coordinate-map-id coordinate-map-id i))
 
     (define/query-value touching? #f (inbound (touching id)) #t)
     (on #:when (touching?) (message (inbound (mouse-event trigger-event $s)))
@@ -505,17 +510,17 @@
          (parameterize ((theme-button-y-padding 8)
                         (theme-button-min-height 0))
            (pushbutton "Start" x y #:id 'start-button #:parent 'toolbar
+                       #:coordinate-map-id 'start-button
                        #:trigger-event 'left-down)))
        (during (layout-solution 'toolbar (horizontal-layout '(-10.0 0.0)) reqsize
                                 (rectangle $l $t $w $h))
          (x l)
          (y t)
-         ;; TODO: Some way of getting hold of various stages of
-         ;; coordinate transform, so that we can pop up the menu with
-         ;; precision over the top-left corner of the start button,
-         ;; rather than whereever the mouse happens to be.
-         (on (message (button-click 'start-button (mouse-state $mx $my _ _ _)))
-             (send! (pop-up-menu-trigger 'system-menu mx my 0 1 'left-up)))))
+         (during (inbound (coordinate-map 'start-button $xform))
+           (on (message (button-click 'start-button _))
+               (define pt (- (transform-point xform 0+0i) 1+4i)) ;; padding + unoffset
+               (send!
+                (pop-up-menu-trigger 'system-menu (real-part pt) (imag-part pt) 0 1 'left-up))))))
 
 (actor #:name 'window-list-monitor
        (during/actor (window-state $id $title _)