factor/library/ui/gadgets.factor

66 lines
1.8 KiB
Factor
Raw Normal View History

2005-01-31 14:02:09 -05:00
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: generic hashtables kernel lists namespaces ;
! Gadget protocol.
2005-02-01 19:00:16 -05:00
GENERIC: pick-up* ( point gadget -- gadget/t )
2005-01-31 14:02:09 -05:00
2005-02-01 19:00:16 -05:00
: pick-up ( point gadget -- gadget )
#! pick-up* returns t to mean 'this gadget', avoiding the
#! exposed facade issue.
tuck pick-up* dup t = [ drop ] [ nip ] ifte ;
2005-02-01 21:47:10 -05:00
! A gadget is a shape, a paint, a mapping of gestures to
! actions, and a reference to the gadget's parent. A gadget
! delegates to its shape.
TUPLE: gadget paint gestures parent delegate ;
2005-01-31 14:02:09 -05:00
C: gadget ( shape -- gadget )
[ set-gadget-delegate ] keep
2005-02-01 21:47:10 -05:00
[ <namespace> swap set-gadget-paint ] keep
[ <namespace> swap set-gadget-gestures ] keep ;
2005-01-31 14:02:09 -05:00
: paint-property ( gadget key -- value )
swap gadget-paint hash ;
: set-paint-property ( gadget value key -- )
rot gadget-paint set-hash ;
2005-02-01 21:47:10 -05:00
: action ( gadget gesture -- quot )
swap gadget-gestures hash ;
: set-action ( gadget quot gesture -- )
rot gadget-gestures set-hash ;
2005-01-31 14:02:09 -05:00
: with-gadget ( gadget quot -- )
#! All drawing done inside the quotation is done with the
#! gadget's paint. If the gadget does not have any custom
#! paint, just call the quotation.
>r gadget-paint r> bind ;
2005-02-01 22:48:04 -05:00
M: gadget draw ( gadget -- ) drop ;
2005-01-31 14:02:09 -05:00
2005-02-01 19:00:16 -05:00
M: gadget pick-up* inside? ;
2005-01-31 14:02:09 -05:00
2005-02-01 21:47:10 -05:00
DEFER: redraw ( gadget -- )
2005-02-01 20:14:03 -05:00
2005-02-01 19:00:16 -05:00
: move-gadget ( x y gadget -- )
2005-02-01 20:14:03 -05:00
[ move-shape ] keep
[ set-gadget-delegate ] keep
redraw ;
: resize-gadget ( w h gadget -- )
[ resize-shape ] keep
[ set-gadget-delegate ] keep
redraw ;
2005-02-01 19:00:16 -05:00
2005-02-01 22:48:04 -05:00
! A simple gadget that just draws its shape.
TUPLE: stamp delegate ;
C: stamp ( shape -- )
swap <gadget> over set-stamp-delegate ;
M: stamp draw ( stamp -- )
dup [ gadget-delegate draw ] with-gadget ;