1 ! Copyright (C) 2006 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
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 ;
10 GENERIC: node>gadget* ( height node -- gadget )
12 GENERIC: node-presents ( node -- object )
14 ! Representation of shuffle nodes
15 TUPLE: shuffle-gadget value ;
17 : literal-theme ( shuffle -- )
18 T{ solid f { 0.6 0.6 0.6 1.0 } } swap set-gadget-boundary ;
20 : word-theme ( shuffle -- )
21 T{ solid f { 1.0 0.6 0.6 1.0 } } swap set-gadget-boundary ;
23 C: shuffle-gadget ( node -- gadget )
24 [ set-shuffle-gadget-value ] keep
27 : shuffled-offsets ( shuffle -- seq )
28 dup effect-in swap effect-out [ swap index ] map-with ;
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>
36 : draw-shuffle ( gadget seq seq -- )
37 >r >r rect-dim first2 r> r> shuffled-endpoints
38 [ first2 gl-line ] each ;
40 M: shuffle-gadget draw-gadget*
42 dup shuffle-gadget-value
43 shuffled-offsets [ length ] keep
46 : node-dim ( n -- dim ) 30 * 10 swap 2array ;
48 : shuffle-dim ( shuffle -- dim )
49 dup effect-in length swap effect-out length max
52 M: shuffle-gadget pref-dim*
53 shuffle-gadget-value shuffle-dim ;
55 M: #shuffle node>gadget* nip node-shuffle <shuffle-gadget> ;
57 M: #shuffle node-presents drop f ;
59 ! Stack height underneath a node
60 TUPLE: height-gadget value ;
62 C: height-gadget ( value -- gadget )
63 [ set-height-gadget-value ] keep
66 M: height-gadget pref-dim*
67 height-gadget-value node-dim ;
69 M: height-gadget draw-gadget*
71 dup height-gadget-value dup draw-shuffle ;
74 TUPLE: node-gadget value height ;
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
82 M: node-gadget pref-dim*
84 swap dup node-gadget-height [
87 node-gadget-value node-shuffle shuffle-dim
92 [ node-param word-name <label> ] keep
93 f <node-gadget> dup word-theme ;
95 M: #call node-presents node-param ;
99 >#push< [ literalize unparse ] map " " join <label>
100 ] keep f <node-gadget> dup literal-theme ;
102 M: #push node-presents >#push< first ;
104 ! #if #dispatch #label etc
105 : <child-nodes> ( seq -- seq )
108 >r number>string "Child " swap append <label> r>
109 <object-presentation>
112 : <node-presentation> ( node -- gadget )
113 class [ word-name <label> ] keep <link>
114 <object-presentation> ;
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 ;
121 M: object node>gadget*
122 nip dup default-node-content swap f <node-gadget> ;
124 M: object node-presents
127 UNION: full-height-node #if #dispatch #label #merge #return
130 M: full-height-node node>gadget*
131 dup default-node-content swap rot <node-gadget> ;
133 ! Constructing the graphical representation; first we compute
137 DEFER: (compute-heights)
139 : compute-child-heights ( node -- )
140 node-children dup empty? [
144 [ (compute-heights) d-height get ] { } make drop
145 ] map supremum d-height set
148 : (compute-heights) ( node -- )
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)
157 : normalize-height ( seq -- seq )
159 [ dup first swap second node-in-d length - ] map infimum
161 [ first2 >r swap - r> 2array ] map-with ;
163 : compute-heights ( nodes -- pairs )
164 [ 0 d-height set (compute-heights) ] { } make
167 ! Then we create gadgets for every node
168 : node>gadget ( height node -- gadget )
169 [ node>gadget* ] keep node-presents
170 [ <object-presentation> ] when* ;
172 : print-node ( d-height node -- )
173 dup full-height-node? [
176 [ node-in-d length - <height-gadget> ] 2keep
177 node>gadget swap 2array
178 make-pile 1 over set-pack-fill
181 : <dataflow-graph> ( node -- gadget )
183 dup empty? [ dup first first <height-gadget> , ] unless
184 [ first2 print-node ] each
186 make-shelf 1 over set-pack-align ;
189 TUPLE: dataflow-gadget history ;
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 ] }
196 : <dataflow-pane> ( history -- gadget )
197 gadget get dataflow-gadget-history
198 [ <dataflow-graph> gadget. ]
201 C: dataflow-gadget ( -- gadget )
202 f <history> over set-dataflow-gadget-history {
203 { [ <dataflow-pane> ] f [ <scroller> ] @center }
206 M: dataflow-gadget call-tool* ( node dataflow -- )
207 dup dataflow-gadget-history add-history
208 dataflow-gadget-history set-model ;
210 M: dataflow-gadget tool-help drop "ui-dataflow" ;
214 : show-dataflow ( quot -- )
215 dataflow optimize dataflow-gadget call-tool ;