menus: allow keyboard control

basis/ui/gadgets/menus/menus.factor

@@ -1,29 +1,56 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel locals math.rectangles math.vectors
-namespaces opengl sequences sorting ui.commands ui.gadgets
-ui.gadgets.buttons ui.gadgets.glass ui.gadgets.packs
-ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.operations
-ui.pens ui.pens.solid ui.theme ui.tools.common ;
+USING: accessors combinators kernel locals math math.rectangles
+math.vectors memoize models namespaces opengl sequences sorting
+ui.commands ui.gadgets ui.gadgets.buttons ui.gadgets.glass
+ui.gadgets.packs ui.gadgets.worlds ui.gadgets.wrappers ui.gestures
+ui.operations ui.pens ui.pens.solid ui.theme ui.tools.common ;
 
 FROM: ui.gadgets.wrappers => wrapper ;
 
 IN: ui.gadgets.menus
 
+<PRIVATE
+
 : (show-menu) ( owner menu -- )
     [ find-world ] dip hand-loc get-global point>rect show-glass ;
 
+PRIVATE>
+
 : show-menu ( owner menu -- )
     [ (show-menu) ] keep request-focus ;
 
-GENERIC: <menu-item> ( target hook command -- button )
+TUPLE: menu-button < button ;
 
-M:: object <menu-item> ( target hook command -- button )
+<PRIVATE
+
+: align-left ( menu-button -- menu-button )
+    { 0 1/2 } >>align ; inline
+
+MEMO: menu-button-pen-boundary ( -- pen )
+    f f roll-button-rollover-border <solid> dup dup <button-pen> ;
+
+MEMO: menu-button-pen-interior ( -- pen )
+    f f roll-button-selected-background <solid> f over <button-pen> ;
+
+: menu-button-theme ( menu-button -- menu-button )
+    menu-button-pen-boundary >>boundary
+    menu-button-pen-interior >>interior
+    align-left ; inline
+
+: <menu-button> ( label quot -- menu-button )
+    menu-button new-button menu-button-theme ; inline
+
+PRIVATE>
+
+GENERIC: <menu-item> ( target hook command -- menu-item )
+
+M:: object <menu-item> ( target hook command -- menu-item )
     command command-name [
         hook call
         target command command-button-quot call
         hide-glass
-    ] <roll-button> ;
+    ] <menu-button> ;
 
 <PRIVATE
 
@@ -49,19 +76,75 @@ M: ---- <menu-item>
         { 0 5 } >>dim
         menu-border-color <separator-pen> >>interior ;
 
-TUPLE: menu < wrapper ;
+TUPLE: menu < wrapper
+    items ;
+
+<PRIVATE
+
+: find-menu ( menu-button -- menu )
+    [ menu? ] find-parent ;
+
+: activate-item ( menu-button -- )
+    dup find-menu set-control-value ;
+
+: inactivate-item ( menu-button -- )
+    f swap find-menu set-control-value ;
+
+: menu-buttons ( menu-items -- menu-buttons )
+    children>> [ menu-button? ] filter ;
+
+:: prepare-menu ( menu items -- )
+    f <model> :> model
+    items menu-buttons :> buttons
+    buttons [ model add-connection ] each
+    menu model >>model buttons >>items drop ;
+
+PRIVATE>
+
+M: menu-button model-changed
+    swap value>> over = >>selected? relayout-1 ;
+
+M: menu-button handle-gesture
+    [
+        {
+            { [ over mouse-enter? ] [ nip activate-item ] }
+            { [ over mouse-leave? ] [ nip inactivate-item ] }
+            [ 2drop ]
+        } cond
+    ] 2keep call-next-method ;
+
+<PRIVATE
+
+:: next-item ( menu dir --  )
+    menu [ items>> ] [ control-value ] bi :> ( items curr )
+    curr [
+        items length :> max
+        curr items index :> indx
+        indx dir + max rem items nth
+    ] [ items first ] if menu set-control-value ;
+
+: activate-menu-item ( menu -- )
+    control-value [
+        dup quot>> ( button -- ) call-effect
+    ] when* ;
+
+PRIVATE>
 
 menu H{
     { T{ key-down f f "ESC" } [ hide-glass ] }
+    { T{ key-down f f "DOWN" } [ 1 next-item ] }
+    { T{ key-down f f "UP" } [ -1 next-item ] }
+    { T{ key-down f f "RET" } [ activate-menu-item ] }
 } set-gestures
 
 : <menu> ( gadgets -- menu )
-    <menu-items>
-    { 0 3 } >>gap
-    margins
-    menu-border-color <solid> >>boundary 
-    menu-background <solid> >>interior
-    menu new-wrapper ;
+    <menu-items> [
+        { 0 3 } >>gap
+        margins
+        menu-border-color <solid> >>boundary
+        menu-background <solid> >>interior
+        menu new-wrapper
+    ] [ dupd prepare-menu ] bi ;
 
 : <commands-menu> ( target hook commands -- menu )
     [ <menu-item> ] 2with map <menu> ;