basis/ui/gadgets/menus/menus.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: locals accessors arrays ui.commands ui.operations ui.gadgets
   4 ui.gadgets.buttons ui.gadgets.worlds ui.gestures generic
   5 hashtables kernel math models namespaces opengl sequences
   6 math.vectors ui.gadgets.theme ui.gadgets.packs
   7 ui.gadgets.borders colors math.geometry.rect ;
   8 IN: ui.gadgets.menus
   9
  10 : menu-loc ( world menu -- loc )
  11     [ rect-dim ] [ pref-dim ] bi* [v-] hand-loc get-global vmin ;
  12
  13 TUPLE: menu-glass < gadget ;
  14
  15 : <menu-glass> ( world menu -- glass )
  16     tuck menu-loc >>loc
  17     menu-glass new-gadget
  18     swap add-gadget ;
  19
  20 M: menu-glass layout* gadget-child prefer ;
  21
  22 : hide-glass ( world -- )
  23     [ [ unparent ] when* f ] change-glass drop ;
  24
  25 : show-glass ( world gadget -- )
  26     [ [ hide-glass ] [ hand-clicked set-global ] bi* ]
  27     [ add-gadget drop ]
  28     [ >>glass drop ]
  29     2tri ;
  30
  31 : show-menu ( owner menu -- )
  32     [ find-world dup ] dip <menu-glass> 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> ( target hook command -- button )
  40     command command-name [
  41         hook call
  42         target command command-button-quot call
  43         hand-clicked get find-world hide-glass
  44     ] <roll-button> ;
  45
  46 : menu-theme ( gadget -- gadget )
  47     light-gray solid-interior
  48     faint-boundary ;
  49
  50 : <commands-menu> ( target hook commands -- menu )
  51     [ <filled-pile> ] 3dip
  52     [ <menu-item> add-gadget ] with with each
  53     5 <border> menu-theme ;
  54
  55 : show-commands-menu ( target commands -- )
  56     [ dup [ ] ] dip <commands-menu> show-menu ;
  57
  58 : <operations-menu> ( target hook -- menu )
  59     over object-operations <commands-menu> ;
  60
  61 : show-operations-menu ( gadget target -- )
  62     [ ] <operations-menu> show-menu ;