extra/ui/gadgets/menus/menus.factor

   1 ! Copyright (C) 2005, 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays ui.commands ui.gadgets ui.gadgets.buttons
   4 ui.gadgets.worlds ui.gestures generic hashtables kernel math
   5 models namespaces opengl sequences math.vectors
   6 ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors ;
   7 IN: ui.gadgets.menus
   8
   9 : menu-loc ( world menu -- loc )
  10     >r rect-dim r> pref-dim [v-] hand-loc get-global vmin ;
  11
  12 TUPLE: menu-glass ;
  13
  14 : <menu-glass> ( menu world -- glass )
  15     menu-glass construct-gadget
  16     >r over menu-loc over set-rect-loc r>
  17     [ add-gadget ] keep ;
  18
  19 M: menu-glass layout* gadget-child prefer ;
  20
  21 : hide-glass ( world -- )
  22     dup world-glass [ unparent ] when*
  23     f swap set-world-glass ;
  24
  25 : show-glass ( gadget world -- )
  26     over hand-clicked set-global
  27     [ hide-glass ] keep
  28     [ add-gadget ] 2keep
  29     set-world-glass ;
  30
  31 : show-menu ( gadget owner -- )
  32     find-world [ <menu-glass> ] keep show-glass ;
  33
  34 \ menu-glass H{
  35     { T{ button-down } [ find-world [ hide-glass ] when* ] }
  36     { T{ drag } [ update-clicked drop ] }
  37 } set-gestures
  38
  39 : <menu-item> ( hook target command -- button )
  40     dup command-name -rot command-button-quot
  41     swapd
  42     [ hand-clicked get find-world hide-glass ]
  43     3append <roll-button> ;
  44
  45 : menu-theme ( gadget -- )
  46     dup light-gray solid-interior
  47     faint-boundary ;
  48
  49 : <commands-menu> ( hook target commands -- gadget )
  50     [
  51         [ >r 2dup r> <menu-item> gadget, ] each 2drop
  52     ] make-filled-pile 5 <border> dup menu-theme ;