88 lines
1.6 KiB
Factor
88 lines
1.6 KiB
Factor
|
! Copyright (C) 2011 Alex Vondrak.
|
||
|
|
! See http://factorcode.org/license.txt for BSD license.
|
||
|
|
USING: accessors arrays grouping kernel namespaces present
|
||
|
|
sequences strings
|
||
|
|
graphviz.attributes
|
||
|
|
;
|
||
|
|
IN: graphviz
|
||
|
|
|
||
|
|
TUPLE: graph
|
||
|
|
{ id string }
|
||
|
|
{ strict? boolean }
|
||
|
|
{ directed? boolean }
|
||
|
|
statements ;
|
||
|
|
|
||
|
|
TUPLE: subgraph
|
||
|
|
{ id string }
|
||
|
|
statements ;
|
||
|
|
|
||
|
|
TUPLE: node
|
||
|
|
{ id string }
|
||
|
|
{ attributes node-attributes } ;
|
||
|
|
|
||
|
|
TUPLE: edge
|
||
|
|
tail
|
||
|
|
head
|
||
|
|
{ attributes edge-attributes } ;
|
||
|
|
|
||
|
|
! Constructors
|
||
|
|
|
||
|
|
<PRIVATE
|
||
|
|
|
||
|
|
: anon-id ( -- id )
|
||
|
|
\ anon-id counter present "_anonymous_" prepend ; inline
|
||
|
|
|
||
|
|
PRIVATE>
|
||
|
|
|
||
|
|
: <graph> ( -- graph )
|
||
|
|
anon-id f f V{ } clone graph boa ;
|
||
|
|
|
||
|
|
: <strict-graph> ( -- graph )
|
||
|
|
<graph> t >>strict? ;
|
||
|
|
|
||
|
|
: <digraph> ( -- graph )
|
||
|
|
<graph> t >>directed? ;
|
||
|
|
|
||
|
|
: <strict-digraph> ( -- graph )
|
||
|
|
<digraph> t >>strict? ;
|
||
|
|
|
||
|
|
: <anon> ( -- subgraph )
|
||
|
|
anon-id V{ } clone subgraph boa ;
|
||
|
|
|
||
|
|
: <subgraph> ( id -- subgraph )
|
||
|
|
present V{ } clone subgraph boa ;
|
||
|
|
|
||
|
|
: <cluster> ( id -- subgraph )
|
||
|
|
present "cluster_" prepend V{ } clone subgraph boa ;
|
||
|
|
|
||
|
|
: <node> ( id -- node )
|
||
|
|
present <node-attributes> node boa ;
|
||
|
|
|
||
|
|
DEFER: add-nodes
|
||
|
|
|
||
|
|
: <edge> ( tail head -- edge )
|
||
|
|
[
|
||
|
|
dup array?
|
||
|
|
[ <anon> swap add-nodes ]
|
||
|
|
[ dup subgraph? [ present ] unless ]
|
||
|
|
if
|
||
|
|
] bi@
|
||
|
|
<edge-attributes> edge boa ;
|
||
|
|
|
||
|
|
! Building graphs
|
||
|
|
|
||
|
|
: add ( graph statement -- graph' )
|
||
|
|
over statements>> push ;
|
||
|
|
|
||
|
|
: add-node ( graph id -- graph' )
|
||
|
|
<node> add ; inline
|
||
|
|
|
||
|
|
: add-edge ( graph tail head -- graph' )
|
||
|
|
<edge> add ; inline
|
||
|
|
|
||
|
|
: add-nodes ( graph nodes -- graph' )
|
||
|
|
[ add-node ] each ;
|
||
|
|
|
||
|
|
: add-path ( graph nodes -- graph' )
|
||
|
|
2 <clumps> [ first2 add-edge ] each ;
|