"Clip" shrinkable pushbuttons better. Still needs lots of work.

This commit is contained in:
Tony Garnock-Jones 2016-09-27 00:21:02 -04:00
parent 105646be57
commit 9bae5a3536
1 changed files with 10 additions and 8 deletions

18
gui.rkt
View File

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