2008-07-10 21:32:17 -04:00
|
|
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
2007-09-20 18:09:08 -04:00
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2008-07-10 21:32:17 -04:00
|
|
|
USING: accessors arrays ui.gadgets kernel math
|
2008-07-11 19:34:43 -04:00
|
|
|
namespaces vectors sequences math.vectors math.geometry.rect ;
|
2007-09-20 18:09:08 -04:00
|
|
|
IN: ui.gadgets.borders
|
|
|
|
|
2008-07-11 02:33:20 -04:00
|
|
|
TUPLE: border < gadget
|
|
|
|
{ size initial: { 0 0 } }
|
|
|
|
{ fill initial: { 0 0 } }
|
|
|
|
{ align initial: { 1/2 1/2 } } ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-07-11 01:46:15 -04:00
|
|
|
: new-border ( child class -- border )
|
2008-09-27 15:36:04 -04:00
|
|
|
new-gadget swap add-gadget ; inline
|
2008-07-11 01:46:15 -04:00
|
|
|
|
|
|
|
: <border> ( child gap -- border )
|
|
|
|
swap border new-border
|
|
|
|
swap dup 2array >>size ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-12-19 03:25:40 -05:00
|
|
|
: <filled-border> ( child gap -- border )
|
|
|
|
<border> { 1 1 } >>fill ;
|
|
|
|
|
2007-09-20 18:09:08 -04:00
|
|
|
M: border pref-dim*
|
2008-07-11 02:33:20 -04:00
|
|
|
[ size>> 2 v*n ] keep
|
2007-09-20 18:09:08 -04:00
|
|
|
gadget-child pref-dim v+ ;
|
|
|
|
|
2008-07-11 02:33:20 -04:00
|
|
|
: border-major-dim ( border -- dim )
|
|
|
|
[ dim>> ] [ size>> 2 v*n ] bi v- ;
|
2007-10-31 20:26:12 -04:00
|
|
|
|
2008-07-11 02:33:20 -04:00
|
|
|
: border-minor-dim ( border -- dim )
|
|
|
|
gadget-child pref-dim ;
|
2007-10-31 20:26:12 -04:00
|
|
|
|
2008-07-11 02:33:20 -04:00
|
|
|
: scale ( a b s -- c )
|
|
|
|
tuck { 1 1 } swap v- [ v* ] 2bi@ v+ ;
|
2007-10-31 20:26:12 -04:00
|
|
|
|
2008-07-11 02:33:20 -04:00
|
|
|
: border-dim ( border -- dim )
|
|
|
|
[ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ;
|
|
|
|
|
|
|
|
: border-loc ( border dim -- loc )
|
2008-07-12 02:29:12 -04:00
|
|
|
[ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip
|
|
|
|
v- v* v+ [ >fixnum ] map ;
|
2007-10-31 20:26:12 -04:00
|
|
|
|
|
|
|
: border-child-rect ( border -- rect )
|
2008-07-11 02:33:20 -04:00
|
|
|
dup border-dim [ border-loc ] keep <rect> ;
|
2007-10-31 20:26:12 -04:00
|
|
|
|
2007-09-20 18:09:08 -04:00
|
|
|
M: border layout*
|
2007-10-31 20:26:12 -04:00
|
|
|
dup border-child-rect swap gadget-child
|
2008-09-01 23:43:02 -04:00
|
|
|
over loc>> >>loc
|
2008-09-27 17:45:20 -04:00
|
|
|
swap dim>> >>dim
|
|
|
|
drop ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
M: border focusable-child*
|
|
|
|
gadget-child ;
|