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