library/ui/tools/dataflow.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets-dataflow
   4 USING: namespaces arrays sequences io inference math kernel
   5 generic prettyprint words gadgets opengl gadgets-panes
   6 gadgets-labels gadgets-theme gadgets-presentations
   7 gadgets-buttons gadgets-borders gadgets-scrolling
   8 gadgets-frames gadgets-workspace optimizer models help ;
   9
  10 GENERIC: node>gadget* ( height node -- gadget )
  11
  12 GENERIC: node-presents ( node -- object )
  13
  14 ! Representation of shuffle nodes
  15 TUPLE: shuffle-gadget value ;
  16
  17 : literal-theme ( shuffle -- )
  18     T{ solid f { 0.6 0.6 0.6 1.0 } } swap set-gadget-boundary ;
  19
  20 : word-theme ( shuffle -- )
  21     T{ solid f { 1.0 0.6 0.6 1.0 } } swap set-gadget-boundary ;
  22
  23 C: shuffle-gadget ( node -- gadget )
  24     [ set-shuffle-gadget-value ] keep
  25     dup delegate>gadget ;
  26
  27 : shuffled-offsets ( shuffle -- seq )
  28     dup effect-in swap effect-out [ swap index ] map-with ;
  29
  30 : shuffled-endpoints ( w h seq seq -- seq )
  31     [ [ 30 * 15 + ] map ] 2apply
  32     >r over r> [ - ] map-with >r [ - ] map-with r>
  33     [ 0 swap 2array ] map >r [ 2array ] map-with r>
  34     [ 2array ] 2map ;
  35
  36 : draw-shuffle ( gadget seq seq -- )
  37     >r >r rect-dim first2 r> r> shuffled-endpoints
  38     [ first2 gl-line ] each ;
  39
  40 M: shuffle-gadget draw-gadget*
  41     { 0 0 0 1 } gl-color
  42     dup shuffle-gadget-value
  43     shuffled-offsets [ length ] keep
  44     draw-shuffle ;
  45
  46 : node-dim ( n -- dim ) 30 * 10 swap 2array ;
  47
  48 : shuffle-dim ( shuffle -- dim )
  49     dup effect-in length swap effect-out length max
  50     node-dim ;
  51
  52 M: shuffle-gadget pref-dim*
  53     shuffle-gadget-value shuffle-dim ;
  54
  55 M: #shuffle node>gadget* nip node-shuffle <shuffle-gadget> ;
  56
  57 M: #shuffle node-presents drop f ;
  58
  59 ! Stack height underneath a node
  60 TUPLE: height-gadget value ;
  61
  62 C: height-gadget ( value -- gadget )
  63     [ set-height-gadget-value ] keep
  64     dup delegate>gadget ;
  65
  66 M: height-gadget pref-dim*
  67     height-gadget-value node-dim ;
  68
  69 M: height-gadget draw-gadget*
  70     { 0 0 0 1 } gl-color
  71     dup height-gadget-value dup draw-shuffle ;
  72
  73 ! Calls and pushes
  74 TUPLE: node-gadget value height ;
  75
  76 C: node-gadget ( gadget node height -- gadget )
  77     [ set-node-gadget-height ] keep
  78     [ set-node-gadget-value ] keep
  79     swap <default-border> over set-gadget-delegate
  80     dup faint-boundary ;
  81
  82 M: node-gadget pref-dim*
  83     dup delegate pref-dim
  84     swap dup node-gadget-height [
  85         node-dim
  86     ] [
  87         node-gadget-value node-shuffle shuffle-dim
  88     ] ?if vmax ;
  89
  90 M: #call node>gadget*
  91     nip
  92     [ node-param word-name <label> ] keep
  93     f <node-gadget> dup word-theme ;
  94
  95 M: #call node-presents node-param ;
  96
  97 M: #push node>gadget*
  98     nip [
  99         >#push< [ literalize unparse ] map " " join <label>
 100     ] keep f <node-gadget> dup literal-theme ;
 101
 102 M: #push node-presents >#push< first ;
 103
 104 ! #if #dispatch #label etc
 105 : <child-nodes> ( seq -- seq )
 106     [ length ] keep
 107     [
 108         >r number>string "Child " swap append <label> r>
 109         <presentation>
 110     ] 2map ;
 111
 112 : <node-presentation> ( node -- gadget )
 113     class [ word-name <label> ] keep <link>
 114     <presentation> ;
 115
 116 : default-node-content ( node -- gadget )
 117     dup node-children <child-nodes>
 118     swap class word-name <label> add* make-pile
 119     { 5 5 } over set-pack-gap ;
 120
 121 M: object node>gadget*
 122     nip dup default-node-content swap f <node-gadget> ;
 123
 124 M: object node-presents
 125     class <link> ;
 126
 127 UNION: full-height-node #if #dispatch #label #merge #return
 128 #values #entry ;
 129
 130 M: full-height-node node>gadget*
 131     dup default-node-content swap rot <node-gadget> ;
 132
 133 ! Constructing the graphical representation; first we compute
 134 ! stack heights
 135 SYMBOL: d-height
 136
 137 DEFER: (compute-heights)
 138
 139 : compute-child-heights ( node -- )
 140     node-children dup empty? [
 141         drop
 142     ] [
 143         [
 144             [ (compute-heights) d-height get ] { } make drop
 145         ] map supremum d-height set
 146     ] if ;
 147
 148 : (compute-heights) ( node -- )
 149     [
 150         d-height get over 2array ,
 151         dup node-out-d length over node-in-d length -
 152         d-height [ + ] change
 153         dup compute-child-heights
 154         node-successor (compute-heights)
 155     ] when* ;
 156
 157 : normalize-height ( seq -- seq )
 158     [
 159         [ dup first swap second node-in-d length - ] map infimum
 160     ] keep
 161     [ first2 >r swap - r> 2array ] map-with ;
 162
 163 : compute-heights ( nodes -- pairs )
 164     [ 0 d-height set (compute-heights) ] { } make
 165     normalize-height ;
 166
 167 ! Then we create gadgets for every node
 168 : node>gadget ( height node -- gadget )
 169     [ node>gadget* ] keep node-presents
 170     [ <presentation> ] when* ;
 171
 172 : print-node ( d-height node -- )
 173     dup full-height-node? [
 174         node>gadget
 175     ] [
 176         [ node-in-d length - <height-gadget> ] 2keep
 177         node>gadget swap 2array
 178         make-pile 1 over set-pack-fill
 179     ] if , ;
 180
 181 : <dataflow-graph> ( node -- gadget )
 182     compute-heights [
 183         dup empty? [ dup first first <height-gadget> , ] unless
 184         [ first2 print-node ] each
 185     ] { } make
 186     make-shelf 1 over set-pack-align ;
 187
 188 ! The UI tool
 189 TUPLE: dataflow-gadget history ;
 190
 191 dataflow-gadget "toolbar" {
 192     { "Back" T{ key-down f { C+ } "b" } [ dataflow-gadget-history go-back ] }
 193     { "Forward" T{ key-down f { C+ } "f" } [ dataflow-gadget-history go-forward ] }
 194 } define-commands
 195
 196 : <dataflow-pane> ( history -- gadget )
 197     gadget get dataflow-gadget-history
 198     [ <dataflow-graph> gadget. ]
 199     <pane-control> ;
 200
 201 C: dataflow-gadget ( -- gadget )
 202     f <history> over set-dataflow-gadget-history {
 203         { [ <dataflow-pane> ] f [ <scroller> ] @center }
 204     } make-frame* ;
 205
 206 M: dataflow-gadget call-tool* ( node dataflow -- )
 207     dup dataflow-gadget-history add-history
 208     dataflow-gadget-history set-model ;
 209
 210 M: dataflow-gadget tool-help drop "ui-dataflow" ;
 211
 212 IN: tools
 213
 214 : show-dataflow ( quot -- )
 215     dataflow optimize dataflow-gadget call-tool ;