91 lines
2.4 KiB
Factor
91 lines
2.4 KiB
Factor
! Copyright (C) 2006 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: arrays definitions kernel gadgets sequences strings math
|
|
words generic namespaces hashtables help ;
|
|
IN: gadgets
|
|
|
|
TUPLE: command name gesture quot ;
|
|
|
|
M: command equal? eq? ;
|
|
|
|
GENERIC: invoke-command ( target command -- )
|
|
|
|
M: f invoke-command ( target command -- ) 2drop ;
|
|
|
|
M: command invoke-command ( target command -- )
|
|
command-quot call ;
|
|
|
|
GENERIC: gesture>string ( gesture -- string/f )
|
|
|
|
: modifiers>string ( modifiers -- string )
|
|
[ word-name ] map concat >string ;
|
|
|
|
M: key-down gesture>string
|
|
dup key-down-mods modifiers>string
|
|
swap key-down-sym append ;
|
|
|
|
M: button-up gesture>string
|
|
[
|
|
dup button-up-mods modifiers>string %
|
|
"Click Button" %
|
|
button-up-# [ " " % # ] when*
|
|
] "" make ;
|
|
|
|
M: button-down gesture>string
|
|
[
|
|
dup button-down-mods modifiers>string %
|
|
"Press Button" %
|
|
button-down-# [ " " % # ] when*
|
|
] "" make ;
|
|
|
|
M: object gesture>string drop f ;
|
|
|
|
: commands ( class -- hash )
|
|
dup "commands" word-prop [ ] [
|
|
H{ } clone [ "commands" set-word-prop ] keep
|
|
] ?if ;
|
|
|
|
: commands>gestures ( class -- hash )
|
|
commands hash-values concat
|
|
[ command-gesture ] subset
|
|
[ dup command-gesture swap [ invoke-command ] curry ]
|
|
map>hash ;
|
|
|
|
: define-commands ( class group specs -- )
|
|
[ dup array? [ first3 <command> ] when ] map
|
|
swap pick commands set-hash
|
|
dup commands>gestures "gestures" set-word-prop ;
|
|
|
|
: command-description ( command -- element )
|
|
dup command-name swap command-gesture gesture>string
|
|
2array ;
|
|
|
|
: commands. ( commands -- )
|
|
[ command-gesture key-down? ] subset
|
|
[ command-description ] map
|
|
{ { $strong "Command" } { $strong "Shortcut" } } add*
|
|
$table ;
|
|
|
|
: $commands ( element -- )
|
|
first2 swap commands hash commands. ;
|
|
|
|
TUPLE: operation predicate primary? secondary? listener? hook ;
|
|
|
|
SYMBOL: operations
|
|
|
|
: object-operations ( obj -- operations )
|
|
operations get [ operation-predicate call ] subset-with ;
|
|
|
|
: class-operations ( class -- operations )
|
|
"predicate" word-prop
|
|
operations get [ operation-predicate = ] subset-with ;
|
|
|
|
: primary-operation ( obj -- command )
|
|
object-operations [ operation-primary? ] find-last nip ;
|
|
|
|
: secondary-operation ( obj -- command )
|
|
object-operations [ operation-secondary? ] find-last nip ;
|
|
|
|
: $operations ( element -- )
|
|
[ class-operations ] map concat commands. ;
|