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