swap [ with rot ] map 2nip ; inline
: remove ( obj list -- list )
- #! Remove all occurrences of the object from the list.
+ #! Remove all occurrences of objects equal to this one from
+ #! the list.
[ = not ] subset-with ;
+: remq ( obj list -- list )
+ #! Remove all occurrences of the object from the list.
+ [ eq? not ] subset-with ;
+
: length ( list -- length )
0 swap [ drop 1 + ] each ;
] with-translation ;
: box- ( gadget box -- )
- 2dup box-contents remove swap tuck set-box-contents redraw
+ [ 2dup box-contents remq swap set-box-contents ] keep
+ redraw
f swap set-gadget-parent ;
: (box+) ( gadget box -- )
! Gadget protocol.
GENERIC: pick-up* ( point gadget -- gadget/t )
-GENERIC: handle-gesture* ( gesture gadget -- ? )
: 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 ;
-! A gadget is a shape together with paint, and a reference to
-! the gadget's parent. A gadget delegates to its shape.
-TUPLE: gadget paint parent delegate ;
+! 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 ;
C: gadget ( shape -- gadget )
[ set-gadget-delegate ] keep
- [ <namespace> swap set-gadget-paint ] keep ;
+ [ <namespace> swap set-gadget-paint ] keep
+ [ <namespace> swap set-gadget-gestures ] keep ;
: paint-property ( gadget key -- value )
swap gadget-paint hash ;
: set-paint-property ( gadget value key -- )
rot gadget-paint set-hash ;
+: action ( gadget gesture -- quot )
+ swap gadget-gestures hash ;
+
+: set-action ( gadget quot gesture -- )
+ rot gadget-gestures set-hash ;
+
: 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
M: gadget pick-up* inside? ;
-M: gadget handle-gesture* 2drop t ;
-
-GENERIC: redraw ( gadget -- )
+DEFER: redraw ( gadget -- )
: move-gadget ( x y gadget -- )
[ move-shape ] keep
WRAPPER: ghost
M: ghost draw drop ;
M: ghost pick-up* 2drop f ;
+M: ghost draw drop ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: generic kernel lists sdl-event ;
+USING: alien generic hashtables kernel lists sdl-event ;
+
+: handle-gesture* ( gesture gadget -- ? )
+ tuck gadget-gestures hash* dup [
+ cdr call f
+ ] [
+ 2drop t
+ ] ifte ;
: handle-gesture ( gesture gadget -- )
#! If a gadget's handle-gesture* generic returns t, the
2drop
] ifte ;
-TUPLE: redraw-gesture ;
-C: redraw-gesture ;
+! Redraw gesture. Don't handle this yourself.
+: redraw ( gadget -- )
+ \ redraw swap handle-gesture ;
-M: object redraw ( gadget -- )
- <redraw-gesture> swap handle-gesture ;
+! Mouse gestures are lists where the first element is one of:
+SYMBOL: motion
+SYMBOL: button-up
+SYMBOL: button-down
USING: alien generic kernel lists math namespaces sdl sdl-event
sdl-video ;
+SYMBOL: world
+
! The hand is a special gadget that holds mouse position and
! mouse button click state. The hand's parent is the world, but
! it is special in that the world does not list it as part of
! its contents.
TUPLE: hand click-pos clicked buttons delegate ;
-C: hand ( -- hand )
+C: hand ( world -- hand )
0 <gadget> <ghost> <box>
- over set-hand-delegate ;
+ over set-hand-delegate
+ [ set-gadget-parent ] keep ;
-GENERIC: hand-gesture ( hand gesture -- )
+: motion-gesture ( gesture hand -- )
+ #! Send the gesture to the gadget at the hand's position in
+ #! the world.
+ world get pick-up handle-gesture ;
-M: object hand-gesture ( hand gesture -- ) 2drop ;
+: button-gesture ( gesture hand -- )
+ #! Send the gesture to the gadget at the hand's last click
+ #! position in the world. This is used to send a button up
+ #! to the gadget that was clicked, regardless of the mouse
+ #! position at the time of the button up.
+ hand-clicked handle-gesture ;
: button/ ( n hand -- )
[ hand-buttons unique ] keep set-hand-buttons ;
: button\ ( n hand -- )
[ hand-buttons remove ] keep set-hand-buttons ;
-
-M: button-down-event hand-gesture ( hand gesture -- )
- 2dup
- dup button-event-x swap button-event-y rect>
- swap set-hand-click-pos
- button-event-button swap button/ ;
-
-M: button-up-event hand-gesture ( hand gesture -- )
- button-event-button swap button\ ;
-
-M: motion-event hand-gesture ( hand gesture -- )
- dup motion-event-x swap motion-event-y rot move-gadget ;
-
-M: hand redraw ( hand -- )
- drop world get redraw ;
GENERIC: draw ( obj -- )
-M: ghost draw ( ghost -- )
- drop ;
-
M: number draw ( point -- )
>r surface get r> >rect rgb-color pixelColor ;
! world variable.
TUPLE: world running? hand delegate redraw? ;
-M: hand handle-gesture* ( gesture hand -- ? )
- 2dup swap hand-gesture
- world get pick-up handle-gesture* ;
-
: <world-box> ( -- box )
0 0 0 0 <rectangle> <everywhere> <gadget>
dup blue 3list color set-paint-property
<world-box> over set-world-delegate
t over set-world-running?
t over set-world-redraw?
- <hand> over set-world-hand ;
-
-GENERIC: world-gesture ( world gesture -- )
-
-M: alien world-gesture ( world gesture -- ) 2drop ;
-
-M: quit-event world-gesture ( world gesture -- )
- drop f swap set-world-running? ;
-
-M: resize-event world-gesture ( world gesture -- ? )
- dup resize-event-w swap resize-event-h
- [ rot resize-gadget ] 2keep
- 0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen
- world get redraw ;
-
-M: redraw-gesture world-gesture ( world gesture -- )
-
- drop t swap set-world-redraw? ;
-
-M: world handle-gesture* ( gesture world -- ? )
- swap world-gesture f ;
+ dup <hand> over set-world-hand ;
: my-hand ( -- hand ) world get world-hand ;
drop
] ifte ;
+DEFER: handle-event
+
: run-world ( -- )
world get world-running? [
<event> dup SDL_WaitEvent 1 = [
- my-hand handle-gesture draw-world run-world
+ handle-event draw-world run-world
] [
drop
] ifte
: init-world ( w h -- )
t world get set-world-running?
t world get set-world-redraw?
+ world get [ t swap set-world-redraw? ] \ redraw set-action
world get resize-gadget ;
: world-flags SDL_HWSURFACE SDL_RESIZABLE bitor ;