more UI work

library/generic/tuple.factor

@@ -87,15 +87,22 @@ kernel-internals math hashtables errors ;
         drop f
     ] ifte ; inline
 
+: lookup-method ( class selector -- method )
+    "methods" word-property hash* ; inline
+
 : tuple-dispatch ( object selector -- )
-    over class over "methods" word-property hash* [
+    over class over lookup-method [
         cdr call ( method is defined )
     ] [
-        over tuple-delegate [
+        object over lookup-method [
-            rot drop swap execute ( check delegate )
+            cdr call
         ] [
-            undefined-method ( no delegate )
+            over tuple-delegate [
-        ] ifte*
+                rot drop swap execute ( check delegate )
+            ] [
+                undefined-method ( no delegate )
+            ] ifte*
+        ] ?ifte
     ] ?ifte ;
 
 : add-tuple-dispatch ( word vtable -- )

library/stack.factor

@@ -10,6 +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
 : 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/test/tuple.factor

@@ -15,4 +15,11 @@ C: rect
 
 [ t ] [ 10 20 30 40 <rect> dup clone 0 swap [ move ] keep = ] unit-test
 
+GENERIC: delegation-test
+M: object delegation-test drop 3 ;
+TUPLE: quux-tuple ;
+C: quux-tuple ;
+M: quux-tuple delegation-test drop 4 ;
+WRAPPER: quuux-tuple
 
+[ 3 ] [ <quux-tuple> <quuux-tuple> delegation-test ] unit-test

library/ui/boxes.factor

@@ -20,7 +20,7 @@ M: box draw ( box -- )
         ] with-gadget
     ] with-translation ;
 
-M: general-list pick-up ( point list -- gadget )
+M: general-list pick-up* ( point list -- gadget )
     dup [
         2dup car pick-up dup [
             2nip
@@ -31,17 +31,17 @@ M: general-list pick-up ( point list -- gadget )
         2drop f
     ] ifte ;
 
-M: box pick-up ( point box -- gadget )
+M: box pick-up* ( point box -- gadget )
     #! The logic is thus. If the point is definately outside the
     #! box, return f. Otherwise, see if the point is contained
     #! in any subgadget. If not, see if it is contained in the
     #! box delegate.
     dup [
-        2dup gadget-delegate inside? [
+        2dup inside? [
             2dup box-contents pick-up dup [
                 2nip
             ] [
-                drop box-delegate pick-up
+                drop box-delegate pick-up*
             ] ifte
         ] [
             2drop f
@@ -54,5 +54,5 @@ M: box pick-up ( point box -- gadget )
 
 : box+ ( gadget box -- )
     #! Add a gadget to a box.
-    swap dup gadget-parent dup [ box- ] [ 2drop ] ifte
+    over gadget-parent [ pick swap box- ] when*
     [ box-contents cons ] keep set-box-contents ;

library/ui/gadgets.factor

@@ -4,9 +4,15 @@ IN: gadgets
 USING: generic hashtables kernel lists namespaces ;
 
 ! Gadget protocol.
-GENERIC: pick-up ( point gadget -- gadget )
+
+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 ;
@@ -30,11 +36,14 @@ C: gadget ( shape -- gadget )
 M: gadget draw ( gadget -- )
     dup [ gadget-delegate draw ] with-gadget ;
 
-M: gadget pick-up tuck inside? [ drop f ] unless ;
+M: gadget pick-up* inside? ;
 
 M: gadget handle-gesture* 2drop t ;
 
+: move-gadget ( x y gadget -- )
+    [ move-shape ] keep set-gadget-delegate ;
+
 ! An invisible gadget.
 WRAPPER: ghost
 M: ghost draw drop ;
-M: ghost pick-up 2drop f ;
+M: ghost pick-up* 2drop f ;

library/ui/gestures.factor

@@ -7,9 +7,9 @@ USING: generic kernel lists sdl-event ;
     #! If a gadget's handle-gesture* generic returns t, the
     #! event was not consumed and is passed on to the gadget's
     #! parent.
-    2dup handle-gesture* [
+    dup [
-        gadget-parent dup [
+        2dup handle-gesture* [
-            handle-gesture
+            gadget-parent handle-gesture
         ] [
             2drop
         ] ifte

library/ui/shapes.factor

@@ -3,12 +3,15 @@
 IN: gadgets
 USING: generic kernel math namespaces ;
 
-! Shape protocol.
+! Shape protocol. Shapes are immutable; moving or resizing a
+! shape makes a new shape.
 
 ! These dynamically-bound variables affect the generic word
 ! inside?.
-SYMBOL: x ! x translation
+SYMBOL: x
-SYMBOL: y ! y translation
+SYMBOL: y
+
+GENERIC: inside? ( point shape -- ? )
 
 ! A shape is an object with a defined bounding
 ! box, and a notion of interior.
@@ -17,7 +20,8 @@ GENERIC: shape-y
 GENERIC: shape-w
 GENERIC: shape-h
 
-GENERIC: inside? ( point shape -- ? )
+GENERIC: move-shape ( x y shape -- shape )
+GENERIC: resize-shape ( w h shape -- shape )
 
 : with-translation ( shape quot -- )
     #! All drawing done inside the quotation is translated
@@ -31,11 +35,14 @@ GENERIC: inside? ( point shape -- ? )
 
 ! A point, represented as a complex number, is the simplest type
 ! of shape.
+M: number inside? = ;
+
 M: number shape-x real ;
 M: number shape-y imaginary ;
 M: number shape-w drop 0 ;
 M: number shape-h drop 0 ;
-M: number inside? = ;
+
+M: number move-shape ( x y point -- point ) drop rect> ;
 
 ! A rectangle maps trivially to the shape protocol.
 TUPLE: rect x y w h ;
@@ -55,6 +62,15 @@ C: rect ( x y w h -- rect )
     [ set-rect-y ] keep
     [ set-rect-x ] keep ;
 
+M: number resize-shape ( w h point -- rect )
+     >rect 2swap <rect> ;
+
+M: rect move-shape ( x y rect -- rect )
+    [ rect-w ] keep rect-h <rect> ;
+
+M: rect resize-shape ( w h rect -- rect )
+    [ rect-x ] keep rect-y 2swap <rect> ;
+
 : rect-x-extents ( rect -- x1 x2 )
     dup rect-x x get + swap rect-w dupd + ;
 

library/ui/world.factor

@@ -28,10 +28,19 @@ M: button-down-event hand-gesture ( hand gesture -- )
 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 ;
+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
@@ -43,6 +52,7 @@ M: hand handle-gesture* ( gesture hand -- ? )
 C: world ( -- world )
     <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 -- )
@@ -52,15 +62,28 @@ M: alien world-gesture ( world gesture -- ) 2drop ;
 M: quit-event world-gesture ( world gesture -- )
     drop f swap set-world-running? ;
 
+M: redraw-gesture world-gesture ( world gesture -- )
+    drop t swap set-world-redraw? ;
+
 M: world handle-gesture* ( gesture world -- ? )
     swap world-gesture f ;
 
 : my-hand ( -- hand ) world get world-hand ;
 
+: draw-world ( -- )
+    world get dup world-redraw? [
+        [
+            f over set-world-redraw?
+            draw
+        ] with-surface
+    ] [
+        drop
+    ] ifte ;
+
 : run-world ( -- )
     world get world-running? [
         <event> dup SDL_WaitEvent 1 = [
-            my-hand handle-gesture run-world
+            my-hand handle-gesture draw-world run-world
         ] [
             drop
         ] ifte