1 ! Copyright (C) 2005, 2009 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors combinators kernel math math.rectangles
4 math.vectors models namespaces opengl sequences sorting
5 ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons
6 ui.gadgets.glass ui.gadgets.packs ui.gadgets.worlds
7 ui.gadgets.wrappers ui.gestures ui.operations ui.pens
8 ui.pens.solid ui.theme ;
9 FROM: ui.gadgets.wrappers => wrapper ;
15 : (show-menu) ( owner menu -- )
16 [ find-world ] dip hand-loc get-global point>rect show-glass ;
20 : show-menu ( owner menu -- )
21 [ (show-menu) ] keep request-focus ;
23 TUPLE: menu-button < button ;
27 : align-left ( menu-button -- menu-button )
28 { 0 1/2 } >>align ; inline
30 MEMO: menu-button-pen-boundary ( -- pen )
31 f f roll-button-rollover-border <solid> dup dup <button-pen> ;
33 MEMO: menu-button-pen-interior ( -- pen )
34 f f roll-button-selected-background <solid> f over <button-pen> ;
36 : menu-button-theme ( menu-button -- menu-button )
37 menu-button-pen-boundary >>boundary
38 menu-button-pen-interior >>interior
41 : <menu-button> ( label quot -- menu-button )
42 menu-button new-button menu-button-theme ; inline
46 GENERIC: <menu-item> ( target hook command -- menu-item )
48 M:: object <menu-item> ( target hook command -- menu-item )
49 command command-name [
51 target command command-button-quot call
57 TUPLE: separator-pen color ;
59 C: <separator-pen> separator-pen
61 M: separator-pen draw-interior
63 dim>> [ { 0 0.5 } v* ] [ { 1 0.5 } v* ] bi
64 [ v>integer ] bi@ gl-line ;
66 : <menu-items> ( items -- gadget )
67 [ <filled-pile> ] dip add-gadgets ;
77 menu-border-color <separator-pen> >>interior ;
84 : find-menu ( menu-button -- menu )
85 [ menu? ] find-parent ;
87 : activate-item ( menu-button -- )
88 dup find-menu set-control-value ;
90 : inactivate-item ( menu-button -- )
91 f swap find-menu set-control-value ;
93 : menu-buttons ( menu-items -- menu-buttons )
94 children>> [ menu-button? ] filter ;
96 :: prepare-menu ( menu items -- )
98 items menu-buttons :> buttons
99 buttons [ model add-connection ] each
100 menu model >>model buttons >>items drop ;
104 M: menu-button model-changed
105 swap value>> over = >>selected? relayout-1 ;
107 M: menu-button handle-gesture
110 { [ over mouse-enter? ] [ nip activate-item ] }
111 { [ over mouse-leave? ] [ nip inactivate-item ] }
114 ] 2keep call-next-method ;
118 :: next-item ( menu dir -- )
119 menu [ items>> ] [ control-value ] bi :> ( items curr )
122 curr items index :> indx
123 indx dir + max rem items nth
124 ] [ items first ] if menu set-control-value ;
126 : activate-menu-item ( menu -- )
128 dup quot>> ( button -- ) call-effect
134 { T{ key-down f f "ESC" } [ hide-glass ] }
135 { T{ key-down f f "DOWN" } [ 1 next-item ] }
136 { T{ key-down f f "UP" } [ -1 next-item ] }
137 { T{ key-down f f "RET" } [ activate-menu-item ] }
140 : <menu> ( gadgets -- menu )
143 { 5 5 } <filled-border>
144 menu-border-color <solid> >>boundary
145 menu-background <solid> >>interior
147 ] [ dupd prepare-menu ] bi ;
149 : <commands-menu> ( target hook commands -- menu )
150 [ <menu-item> ] 2with map <menu> ;
152 : show-commands-menu ( target commands -- )
153 [ dup [ ] ] dip <commands-menu> show-menu ;
155 : <operations-menu> ( target hook -- menu )
156 over object-operations
157 [ primary-operation? ] partition
158 [ reverse ] [ [ command-name ] sort-by ] bi*
159 { ---- } glue <commands-menu> ;
161 : show-operations-menu ( gadget target hook -- )
162 <operations-menu> show-menu ;