1 USING: accessors arrays assocs continuations formatting graphviz
2 graphviz.notation graphviz.render graphviz.render.private
3 images.loader.private io.directories io.encodings.8-bit.latin1
4 io.encodings.ascii io.encodings.utf8 io.files io.launcher kernel
5 locals make math math.combinatorics math.parser namespaces
6 sequences sequences.extras sets splitting system tools.test ;
10 : force-error-message ( flag -- elts )
12 [ default-graphviz-program , , "?" , ] { } make
14 ! To balance the stack height, have to return a default
15 ! 'elts' value, though it shouldn't ever get pushed:
19 "Use one of: " split1 nip "\n" ?tail drop
23 ! http://www.graphviz.org/Download_macos.php#comment-474
24 : remove-sfdp-in-case-homebrew-is-dumb ( seq -- seq' )
25 os macosx? [ "sfdp" swap remove ] when ;
27 SYMBOLS: supported-layouts supported-formats ;
29 : init-supported-layouts/formats ( -- )
30 "-K" force-error-message standard-layouts intersect
31 remove-sfdp-in-case-homebrew-is-dumb
32 supported-layouts set-global
34 "-T" force-error-message standard-formats intersect
35 supported-formats set-global ;
37 ! Can't predict file extension since we use Graphviz's actual
38 ! -O flag, so just look to see that there seems to be some sort
40 : graphviz-output-appears-to-exist? ( base -- ? )
41 "." directory-files [ swap head? ] with count 1 = ;
43 : next! ( seq -- elt ) [ first ] [ 1 rotate! ] bi ;
45 :: smoke-test ( graph -- pass? )
46 supported-formats get-global next! :> -T
47 supported-layouts get-global next! :> -K
49 graph "smoke-test" -T -K graphviz
50 "smoke-test" graphviz-output-appears-to-exist?
51 ] with-test-directory ;
53 : preview-smoke-test ( graph -- pass? )
54 [ exists? ] with-preview ;
58 [node "point" =shape ];
59 [graph "t" =labelloc "circo" =layout ];
60 over number>string "K " prepend =label
61 swap iota 2 [ first2 add-edge ] each-combination ;
63 :: partite-set ( n color -- cluster )
68 number>string color prepend add-node
71 :: K_n,m ( n m -- graph )
73 [node "point" =shape ];
74 [graph "t" =labelloc "dot" =layout "LR" =rankdir ];
75 n "#FF0000" partite-set
76 m "#0000FF" partite-set
78 n m "K %d,%d" sprintf =label ;
80 : add-cycle ( graph n -- graph' )
81 [ iota add-path ] [ 1 - 0 add-edge ] bi ;
85 [graph "t" =labelloc "circo" =layout ];
86 [node "point" =shape ];
87 over number>string "C " prepend =label
92 [graph "t" =labelloc "twopi" =layout ];
93 [node "point" =shape ];
94 over number>string "W " prepend =label
97 swap [ ] [ 1 - iota >array ] bi add-edge ;
99 : cluster-example ( -- graph )
105 [node "filled" =style "white" =color ];
106 { "a0" "a1" "a2" "a3" } ~->
110 [node "filled" =style ];
111 { "b0" "b1" "b2" "b3" } ~->
122 "start" [add-node "Mdiamond" =shape ];
123 "end" [add-node "Msquare" =shape ];
126 : colored-circle ( i -- node )
128 [ 16.0 / 0.5 + =width ]
129 [ 16.0 / 0.5 + =height ]
130 [ 16 * "#%2x0000" sprintf =fillcolor ] tri ;
132 : colored-circles-example ( -- graph )
134 [graph "3,3" =size "circo" =layout ];
135 [node "filled" =style
139 [edge "invis" =style ];
140 0 [add-node "invis" =style "none" =shape ];
142 [ 0 -- ] [ colored-circle add ] bi
145 : dfa-example ( -- graph )
149 [node "doublecircle" =shape ];
150 { "LR_0" "LR_3" "LR_4" "LR_8" } add-nodes
151 [node "circle" =shape ];
152 "LR_0" "LR_2" [-> "SS(B)" =label ];
153 "LR_0" "LR_1" [-> "SS(S)" =label ];
154 "LR_1" "LR_3" [-> "S($end)" =label ];
155 "LR_2" "LR_6" [-> "SS(b)" =label ];
156 "LR_2" "LR_5" [-> "SS(a)" =label ];
157 "LR_2" "LR_4" [-> "S(A)" =label ];
158 "LR_5" "LR_7" [-> "S(b)" =label ];
159 "LR_5" "LR_5" [-> "S(a)" =label ];
160 "LR_6" "LR_6" [-> "S(b)" =label ];
161 "LR_6" "LR_5" [-> "S(a)" =label ];
162 "LR_7" "LR_8" [-> "S(b)" =label ];
163 "LR_7" "LR_5" [-> "S(a)" =label ];
164 "LR_8" "LR_6" [-> "S(b)" =label ];
165 "LR_8" "LR_5" [-> "S(a)" =label ];
168 : record-example ( -- graph )
170 [graph "LR" =rankdir "8,8" =size ];
171 [node 8 =fontsize "record" =shape ];
174 "<f0> 0x10ba8| <f1>" =label
177 "<f0> 0xf7fc4380| <f1> | <f2> |-1" =label
180 "<f0> 0xf7fc44b8| | |2" =label
183 "<f0> 3.43322790286038071e-06|44.79998779296875|0" =label
186 "<f0> 0xf7fc4380| <f1> | <f2> |2" =label
189 "<f0> (nil)| | |-1" =label
192 "<f0> 0xf7fc4380| <f1> | <f2> |1" =label
195 "<f0> 0xf7fc4380| <f1> | <f2> |2" =label
198 "<f0> (nil)| | |-1" =label
201 "<f0> (nil)| | |-1" =label
204 "<f0> (nil)| <f1> | <f2> |-1" =label
207 "<f0> (nil)| <f1> | <f2> |-1" =label
210 "<f0> 0xf7fc43e0| | |1" =label
213 "node0" "node1" [-> "f0" =tailport "f0" =headport ];
214 "node0" "node2" [-> "f1" =tailport "f0" =headport ];
215 "node1" "node3" [-> "f0" =tailport "f0" =headport ];
216 "node1" "node4" [-> "f1" =tailport "f0" =headport ];
217 "node1" "node5" [-> "f2" =tailport "f0" =headport ];
218 "node4" "node3" [-> "f0" =tailport "f0" =headport ];
219 "node4" "node6" [-> "f1" =tailport "f0" =headport ];
220 "node4" "node10" [-> "f2" =tailport "f0" =headport ];
221 "node6" "node3" [-> "f0" =tailport "f0" =headport ];
222 "node6" "node7" [-> "f1" =tailport "f0" =headport ];
223 "node6" "node9" [-> "f2" =tailport "f0" =headport ];
224 "node7" "node3" [-> "f0" =tailport "f0" =headport ];
225 "node7" "node1" [-> "f1" =tailport "f0" =headport ];
226 "node7" "node8" [-> "f2" =tailport "f0" =headport ];
227 "node10" "node11" [-> "f1" =tailport "f0" =headport ];
228 "node10" "node12" [-> "f2" =tailport "f0" =headport ];
229 "node11" "node1" [-> "f2" =tailport "f0" =headport ];
232 :: with-global-value ( value variable quot -- )
233 variable get-global "orig" [
234 [ value variable set-global quot call ]
235 [ "orig" get variable set-global ] [ ] cleanup
236 ] with-variable ; inline
238 : preview-format-test ( format -- pass? )
240 <graph> preview-smoke-test
241 ] with-global-value ;
243 : valid-preview-formats ( -- formats )
244 types get keys "jpe" suffix
245 supported-formats get-global intersect ;
247 : encoding-test ( encoding -- pass? )
248 graph-encoding [ <graph> smoke-test ] with-global-value ;
250 default-graphviz-program [
252 init-supported-layouts/formats
254 { t } [ 5 K_n smoke-test ] unit-test
255 { t } [ 6 K_n smoke-test ] unit-test
256 { t } [ 7 K_n smoke-test ] unit-test
257 { t } [ 8 K_n preview-smoke-test ] unit-test
259 { t } [ 8 6 K_n,m smoke-test ] unit-test
260 { t } [ 7 5 K_n,m smoke-test ] unit-test
261 { t } [ 3 9 K_n,m smoke-test ] unit-test
262 { t } [ 3 4 K_n,m preview-smoke-test ] unit-test
264 { t } [ 5 C_n smoke-test ] unit-test
265 { t } [ 6 C_n smoke-test ] unit-test
266 { t } [ 7 C_n smoke-test ] unit-test
267 { t } [ 8 C_n preview-smoke-test ] unit-test
269 { t } [ 5 W_n smoke-test ] unit-test
270 { t } [ 6 W_n smoke-test ] unit-test
271 { t } [ 7 W_n smoke-test ] unit-test
272 { t } [ 8 W_n preview-smoke-test ] unit-test
274 { t } [ cluster-example smoke-test ] unit-test
275 { t } [ cluster-example preview-smoke-test ] unit-test
277 { t } [ colored-circles-example smoke-test ] unit-test
278 { t } [ colored-circles-example preview-smoke-test ] unit-test
280 { t } [ dfa-example smoke-test ] unit-test
281 { t } [ dfa-example preview-smoke-test ] unit-test
283 { t } [ record-example smoke-test ] unit-test
284 { t } [ record-example preview-smoke-test ] unit-test
287 valid-preview-formats [ preview-format-test ] all?
291 supported-formats get-global valid-preview-formats diff
292 [ preview-format-test ] attempt-all
293 ] [ unsupported-preview-format? ] must-fail-with
295 { t } [ latin1 encoding-test ] unit-test
297 { t } [ utf8 encoding-test ] unit-test
299 [ ascii encoding-test ] [ unsupported-encoding? ] must-fail-with