basis/ui/gadgets/menus/menus.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators kernel math math.rectangles
   4 math.vectors models namespaces opengl sequences sorting
   5 ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons
   6 ui.gadgets.glass ui.gadgets.packs ui.gadgets.worlds
   7 ui.gadgets.wrappers ui.gestures ui.operations ui.pens
   8 ui.pens.solid ui.theme ;
   9 FROM: ui.gadgets.wrappers => wrapper ;
  10
  11 IN: ui.gadgets.menus
  12
  13 <PRIVATE
  14
  15 : (show-menu) ( owner menu -- )
  16     [ find-world ] dip hand-loc get-global point>rect show-glass ;
  17
  18 PRIVATE>
  19
  20 : show-menu ( owner menu -- )
  21     [ (show-menu) ] keep request-focus ;
  22
  23 TUPLE: menu-button < button ;
  24
  25 <PRIVATE
  26
  27 : align-left ( menu-button -- menu-button )
  28     { 0 1/2 } >>align ; inline
  29
  30 MEMO: menu-button-pen-boundary ( -- pen )
  31     f f roll-button-rollover-border <solid> dup dup <button-pen> ;
  32
  33 MEMO: menu-button-pen-interior ( -- pen )
  34     f f roll-button-selected-background <solid> f over <button-pen> ;
  35
  36 : menu-button-theme ( menu-button -- menu-button )
  37     menu-button-pen-boundary >>boundary
  38     menu-button-pen-interior >>interior
  39     align-left ; inline
  40
  41 : <menu-button> ( label quot -- menu-button )
  42     menu-button new-button menu-button-theme ; inline
  43
  44 PRIVATE>
  45
  46 GENERIC: <menu-item> ( target hook command -- menu-item )
  47
  48 M:: object <menu-item> ( target hook command -- menu-item )
  49     command command-name [
  50         hook call
  51         target command command-button-quot call
  52         hide-glass
  53     ] <menu-button> ;
  54
  55 <PRIVATE
  56
  57 TUPLE: separator-pen color ;
  58
  59 C: <separator-pen> separator-pen
  60
  61 M: separator-pen draw-interior
  62     color>> gl-color
  63     dim>> [ { 0 0.5 } v* ] [ { 1 0.5 } v* ] bi
  64     [ v>integer ] bi@ gl-line ;
  65
  66 : <menu-items> ( items -- gadget )
  67     [ <filled-pile> ] dip add-gadgets ;
  68
  69 PRIVATE>
  70
  71 SINGLETON: ----
  72
  73 M: ---- <menu-item>
  74     3drop
  75     <gadget>
  76         { 0 5 } >>dim
  77         menu-border-color <separator-pen> >>interior ;
  78
  79 TUPLE: menu < wrapper
  80     items ;
  81
  82 <PRIVATE
  83
  84 : find-menu ( menu-button -- menu )
  85     [ menu? ] find-parent ;
  86
  87 : activate-item ( menu-button -- )
  88     dup find-menu set-control-value ;
  89
  90 : inactivate-item ( menu-button -- )
  91     f swap find-menu set-control-value ;
  92
  93 : menu-buttons ( menu-items -- menu-buttons )
  94     children>> [ menu-button? ] filter ;
  95
  96 :: prepare-menu ( menu items -- )
  97     f <model> :> model
  98     items menu-buttons :> buttons
  99     buttons [ model add-connection ] each
 100     menu model >>model buttons >>items drop ;
 101
 102 PRIVATE>
 103
 104 M: menu-button model-changed
 105     swap value>> over = >>selected? relayout-1 ;
 106
 107 M: menu-button handle-gesture
 108     [
 109         {
 110             { [ over mouse-enter? ] [ nip activate-item ] }
 111             { [ over mouse-leave? ] [ nip inactivate-item ] }
 112             [ 2drop ]
 113         } cond
 114     ] 2keep call-next-method ;
 115
 116 <PRIVATE
 117
 118 :: next-item ( menu dir --  )
 119     menu [ items>> ] [ control-value ] bi :> ( items curr )
 120     curr [
 121         items length :> max
 122         curr items index :> indx
 123         indx dir + max rem items nth
 124     ] [ items first ] if menu set-control-value ;
 125
 126 : activate-menu-item ( menu -- )
 127     control-value [
 128         dup quot>> ( button -- ) call-effect
 129     ] when* ;
 130
 131 PRIVATE>
 132
 133 menu H{
 134     { T{ key-down f f "ESC" } [ hide-glass ] }
 135     { T{ key-down f f "DOWN" } [ 1 next-item ] }
 136     { T{ key-down f f "UP" } [ -1 next-item ] }
 137     { T{ key-down f f "RET" } [ activate-menu-item ] }
 138 } set-gestures
 139
 140 : <menu> ( gadgets -- menu )
 141     <menu-items> [
 142         { 0 3 } >>gap
 143         { 5 5 } <filled-border>
 144         menu-border-color <solid> >>boundary
 145         menu-background <solid> >>interior
 146         menu new-wrapper
 147     ] [ dupd prepare-menu ] bi ;
 148
 149 : <commands-menu> ( target hook commands -- menu )
 150     [ <menu-item> ] 2with map <menu> ;
 151
 152 : show-commands-menu ( target commands -- )
 153     [ dup [ ] ] dip <commands-menu> show-menu ;
 154
 155 : <operations-menu> ( target hook -- menu )
 156     over object-operations
 157     [ primary-operation? ] partition
 158     [ reverse ] [ [ command-name ] sort-with ] bi*
 159     { ---- } glue <commands-menu> ;
 160
 161 : show-operations-menu ( gadget target hook -- )
 162     <operations-menu> show-menu ;