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 ;
11 : show-menu ( owner menu -- )
12 [ find-world ] dip hand-loc get { 0 0 } <rect> show-glass ;
14 GENERIC: <menu-item> ( target hook command -- button )
16 M:: object <menu-item> ( target hook command -- button )
17 command command-name [
19 target command command-button-quot call
25 TUPLE: separator-pen color ;
27 C: <separator-pen> separator-pen
29 M: separator-pen draw-interior
31 dim>> [ { 0 0.5 } v* ] [ { 1 0.5 } v* ] bi
32 [ [ >integer ] map ] bi@ gl-line ;
34 : <menu-items> ( items -- gadget )
35 [ <filled-pile> ] dip add-gadgets
36 panel-background-color <solid> >>interior ;
46 COLOR: black <separator-pen> >>interior ;
48 : menu-theme ( gadget -- gadget )
49 COLOR: light-gray <solid> >>interior ;
51 : <menu> ( gadgets -- menu )
53 frame "menu-background" [
59 : <commands-menu> ( target hook commands -- menu )
60 [ <menu-item> ] with with map <menu> ;
62 : show-commands-menu ( target commands -- )
63 [ dup [ ] ] dip <commands-menu> show-menu ;
65 : <operations-menu> ( target hook -- menu )
66 over object-operations
67 [ primary-operation? ] partition
68 [ reverse ] [ [ [ command-name ] compare ] sort ] bi*
69 { ---- } glue <commands-menu> ;
71 : show-operations-menu ( gadget target hook -- )
72 <operations-menu> show-menu ;