2006-01-26 23:01:14 -05:00
|
|
|
! Copyright (C) 2005, 2006 Slava Pestov.
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2005-03-07 22:11:36 -05:00
|
|
|
IN: gadgets
|
2006-06-02 15:12:57 -04:00
|
|
|
USING: generic hashtables kernel math namespaces sequences
|
2006-06-29 01:54:11 -04:00
|
|
|
vectors words ;
|
2005-03-07 22:11:36 -05:00
|
|
|
|
2006-06-29 04:07:10 -04:00
|
|
|
GENERIC: graft* ( gadget -- )
|
2006-01-30 20:35:55 -05:00
|
|
|
|
2006-06-29 04:07:10 -04:00
|
|
|
M: gadget graft* drop ;
|
2006-01-30 20:35:55 -05:00
|
|
|
|
2006-06-29 04:07:10 -04:00
|
|
|
: graft ( gadget -- )
|
|
|
|
t over set-gadget-grafted?
|
|
|
|
dup graft*
|
2006-07-01 16:07:10 -04:00
|
|
|
[ graft ] each-child ;
|
2006-01-30 20:35:55 -05:00
|
|
|
|
2006-06-29 04:07:10 -04:00
|
|
|
GENERIC: ungraft* ( gadget -- )
|
2006-01-30 20:35:55 -05:00
|
|
|
|
2006-06-29 04:07:10 -04:00
|
|
|
M: gadget ungraft* drop ;
|
2006-01-30 20:35:55 -05:00
|
|
|
|
2006-06-29 04:07:10 -04:00
|
|
|
: ungraft ( gadget -- )
|
|
|
|
dup gadget-grafted? [
|
|
|
|
dup [ ungraft* ] each-child
|
|
|
|
dup ungraft*
|
|
|
|
f over set-gadget-grafted?
|
|
|
|
] when drop ;
|
2006-01-30 20:35:55 -05:00
|
|
|
|
|
|
|
: (unparent) ( gadget -- )
|
2006-06-29 04:07:10 -04:00
|
|
|
dup ungraft
|
2006-01-30 20:35:55 -05:00
|
|
|
dup forget-pref-dim f swap set-gadget-parent ;
|
2005-03-07 22:11:36 -05:00
|
|
|
|
|
|
|
: unparent ( gadget -- )
|
2005-06-27 16:50:21 -04:00
|
|
|
[
|
2006-01-30 20:35:55 -05:00
|
|
|
dup gadget-parent dup [
|
|
|
|
over (unparent)
|
|
|
|
[ gadget-children delete ] keep relayout
|
|
|
|
] [
|
|
|
|
2drop
|
|
|
|
] if
|
2005-06-27 16:50:21 -04:00
|
|
|
] when* ;
|
2005-03-07 22:11:36 -05:00
|
|
|
|
2005-07-17 00:21:10 -04:00
|
|
|
: (clear-gadget) ( gadget -- )
|
2006-05-24 03:23:45 -04:00
|
|
|
dup [ (unparent) ] each-child f swap set-gadget-children ;
|
2005-07-17 00:21:10 -04:00
|
|
|
|
2005-07-14 00:32:52 -04:00
|
|
|
: clear-gadget ( gadget -- )
|
2005-07-17 00:21:10 -04:00
|
|
|
dup (clear-gadget) relayout ;
|
2005-07-16 22:16:18 -04:00
|
|
|
|
2006-06-29 04:07:10 -04:00
|
|
|
: ((add-gadget)) ( gadget box -- )
|
|
|
|
[ gadget-children ?push ] keep set-gadget-children ;
|
|
|
|
|
2005-07-09 16:08:50 -04:00
|
|
|
: (add-gadget) ( gadget box -- )
|
2005-03-07 22:11:36 -05:00
|
|
|
over unparent
|
|
|
|
dup pick set-gadget-parent
|
2006-06-29 04:07:10 -04:00
|
|
|
[ ((add-gadget)) ] 2keep
|
|
|
|
gadget-grafted? [ graft ] [ drop ] if ;
|
2005-07-09 16:08:50 -04:00
|
|
|
|
|
|
|
: add-gadget ( gadget parent -- )
|
|
|
|
#! Add a gadget to a parent gadget.
|
|
|
|
[ (add-gadget) ] keep relayout ;
|
2005-03-07 22:11:36 -05:00
|
|
|
|
2005-08-26 21:42:43 -04:00
|
|
|
: add-gadgets ( seq parent -- )
|
|
|
|
#! Add all gadgets in a sequence to a parent gadget.
|
|
|
|
swap [ over (add-gadget) ] each relayout ;
|
|
|
|
|
2006-06-29 01:54:11 -04:00
|
|
|
: add-spec ( { quot setter post loc } quot -- )
|
2006-06-29 03:54:30 -04:00
|
|
|
[
|
|
|
|
over first %
|
|
|
|
over second [ [ dup gadget get ] % , ] when*
|
|
|
|
over third %
|
|
|
|
[ gadget get ] %
|
|
|
|
swap fourth ,
|
|
|
|
%
|
|
|
|
] [ ] make call ;
|
2006-06-29 01:54:11 -04:00
|
|
|
|
2005-10-09 21:27:14 -04:00
|
|
|
: (parents) ( gadget vector -- )
|
|
|
|
over
|
|
|
|
[ 2dup push >r gadget-parent r> (parents) ] [ 2drop ] if ;
|
2005-07-20 18:04:29 -04:00
|
|
|
|
2005-10-09 21:27:14 -04:00
|
|
|
: parents ( gadget -- vector )
|
2005-07-13 21:03:34 -04:00
|
|
|
#! A list of all parents of the gadget, the first element
|
|
|
|
#! is the gadget itself.
|
2005-10-29 23:25:38 -04:00
|
|
|
V{ } clone [ (parents) ] keep ;
|
2005-03-07 22:11:36 -05:00
|
|
|
|
|
|
|
: each-parent ( gadget quot -- ? )
|
2005-10-09 21:27:14 -04:00
|
|
|
>r parents r> all? ; inline
|
2005-03-07 22:11:36 -05:00
|
|
|
|
2005-12-22 18:38:10 -05:00
|
|
|
: find-parent ( gadget quot -- gadget )
|
2005-10-09 21:27:14 -04:00
|
|
|
>r parents r> find nip ; inline
|
2005-07-20 16:03:03 -04:00
|
|
|
|
2005-06-22 02:32:17 -04:00
|
|
|
: screen-loc ( gadget -- point )
|
|
|
|
#! The position of the gadget on the screen.
|
2006-06-23 00:06:53 -04:00
|
|
|
parents { 0 0 } [ rect-loc v+ ] reduce ;
|
2005-06-22 02:32:17 -04:00
|
|
|
|
2005-09-01 01:20:43 -04:00
|
|
|
: gadget-point ( gadget vector -- point )
|
2006-06-23 00:06:53 -04:00
|
|
|
#! { 0 0 } - top left corner
|
|
|
|
#! { 1/2 1/2 } - middle
|
|
|
|
#! { 1 1 } - bottom right corner
|
2005-09-01 01:20:43 -04:00
|
|
|
>r dup screen-loc swap rect-dim r> v* v+ ;
|
|
|
|
|
2006-03-19 00:30:57 -05:00
|
|
|
: relative-loc ( g1 point -- point-g1 ) swap screen-loc v- ;
|
2005-03-07 22:11:36 -05:00
|
|
|
|
2005-10-09 21:27:14 -04:00
|
|
|
: child? ( parent child -- ? ) parents memq? ;
|
2005-08-24 19:25:12 -04:00
|
|
|
|
|
|
|
GENERIC: focusable-child* ( gadget -- gadget/t )
|
|
|
|
|
|
|
|
M: gadget focusable-child* drop t ;
|
|
|
|
|
|
|
|
: focusable-child ( gadget -- gadget )
|
|
|
|
dup focusable-child*
|
2006-03-24 22:58:03 -05:00
|
|
|
dup t eq? [ drop ] [ nip focusable-child ] if ;
|
2005-09-27 00:44:38 -04:00
|
|
|
|
|
|
|
: make-pile ( children -- pack ) <pile> [ add-gadgets ] keep ;
|
|
|
|
|
|
|
|
: make-shelf ( children -- pack ) <shelf> [ add-gadgets ] keep ;
|