diff --git a/library/ui/load.factor b/library/ui/load.factor index 9491a5f53b..3995fb38ef 100644 --- a/library/ui/load.factor +++ b/library/ui/load.factor @@ -36,6 +36,7 @@ PROVIDE: library/ui { "text/interactor.factor" "gadgets/presentations.factor" "ui.factor" + "tools/tools.factor" "tools/listener.factor" "tools/walker.factor" "tools/search.factor" @@ -43,6 +44,7 @@ PROVIDE: library/ui { "tools/help.factor" "tools/dataflow.factor" "tools/workspace.factor" + "tools/operations.factor" } { "test/models.factor" "test/document.factor" diff --git a/library/ui/tools/browser.factor b/library/ui/tools/browser.factor index fef15d9350..e7cab24e55 100644 --- a/library/ui/tools/browser.factor +++ b/library/ui/tools/browser.factor @@ -4,7 +4,8 @@ USING: arrays sequences kernel gadgets-panes definitions prettyprint gadgets-theme gadgets-borders gadgets generic gadgets-scrolling math io words models styles namespaces gadgets-tracks gadgets-presentations gadgets-grids -gadgets-frames help gadgets-buttons gadgets-search tools ; +gadgets-workspace gadgets-frames help gadgets-buttons +gadgets-search tools ; IN: gadgets-browser TUPLE: browser navigator definitions search ; @@ -104,3 +105,10 @@ browser { { "Clear" T{ key-down f f "CLEAR" } [ clear-browser ] } } } define-commands + +M: browser call-tool* + over vocab-link? [ + >r vocab-link-name r> show-vocab + ] [ + show-word + ] if ; diff --git a/library/ui/tools/dataflow.factor b/library/ui/tools/dataflow.factor index 560ee2ff55..4990fe2e2e 100644 --- a/library/ui/tools/dataflow.factor +++ b/library/ui/tools/dataflow.factor @@ -5,7 +5,7 @@ USING: namespaces arrays sequences io inference math kernel generic prettyprint words gadgets opengl gadgets-panes gadgets-labels gadgets-theme gadgets-presentations gadgets-buttons gadgets-borders gadgets-scrolling -gadgets-frames optimizer models ; +gadgets-frames gadgets-workspace optimizer models ; : shuffle-in dup shuffle-in-d swap shuffle-in-r append ; @@ -111,35 +111,30 @@ M: object node>gadget { 5 5 } over set-pack-gap swap dup faint-boundary ; +: (compute-heights) ( node -- ) + [ + [ node-d-height ] keep + [ node-r-height ] keep + [ 3array , ] keep + node-successor (compute-heights) + ] when* ; + : node-in-d# node-in-d length ; : node-out-d# node-out-d length ; : node-in-r# node-in-r length ; : node-out-r# node-out-r length ; -SYMBOL: d-height -SYMBOL: r-height - -: (compute-heights) ( node -- ) - [ - dup node-in-d# d-height [ swap - ] change - dup node-in-r# r-height [ swap - ] change - d-height get r-height get pick 3array , - dup node-out-d# d-height [ + ] change - dup node-out-r# r-height [ + ] change - node-successor (compute-heights) - ] when* ; - : normalize-d-height ( seq -- seq ) - [ [ first ] map infimum ] keep + [ [ dup first swap third node-in-d# - ] map infimum ] keep [ first3 >r >r swap - r> r> 3array ] map-with ; : normalize-r-height ( seq -- seq ) - [ [ second ] map infimum ] keep + [ [ dup second swap third node-in-r# - ] map infimum ] keep [ first3 >r rot - r> 3array ] map-with ; : compute-heights ( nodes -- pairs ) - [ 0 d-height set 0 r-height set (compute-heights) ] { } make + [ (compute-heights) ] { } make normalize-d-height normalize-r-height ; : node-r-skew-1 ( node -- n ) @@ -149,17 +144,18 @@ SYMBOL: r-height dup node-in-d# over node-out-r# [-] swap node-out-d# [-] ; SYMBOL: prev-node + : node-r-skew ( node -- n ) node-r-skew-1 prev-node get [ node-r-skew-2 - ] when* ; : print-node ( d-height r-height node -- ) [ [ - pick over node-in-d# + 0 , + pick 0 , 2dup node-in-r# + over node-r-skew , ] { } make make-pile , [ - rot 0 , + rot over node-in-d# - 0 , node>gadget , 0 , ] { } make make-pile 1 over set-pack-fill , @@ -190,3 +186,12 @@ C: dataflow-gadget ( -- gadget ) f over set-dataflow-gadget-history { { [ ] f [ ] @center } } make-frame* ; + +M: dataflow-gadget call-tool* ( node dataflow -- ) + dup dataflow-gadget-history add-history + dataflow-gadget-history set-model ; + +IN: tools + +: show-dataflow ( quot -- ) + dataflow optimize dataflow-gadget call-tool ; diff --git a/library/ui/tools/help.factor b/library/ui/tools/help.factor index f3ac9734bb..8819355da1 100644 --- a/library/ui/tools/help.factor +++ b/library/ui/tools/help.factor @@ -3,7 +3,7 @@ IN: gadgets-help USING: gadgets gadgets-borders gadgets-buttons gadgets-frames gadgets-panes gadgets-search gadgets-scrolling help kernel -models namespaces sequences gadgets-tracks ; +models namespaces sequences gadgets-tracks gadgets-workspace ; TUPLE: help-gadget history search ; @@ -36,3 +36,5 @@ C: help-gadget ( -- gadget ) } { 0 1 } make-track* ; M: help-gadget focusable-child* help-gadget-search ; + +M: help-gadget call-tool* show-help ; diff --git a/library/ui/tools/listener.factor b/library/ui/tools/listener.factor index 148a23e24f..df88e85bf5 100644 --- a/library/ui/tools/listener.factor +++ b/library/ui/tools/listener.factor @@ -3,9 +3,9 @@ IN: gadgets-listener USING: arrays gadgets gadgets-frames gadgets-labels gadgets-panes gadgets-scrolling gadgets-text gadgets-theme -gadgets-tracks generic hashtables tools io +gadgets-tracks gadgets-workspace generic hashtables tools io kernel listener math models namespaces parser prettyprint -sequences shells styles threads words memory ; +sequences shells strings styles threads words memory ; TUPLE: listener-gadget input output stack ; @@ -63,3 +63,25 @@ M: listener-gadget focusable-child* : clear-output ( -- ) stdio get duplex-stream-out pane-clear ; + +G: call-listener ( quot/string listener -- ) + 1 standard-combination ; + +M: quotation call-listener + listener-gadget-input interactor-call ; + +M: string call-listener + listener-gadget-input set-editor-text ; + +M: input call-listener + >r input-string r> call-listener ; + +M: listener-gadget call-tool* ( quot/string listener -- ) + call-listener ; + +: listener-run-files ( seq -- ) + dup empty? [ + drop + ] [ + [ [ run-file ] each ] curry listener-gadget call-tool + ] if ; diff --git a/library/ui/tools/operations.factor b/library/ui/tools/operations.factor new file mode 100644 index 0000000000..ac05d7b3e0 --- /dev/null +++ b/library/ui/tools/operations.factor @@ -0,0 +1,230 @@ +! Copyright (C) 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: gadgets-workspace +USING: definitions gadgets gadgets-browser gadgets-dataflow +gadgets-help gadgets-listener gadgets-text gadgets-workspace +hashtables help inference kernel namespaces parser prettyprint +scratchpad sequences strings styles syntax test tools words +generic ; + +V{ } clone operations set-global + +: define-operation ( class props -- ) + operations get push-new ; + +M: operation invoke-command ( target operation -- ) + dup command-quot swap operation-listener? + [ curry listener-gadget call-tool ] [ call ] if ; + +: modify-operation ( quot operation -- operation ) + clone + [ command-quot append ] keep + [ set-command-quot ] keep ; + +: modify-operations ( quot operations -- operations ) + [ modify-operation ] map-with ; + +: modify-listener-operation ( quot operation -- operation ) + clone t over set-operation-listener? + modify-operation ; + +: modify-listener-operations ( quot operations -- operations ) + [ modify-listener-operation ] map-with ; + +! Objects +[ drop t ] H{ + { +button+ 1 } + { +name+ "Inspect" } + { +quot+ [ inspect ] } + { +listener+ t } +} define-operation + +! Input +[ input? ] H{ + { +button+ 1 } + { +name+ "Input" } + { +quot+ [ listener-gadget call-tool ] } +} define-operation + +! Words +[ word? ] H{ + { +button+ 1 } + { +group+ "Words" } + { +name+ "Browse" } + { +gesture+ T{ key-down f { A+ } "b" } } + { +quot+ [ browser call-tool ] } +} define-operation + +[ word? ] H{ + { +button+ 2 } + { +group+ "Words" } + { +name+ "Edit" } + { +gesture+ T{ key-down f { A+ } "e" } } + { +quot+ [ edit ] } +} define-operation + +[ word? ] H{ + { +button+ 3 } + { +group+ "Words" } + { +name+ "Documentation" } + { +gesture+ T{ key-down f { A+ } "h" } } + { +quot+ [ help-gadget call-tool ] } +} define-operation + +[ word? ] H{ + { +group+ "Words" } + { +name+ "Usage" } + { +gesture+ T{ key-down f { A+ } "u" } } + { +quot+ [ usage. ] } + { +listener+ t } +} define-operation + +[ word? ] H{ + { +group+ "Words" } + { +name+ "Reload" } + { +gesture+ T{ key-down f { A+ } "r" } } + { +quot+ [ reload ] } + { +listener+ t } +} define-operation + +[ word? ] H{ + { +group+ "Words" } + { +name+ "Watch" } + { +quot+ [ watch ] } + { +listener+ t } +} define-operation + +! Vocabularies +[ vocab-link? ] H{ + { +button+ 1 } + { +name+ "Browse" } + { +quot+ [ browser call-tool ] } +} define-operation + +! Link +[ link? ] H{ + { +button+ 1 } + { +name+ "Follow" } + { +quot+ [ help-gadget call-tool ] } +} define-operation + +[ link? ] H{ + { +button+ 2 } + { +name+ "Edit" } + { +quot+ [ edit ] } +} define-operation + +[ word-link? ] H{ + { +button+ 3 } + { +name+ "Definition" } + { +quot+ [ link-name browser call-tool ] } +} define-operation + +! Strings +[ string? ] H{ + { +group+ "Words" } + { +name+ "Apropos (all)" } + { +gesture+ T{ key-down f { A+ } "a" } } + { +quot+ [ apropos ] } + { +listener+ t } +} define-operation + +: usable-words ( -- seq ) + [ + use get [ hash-values [ dup set ] each ] each + ] make-hash hash-values natural-sort ; + +[ string? ] H{ + { +group+ "Words" } + { +name+ "Apropos (used)" } + { +gesture+ T{ key-down f f "TAB" } } + { +quot+ [ usable-words (apropos) ] } + { +listener+ t } +} define-operation + +! Quotations +[ quotation? ] H{ + { +group+ "Quotations" } + { +name+ "Infer" } + { +gesture+ T{ key-down f { C+ A+ } "i" } } + { +quot+ [ infer . ] } + { +listener+ t } +} define-operation + +[ quotation? ] H{ + { +group+ "Quotations" } + { +name+ "Dataflow" } + { +gesture+ T{ key-down f { C+ A+ } "d" } } + { +quot+ [ show-dataflow ] } + { +listener+ t } +} define-operation + +[ quotation? ] H{ + { +group+ "Quotations" } + { +name+ "Walk" } + { +gesture+ T{ key-down f { C+ A+ } "w" } } + { +quot+ [ walk ] } + { +listener+ t } +} define-operation + +[ quotation? ] H{ + { +group+ "Quotations" } + { +name+ "Time" } + { +gesture+ T{ key-down f { C+ A+ } "t" } } + { +quot+ [ time ] } + { +listener+ t } +} define-operation + +! Dataflow nodes +[ word? ] H{ + { +group+ "Words" } + { +name+ "Word dataflow" } + { +quot+ [ word-def dataflow-gadget call-tool ] } +} define-operation + +[ [ node? ] is? ] H{ + { +button+ 1 } + { +group+ "Nodes" } + { +name+ "Quotation dataflow" } + { +quot+ [ dataflow-gadget call-tool ] } +} define-operation + +! Define commands in terms of operations + +! Tile commands +tile +[ tile-definition ] \ word class-operations modify-operations +[ command-name "Browse" = not ] subset +T{ command f f "Close" f [ close-tile ] } add* +define-commands* + +! Interactor commands +: selected-word ( editor -- string ) + dup gadget-selection? + [ dup T{ word-elt } select-elt ] unless + gadget-selection ; + +: word-action ( target -- quot ) + selected-word search ; + +: quot-action ( quot -- quot ) + field-commit parse ; + +interactor [ + { + "Listener" + { "Evaluate" T{ key-down f f "RETURN" } [ interactor-commit ] } + { "Send EOF" T{ key-down f { C+ } "d" } [ f swap interactor-eval ] } + } % + + [ word-action ] \ word class-operations modify-listener-operations % + [ selected-word ] string class-operations modify-listener-operations % + [ quot-action ] quotation class-operations modify-listener-operations % + + { + "Listener" + { "History" T{ key-down f { C+ } "h" } [ [ interactor-history. ] swap interactor-call ] } + { "Clear output" T{ key-down f f "CLEAR" } [ [ clear-output ] swap interactor-call ] } + { "Clear stack" T{ key-down f { C+ } "CLEAR" } [ [ clear ] swap interactor-call ] } + } % +] { } make define-commands* diff --git a/library/ui/tools/tools.factor b/library/ui/tools/tools.factor new file mode 100644 index 0000000000..6f769336af --- /dev/null +++ b/library/ui/tools/tools.factor @@ -0,0 +1,26 @@ +! Copyright (C) 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: gadgets-workspace +USING: gadgets gadgets-books gadgets-controls gadgets-workspace +generic kernel models scratchpad sequences syntax ; + +DEFER: workspace-window + +GENERIC: call-tool* ( arg tool -- ) + +TUPLE: workspace ; + +TUPLE: tool gadget ; + +: show-tool ( class workspace -- tool ) + [ book-pages [ tool-gadget class eq? ] find-with swap ] keep + control-model set-model* ; + +: select-tool ( workspace class -- ) swap show-tool drop ; + +: find-workspace ( -- workspace ) + [ workspace? ] find-window + [ world-gadget ] [ workspace-window find-workspace ] if* ; + +: call-tool ( arg class -- ) + find-workspace show-tool call-tool* ; diff --git a/library/ui/tools/walker.factor b/library/ui/tools/walker.factor index 689c4a96ea..09d28c6408 100644 --- a/library/ui/tools/walker.factor +++ b/library/ui/tools/walker.factor @@ -3,7 +3,7 @@ IN: gadgets-walker USING: arrays errors gadgets gadgets-buttons gadgets-frames gadgets-listener gadgets-panes gadgets-scrolling gadgets-text -gadgets-tracks generic hashtables tools +gadgets-tracks gadgets-workspace generic hashtables tools interpreter io kernel kernel-internals listener math models namespaces sequences shells threads vectors ; @@ -60,3 +60,35 @@ C: walker-gadget ( -- gadget ) { [ walker-gadget-model$ ] f f 1/4 } { [ walker-gadget-model$ ] f f 1/3 } } { 0 1 } make-track* ; + +M: walker-gadget call-tool* ( continuation walker -- ) + dup reset-walker [ + V{ } clone meta-history set + restore-normally + ] with-walker ; + +: walker-inspect ( walker -- ) + walker-gadget-ns [ meta-interp get ] bind + [ inspect ] curry listener-gadget call-tool ; + +: walker-step-all ( walker -- ) + dup [ step-all ] walker-command reset-walker + find-workspace listener-gadget select-tool ; + +walker-gadget { + { + "Walker" + { "Step" T{ key-down f f "s" } [ walker-step ] } + { "Step in" T{ key-down f f "i" } [ walker-step-in ] } + { "Step out" T{ key-down f f "o" } [ walker-step-out ] } + { "Step back" T{ key-down f f "b" } [ walker-step-back ] } + { "Continue" T{ key-down f f "c" } [ walker-step-all ] } + { "Inspect" T{ key-down f f "n" } [ walker-inspect ] } + } +} define-commands + +[ walker-gadget call-tool stop ] break-hook set-global + +IN: tools + +: walk ( quot -- ) [ break ] swap append call ; diff --git a/library/ui/tools/workspace.factor b/library/ui/tools/workspace.factor index c8dff75fac..09c655360f 100644 --- a/library/ui/tools/workspace.factor +++ b/library/ui/tools/workspace.factor @@ -1,18 +1,11 @@ ! Copyright (C) 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays compiler gadgets gadgets-listener gadgets-buttons -gadgets-walker gadgets-help gadgets-walker sequences -gadgets-browser gadgets-books gadgets-frames gadgets-controls -gadgets-grids gadgets-presentations kernel models namespaces -styles words help parser tools memory generic threads -gadgets-text gadgets-dataflow definitions inference test -prettyprint math strings hashtables tools modules interpreter -optimizer inference ; IN: gadgets-workspace - -GENERIC: call-tool* ( arg tool -- ) - -TUPLE: tool gadget ; +USING: arrays compiler gadgets gadgets-books gadgets-browser +gadgets-buttons gadgets-controls gadgets-dataflow gadgets-frames +gadgets-grids gadgets-help gadgets-listener +gadgets-presentations gadgets-walker gadgets-workspace generic +kernel math modules scratchpad sequences syntax words ; C: tool ( gadget -- tool ) { @@ -24,8 +17,6 @@ M: tool focusable-child* tool-gadget ; M: tool call-tool* tool-gadget call-tool* ; -TUPLE: workspace ; - : workspace-tabs { { "Listener" } @@ -58,23 +49,10 @@ M: workspace pref-dim* delegate pref-dim* { 550 650 } vmax ; [ init-tabs ] keep open-window ; -: show-tool ( class workspace -- tool ) - [ book-pages [ tool-gadget class eq? ] find-with swap ] keep - control-model set-model* ; - -: find-workspace ( -- workspace ) - [ workspace? ] find-window - [ world-gadget ] [ workspace-window find-workspace ] if* ; - -: call-tool ( arg class -- ) - find-workspace show-tool call-tool* ; - : commands-window ( workspace -- ) dup find-world world-focus [ ] [ gadget-child ] ?if [ commands. ] "Commands" pane-window ; -: select-tool ( workspace class -- ) swap show-tool drop ; - : tool-window ( class -- ) workspace-window show-tool drop ; workspace { @@ -101,298 +79,3 @@ workspace { { "Recompile changed words" T{ key-down f f "F8" } [ drop [ recompile ] listener-gadget call-tool ] } } } define-commands - -! Walker tool -IN: gadgets-walker - -M: walker-gadget call-tool* ( continuation walker -- ) - dup reset-walker [ - V{ } clone meta-history set - restore-normally - ] with-walker ; - -: walker-inspect ( walker -- ) - walker-gadget-ns [ meta-interp get ] bind - [ inspect ] curry listener-gadget call-tool ; - -: walker-step-all ( walker -- ) - dup [ step-all ] walker-command reset-walker - find-workspace listener-gadget select-tool ; - -walker-gadget { - { - "Walker" - { "Step" T{ key-down f f "s" } [ walker-step ] } - { "Step in" T{ key-down f f "i" } [ walker-step-in ] } - { "Step out" T{ key-down f f "o" } [ walker-step-out ] } - { "Step back" T{ key-down f f "b" } [ walker-step-back ] } - { "Continue" T{ key-down f f "c" } [ walker-step-all ] } - { "Inspect" T{ key-down f f "n" } [ walker-inspect ] } - } -} define-commands - -[ walker-gadget call-tool stop ] break-hook set-global - -! Dataflow tool -M: dataflow-gadget call-tool* ( node dataflow -- ) - dup dataflow-gadget-history add-history - dataflow-gadget-history set-model ; - -IN: tools - -: walk ( quot -- ) [ break ] swap append call ; - -: show-dataflow ( quot -- ) - dataflow optimize dataflow-gadget call-tool ; - -IN: gadgets-workspace - -! Listener tool -G: call-listener ( quot/string listener -- ) - 1 standard-combination ; - -M: quotation call-listener - listener-gadget-input interactor-call ; - -M: string call-listener - listener-gadget-input set-editor-text ; - -M: input call-listener - >r input-string r> call-listener ; - -M: listener-gadget call-tool* ( quot/string listener -- ) - call-listener ; - -: listener-run-files ( seq -- ) - dup empty? [ - drop - ] [ - [ [ run-file ] each ] curry listener-gadget call-tool - ] if ; - -! Browser tool -M: browser call-tool* - over vocab-link? [ - >r vocab-link-name r> show-vocab - ] [ - show-word - ] if ; - -! Help tool -M: help-gadget call-tool* show-help ; - -! Operations -V{ } clone operations set-global - -: define-operation ( class props -- ) - operations get push-new ; - -M: operation invoke-command ( target operation -- ) - dup command-quot swap operation-listener? - [ curry listener-gadget call-tool ] [ call ] if ; - -: modify-operation ( quot operation -- operation ) - clone - [ command-quot append ] keep - [ set-command-quot ] keep ; - -: modify-operations ( quot operations -- operations ) - [ modify-operation ] map-with ; - -: modify-listener-operation ( quot operation -- operation ) - clone t over set-operation-listener? - modify-operation ; - -: modify-listener-operations ( quot operations -- operations ) - [ modify-listener-operation ] map-with ; - -! Objects -[ drop t ] H{ - { +button+ 1 } - { +name+ "Inspect" } - { +quot+ [ inspect ] } - { +listener+ t } -} define-operation - -! Input -[ input? ] H{ - { +button+ 1 } - { +name+ "Input" } - { +quot+ [ listener-gadget call-tool ] } -} define-operation - -! Words -[ word? ] H{ - { +button+ 1 } - { +group+ "Words" } - { +name+ "Browse" } - { +gesture+ T{ key-down f { A+ } "b" } } - { +quot+ [ browser call-tool ] } -} define-operation - -[ word? ] H{ - { +button+ 2 } - { +group+ "Words" } - { +name+ "Edit" } - { +gesture+ T{ key-down f { A+ } "e" } } - { +quot+ [ edit ] } -} define-operation - -[ word? ] H{ - { +button+ 3 } - { +group+ "Words" } - { +name+ "Documentation" } - { +gesture+ T{ key-down f { A+ } "h" } } - { +quot+ [ help-gadget call-tool ] } -} define-operation - -[ word? ] H{ - { +group+ "Words" } - { +name+ "Usage" } - { +gesture+ T{ key-down f { A+ } "u" } } - { +quot+ [ usage. ] } - { +listener+ t } -} define-operation - -[ word? ] H{ - { +group+ "Words" } - { +name+ "Reload" } - { +gesture+ T{ key-down f { A+ } "r" } } - { +quot+ [ reload ] } - { +listener+ t } -} define-operation - -[ word? ] H{ - { +group+ "Words" } - { +name+ "Watch" } - { +quot+ [ watch ] } - { +listener+ t } -} define-operation - -! Vocabularies -[ vocab-link? ] H{ - { +button+ 1 } - { +name+ "Browse" } - { +quot+ [ browser call-tool ] } -} define-operation - -! Link -[ link? ] H{ - { +button+ 1 } - { +name+ "Follow" } - { +quot+ [ help-gadget call-tool ] } -} define-operation - -[ link? ] H{ - { +button+ 2 } - { +name+ "Edit" } - { +quot+ [ edit ] } -} define-operation - -[ word-link? ] H{ - { +button+ 3 } - { +name+ "Definition" } - { +quot+ [ link-name browser call-tool ] } -} define-operation - -! Strings -[ string? ] H{ - { +group+ "Words" } - { +name+ "Apropos (all)" } - { +gesture+ T{ key-down f { A+ } "a" } } - { +quot+ [ apropos ] } - { +listener+ t } -} define-operation - -: usable-words ( -- seq ) - [ - use get [ hash-values [ dup set ] each ] each - ] make-hash hash-values natural-sort ; - -[ string? ] H{ - { +group+ "Words" } - { +name+ "Apropos (used)" } - { +gesture+ T{ key-down f f "TAB" } } - { +quot+ [ usable-words (apropos) ] } - { +listener+ t } -} define-operation - -! Quotations -[ quotation? ] H{ - { +group+ "Quotations" } - { +name+ "Infer" } - { +gesture+ T{ key-down f { C+ A+ } "i" } } - { +quot+ [ infer . ] } - { +listener+ t } -} define-operation - -[ quotation? ] H{ - { +group+ "Quotations" } - { +name+ "Dataflow" } - { +gesture+ T{ key-down f { C+ A+ } "d" } } - { +quot+ [ show-dataflow ] } - { +listener+ t } -} define-operation - -[ quotation? ] H{ - { +group+ "Quotations" } - { +name+ "Walk" } - { +gesture+ T{ key-down f { C+ A+ } "w" } } - { +quot+ [ walk ] } - { +listener+ t } -} define-operation - -[ quotation? ] H{ - { +group+ "Quotations" } - { +name+ "Time" } - { +gesture+ T{ key-down f { C+ A+ } "t" } } - { +quot+ [ time ] } - { +listener+ t } -} define-operation - -! Dataflow nodes -[ node? ] H{ - { +group+ "Nodes" } - { +name+ "Display" } - { +quot+ [ dataflow-gadget call-tool ] } -} define-operation - -! Define commands in terms of operations - -! Tile commands -tile -[ tile-definition ] \ word class-operations modify-operations -[ command-name "Browse" = not ] subset -T{ command f f "Close" f [ close-tile ] } add* -define-commands* - -! Interactor commands -: selected-word ( editor -- string ) - dup gadget-selection? - [ dup T{ word-elt } select-elt ] unless - gadget-selection ; - -: word-action ( target -- quot ) - selected-word search ; - -: quot-action ( quot -- quot ) - field-commit parse ; - -interactor [ - { - "Listener" - { "Evaluate" T{ key-down f f "RETURN" } [ interactor-commit ] } - { "Send EOF" T{ key-down f { C+ } "d" } [ f swap interactor-eval ] } - } % - - [ word-action ] \ word class-operations modify-listener-operations % - [ selected-word ] string class-operations modify-listener-operations % - [ quot-action ] quotation class-operations modify-listener-operations % - - { - "Listener" - { "History" T{ key-down f { C+ } "h" } [ [ interactor-history. ] swap interactor-call ] } - { "Clear output" T{ key-down f f "CLEAR" } [ [ clear-output ] swap interactor-call ] } - { "Clear stack" T{ key-down f { C+ } "CLEAR" } [ [ clear ] swap interactor-call ] } - } % -] { } make define-commands*