"Clip" shrinkable pushbuttons better. Still needs lots of work.
This commit is contained in:
parent
105646be57
commit
9bae5a3536
18
gui.rkt
18
gui.rkt
|
@ -387,7 +387,7 @@
|
|||
;; TODO: figure out what it is about (define (f #:x x) x) that
|
||||
;; mandates begin-for-declarations to hide it from syndicate/lang's
|
||||
;; local-expansion here :-(
|
||||
(define (pushbutton label-str x y
|
||||
(define (pushbutton label-str x y [w #f] [h #f]
|
||||
#:shrink-x [shrink-x 0]
|
||||
#:id id
|
||||
#:parent parent-id
|
||||
|
@ -399,8 +399,11 @@
|
|||
(define/query-value touching? #f (inbound (touching id)) #t)
|
||||
(on #:when (touching?) (message (inbound (mouse-event trigger-event $s)))
|
||||
(send! (button-click id s)))
|
||||
(assert (outbound (c 0 (rectangle (x) (y) (*width i) (*height i)))))
|
||||
(box-size (sizing (*width i) 0 shrink-x) (sizing (*height i) 0 0))))
|
||||
(assert (outbound (c 0 (rectangle (x)
|
||||
(y)
|
||||
(or (and w (w)) (*width i))
|
||||
(or (and h (h)) (*height i))))))
|
||||
(box-size (sizing (*width i) 0 (* shrink-x (*width i))) (sizing (*height i) 0 0))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
|
@ -517,18 +520,17 @@
|
|||
(actor #:name 'window-list-monitor
|
||||
(during/actor (window-state $id $title _)
|
||||
#:name (list 'window-list id)
|
||||
(field [x 0] [y 0])
|
||||
(field [x 0] [y 0] [width #f] [height #f])
|
||||
(define reqsize
|
||||
(parameterize ((theme-button-y-padding 8)
|
||||
(theme-button-min-height 0)
|
||||
(theme-button-background-color (hsv->color 240 1 0.6)))
|
||||
(pushbutton title x y #:id (list 'window-list id) #:parent 'toolbar
|
||||
#:shrink-x weak-fill
|
||||
(pushbutton title x y width height #:id (list 'window-list id) #:parent 'toolbar
|
||||
#:shrink-x 1
|
||||
#:trigger-event 'left-down)))
|
||||
(during (layout-solution 'toolbar (horizontal-layout `(-5.0 ,id)) reqsize
|
||||
(rectangle $l $t $w $h))
|
||||
(x l)
|
||||
(y t)
|
||||
(begin (x l) (y t) (width w) (height h))
|
||||
(during (top-widget id)
|
||||
(assert (outbound (sprite #:id (list 'window-list id 'highlight)
|
||||
#:parent (list 'window-list id)
|
||||
|
|
Loading…
Reference in New Issue