diff --git a/library/lists.factor b/library/lists.factor index d93d7f195a..f1cea1f255 100644 --- a/library/lists.factor +++ b/library/lists.factor @@ -93,9 +93,14 @@ DEFER: tree-contains? 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 ; diff --git a/library/ui/boxes.factor b/library/ui/boxes.factor index 37668b581f..62f79a8eba 100644 --- a/library/ui/boxes.factor +++ b/library/ui/boxes.factor @@ -50,7 +50,8 @@ M: box pick-up* ( point box -- gadget ) ] 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 -- ) diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 149245999e..992136316d 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -5,20 +5,21 @@ USING: generic hashtables kernel lists namespaces ; ! 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 - [ swap set-gadget-paint ] keep ; + [ swap set-gadget-paint ] keep + [ swap set-gadget-gestures ] keep ; : paint-property ( gadget key -- value ) swap gadget-paint hash ; @@ -26,6 +27,12 @@ C: gadget ( shape -- gadget ) : 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 @@ -37,9 +44,7 @@ M: gadget draw ( gadget -- ) 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 @@ -55,3 +60,4 @@ GENERIC: redraw ( gadget -- ) WRAPPER: ghost M: ghost draw drop ; M: ghost pick-up* 2drop f ; +M: ghost draw drop ; diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor index 058eee2e39..7c9999996b 100644 --- a/library/ui/gestures.factor +++ b/library/ui/gestures.factor @@ -1,7 +1,14 @@ ! 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 @@ -17,8 +24,11 @@ USING: generic kernel lists sdl-event ; 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 -- ) - swap handle-gesture ; +! Mouse gestures are lists where the first element is one of: +SYMBOL: motion +SYMBOL: button-up +SYMBOL: button-down diff --git a/library/ui/hand.factor b/library/ui/hand.factor index 8868b5d743..e84289a177 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -4,37 +4,33 @@ IN: gadgets 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 - 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 ; diff --git a/library/ui/paint.factor b/library/ui/paint.factor index 0435cb90ee..a0b9ec628b 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -21,9 +21,6 @@ SYMBOL: filled ! is the interior of the shape filled? GENERIC: draw ( obj -- ) -M: ghost draw ( ghost -- ) - drop ; - M: number draw ( point -- ) >r surface get r> >rect rgb-color pixelColor ; diff --git a/library/ui/world.factor b/library/ui/world.factor index 9c380bf527..a8e428a1a2 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -9,10 +9,6 @@ sdl-video ; ! world variable. TUPLE: world running? hand delegate redraw? ; -M: hand handle-gesture* ( gesture hand -- ? ) - 2dup swap hand-gesture - world get pick-up handle-gesture* ; - : ( -- box ) 0 0 0 0 dup blue 3list color set-paint-property @@ -23,27 +19,7 @@ C: world ( -- world ) over set-world-delegate t over set-world-running? t over set-world-redraw? - 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 over set-world-hand ; : my-hand ( -- hand ) world get world-hand ; @@ -58,10 +34,12 @@ M: world handle-gesture* ( gesture world -- ? ) drop ] ifte ; +DEFER: handle-event + : run-world ( -- ) world get world-running? [ dup SDL_WaitEvent 1 = [ - my-hand handle-gesture draw-world run-world + handle-event draw-world run-world ] [ drop ] ifte @@ -70,6 +48,7 @@ M: world handle-gesture* ( gesture world -- ? ) : 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 ;