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 ;
|