fix menu drag

diff --git a/library/ui/buttons.factor b/library/ui/buttons.factor
index 10cdcc6664a1e0628fb916f02a9160a6ee718de6..76520d29992a2d5b8a6ec817ff46997352698d10 100644 (file)
--- a/library/ui/buttons.factor
+++ b/library/ui/buttons.factor
@@ -32,7 +32,7 @@ namespaces sdl sequences sequences styles threads ;
 : button-theme ( button -- )
     dup { 216 216 216 } background set-paint-prop
     dup f reverse-video set-paint-prop
-    << solid f >> interior set-paint-prop ;
+    << solid >> interior set-paint-prop ;
 
 : roll-button-theme ( button -- )
     dup f reverse-video set-paint-prop

diff --git a/library/ui/listener.factor b/library/ui/listener.factor
index 25fc0b864afa19c0aee36bcfca03b5d164c0100b..f9579d2b24d74b489323a11119a520f27534f98e 100644 (file)
--- a/library/ui/listener.factor
+++ b/library/ui/listener.factor
@@ -31,7 +31,7 @@ C: display ( -- display )
     <scroller> over add-center ;
 
 : make-presentations ( seq -- seq )
-    [ <object-presentation> ] map ;
+    [ [ unparse-short <label> ] keep <object-button> ] map ;
 
 : present-stack ( seq title display -- )
     [ display-title set-label-text ] keep

diff --git a/library/ui/menus.factor b/library/ui/menus.factor
index 7a3a4fcefa6587d7c1bd250364044568c9cedcc3..902c6b7592c560a612b7e111c9303858940e672e 100644 (file)
--- a/library/ui/menus.factor
+++ b/library/ui/menus.factor
@@ -4,7 +4,16 @@ IN: gadgets-menus
 USING: gadgets gadgets-borders gadgets-buttons gadgets-layouts
 gadgets-labels generic kernel lists math namespaces sequences ;
 
+: retarget-drag ( -- )
+    hand [ rect-loc world get pick-up ] keep
+    2dup hand-clicked eq? [
+        2drop
+    ] [
+        [ set-hand-clicked ] keep update-hand
+    ] ifte ;
+
 : menu-actions ( glass -- )
+    dup [ drop retarget-drag ] [ drag 1 ] set-action
     [ drop hide-glass ] [ button-down 1 ] set-action ;
 
 : fit-bounds ( loc dim max -- loc )
@@ -17,7 +26,8 @@ gadgets-labels generic kernel lists math namespaces sequences ;
 : show-menu ( menu -- )
     dup show-glass
     dup menu-loc swap set-rect-loc
-    world get world-glass menu-actions ;
+    world get world-glass dup menu-actions
+    hand set-hand-clicked ;
 
 : menu-items ( assoc -- pile )
     #! Given an association list mapping labels to quotations.
@@ -26,7 +36,7 @@ gadgets-labels generic kernel lists math namespaces sequences ;
     <pile> 1 over set-pack-fill [ add-gadgets ] keep ;
 
 : menu-theme ( menu -- )
-    << solid f >> interior set-paint-prop ;
+    << solid >> interior set-paint-prop ;
 
 : <menu> ( assoc -- gadget )
     #! Given an association list mapping labels to quotations.

diff --git a/library/ui/presentations.factor b/library/ui/presentations.factor
index 75b4d6ae33edb7000bbe1cf614aa7030c79fd41f..6f15c8f0f4408c332761f382a8aee026879e0800 100644 (file)
--- a/library/ui/presentations.factor
+++ b/library/ui/presentations.factor
@@ -25,17 +25,16 @@ SYMBOL: commands
 : command-menu ( presented -- menu )
     dup applicable
     [ [ third command-quot ] keep second swons ] map-with
-    <menu> ;
+    <menu> show-menu ;
 
+: <object-button> ( gadget object -- button )
+    [ \ drop , literalize , \ command-menu , ] [ ] make
+    <roll-button>
+    dup [ button-clicked ] [ button-down 1 ] set-action
+    dup [ button-update ] [ button-up 1 ] set-action ;
+    
 : init-commands ( gadget -- gadget )
-    dup presented paint-prop [
-        [
-            \ drop ,
-            literalize ,
-            [ command-menu show-menu ] %
-        ] [ ] make
-        <roll-button>
-    ] when* ;
+    dup presented paint-prop [ <object-button> ] when* ;
 
 : <styled-label> ( style text -- label )
     <label> swap dup [ alist>hash ] when over set-gadget-paint ;
@@ -44,9 +43,6 @@ SYMBOL: commands
     gadget pick assoc dup
     [ 2nip ] [ drop <styled-label> init-commands ] ifte ;
 
-: <object-presentation> ( object -- gadget )
-    dup presented swons unit swap unparse-short <presentation> ;
-
 : gadget. ( gadget -- )
     gadget swons unit
     "This stream does not support live gadgets"