Improved border gadget

release
Slava Pestov 2007-10-31 20:26:12 -04:00
parent af2d0abb0e
commit 0a8682ce9b
1 changed files with 27 additions and 9 deletions

View File

@ -4,23 +4,41 @@ USING: arrays ui.gadgets generic hashtables kernel math
namespaces vectors sequences math.vectors ;
IN: ui.gadgets.borders
TUPLE: border size ;
TUPLE: border size fill ;
: <border> ( child gap -- border )
border construct-gadget
[ >r dup 2array r> set-border-size ] keep
[ add-gadget ] keep ;
: layout-border-loc ( border -- )
dup rect-dim swap gadget-child
[ pref-dim v- 2 v/n [ >fixnum ] map ] keep set-rect-loc ;
dup 2array { 0 0 } border construct-boa
<gadget> over set-delegate
tuck add-gadget ;
M: border pref-dim*
[ border-size 2 v*n ] keep
gadget-child pref-dim v+ ;
: border-major-rect ( border -- rect )
dup border-size swap rect-dim over 2 v*n v- <rect> ;
: border-minor-rect ( major border -- rect )
gadget-child pref-dim
[ >r rect-bounds r> v- 2 v/n v+ ] keep <rect> ;
: scale-rect ( rect vec -- loc dim )
[ v* ] curry >r rect-bounds r> 2apply ;
: average-rects ( rect1 rect2 weight -- rect )
tuck >r >r scale-rect r> r> { 1 1 } swap v- scale-rect
swapd v+ >r v+ r> <rect> ;
: border-child-rect ( border -- rect )
dup border-major-rect
dup pick border-minor-rect
rot border-fill
average-rects ;
M: border layout*
dup layout-border-loc gadget-child prefer ;
dup border-child-rect swap gadget-child
over rect-loc over set-rect-loc
swap rect-dim swap set-layout-dim ;
M: border focusable-child*
gadget-child ;