extra/graphviz/graphviz-tests.factor

   1 USING: accessors arrays assocs combinators.short-circuit
   2 continuations formatting graphviz graphviz.attributes
   3 graphviz.dot graphviz.notation graphviz.render
   4 graphviz.render.private images.loader.private io.directories
   5 io.directories.hierarchy io.files io.files.unique io.launcher
   6 io.pathnames kernel locals make math math.combinatorics
   7 math.parser memoize namespaces sequences sequences.extras sets
   8 splitting system tools.test ;
   9 IN: graphviz.tests
  10
  11 ! XXX hack
  12 : force-error-message ( flag -- elts )
  13     [
  14         [ default-graphviz-program , , "?" , ] { } make
  15         try-output-process
  16         ! To balance the stack height, have to return a default
  17         ! 'elts' value, though it shouldn't ever get pushed:
  18         f
  19     ] [
  20         nip output>>
  21         "Use one of: " split1 nip "\n" ?tail drop
  22         " " split
  23     ] recover ;
  24
  25 ! http://www.graphviz.org/Download_macos.php#comment-474
  26 : remove-sfdp-in-case-homebrew-is-dumb ( seq -- seq' )
  27     os macosx? [ "sfdp" swap remove ] when ;
  28
  29 SYMBOLS: supported-layouts supported-formats ;
  30
  31 : init-supported-layouts/formats ( -- )
  32     "-K" force-error-message standard-layouts intersect
  33     remove-sfdp-in-case-homebrew-is-dumb
  34     supported-layouts set-global
  35
  36     "-T" force-error-message standard-formats intersect
  37     supported-formats set-global ;
  38
  39 ! Can't predict file extension since we use Graphviz's actual
  40 ! -O flag, so just look to see that there seems to be some sort
  41 ! of output.
  42 : graphviz-output-appears-to-exist? ( base -- ? )
  43     current-directory get directory-files
  44     [ swap head? ] with count 1 = ;
  45
  46 : next! ( seq -- elt ) [ first ] [ 1 rotate! ] bi ;
  47
  48 :: smoke-test ( graph -- pass? )
  49     supported-formats get-global next! :> -T
  50     supported-layouts get-global next! :> -K
  51     [
  52         graph "smoke-test" -T -K graphviz
  53         "smoke-test" graphviz-output-appears-to-exist?
  54     ] cleanup-unique-working-directory ;
  55
  56 : preview-smoke-test ( graph -- pass? )
  57     f "pass?" [
  58         [ exists? "pass?" set ] with-preview
  59         "pass?" get
  60     ] with-variable ;
  61
  62 : K_n ( n -- graph )
  63     <graph>
  64     [node "point" =shape ];
  65     [graph "t" =labelloc "circo" =layout ];
  66     over number>string "K " prepend =label
  67     swap iota 2 [ first2 add-edge ] each-combination ;
  68
  69 :: partite-set ( n color -- cluster )
  70     color <cluster>
  71         color =color
  72         [node color =color ];
  73         n iota [
  74             number>string color prepend add-node
  75         ] each ;
  76
  77 :: K_n,m ( n m -- graph )
  78     <graph>
  79     [node "point" =shape ];
  80     [graph "t" =labelloc "dot" =layout "LR" =rankdir ];
  81     n "#FF0000" partite-set
  82     m "#0000FF" partite-set
  83     add-edge
  84     n m "K %d,%d" sprintf =label ;
  85
  86 : add-cycle ( graph n -- graph' )
  87     [ iota add-path ] [ 1 - 0 add-edge ] bi ;
  88
  89 : C_n ( n -- graph )
  90     <graph>
  91     [graph "t" =labelloc "circo" =layout ];
  92     [node "point" =shape ];
  93     over number>string "C " prepend =label
  94     swap add-cycle ;
  95
  96 : W_n ( n -- graph )
  97     <graph>
  98     [graph "t" =labelloc "twopi" =layout ];
  99     [node "point" =shape ];
 100     over number>string "W " prepend =label
 101     over add-node
 102     over 1 - add-cycle
 103     swap [ ] [ 1 - iota >array ] bi add-edge ;
 104
 105 : cluster-example ( -- graph )
 106     <digraph>
 107         "dot" =layout
 108         0 <cluster>
 109             "filled" =style
 110             "lightgrey" =color
 111             [node "filled" =style "white" =color ];
 112             { "a0" "a1" "a2" "a3" } ~->
 113             "process #1" =label
 114         add
 115         1 <cluster>
 116             [node "filled" =style ];
 117             { "b0" "b1" "b2" "b3" } ~->
 118             "process #2" =label
 119             "blue" =color
 120         add
 121         "start" "a0" ->
 122         "start" "b0" ->
 123         "a1" "b3" ->
 124         "b2" "a3" ->
 125         "a3" "a0" ->
 126         "a3" "end" ->
 127         "b3" "end" ->
 128         "start" [add-node "Mdiamond" =shape ];
 129         "end" [add-node "Msquare" =shape ];
 130     ;
 131
 132 : colored-circle ( i -- node )
 133     [ <node> ] keep
 134     [ 16.0 / 0.5 + =width ]
 135     [ 16.0 / 0.5 + =height ]
 136     [ 16 * "#%2x0000" sprintf =fillcolor ] tri ;
 137
 138 : colored-circles-example ( -- graph )
 139     <graph>
 140     [graph "3,3" =size "circo" =layout ];
 141     [node "filled" =style
 142           "circle" =shape
 143           "true"   =fixedsize
 144           ""       =label ];
 145     [edge "invis" =style ];
 146     0 [add-node "invis" =style "none" =shape ];
 147     16 iota [
 148         [ 0 -- ] [ colored-circle add ] bi
 149     ] each ;
 150
 151 : dfa-example ( -- graph )
 152     <digraph>
 153         "LR" =rankdir
 154         "8,5" =size
 155         [node "doublecircle" =shape ];
 156         { "LR_0" "LR_3" "LR_4" "LR_8" } add-nodes
 157         [node "circle" =shape ];
 158         "LR_0" "LR_2" [-> "SS(B)" =label ];
 159         "LR_0" "LR_1" [-> "SS(S)" =label ];
 160         "LR_1" "LR_3" [-> "S($end)" =label ];
 161         "LR_2" "LR_6" [-> "SS(b)" =label ];
 162         "LR_2" "LR_5" [-> "SS(a)" =label ];
 163         "LR_2" "LR_4" [-> "S(A)" =label ];
 164         "LR_5" "LR_7" [-> "S(b)" =label ];
 165         "LR_5" "LR_5" [-> "S(a)" =label ];
 166         "LR_6" "LR_6" [-> "S(b)" =label ];
 167         "LR_6" "LR_5" [-> "S(a)" =label ];
 168         "LR_7" "LR_8" [-> "S(b)" =label ];
 169         "LR_7" "LR_5" [-> "S(a)" =label ];
 170         "LR_8" "LR_6" [-> "S(b)" =label ];
 171         "LR_8" "LR_5" [-> "S(a)" =label ];
 172     ;
 173
 174 : record-example ( -- graph )
 175     <digraph>
 176         [graph "LR" =rankdir "8,8" =size ];
 177         [node 8 =fontsize "record" =shape ];
 178
 179         "node0" [add-node
 180             "<f0> 0x10ba8| <f1>" =label
 181         ];
 182         "node1" [add-node
 183             "<f0> 0xf7fc4380| <f1> | <f2> |-1" =label
 184         ];
 185         "node2" [add-node
 186             "<f0> 0xf7fc44b8| | |2" =label
 187         ];
 188         "node3" [add-node
 189             "<f0> 3.43322790286038071e-06|44.79998779296875|0" =label
 190         ];
 191         "node4" [add-node
 192             "<f0> 0xf7fc4380| <f1> | <f2> |2" =label
 193         ];
 194         "node5" [add-node
 195             "<f0> (nil)| | |-1" =label
 196         ];
 197         "node6" [add-node
 198             "<f0> 0xf7fc4380| <f1> | <f2> |1" =label
 199         ];
 200         "node7" [add-node
 201             "<f0> 0xf7fc4380| <f1> | <f2> |2" =label
 202         ];
 203         "node8" [add-node
 204             "<f0> (nil)| | |-1" =label
 205         ];
 206         "node9" [add-node
 207             "<f0> (nil)| | |-1" =label
 208         ];
 209         "node10" [add-node
 210             "<f0> (nil)| <f1> | <f2> |-1" =label
 211         ];
 212         "node11" [add-node
 213             "<f0> (nil)| <f1> | <f2> |-1" =label
 214         ];
 215         "node12" [add-node
 216             "<f0> 0xf7fc43e0| | |1" =label
 217         ];
 218
 219         "node0" "node1"   [-> "f0" =tailport "f0" =headport ];
 220         "node0" "node2"   [-> "f1" =tailport "f0" =headport ];
 221         "node1" "node3"   [-> "f0" =tailport "f0" =headport ];
 222         "node1" "node4"   [-> "f1" =tailport "f0" =headport ];
 223         "node1" "node5"   [-> "f2" =tailport "f0" =headport ];
 224         "node4" "node3"   [-> "f0" =tailport "f0" =headport ];
 225         "node4" "node6"   [-> "f1" =tailport "f0" =headport ];
 226         "node4" "node10"  [-> "f2" =tailport "f0" =headport ];
 227         "node6" "node3"   [-> "f0" =tailport "f0" =headport ];
 228         "node6" "node7"   [-> "f1" =tailport "f0" =headport ];
 229         "node6" "node9"   [-> "f2" =tailport "f0" =headport ];
 230         "node7" "node3"   [-> "f0" =tailport "f0" =headport ];
 231         "node7" "node1"   [-> "f1" =tailport "f0" =headport ];
 232         "node7" "node8"   [-> "f2" =tailport "f0" =headport ];
 233         "node10" "node11" [-> "f1" =tailport "f0" =headport ];
 234         "node10" "node12" [-> "f2" =tailport "f0" =headport ];
 235         "node11" "node1"  [-> "f2" =tailport "f0" =headport ];
 236     ;
 237
 238 :: with-global-value ( value variable quot -- )
 239     variable get-global "orig" [
 240         [ value variable set-global quot call ]
 241         [ "orig" get variable set-global ] [ ] cleanup
 242     ] with-variable ; inline
 243
 244 : preview-format-test ( format -- pass? )
 245     preview-format [
 246         <graph> preview-smoke-test
 247     ] with-global-value ;
 248
 249 : valid-preview-formats ( -- formats )
 250     types get keys "jpe" suffix
 251     supported-formats get-global intersect ;
 252
 253 : encoding-test ( encoding -- pass? )
 254     graph-encoding [ <graph> smoke-test ] with-global-value ;
 255
 256 default-graphviz-program [
 257
 258     init-supported-layouts/formats
 259
 260     { t } [ 5 K_n smoke-test ] unit-test
 261     { t } [ 6 K_n smoke-test ] unit-test
 262     { t } [ 7 K_n smoke-test ] unit-test
 263     { t } [ 8 K_n preview-smoke-test ] unit-test
 264
 265     { t } [ 8 6 K_n,m smoke-test ] unit-test
 266     { t } [ 7 5 K_n,m smoke-test ] unit-test
 267     { t } [ 3 9 K_n,m smoke-test ] unit-test
 268     { t } [ 3 4 K_n,m preview-smoke-test ] unit-test
 269
 270     { t } [ 5 C_n smoke-test ] unit-test
 271     { t } [ 6 C_n smoke-test ] unit-test
 272     { t } [ 7 C_n smoke-test ] unit-test
 273     { t } [ 8 C_n preview-smoke-test ] unit-test
 274
 275     { t } [ 5 W_n smoke-test ] unit-test
 276     { t } [ 6 W_n smoke-test ] unit-test
 277     { t } [ 7 W_n smoke-test ] unit-test
 278     { t } [ 8 W_n preview-smoke-test ] unit-test
 279
 280     { t } [ cluster-example smoke-test ] unit-test
 281     { t } [ cluster-example preview-smoke-test ] unit-test
 282
 283     { t } [ colored-circles-example smoke-test ] unit-test
 284     { t } [ colored-circles-example preview-smoke-test ] unit-test
 285
 286     { t } [ dfa-example smoke-test ] unit-test
 287     { t } [ dfa-example preview-smoke-test ] unit-test
 288
 289     { t } [ record-example smoke-test ] unit-test
 290     { t } [ record-example preview-smoke-test ] unit-test
 291
 292     { t } [
 293         valid-preview-formats [ preview-format-test ] all?
 294     ] unit-test
 295
 296     [
 297         supported-formats get-global valid-preview-formats diff
 298         [ preview-format-test ] attempt-all
 299     ] [ unsupported-preview-format? ] must-fail-with
 300
 301     { t }
 302     [
 303         USE: io.encodings.8-bit.latin1
 304         latin1 encoding-test
 305     ] unit-test
 306
 307     { t }
 308     [
 309         USE: io.encodings.utf8
 310         utf8 encoding-test
 311     ] unit-test
 312
 313     [
 314         USE: io.encodings.ascii
 315         ascii encoding-test
 316     ] [ unsupported-encoding? ] must-fail-with
 317
 318 ] when