basis/ui/gadgets/menus/menus.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel locals math.rectangles math.vectors
   4 namespaces opengl sequences sorting ui.commands ui.gadgets
   5 ui.gadgets.buttons ui.gadgets.glass ui.gadgets.packs
   6 ui.gadgets.theme ui.gadgets.worlds ui.gestures ui.operations
   7 ui.pens ui.pens.solid ui.tools.common ;
   8 IN: ui.gadgets.menus
   9
  10 : show-menu ( owner menu -- )
  11     [ find-world ] dip hand-loc get-global { 0 0 } <rect> show-glass ;
  12
  13 GENERIC: <menu-item> ( target hook command -- button )
  14
  15 M:: object <menu-item> ( target hook command -- button )
  16     command command-name [
  17         hook call
  18         target command command-button-quot call
  19         hide-glass
  20     ] <roll-button> ;
  21
  22 <PRIVATE
  23
  24 TUPLE: separator-pen color ;
  25
  26 C: <separator-pen> separator-pen
  27
  28 M: separator-pen draw-interior
  29     color>> gl-color
  30     dim>> [ { 0 0.5 } v* ] [ { 1 0.5 } v* ] bi
  31     [ v>integer ] bi@ gl-line ;
  32
  33 : <menu-items> ( items -- gadget )
  34     [ <filled-pile> ] dip add-gadgets ;
  35
  36 PRIVATE>
  37
  38 SINGLETON: ----
  39
  40 M: ---- <menu-item>
  41     3drop
  42     <gadget>
  43         { 0 5 } >>dim
  44         menu-border-color <separator-pen> >>interior ;
  45
  46 : <menu> ( gadgets -- menu )
  47     <menu-items>
  48     { 0 3 } >>gap
  49     margins
  50     menu-border-color <solid> >>boundary
  51     menu-background <solid> >>interior ;
  52
  53 : <commands-menu> ( target hook commands -- menu )
  54     [ <menu-item> ] 2with map <menu> ;
  55
  56 : show-commands-menu ( target commands -- )
  57     [ dup [ ] ] dip <commands-menu> show-menu ;
  58
  59 : <operations-menu> ( target hook -- menu )
  60     over object-operations
  61     [ primary-operation? ] partition
  62     [ reverse ] [ [ command-name ] sort-with ] bi*
  63     { ---- } glue <commands-menu> ;
  64
  65 : show-operations-menu ( gadget target hook -- )
  66     <operations-menu> show-menu ;