steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Display gesture modifiers using Mac OS X Unicode characters

db4
Slava Pestov 2009-01-26 17:58:23 -06:00
parent 9bf2675fa3
commit f5d850f39e
2 changed files with 27 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
basis/ui/gadgets/buttons/buttons.factor
View File

@ -218,12 +218,10 @@ TUPLE: radio-control < button value ;
align-left ; inline align-left ; inline
M: radio-control model-changed M: radio-control model-changed
swap value>> 2dup [ value>> ] bi@ = >>selected? relayout-1 drop ;
over value>> = >>selected?
relayout-1 ;
: <radio-controls> ( assoc model parent quot: ( value model label -- gadget ) -- parent ) :: <radio-controls> ( parent model assoc quot: ( value model label -- gadget ) -- parent )
'[ _ swap @ add-gadget ] assoc-each ; inline assoc model [ parent swap quot call add-gadget ] assoc-each ; inline
: radio-button-theme ( gadget -- gadget ) : radio-button-theme ( gadget -- gadget )
{ 5 5 } >>gap { 5 5 } >>gap
@ -234,7 +232,7 @@ M: radio-control model-changed
: <radio-buttons> ( model assoc -- gadget ) : <radio-buttons> ( model assoc -- gadget )
<filled-pile> <filled-pile>
spin [ <radio-button> ] <radio-controls> [ <radio-button> ] <radio-controls>
{ 5 5 } >>gap ; { 5 5 } >>gap ;
: <toggle-button> ( value model label -- gadget ) : <toggle-button> ( value model label -- gadget )
@ -242,7 +240,7 @@ M: radio-control model-changed
: <toggle-buttons> ( model assoc -- gadget ) : <toggle-buttons> ( model assoc -- gadget )
<shelf> <shelf>
spin [ <toggle-button> ] <radio-controls> ; [ <toggle-button> ] <radio-controls> ;
: command-button-quot ( target command -- quot ) : command-button-quot ( target command -- quot )
'[ _ _ invoke-command drop ] ; '[ _ _ invoke-command drop ] ;
@ -252,8 +250,9 @@ M: radio-control model-changed
: <toolbar> ( target -- toolbar ) : <toolbar> ( target -- toolbar )
<shelf> <shelf>
1 >>fill
swap swap
"toolbar" over class command-map commands>> swap [ [ "toolbar" ] dip class command-map commands>> ] keep
'[ [ _ ] 2dip <command-button> add-gadget ] assoc-each ; '[ [ _ ] 2dip <command-button> add-gadget ] assoc-each ;
: add-toolbar ( track -- track ) : add-toolbar ( track -- track )

25
basis/ui/gestures/gestures.factor
View File

@ -3,7 +3,8 @@
USING: accessors arrays assocs kernel math math.order models USING: accessors arrays assocs kernel math math.order models
namespaces make sequences words strings system hashtables namespaces make sequences words strings system hashtables
math.parser math.vectors classes.tuple classes boxes calendar math.parser math.vectors classes.tuple classes boxes calendar
alarms combinators sets columns fry deques ui.gadgets ; alarms combinators sets columns fry deques ui.gadgets
unicode.case combinators.short-circuit ;
IN: ui.gestures IN: ui.gestures
GENERIC: handle-gesture ( gesture gadget -- ? ) GENERIC: handle-gesture ( gesture gadget -- ? )
@ -280,12 +281,26 @@ SYMBOL: drag-timer
GENERIC: gesture>string ( gesture -- string/f ) GENERIC: gesture>string ( gesture -- string/f )
: modifiers>string ( modifiers -- string ) HOOK: modifiers>string os ( modifiers -- string )
[ name>> ] map concat >string ;
M: macosx modifiers>string
[
{
{ A+ [ "⌘" ] }
{ M+ [ "⎇" ] }
{ S+ [ "⇧" ] }
{ C+ [ "⌃" ] }
} case
] map "" join ;
M: object modifiers>string
[ name>> ] map "" join ;
M: key-down gesture>string M: key-down gesture>string
dup mods>> modifiers>string [ mods>> ] [ sym>> ] bi
swap sym>> append ; dup { [ length 1 = ] [ upper? ] } 1&&
[ [ S+ prefix ] dip ] [ >upper ] if
[ modifiers>string ] dip append ;
M: button-up gesture>string M: button-up gesture>string
[ [