extra/graphviz/graphviz.factor

   1 ! Copyright (C) 2011 Alex Vondrak.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays grouping kernel namespaces present
   4 sequences strings
   5 graphviz.attributes
   6 ;
   7 IN: graphviz
   8
   9 TUPLE: graph
  10 { id string }
  11 { strict? boolean }
  12 { directed? boolean }
  13 statements ;
  14
  15 TUPLE: subgraph
  16 { id string }
  17 statements ;
  18
  19 TUPLE: node
  20 { id string }
  21 { attributes node-attributes } ;
  22
  23 TUPLE: edge
  24 tail
  25 head
  26 { attributes edge-attributes } ;
  27
  28 ! Constructors
  29
  30 <PRIVATE
  31
  32 : anon-id ( -- id )
  33     \ anon-id counter present "_anonymous_" prepend ; inline
  34
  35 PRIVATE>
  36
  37 : <graph> ( -- graph )
  38     anon-id f f V{ } clone graph boa ;
  39
  40 : <strict-graph> ( -- graph )
  41     <graph> t >>strict? ;
  42
  43 : <digraph> ( -- graph )
  44     <graph> t >>directed? ;
  45
  46 : <strict-digraph> ( -- graph )
  47     <digraph> t >>strict? ;
  48
  49 : <anon> ( -- subgraph )
  50     anon-id V{ } clone subgraph boa ;
  51
  52 : <subgraph> ( id -- subgraph )
  53     present V{ } clone subgraph boa ;
  54
  55 : <cluster> ( id -- subgraph )
  56     present "cluster_" prepend V{ } clone subgraph boa ;
  57
  58 : <node> ( id -- node )
  59     present <node-attributes> node boa ;
  60
  61 DEFER: add-nodes
  62
  63 : <edge> ( tail head -- edge )
  64     [
  65         dup array?
  66         [ <anon> swap add-nodes ]
  67         [ dup subgraph? [ present ] unless ]
  68         if
  69     ] bi@
  70     <edge-attributes> edge boa ;
  71
  72 ! Building graphs
  73
  74 : add ( graph statement -- graph' )
  75     over statements>> push ;
  76
  77 : add-node ( graph id -- graph' )
  78     <node> add ; inline
  79
  80 : add-edge ( graph tail head -- graph' )
  81     <edge> add ; inline
  82
  83 : add-nodes ( graph nodes -- graph' )
  84     [ add-node ] each ;
  85
  86 : add-path ( graph nodes -- graph' )
  87     2 <clumps> [ first2 add-edge ] each ;