More slight operations fixes
parent
7ee943117c
commit
b979addffc
|
@ -89,32 +89,36 @@ SYMBOL: +quot+
|
||||||
SYMBOL: +listener+
|
SYMBOL: +listener+
|
||||||
SYMBOL: +gesture+
|
SYMBOL: +gesture+
|
||||||
|
|
||||||
TUPLE: operation class tags gesture listener? ;
|
TUPLE: operation predicate tags gesture listener? ;
|
||||||
|
|
||||||
: (operation) ( -- command )
|
: (operation) ( -- command )
|
||||||
f +name+ get +gesture+ get +quot+ get <command> ;
|
f +name+ get +gesture+ get +quot+ get <command> ;
|
||||||
|
|
||||||
: (tags) ( -- seq ) +button+ get +group+ get 2array ;
|
: (tags) ( -- seq ) +button+ get +group+ get 2array ;
|
||||||
|
|
||||||
C: operation ( class hash -- operation )
|
C: operation ( predicate hash -- operation )
|
||||||
swap [
|
swap [
|
||||||
(operation) over set-delegate
|
(operation) over set-delegate
|
||||||
(tags) over set-operation-tags
|
(tags) over set-operation-tags
|
||||||
+listener+ get over set-operation-listener?
|
+listener+ get over set-operation-listener?
|
||||||
] bind
|
] bind
|
||||||
[ set-operation-class ] keep ;
|
[ set-operation-predicate ] keep ;
|
||||||
|
|
||||||
SYMBOL: operations
|
SYMBOL: operations
|
||||||
|
|
||||||
: class-operations ( class -- operations )
|
: object-operations ( obj -- operations )
|
||||||
operations get [ operation-class class< ] subset-with ;
|
operations get [ operation-predicate call ] subset-with ;
|
||||||
|
|
||||||
: tagged-operations ( class tag -- commands )
|
: class-operations ( class -- operations )
|
||||||
swap class-operations
|
"predicate" word-prop
|
||||||
|
operations get [ operation-predicate = ] subset-with ;
|
||||||
|
|
||||||
|
: tagged-operations ( obj tag -- commands )
|
||||||
|
swap object-operations
|
||||||
[ operation-tags member? ] subset-with ;
|
[ operation-tags member? ] subset-with ;
|
||||||
|
|
||||||
: mouse-operation ( class button# -- command )
|
: mouse-operation ( obj button# -- command )
|
||||||
tagged-operations dup empty? [ drop f ] [ peek ] if ;
|
tagged-operations dup empty? [ drop f ] [ peek ] if ;
|
||||||
|
|
||||||
: mouse-operations ( class -- seq )
|
: mouse-operations ( obj -- seq )
|
||||||
3 [ 1+ mouse-operation ] map-with ;
|
3 [ 1+ mouse-operation ] map-with ;
|
||||||
|
|
|
@ -17,7 +17,7 @@ C: presentation ( button object commands -- button )
|
||||||
|
|
||||||
: <object-presentation> ( gadget object -- button )
|
: <object-presentation> ( gadget object -- button )
|
||||||
>r f <roll-button> r>
|
>r f <roll-button> r>
|
||||||
dup class mouse-operations <presentation> ;
|
dup mouse-operations <presentation> ;
|
||||||
|
|
||||||
: <command-presentation> ( target command -- button )
|
: <command-presentation> ( target command -- button )
|
||||||
dup command-name f <bevel-button> -rot { f f } swap add*
|
dup command-name f <bevel-button> -rot { f f } swap add*
|
||||||
|
|
|
@ -155,7 +155,7 @@ M: operation invoke-command ( target operation -- )
|
||||||
[ modify-listener-operation ] map-with ;
|
[ modify-listener-operation ] map-with ;
|
||||||
|
|
||||||
! Objects
|
! Objects
|
||||||
object H{
|
[ drop t ] H{
|
||||||
{ +button+ 1 }
|
{ +button+ 1 }
|
||||||
{ +name+ "Inspect" }
|
{ +name+ "Inspect" }
|
||||||
{ +quot+ [ inspect ] }
|
{ +quot+ [ inspect ] }
|
||||||
|
@ -163,76 +163,82 @@ object H{
|
||||||
} define-operation
|
} define-operation
|
||||||
|
|
||||||
! Input
|
! Input
|
||||||
input H{
|
[ input? ] H{
|
||||||
{ +button+ 1 }
|
{ +button+ 1 }
|
||||||
{ +name+ "Input" }
|
{ +name+ "Input" }
|
||||||
{ +quot+ [ listener-gadget call-tool ] }
|
{ +quot+ [ listener-gadget call-tool ] }
|
||||||
} define-operation
|
} define-operation
|
||||||
|
|
||||||
! Words
|
! Words
|
||||||
\ word H{
|
[ word? ] H{
|
||||||
{ +button+ 1 }
|
{ +button+ 1 }
|
||||||
{ +name+ "Browse" }
|
{ +name+ "Browse" }
|
||||||
{ +gesture+ T{ key-down f { A+ } "b" } }
|
{ +gesture+ T{ key-down f { A+ } "b" } }
|
||||||
{ +quot+ [ browser call-tool ] }
|
{ +quot+ [ browser call-tool ] }
|
||||||
} define-operation
|
} define-operation
|
||||||
|
|
||||||
\ word H{
|
[ word? ] H{
|
||||||
{ +button+ 2 }
|
{ +button+ 2 }
|
||||||
{ +name+ "Edit" }
|
{ +name+ "Edit" }
|
||||||
{ +gesture+ T{ key-down f { A+ } "e" } }
|
{ +gesture+ T{ key-down f { A+ } "e" } }
|
||||||
{ +quot+ [ edit ] }
|
{ +quot+ [ edit ] }
|
||||||
} define-operation
|
} define-operation
|
||||||
|
|
||||||
\ word H{
|
[ word? ] H{
|
||||||
{ +button+ 3 }
|
{ +button+ 3 }
|
||||||
{ +name+ "Documentation" }
|
{ +name+ "Documentation" }
|
||||||
{ +gesture+ T{ key-down f { A+ } "h" } }
|
{ +gesture+ T{ key-down f { A+ } "h" } }
|
||||||
{ +quot+ [ help-gadget call-tool ] }
|
{ +quot+ [ help-gadget call-tool ] }
|
||||||
} define-operation
|
} define-operation
|
||||||
|
|
||||||
\ word H{
|
[ word? ] H{
|
||||||
{ +name+ "Usage" }
|
{ +name+ "Usage" }
|
||||||
{ +gesture+ T{ key-down f { A+ } "u" } }
|
{ +gesture+ T{ key-down f { A+ } "u" } }
|
||||||
{ +quot+ [ usage. ] }
|
{ +quot+ [ usage. ] }
|
||||||
{ +listener+ t }
|
{ +listener+ t }
|
||||||
} define-operation
|
} define-operation
|
||||||
|
|
||||||
\ word H{
|
[ word? ] H{
|
||||||
{ +name+ "Reload" }
|
{ +name+ "Reload" }
|
||||||
{ +gesture+ T{ key-down f { A+ } "r" } }
|
{ +gesture+ T{ key-down f { A+ } "r" } }
|
||||||
{ +quot+ [ reload ] }
|
{ +quot+ [ reload ] }
|
||||||
{ +listener+ t }
|
{ +listener+ t }
|
||||||
} define-operation
|
} define-operation
|
||||||
|
|
||||||
\ word H{
|
[ word? ] H{
|
||||||
{ +name+ "Watch" }
|
{ +name+ "Watch" }
|
||||||
{ +quot+ [ watch ] }
|
{ +quot+ [ watch ] }
|
||||||
{ +listener+ t }
|
{ +listener+ t }
|
||||||
} define-operation
|
} define-operation
|
||||||
|
|
||||||
! Vocabularies
|
! Vocabularies
|
||||||
vocab-link H{
|
[ vocab-link? ] H{
|
||||||
{ +button+ 1 }
|
{ +button+ 1 }
|
||||||
{ +name+ "Browse" }
|
{ +name+ "Browse" }
|
||||||
{ +quot+ [ browser call-tool ] }
|
{ +quot+ [ browser call-tool ] }
|
||||||
} define-operation
|
} define-operation
|
||||||
|
|
||||||
! Link
|
! Link
|
||||||
link H{
|
[ link? ] H{
|
||||||
{ +button+ 1 }
|
{ +button+ 1 }
|
||||||
{ +name+ "Follow" }
|
{ +name+ "Follow" }
|
||||||
{ +quot+ [ help-gadget call-tool ] }
|
{ +quot+ [ help-gadget call-tool ] }
|
||||||
} define-operation
|
} define-operation
|
||||||
|
|
||||||
link H{
|
[ link? ] H{
|
||||||
{ +button+ 2 }
|
{ +button+ 2 }
|
||||||
{ +name+ "Edit" }
|
{ +name+ "Edit" }
|
||||||
{ +quot+ [ edit ] }
|
{ +quot+ [ edit ] }
|
||||||
} define-operation
|
} define-operation
|
||||||
|
|
||||||
|
[ word-link? ] H{
|
||||||
|
{ +button+ 2 }
|
||||||
|
{ +name+ "Definition" }
|
||||||
|
{ +quot+ [ link-name browser call-tool ] }
|
||||||
|
} define-operation
|
||||||
|
|
||||||
! Strings
|
! Strings
|
||||||
string H{
|
[ string? ] H{
|
||||||
{ +name+ "Apropos (all)" }
|
{ +name+ "Apropos (all)" }
|
||||||
{ +gesture+ T{ key-down f { A+ } "a" } }
|
{ +gesture+ T{ key-down f { A+ } "a" } }
|
||||||
{ +quot+ [ apropos ] }
|
{ +quot+ [ apropos ] }
|
||||||
|
@ -244,7 +250,7 @@ string H{
|
||||||
use get [ hash-values [ dup set ] each ] each
|
use get [ hash-values [ dup set ] each ] each
|
||||||
] make-hash hash-values natural-sort ;
|
] make-hash hash-values natural-sort ;
|
||||||
|
|
||||||
string H{
|
[ string? ] H{
|
||||||
{ +name+ "Apropos (used)" }
|
{ +name+ "Apropos (used)" }
|
||||||
{ +gesture+ T{ key-down f f "TAB" } }
|
{ +gesture+ T{ key-down f f "TAB" } }
|
||||||
{ +quot+ [ usable-words (apropos) ] }
|
{ +quot+ [ usable-words (apropos) ] }
|
||||||
|
@ -252,21 +258,21 @@ string H{
|
||||||
} define-operation
|
} define-operation
|
||||||
|
|
||||||
! Quotations
|
! Quotations
|
||||||
quotation H{
|
[ quotation? ] H{
|
||||||
{ +name+ "Infer" }
|
{ +name+ "Infer" }
|
||||||
{ +gesture+ T{ key-down f { C+ A+ } "i" } }
|
{ +gesture+ T{ key-down f { C+ A+ } "i" } }
|
||||||
{ +quot+ [ infer . ] }
|
{ +quot+ [ infer . ] }
|
||||||
{ +listener+ t }
|
{ +listener+ t }
|
||||||
} define-operation
|
} define-operation
|
||||||
|
|
||||||
quotation H{
|
[ quotation? ] H{
|
||||||
{ +name+ "Walk" }
|
{ +name+ "Walk" }
|
||||||
{ +gesture+ T{ key-down f { C+ A+ } "w" } }
|
{ +gesture+ T{ key-down f { C+ A+ } "w" } }
|
||||||
{ +quot+ [ walk ] }
|
{ +quot+ [ walk ] }
|
||||||
{ +listener+ t }
|
{ +listener+ t }
|
||||||
} define-operation
|
} define-operation
|
||||||
|
|
||||||
quotation H{
|
[ quotation? ] H{
|
||||||
{ +name+ "Time" }
|
{ +name+ "Time" }
|
||||||
{ +gesture+ T{ key-down f { C+ A+ } "t" } }
|
{ +gesture+ T{ key-down f { C+ A+ } "t" } }
|
||||||
{ +quot+ [ time ] }
|
{ +quot+ [ time ] }
|
||||||
|
|
Loading…
Reference in New Issue