UI dataflow visualizer (experiemntal)

TODO.FACTOR.txt

@@ -2,9 +2,6 @@
 
 - UI dataflow visualizer:
   - spacing is weird
-  - clickable child nodes
-  - workspace tool
-  - #declare needs an output
   - #label, #if mess up height
   - [ >r + dup r> ] foo  broken
   - why does + look funny?
@@ -33,7 +30,7 @@
   - write "foo| " and put caret at | then select word element: selects
     space
 - we have trouble drawing rectangles
-- browser: show currently selected vocab & words
+- ui browser: show currently selected vocab & words
 
 - doc sweep
 - tool help

contrib/README.txt

@@ -21,6 +21,8 @@ Available libraries:
 - emacs -- emacs integration (Eduardo Cavazos)
 - embedded -- simple template processor (Alex Chapman)
 - factory -- X11 window manager (Eduardo Cavazos)
+- furnace -- Web framework (Slava Pestov)
+- furnace-pastebin -- demo app for Furnace (Slava Pestov)
 - gap-buffer -- Efficient text editor buffer (Alex Chapman)
 - hexdump -- Hexdump routine (Doug Coleman)
 - http -- Code shared by HTTP server and client (Slava Pestov)

library/compiler/inference/known-words.factor

@@ -7,7 +7,9 @@ sequences strings vectors words prettyprint ;
 \ declare [
     pop-literal nip
     dup length ensure-values
-    dup #declare [ >r length d-tail r> set-node-in-d ] keep
+    dup length d-tail
+    swap #declare
+    [ 2dup set-node-in-d set-node-out-d ] keep
     node,
 ] "infer" set-word-prop
 \ declare { object } { } <effect> "infer-effect" set-word-prop

library/compiler/load.factor

@@ -14,7 +14,6 @@ PROVIDE: library/compiler {
     "optimizer/optimizer.factor"
     "optimizer/inline-methods.factor"
     "optimizer/call-optimizers.factor"
-    "optimizer/print-dataflow.factor"
 
     "generator/architecture.factor"
     "generator/templates.factor"

library/ui/load.factor

@@ -41,6 +41,7 @@ PROVIDE: library/ui {
     "tools/search.factor"
     "tools/browser.factor"
     "tools/help.factor"
+    "tools/dataflow.factor"
     "tools/workspace.factor"
 } {
     "test/models.factor"

library/ui/tools/dataflow.factor

@@ -0,0 +1,192 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: gadgets-dataflow
+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 ;
+
+: shuffle-in dup shuffle-in-d swap shuffle-in-r append ;
+
+: shuffle-out dup shuffle-out-d swap shuffle-out-r append ;
+
+TUPLE: shuffle-gadget value ;
+
+: literal-theme ( shuffle -- )
+    T{ solid f { 0.6 0.6 0.6 1.0 } } swap set-gadget-boundary ;
+
+: word-theme ( shuffle -- )
+    T{ solid f { 1.0 0.6 0.6 1.0 } } swap set-gadget-boundary ;
+
+C: shuffle-gadget ( node -- gadget )
+    [ set-shuffle-gadget-value ] keep
+    dup delegate>gadget ;
+
+: shuffled-offsets ( shuffle -- seq )
+    dup shuffle-in swap shuffle-out [ swap index ] map-with ;
+
+: shuffled-endpoints ( w seq seq -- seq )
+    [ [ 30 * 15 + ] 2apply >r dupd 2array 0 r> 2array 2array ]
+    2map nip ;
+
+: draw-shuffle ( gadget seq seq -- )
+    >r >r rect-dim first r> r> shuffled-endpoints
+    [ first2 gl-line ] each ;
+
+M: shuffle-gadget draw-gadget*
+    { 0 0 0 1 } gl-color
+    dup shuffle-gadget-value
+    shuffled-offsets [ length ] keep
+    draw-shuffle ;
+
+: shuffle-dim ( shuffle -- node )
+    dup shuffle-in length swap shuffle-out length max
+    30 * 10 swap 2array ;
+
+M: shuffle-gadget pref-dim*
+    dup delegate pref-dim
+    swap shuffle-gadget-value shuffle-dim
+    vmax ;
+
+TUPLE: height-gadget value skew ;
+
+C: height-gadget ( value skew -- gadget )
+    [ set-height-gadget-skew ] keep
+    [ set-height-gadget-value ] keep
+    dup delegate>gadget ;
+
+M: height-gadget pref-dim*
+    dup height-gadget-value swap height-gadget-skew abs +
+    30 * 10 swap 2array ;
+
+: height-offsets ( value skew -- seq seq )
+    [ abs swap [ [ + ] map-with ] keep ] keep
+    0 < [ swap ] when ;
+
+M: height-gadget draw-gadget*
+    { 0 0 0 1 } gl-color
+    dup height-gadget-value over height-gadget-skew
+    height-offsets draw-shuffle ;
+
+TUPLE: node-gadget value ;
+
+C: node-gadget ( gadget node -- gadget )
+    [ set-node-gadget-value ] keep
+    swap <default-border> over set-gadget-delegate ;
+
+M: node-gadget pref-dim*
+    dup delegate pref-dim
+    swap node-gadget-value node-shuffle shuffle-dim
+    vmax ;
+
+GENERIC: node>gadget ( node -- gadget )
+
+M: #call node>gadget
+    [ node-param word-name <label> ] keep
+    [ <node-gadget> ] keep node-param <object-presentation>
+    dup word-theme ;
+
+M: #push node>gadget
+    [
+        >#push< [ literalize unparse ] map " " join <label>
+    ] keep <node-gadget> dup literal-theme ;
+
+M: #shuffle node>gadget node-shuffle <shuffle-gadget> ;
+
+DEFER: dataflow.
+
+: <child-nodes> ( seq -- seq )
+    [ length ] keep
+    [
+        >r number>string "Child " swap append <label> r>
+        <object-presentation>
+    ] 2map ;
+
+M: object node>gadget
+    [
+        dup class word-name <label> ,
+        dup node-children <child-nodes> %
+    ] { } make make-pile
+    { 5 5 } over set-pack-gap
+    swap <node-gadget> dup faint-boundary ;
+
+: 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
+    [ first3 >r >r swap - r> r> 3array ] map-with ;
+
+: normalize-r-height ( seq -- seq )
+    [ [ second ] 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
+    normalize-d-height normalize-r-height ;
+
+: node-r-skew-1 ( node -- n )
+    dup node-out-d# over node-in-r# [-] swap node-in-d# [-] ;
+
+: node-r-skew-2 ( node -- n )
+    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 <height-gadget> ,
+            2dup node-in-r# + over node-r-skew <height-gadget> ,
+        ] { } make make-pile ,
+        [
+            rot 0 <height-gadget> ,
+            node>gadget ,
+            0 <height-gadget> ,
+        ] { } make make-pile 1 over set-pack-fill ,
+    ] keep prev-node set ;
+
+: <dataflow-graph> ( node -- gadget )
+    prev-node off
+    compute-heights
+    [ [ first3 print-node ] each ] { } make
+    make-shelf ;
+
+TUPLE: dataflow-gadget history search ;
+
+dataflow-gadget {
+    {
+        "Dataflow"
+        { "Back" T{ key-down f { C+ } "b" } [ dataflow-gadget-history go-back ] }
+        { "Forward" T{ key-down f { C+ } "f" } [ dataflow-gadget-history go-forward ] }
+    }
+} define-commands
+
+: <dataflow-pane> ( history -- gadget )
+    gadget get dataflow-gadget-history
+    [ <dataflow-graph> gadget. ]
+    <pane-control> ;
+
+C: dataflow-gadget ( -- gadget )
+    f <history> over set-dataflow-gadget-history {
+        { [ <dataflow-pane> ] f [ <scroller> ] @center }
+    } make-frame* ;

library/ui/tools/workspace.factor

@@ -5,8 +5,9 @@ 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 definitions inference test prettyprint math strings
-hashtables tools modules interpreter ;
+gadgets-text gadgets-dataflow definitions inference test
+prettyprint math strings hashtables tools modules interpreter
+optimizer inference ;
 IN: gadgets-workspace
 
 GENERIC: call-tool* ( arg tool -- )
@@ -31,6 +32,7 @@ TUPLE: workspace ;
         { "Definitions" <browser> } 
         { "Documentation" <help-gadget> }
         { "Walker" <walker-gadget> }
+        { "Dataflow" <dataflow-gadget> }
     } ;
 
 C: workspace ( -- workspace )
@@ -83,6 +85,7 @@ workspace {
         { "Definitions" T{ key-down f f "F3" } [ browser select-tool ] }
         { "Documentation" T{ key-down f f "F4" } [ help-gadget select-tool ] }
         { "Walker" T{ key-down f f "F5" } [ walker-gadget select-tool ] }
+        { "Dataflow" T{ key-down f f "F6" } [ walker-gadget select-tool ] }
     }
 
     {
@@ -94,8 +97,8 @@ workspace {
     
     {
         "Workflow"
-        { "Recompile changed words" T{ key-down f f "F6" } [ drop [ recompile ] listener-gadget call-tool ] }
         { "Reload changed sources" T{ key-down f f "F7" } [ drop [ reload-modules ] listener-gadget call-tool ] }
+        { "Recompile changed words" T{ key-down f f "F8" } [ drop [ recompile ] listener-gadget call-tool ] }
     }
 } define-commands
 
@@ -130,10 +133,18 @@ walker-gadget {
 
 [ 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
@@ -315,6 +326,14 @@ M: operation invoke-command ( target operation -- )
     { +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" }
@@ -331,6 +350,13 @@ M: operation invoke-command ( target operation -- )
     { +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