USING: accessors arrays assocs continuations formatting graphviz
graphviz.notation graphviz.render graphviz.render.private
images.loader.private io.directories io.encodings.8-bit.latin1
io.encodings.ascii io.encodings.utf8 io.files io.launcher kernel
locals make math math.combinatorics math.parser namespaces
sequences sequences.extras sets splitting system tools.test ;
IN: graphviz.tests

! XXX hack
: force-error-message ( flag -- elts )
    [
        [ default-graphviz-program , , "?" , ] { } make
        try-output-process
        ! To balance the stack height, have to return a default
        ! 'elts' value, though it shouldn't ever get pushed:
        f
    ] [
        nip output>>
        "Use one of: " split1 nip "\n" ?tail drop
        " " split
    ] recover ;

! http://www.graphviz.org/Download_macos.php#comment-474
: remove-sfdp-in-case-homebrew-is-dumb ( seq -- seq' )
    os macosx? [ "sfdp" swap remove ] when ;

SYMBOLS: supported-layouts supported-formats ;

: init-supported-layouts/formats ( -- )
    "-K" force-error-message standard-layouts intersect
    remove-sfdp-in-case-homebrew-is-dumb
    supported-layouts set-global

    "-T" force-error-message standard-formats intersect
    supported-formats set-global ;

! Can't predict file extension since we use Graphviz's actual
! -O flag, so just look to see that there seems to be some sort
! of output.
: graphviz-output-appears-to-exist? ( base -- ? )
    "." directory-files [ swap head? ] with count 1 = ;

: next! ( seq -- elt ) [ first ] [ 1 rotate! ] bi ;

:: smoke-test ( graph -- pass? )
    supported-formats get-global next! :> -T
    supported-layouts get-global next! :> -K
    [
        graph "smoke-test" -T -K graphviz
        "smoke-test" graphviz-output-appears-to-exist?
    ] with-test-directory ;

: preview-smoke-test ( graph -- pass? )
    [ exists? ] with-preview ;

: K_n ( n -- graph )
    <graph>
    node[ "point" =shape ]
    graph[ "t" =labelloc "circo" =layout ]
    over number>string "K " prepend =label
    swap <iota> 2 [ first2 add-edge ] each-combination ;

:: partite-set ( n color -- cluster )
    color <cluster>
        color =color
        node[ color =color ]
        n <iota> [
            number>string color prepend add-node
        ] each ;

:: K_n,m ( n m -- graph )
    <graph>
    node[ "point" =shape ]
    graph[ "t" =labelloc "dot" =layout "LR" =rankdir ]
    n "#FF0000" partite-set
    m "#0000FF" partite-set
    add-edge
    n m "K %d,%d" sprintf =label ;

: add-cycle ( graph n -- graph' )
    [ <iota> add-path ] [ 1 - 0 add-edge ] bi ;

: C_n ( n -- graph )
    <graph>
    graph[ "t" =labelloc "circo" =layout ]
    node[ "point" =shape ]
    over number>string "C " prepend =label
    swap add-cycle ;

: W_n ( n -- graph )
    <graph>
    graph[ "t" =labelloc "twopi" =layout ]
    node[ "point" =shape ]
    over number>string "W " prepend =label
    over add-node
    over 1 - add-cycle
    swap [ ] [ 1 - <iota> >array ] bi add-edge ;

: cluster-example ( -- graph )
    <digraph>
        "dot" =layout
        0 <cluster>
            "filled" =style
            "lightgrey" =color
            node[ "filled" =style "white" =color ]
            { "a0" "a1" "a2" "a3" } ~->
            "process #1" =label
        add
        1 <cluster>
            node[ "filled" =style ]
            { "b0" "b1" "b2" "b3" } ~->
            "process #2" =label
            "blue" =color
        add
        "start" "a0" ->
        "start" "b0" ->
        "a1" "b3" ->
        "b2" "a3" ->
        "a3" "a0" ->
        "a3" "end" ->
        "b3" "end" ->
        "start" add-node[ "Mdiamond" =shape ]
        "end" add-node[ "Msquare" =shape ]
    ;

: colored-circle ( i -- node )
    [ <node> ] keep
    [ 16.0 / 0.5 + =width ]
    [ 16.0 / 0.5 + =height ]
    [ 16 * "#%2x0000" sprintf =fillcolor ] tri ;

: colored-circles-example ( -- graph )
    <graph>
    graph[ "3,3" =size "circo" =layout ]
    node[ "filled" =style
          "circle" =shape
          "true"   =fixedsize
          ""       =label ]
    edge[ "invis" =style ]
    0 add-node[ "invis" =style "none" =shape ]
    16 <iota> [
        [ 0 -- ] [ colored-circle add ] bi
    ] each ;

: dfa-example ( -- graph )
    <digraph>
        "LR" =rankdir
        "8,5" =size
        node[ "doublecircle" =shape ]
        { "LR_0" "LR_3" "LR_4" "LR_8" } add-nodes
        node[ "circle" =shape ]
        "LR_0" "LR_2" ->[ "SS(B)" =label ]
        "LR_0" "LR_1" ->[ "SS(S)" =label ]
        "LR_1" "LR_3" ->[ "S($end)" =label ]
        "LR_2" "LR_6" ->[ "SS(b)" =label ]
        "LR_2" "LR_5" ->[ "SS(a)" =label ]
        "LR_2" "LR_4" ->[ "S(A)" =label ]
        "LR_5" "LR_7" ->[ "S(b)" =label ]
        "LR_5" "LR_5" ->[ "S(a)" =label ]
        "LR_6" "LR_6" ->[ "S(b)" =label ]
        "LR_6" "LR_5" ->[ "S(a)" =label ]
        "LR_7" "LR_8" ->[ "S(b)" =label ]
        "LR_7" "LR_5" ->[ "S(a)" =label ]
        "LR_8" "LR_6" ->[ "S(b)" =label ]
        "LR_8" "LR_5" ->[ "S(a)" =label ]
    ;

: record-example ( -- graph )
    <digraph>
        graph[ "LR" =rankdir "8,8" =size ]
        node[ 8 =fontsize "record" =shape ]

        "node0" add-node[
            "<f0> 0x10ba8| <f1>" =label
        ]
        "node1" add-node[
            "<f0> 0xf7fc4380| <f1> | <f2> |-1" =label
        ]
        "node2" add-node[
            "<f0> 0xf7fc44b8| | |2" =label
        ]
        "node3" add-node[
            "<f0> 3.43322790286038071e-06|44.79998779296875|0" =label
        ]
        "node4" add-node[
            "<f0> 0xf7fc4380| <f1> | <f2> |2" =label
        ]
        "node5" add-node[
            "<f0> (nil)| | |-1" =label
        ]
        "node6" add-node[
            "<f0> 0xf7fc4380| <f1> | <f2> |1" =label
        ]
        "node7" add-node[
            "<f0> 0xf7fc4380| <f1> | <f2> |2" =label
        ]
        "node8" add-node[
            "<f0> (nil)| | |-1" =label
        ]
        "node9" add-node[
            "<f0> (nil)| | |-1" =label
        ]
        "node10" add-node[
            "<f0> (nil)| <f1> | <f2> |-1" =label
        ]
        "node11" add-node[
            "<f0> (nil)| <f1> | <f2> |-1" =label
        ]
        "node12" add-node[
            "<f0> 0xf7fc43e0| | |1" =label
        ]

        "node0" "node1"   ->[ "f0" =tailport "f0" =headport ]
        "node0" "node2"   ->[ "f1" =tailport "f0" =headport ]
        "node1" "node3"   ->[ "f0" =tailport "f0" =headport ]
        "node1" "node4"   ->[ "f1" =tailport "f0" =headport ]
        "node1" "node5"   ->[ "f2" =tailport "f0" =headport ]
        "node4" "node3"   ->[ "f0" =tailport "f0" =headport ]
        "node4" "node6"   ->[ "f1" =tailport "f0" =headport ]
        "node4" "node10"  ->[ "f2" =tailport "f0" =headport ]
        "node6" "node3"   ->[ "f0" =tailport "f0" =headport ]
        "node6" "node7"   ->[ "f1" =tailport "f0" =headport ]
        "node6" "node9"   ->[ "f2" =tailport "f0" =headport ]
        "node7" "node3"   ->[ "f0" =tailport "f0" =headport ]
        "node7" "node1"   ->[ "f1" =tailport "f0" =headport ]
        "node7" "node8"   ->[ "f2" =tailport "f0" =headport ]
        "node10" "node11" ->[ "f1" =tailport "f0" =headport ]
        "node10" "node12" ->[ "f2" =tailport "f0" =headport ]
        "node11" "node1"  ->[ "f2" =tailport "f0" =headport ]
    ;

:: with-global-value ( value variable quot -- )
    variable get-global "orig" [
        [ value variable set-global quot call ]
        [ "orig" get variable set-global ] [ ] cleanup
    ] with-variable ; inline

: preview-format-test ( format -- pass? )
    preview-format [
        <graph> preview-smoke-test
    ] with-global-value ;

: valid-preview-formats ( -- formats )
    types get keys "jpe" suffix
    supported-formats get-global intersect ;

: encoding-test ( encoding -- pass? )
    graph-encoding [ <graph> smoke-test ] with-global-value ;

default-graphviz-program [

    init-supported-layouts/formats

    { t } [ 5 K_n smoke-test ] unit-test
    { t } [ 6 K_n smoke-test ] unit-test
    { t } [ 7 K_n smoke-test ] unit-test
    { t } [ 8 K_n preview-smoke-test ] unit-test

    { t } [ 8 6 K_n,m smoke-test ] unit-test
    { t } [ 7 5 K_n,m smoke-test ] unit-test
    { t } [ 3 9 K_n,m smoke-test ] unit-test
    { t } [ 3 4 K_n,m preview-smoke-test ] unit-test

    { t } [ 5 C_n smoke-test ] unit-test
    { t } [ 6 C_n smoke-test ] unit-test
    { t } [ 7 C_n smoke-test ] unit-test
    { t } [ 8 C_n preview-smoke-test ] unit-test

    { t } [ 5 W_n smoke-test ] unit-test
    { t } [ 6 W_n smoke-test ] unit-test
    { t } [ 7 W_n smoke-test ] unit-test
    { t } [ 8 W_n preview-smoke-test ] unit-test

    { t } [ cluster-example smoke-test ] unit-test
    { t } [ cluster-example preview-smoke-test ] unit-test

    { t } [ colored-circles-example smoke-test ] unit-test
    { t } [ colored-circles-example preview-smoke-test ] unit-test

    { t } [ dfa-example smoke-test ] unit-test
    { t } [ dfa-example preview-smoke-test ] unit-test

    { t } [ record-example smoke-test ] unit-test
    { t } [ record-example preview-smoke-test ] unit-test

    { t } [
        valid-preview-formats [ preview-format-test ] all?
    ] unit-test

    [
        supported-formats get-global valid-preview-formats diff
        [ preview-format-test ] attempt-all
    ] [ unsupported-preview-format? ] must-fail-with

    { t } [ latin1 encoding-test ] unit-test

    { t } [ utf8 encoding-test ] unit-test

    [ ascii encoding-test ] [ unsupported-encoding? ] must-fail-with

] when