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: colors.constants kernel locals math.rectangles namespaces
   4 sequences ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons
   5 ui.gadgets.glass ui.gadgets.packs ui.gadgets.frames ui.gadgets.worlds
   6 ui.gadgets.corners ui.gestures ui.operations
   7 ui.render ui.pens ui.pens.solid opengl math.vectors words accessors
   8 math math.order sorting ;
   9 IN: ui.gadgets.menus
  10
  11 : show-menu ( owner menu -- )
  12     [ find-world ] dip hand-loc get-global { 0 0 } <rect> show-glass ;
  13
  14 GENERIC: <menu-item> ( target hook command -- button )
  15
  16 M:: object <menu-item> ( target hook command -- button )
  17     command command-name [
  18         hook call
  19         target command command-button-quot call
  20         hide-glass
  21     ] <roll-button> ;
  22
  23 <PRIVATE
  24
  25 TUPLE: separator-pen color ;
  26
  27 C: <separator-pen> separator-pen
  28
  29 M: separator-pen draw-interior
  30     color>> gl-color
  31     dim>> [ { 0 0.5 } v* ] [ { 1 0.5 } v* ] bi
  32     [ [ >integer ] map ] bi@ gl-line ;
  33
  34 : <menu-items> ( items -- gadget )
  35     [ <filled-pile> ] dip add-gadgets
  36     panel-background-color <solid> >>interior ;
  37
  38 PRIVATE>
  39
  40 SINGLETON: ----
  41
  42 M: ---- <menu-item>
  43     3drop
  44     <gadget>
  45         { 0 5 } >>dim
  46         COLOR: black <separator-pen> >>interior ;
  47
  48 : menu-theme ( gadget -- gadget )
  49     COLOR: light-gray <solid> >>interior ;
  50
  51 : <menu> ( gadgets -- menu )
  52     <menu-items>
  53     frame "menu-background" [
  54         /-----\
  55         |-----|
  56         \-----/
  57     ] make-corners ;
  58
  59 : <commands-menu> ( target hook commands -- menu )
  60     [ <menu-item> ] with with map <menu> ;
  61
  62 : show-commands-menu ( target commands -- )
  63     [ dup [ ] ] dip <commands-menu> show-menu ;
  64
  65 : <operations-menu> ( target hook -- menu )
  66     over object-operations
  67     [ primary-operation? ] partition
  68     [ reverse ] [ [ command-name ] sort-with ] bi*
  69     { ---- } glue <commands-menu> ;
  70
  71 : show-operations-menu ( gadget target hook -- )
  72     <operations-menu> show-menu ;