working on hand gadget

library/bootstrap/boot-stage2.factor

@@ -157,6 +157,7 @@ cpu "x86" = [
         "/library/ui/gadgets.factor"
         "/library/ui/boxes.factor"
         "/library/ui/gestures.factor"
+        "/library/ui/hand.factor"
         "/library/ui/world.factor"
     ] [
         dup print

library/sdl/sdl-utils.factor

@@ -55,6 +55,7 @@ SYMBOL: surface
 
 : with-screen ( width height bpp flags quot -- )
     #! Set up SDL graphics and call the quotation.
+    SDL_INIT_EVERYTHING SDL_Init drop  TTF_Init
     [ >r init-screen r> call SDL_Quit ] with-scope ; inline
 
 : rgb ( r g b -- n )

library/stack.factor

@@ -10,7 +10,7 @@ IN: kernel
 : -rot ( x y z -- z x y ) swap >r swap r> ; inline
 : dupd ( x y -- x x y ) >r dup r> ; inline
 : swapd ( x y z -- y x z ) >r swap r> ; inline
-: 2swap ( x y z t -- z t x y ) >r rot r> rot ; inline
+: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
 : nip ( x y -- y ) swap drop ; inline
 : 2nip ( x y z -- z ) >r drop drop r> ; inline
 : tuck ( x y -- y x y ) dup >r swap r> ; inline

library/ui/boxes.factor

@@ -15,8 +15,9 @@ M: general-list draw ( list -- )
 M: box draw ( box -- )
     dup [
         dup [
-            dup box-contents draw
+            dup
             box-delegate draw
+            box-contents draw
         ] with-gadget
     ] with-translation ;
 
@@ -49,10 +50,18 @@ M: box pick-up* ( point box -- gadget )
     ] with-translation ;
 
 : box- ( gadget box -- )
-    2dup box-contents remove swap set-box-contents
+    2dup box-contents remove swap tuck set-box-contents redraw
     f swap set-gadget-parent ;
 
+: (box+) ( gadget box -- )
+    [ box-contents cons ] keep set-box-contents ;
+
+: unparent ( gadget -- )
+    dup gadget-parent dup [ box- ] [ 2drop ] ifte ;
+
 : box+ ( gadget box -- )
     #! Add a gadget to a box.
-    over gadget-parent [ pick swap box- ] when*
+    over unparent
-    [ box-contents cons ] keep set-box-contents ;
+    dup pick set-gadget-parent
+    tuck (box+)
+    redraw ;

library/ui/gadgets.factor

@@ -4,7 +4,6 @@ IN: gadgets
 USING: generic hashtables kernel lists namespaces ;
 
 ! Gadget protocol.
-
 GENERIC: pick-up* ( point gadget -- gadget/t )
 GENERIC: handle-gesture* ( gesture gadget -- ? )
 
@@ -40,8 +39,17 @@ M: gadget pick-up* inside? ;
 
 M: gadget handle-gesture* 2drop t ;
 
+GENERIC: redraw ( gadget -- )
+
 : move-gadget ( x y gadget -- )
-    [ move-shape ] keep set-gadget-delegate ;
+    [ move-shape ] keep
+    [ set-gadget-delegate ] keep
+    redraw ;
+
+: resize-gadget ( w h gadget -- )
+    [ resize-shape ] keep
+    [ set-gadget-delegate ] keep
+    redraw ;
 
 ! An invisible gadget.
 WRAPPER: ghost

library/ui/gestures.factor

@@ -16,3 +16,9 @@ USING: generic kernel lists sdl-event ;
     ] [
         2drop
     ] ifte ;
+
+TUPLE: redraw-gesture ;
+C: redraw-gesture ;
+
+M: object redraw ( gadget -- )
+    <redraw-gesture> swap handle-gesture ;

library/ui/hand.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: alien generic kernel lists math namespaces sdl sdl-event
+sdl-video ;
+
+! 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 )
+    0 <gadget> <ghost> <box>
+    over set-hand-delegate ;
+
+GENERIC: hand-gesture ( hand gesture -- )
+
+M: object hand-gesture ( hand gesture -- ) 2drop ;
+
+: 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 ;

library/ui/paint.factor

@@ -21,7 +21,13 @@ SYMBOL: filled ! is the interior of the shape filled?
 
 GENERIC: draw ( obj -- )
 
-M: rect draw ( rect -- )
+M: ghost draw ( ghost -- )
+    drop ;
+
+M: number draw ( point -- )
+    >r surface get r> >rect rgb-color pixelColor ;
+
+M: rectangle draw ( rect -- )
     >r surface get r> shape>screen rgb-color
     filled get [ boxColor ] [ rectangleColor ] ifte ;
 

library/ui/shapes.factor

@@ -45,38 +45,48 @@ M: number shape-h drop 0 ;
 M: number move-shape ( x y point -- point ) drop rect> ;
 
 ! A rectangle maps trivially to the shape protocol.
-TUPLE: rect x y w h ;
+TUPLE: rectangle x y w h ;
-M: rect shape-x rect-x ;
+M: rectangle shape-x rectangle-x ;
-M: rect shape-y rect-y ;
+M: rectangle shape-y rectangle-y ;
-M: rect shape-w rect-w ;
+M: rectangle shape-w rectangle-w ;
-M: rect shape-h rect-h ;
+M: rectangle shape-h rectangle-h ;
 
 : fix-neg ( a b c -- a+c b -c )
     dup 0 < [ neg tuck >r >r + r> r> ] when ;
 
-C: rect ( x y w h -- rect )
+C: rectangle ( x y w h -- rect )
     #! We handle negative w/h for convinience.
     >r fix-neg >r fix-neg r> r>
-    [ set-rect-h ] keep
+    [ set-rectangle-h ] keep
-    [ set-rect-w ] keep
+    [ set-rectangle-w ] keep
-    [ set-rect-y ] keep
+    [ set-rectangle-y ] keep
-    [ set-rect-x ] keep ;
+    [ set-rectangle-x ] keep ;
 
 M: number resize-shape ( w h point -- rect )
-     >rect 2swap <rect> ;
+     >rect 2swap <rectangle> ;
 
-M: rect move-shape ( x y rect -- rect )
+M: rectangle move-shape ( x y rect -- rect )
-    [ rect-w ] keep rect-h <rect> ;
+    [ rectangle-w ] keep rectangle-h <rectangle> ;
 
-M: rect resize-shape ( w h rect -- rect )
+M: rectangle resize-shape ( w h rect -- rect )
-    [ rect-x ] keep rect-y 2swap <rect> ;
+    [ rectangle-x ] keep rectangle-y 2swap <rectangle> ;
 
-: rect-x-extents ( rect -- x1 x2 )
+: rectangle-x-extents ( rect -- x1 x2 )
-    dup rect-x x get + swap rect-w dupd + ;
+    dup rectangle-x x get + swap rectangle-w dupd + ;
 
-: rect-y-extents ( rect -- x1 x2 )
+: rectangle-y-extents ( rect -- x1 x2 )
-    dup rect-y y get + swap rect-h dupd + ;
+    dup rectangle-y y get + swap rectangle-h dupd + ;
 
-M: rect inside? ( point rect -- ? )
+M: rectangle inside? ( point rect -- ? )
-    over shape-x over rect-x-extents between? >r
+    over shape-x over rectangle-x-extents between? >r
-    swap shape-y swap rect-y-extents between? r> and ;
+    swap shape-y swap rectangle-y-extents between? r> and ;
+
+! Delegates to a bounded shape, but absorbs all points.
+WRAPPER: everywhere
+M: everywhere inside? ( point world -- ? ) 2drop t ;
+
+M: everywhere move-shape ( x y everywhere -- )
+    everywhere-delegate move-shape <everywhere> ;
+
+M: everywhere resize-shape ( w h everywhere -- )
+    everywhere-delegate resize-shape <everywhere> ;

library/ui/world.factor

@@ -1,53 +1,23 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: alien generic kernel lists math namespaces sdl sdl-event ;
+USING: alien generic kernel lists math namespaces sdl sdl-event
-
+sdl-video ;
-! The hand is a special gadget that holds mouse position and
-! mouse button click state.
-TUPLE: hand clicked buttons delegate ;
-
-C: hand ( -- hand ) 0 <gadget> over set-hand-delegate ;
-
-GENERIC: hand-gesture ( hand gesture -- )
-
-M: alien hand-gesture ( hand gesture -- ) 2drop ;
-
-: 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-clicked
-    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 ;
 
 ! The world gadget is the top level gadget that all (visible)
 ! gadgets are contained in. The current world is stored in the
 ! world variable.
 TUPLE: world running? hand delegate redraw? ;
 
-TUPLE: redraw-gesture ;
-C: redraw-gesture ;
-
-: redraw ( gadget -- )
-    <redraw-gesture> swap handle-gesture ;
-
 M: hand handle-gesture* ( gesture hand -- ? )
     2dup swap hand-gesture
     world get pick-up handle-gesture* ;
 
 : <world-box> ( -- box )
-    0 0 1000 1000 <rect> <gadget> <box> ;
+    0 0 0 0 <rectangle> <everywhere> <gadget>
+    dup blue 3list color set-paint-property
+    dup t filled set-paint-property
+    <box> ;
 
 C: world ( -- world )
     <world-box> over set-world-delegate
@@ -62,7 +32,14 @@ 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 -- ? )
@@ -74,7 +51,8 @@ M: world handle-gesture* ( gesture world -- ? )
     world get dup world-redraw? [
         [
             f over set-world-redraw?
-            draw
+            dup draw
+            world-hand draw
         ] with-surface
     ] [
         drop
@@ -89,4 +67,17 @@ M: world handle-gesture* ( gesture world -- ? )
         ] ifte
     ] when ;
 
+: init-world ( w h -- )
+    t world get set-world-running?
+    t world get set-world-redraw?
+    world get resize-gadget ;
+
+: world-flags SDL_HWSURFACE SDL_RESIZABLE bitor ;
+
+: start-world ( w h -- )
+    #! Start the Factor graphics subsystem with the given screen
+    #! dimensions.
+    2dup init-world 0 world-flags
+    default-paint [ [ run-world ] with-screen ] bind ;
+
 global [ <world> world set ] bind