139 lines
3.2 KiB
Factor
139 lines
3.2 KiB
Factor
! Copyright (C) 2005, 2007 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: generic hashtables kernel math namespaces sequences vectors words ;
|
|
IN: gadgets
|
|
|
|
GENERIC: graft* ( gadget -- )
|
|
|
|
M: gadget graft* drop ;
|
|
|
|
: graft ( gadget -- )
|
|
t over set-gadget-grafted?
|
|
dup graft*
|
|
[ graft ] each-child ;
|
|
|
|
GENERIC: ungraft* ( gadget -- )
|
|
|
|
M: gadget ungraft* drop ;
|
|
|
|
: ungraft ( gadget -- )
|
|
dup gadget-grafted? [
|
|
dup [ ungraft ] each-child
|
|
dup ungraft*
|
|
f over set-gadget-grafted?
|
|
] when drop ;
|
|
|
|
: (unparent) ( gadget -- )
|
|
dup ungraft
|
|
dup forget-pref-dim
|
|
f swap set-gadget-parent ;
|
|
|
|
: unfocus-gadget ( child gadget -- )
|
|
tuck gadget-focus eq?
|
|
[ f swap set-gadget-focus ] [ drop ] if ;
|
|
|
|
: unparent ( gadget -- )
|
|
[
|
|
dup gadget-parent dup [
|
|
over (unparent)
|
|
[ unfocus-gadget ] 2keep
|
|
[ gadget-children delete ] keep
|
|
relayout
|
|
] [
|
|
2drop
|
|
] if
|
|
] when* ;
|
|
|
|
: (clear-gadget) ( gadget -- )
|
|
dup [ (unparent) ] each-child
|
|
f over set-gadget-focus
|
|
f swap set-gadget-children ;
|
|
|
|
: clear-gadget ( gadget -- )
|
|
dup (clear-gadget) relayout ;
|
|
|
|
: ((add-gadget)) ( gadget box -- )
|
|
[ gadget-children ?push ] keep set-gadget-children ;
|
|
|
|
: (add-gadget) ( gadget box -- )
|
|
over unparent
|
|
dup pick set-gadget-parent
|
|
[ ((add-gadget)) ] 2keep
|
|
gadget-grafted? [ graft ] [ drop ] if ;
|
|
|
|
: add-gadget ( gadget parent -- )
|
|
[ (add-gadget) ] keep relayout ;
|
|
|
|
: add-gadgets ( seq parent -- )
|
|
swap [ over (add-gadget) ] each relayout ;
|
|
|
|
: (parents) ( gadget -- )
|
|
[ dup , gadget-parent (parents) ] when* ;
|
|
|
|
: parents ( gadget -- seq )
|
|
[ (parents) ] { } make ;
|
|
|
|
: each-parent ( gadget quot -- ? )
|
|
>r parents r> all? ; inline
|
|
|
|
: find-parent ( gadget quot -- parent )
|
|
>r parents r> find nip ; inline
|
|
|
|
: screen-loc ( gadget -- loc )
|
|
parents { 0 0 } [ rect-loc v+ ] reduce ;
|
|
|
|
: (screen-rect) ( gadget -- loc ext )
|
|
dup gadget-parent [
|
|
>r rect-extent r> (screen-rect)
|
|
>r tuck v+ r> vmin >r v+ r>
|
|
] [
|
|
rect-extent
|
|
] if* ;
|
|
|
|
: screen-rect ( gadget -- rect )
|
|
(screen-rect) <extent-rect> ;
|
|
|
|
: child? ( parent child -- ? )
|
|
{
|
|
{ [ 2dup eq? ] [ 2drop t ] }
|
|
{ [ dup not ] [ 2drop f ] }
|
|
{ [ t ] [ gadget-parent child? ] }
|
|
} cond ;
|
|
|
|
GENERIC: focusable-child* ( gadget -- child/t )
|
|
|
|
M: gadget focusable-child* drop t ;
|
|
|
|
: focusable-child ( gadget -- child )
|
|
dup focusable-child*
|
|
dup t eq? [ drop ] [ nip focusable-child ] if ;
|
|
|
|
: make-gadget ( quot gadget -- gadget )
|
|
[ dup \ make-gadget set slip ] with-scope ; inline
|
|
|
|
: gadget, ( gadget -- ) \ make-gadget get add-gadget ;
|
|
|
|
: make-pile ( quot -- pack )
|
|
<pile> make-gadget ; inline
|
|
|
|
: make-filled-pile ( quot -- pack )
|
|
<filled-pile> make-gadget ; inline
|
|
|
|
: make-shelf ( quot -- pack )
|
|
<shelf> make-gadget ; inline
|
|
|
|
: with-gadget ( gadget quot -- )
|
|
[ swap gadget set call ] with-scope ; inline
|
|
|
|
: g ( -- gadget ) gadget get ;
|
|
|
|
: g-> ( x -- x x gadget ) dup g ;
|
|
|
|
: with-gadget ( gadget quot -- )
|
|
[
|
|
swap dup \ make-gadget set gadget set call
|
|
] with-scope ; inline
|
|
|
|
: build-gadget ( tuple quot gadget -- tuple )
|
|
pick set-gadget-delegate over >r with-gadget r> ; inline
|