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