163 lines
4.0 KiB
Factor
163 lines
4.0 KiB
Factor
! Copyright (C) 2005, 2009 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors combinators kernel locals math math.rectangles
|
|
math.vectors memoize models namespaces opengl sequences sorting
|
|
ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons
|
|
ui.gadgets.glass ui.gadgets.packs ui.gadgets.worlds
|
|
ui.gadgets.wrappers ui.gestures ui.operations ui.pens
|
|
ui.pens.solid ui.theme ;
|
|
FROM: ui.gadgets.wrappers => wrapper ;
|
|
|
|
IN: ui.gadgets.menus
|
|
|
|
<PRIVATE
|
|
|
|
: (show-menu) ( owner menu -- )
|
|
[ find-world ] dip hand-loc get-global point>rect show-glass ;
|
|
|
|
PRIVATE>
|
|
|
|
: show-menu ( owner menu -- )
|
|
[ (show-menu) ] keep request-focus ;
|
|
|
|
TUPLE: menu-button < button ;
|
|
|
|
<PRIVATE
|
|
|
|
: align-left ( menu-button -- menu-button )
|
|
{ 0 1/2 } >>align ; inline
|
|
|
|
MEMO: menu-button-pen-boundary ( -- pen )
|
|
f f roll-button-rollover-border <solid> dup dup <button-pen> ;
|
|
|
|
MEMO: menu-button-pen-interior ( -- pen )
|
|
f f roll-button-selected-background <solid> f over <button-pen> ;
|
|
|
|
: menu-button-theme ( menu-button -- menu-button )
|
|
menu-button-pen-boundary >>boundary
|
|
menu-button-pen-interior >>interior
|
|
align-left ; inline
|
|
|
|
: <menu-button> ( label quot -- menu-button )
|
|
menu-button new-button menu-button-theme ; inline
|
|
|
|
PRIVATE>
|
|
|
|
GENERIC: <menu-item> ( target hook command -- menu-item )
|
|
|
|
M:: object <menu-item> ( target hook command -- menu-item )
|
|
command command-name [
|
|
hook call
|
|
target command command-button-quot call
|
|
hide-glass
|
|
] <menu-button> ;
|
|
|
|
<PRIVATE
|
|
|
|
TUPLE: separator-pen color ;
|
|
|
|
C: <separator-pen> separator-pen
|
|
|
|
M: separator-pen draw-interior
|
|
color>> gl-color
|
|
dim>> [ { 0 0.5 } v* ] [ { 1 0.5 } v* ] bi
|
|
[ v>integer ] bi@ gl-line ;
|
|
|
|
: <menu-items> ( items -- gadget )
|
|
[ <filled-pile> ] dip add-gadgets ;
|
|
|
|
PRIVATE>
|
|
|
|
SINGLETON: ----
|
|
|
|
M: ---- <menu-item>
|
|
3drop
|
|
<gadget>
|
|
{ 0 5 } >>dim
|
|
menu-border-color <separator-pen> >>interior ;
|
|
|
|
TUPLE: menu < wrapper
|
|
items ;
|
|
|
|
<PRIVATE
|
|
|
|
: find-menu ( menu-button -- menu )
|
|
[ menu? ] find-parent ;
|
|
|
|
: activate-item ( menu-button -- )
|
|
dup find-menu set-control-value ;
|
|
|
|
: inactivate-item ( menu-button -- )
|
|
f swap find-menu set-control-value ;
|
|
|
|
: menu-buttons ( menu-items -- menu-buttons )
|
|
children>> [ menu-button? ] filter ;
|
|
|
|
:: prepare-menu ( menu items -- )
|
|
f <model> :> model
|
|
items menu-buttons :> buttons
|
|
buttons [ model add-connection ] each
|
|
menu model >>model buttons >>items drop ;
|
|
|
|
PRIVATE>
|
|
|
|
M: menu-button model-changed
|
|
swap value>> over = >>selected? relayout-1 ;
|
|
|
|
M: menu-button handle-gesture
|
|
[
|
|
{
|
|
{ [ over mouse-enter? ] [ nip activate-item ] }
|
|
{ [ over mouse-leave? ] [ nip inactivate-item ] }
|
|
[ 2drop ]
|
|
} cond
|
|
] 2keep call-next-method ;
|
|
|
|
<PRIVATE
|
|
|
|
:: next-item ( menu dir -- )
|
|
menu [ items>> ] [ control-value ] bi :> ( items curr )
|
|
curr [
|
|
items length :> max
|
|
curr items index :> indx
|
|
indx dir + max rem items nth
|
|
] [ items first ] if menu set-control-value ;
|
|
|
|
: activate-menu-item ( menu -- )
|
|
control-value [
|
|
dup quot>> ( button -- ) call-effect
|
|
] when* ;
|
|
|
|
PRIVATE>
|
|
|
|
menu H{
|
|
{ T{ key-down f f "ESC" } [ hide-glass ] }
|
|
{ T{ key-down f f "DOWN" } [ 1 next-item ] }
|
|
{ T{ key-down f f "UP" } [ -1 next-item ] }
|
|
{ T{ key-down f f "RET" } [ activate-menu-item ] }
|
|
} set-gestures
|
|
|
|
: <menu> ( gadgets -- menu )
|
|
<menu-items> [
|
|
{ 0 3 } >>gap
|
|
{ 5 5 } <filled-border>
|
|
menu-border-color <solid> >>boundary
|
|
menu-background <solid> >>interior
|
|
menu new-wrapper
|
|
] [ dupd prepare-menu ] bi ;
|
|
|
|
: <commands-menu> ( target hook commands -- menu )
|
|
[ <menu-item> ] 2with map <menu> ;
|
|
|
|
: show-commands-menu ( target commands -- )
|
|
[ dup [ ] ] dip <commands-menu> show-menu ;
|
|
|
|
: <operations-menu> ( target hook -- menu )
|
|
over object-operations
|
|
[ primary-operation? ] partition
|
|
[ reverse ] [ [ command-name ] sort-with ] bi*
|
|
{ ---- } glue <commands-menu> ;
|
|
|
|
: show-operations-menu ( gadget target hook -- )
|
|
<operations-menu> show-menu ;
|