51 lines
1.4 KiB
Factor
51 lines
1.4 KiB
Factor
! Copyright (C) 2005 Slava Pestov.
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
IN: gadgets
|
|
USING: generic hashtables kernel lists math matrices namespaces
|
|
sequences ;
|
|
|
|
: remove-gadget ( gadget parent -- )
|
|
[ 2dup gadget-children remq swap set-gadget-children ] keep
|
|
relayout
|
|
f swap set-gadget-parent ;
|
|
|
|
: unparent ( gadget -- )
|
|
[
|
|
dup gadget-parent dup
|
|
[ remove-gadget ] [ 2drop ] ifte
|
|
] when* ;
|
|
|
|
: (add-gadget) ( gadget box -- )
|
|
#! This is inefficient.
|
|
over unparent
|
|
dup pick set-gadget-parent
|
|
[ gadget-children swap add ] keep set-gadget-children ;
|
|
|
|
: add-gadget ( gadget parent -- )
|
|
#! Add a gadget to a parent gadget.
|
|
[ (add-gadget) ] keep relayout ;
|
|
|
|
: parents ( gadget -- list )
|
|
#! A list of all parents of the gadget, the first element
|
|
#! is the gadget itself.
|
|
dup [ dup gadget-parent parents cons ] when ;
|
|
|
|
: each-parent ( gadget quot -- ? )
|
|
#! Keep executing the quotation on higher and higher
|
|
#! parents until it returns f.
|
|
>r parents r> all? ; inline
|
|
|
|
: screen-loc ( gadget -- point )
|
|
#! The position of the gadget on the screen.
|
|
parents { 0 0 0 } [ shape-loc v+ ] reduce ;
|
|
|
|
: relative ( g1 g2 -- g2-g1 )
|
|
screen-loc swap screen-loc v- ;
|
|
|
|
: child? ( parent child -- ? )
|
|
dup [
|
|
2dup eq? [ 2drop t ] [ gadget-parent child? ] ifte
|
|
] [
|
|
2drop f
|
|
] ifte ;
|