extra/graphviz/dot/dot.factor

   1 ! Copyright (C) 2012 Alex Vondrak.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors classes classes.tuple combinators formatting graphviz
   4 graphviz.attributes io io.files kernel namespaces sequences splitting
   5 strings words ;
   6 IN: graphviz.dot
   7
   8 <PRIVATE
   9
  10 GENERIC: dot. ( obj -- )
  11
  12 ! Graphviz docs claim that there's no semantic difference
  13 ! between quoted & unquoted IDs, but quoting them is the safest
  14 ! option in case there's a keyword clash, spaces in the ID,
  15 ! etc.  This does mean that HTML labels aren't supported, but
  16 ! they don't seem to work using the Graphviz API anyway.
  17 !
  18 ! Special escaping logic is required here because of the \l escape
  19 ! sequence.
  20 : quote-string ( str -- str' )
  21     { { "\"" "\\\"" } { "\0" "" } } [ first2 replace ] each
  22     "\"" "\"" surround ;
  23
  24 M: string dot. quote-string "%s " printf ;
  25
  26 : id. ( obj -- ) id>> dot. ;
  27
  28 M: sequence dot.
  29     "{" print [ dot. ";" print ] each "}" print ;
  30
  31 : statements. ( sub/graph -- ) statements>> dot. ;
  32
  33 SYMBOL: edgeop
  34
  35 : with-edgeop ( graph quot -- )
  36     [
  37         dup directed?>> "-> " "-- " ? edgeop
  38     ] dip with-variable ; inline
  39
  40 : ?strict ( graph -- graph )
  41     dup strict?>> [ "strict " write ] when ;
  42
  43 : (di)graph ( graph -- graph )
  44     dup directed?>> "digraph " "graph " ? write ;
  45
  46 M: graph dot.
  47     ?strict (di)graph dup id. [ statements. ] with-edgeop ;
  48
  49 M: subgraph dot.
  50     "subgraph " write [ id. ] [ statements. ] bi ;
  51
  52 : attribute, ( attr value -- )
  53     [ quote-string "%s=%s," printf ] [ drop ] if* ;
  54
  55 : attributes. ( attrs -- )
  56     "[" write
  57     [ class-of "slots" word-prop ] [ tuple-slots ] bi
  58     [ [ name>> ] dip attribute, ] 2each
  59     "]" write ;
  60
  61 M: graph-attributes dot. "graph" write attributes. ;
  62 M: node-attributes dot. "node" write attributes. ;
  63 M: edge-attributes dot. "edge" write attributes. ;
  64
  65 M: node dot.
  66     [ id. ] [ attributes>> attributes. ] bi ;
  67
  68 M: edge dot.
  69     {
  70         [ tail>> dot. ]
  71         [ drop edgeop get write ]
  72         [ head>> dot. ]
  73         [ attributes>> attributes. ]
  74     } cleave ;
  75
  76 PRIVATE>
  77
  78 : write-dot ( graph path encoding -- )
  79     [ dot. ] with-file-writer ;