syndicate-lang
/
syndicate-gui-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Use coordinate-map to align "start" menu nicely

This commit is contained in:
Tony Garnock-Jones 2016-09-27 17:08:45 -04:00
parent 9bae5a3536
commit 7a2809cff9
1 changed files with 13 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
gui.rkt
View File

@ -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 _)