minivcg2.pl

#!/usr/bin/perl

=for comment

Take a simplified graph description source file (read on STDIN) and generate xvcg graphs.  Requires the xvcg package and NetPBM.

Eg:

foo: Foo is Foo                           -- create a node named 'foo' (in the source file) containing the text (in the output graph) 'Foo is Foo'
bar: Bar is Bar                           -- similar
foo -> bar                                -- draw a directed arrow between 'foo' and 'bar'
foo -> bar: Bar is Bar                    -- define the node 'bar' to contain the text 'Bar is Bar' and draw an arrow between 'foo' and 'bar'
foo -> bar = if y > 3                     -- draw an edge between 'foo' and 'bar' with a label on the edge reading 'if y > 3'
----                                      -- start a new row in the graph
(legend) foo: Foo                         -- legend nodes describe the contents of a row of a graph and should generally be the first thing on a new row

The graph is layed out left to right in the order that nodes appear, and top to bottom as '----' lines break a row.

Edit the code and uncomment/comment to switch between png or PostScript output, and set the size/dpi.  (TODO, would be nice to have this as command line options.)

=cut

use strict;
use warnings;

use IO::Handle;

my $graph = '';
my $pre_graph = '';

$pre_graph .= graph->header;

my %nodes;

my $source;
my $short;
my $long;
my $label;
my $shape;

my $level = 1;
my $horizontal_order = 1;

sub node {
    $nodes{$short} = $long;
    # warn "$short = $long";
    $graph .= graph->node($short, $long); 
}

sub node_with_shape {
    $nodes{$short} = $long;
    $pre_graph .= graph->node($short, $long, $shape); 
}

sub edge {
    exists $nodes{$source} or die "node ``$source'' unknown";
    exists $nodes{$short} or die "node ``$short'' unknown";
    $graph .= graph->edge($source, $short);
}

sub edge_with_label {
    exists $nodes{$source} or die "node ``$source'' unknown";
    exists $nodes{$short} or die "node ``$short'' unknown";
    $graph .= graph->edge($source, $short, $label);
}

sub level {
    $level++;
    $horizontal_order = 1;
}

while(my $line = readline) {
    chomp $line;
    next unless $line;
    next if $line =~ m/^ \s* \#/x;
    $line =~ m/^-----*$/x and do {
        level;
        next;
    };
    ($short, $long) = $line =~ m/^ \s* (\w+) \s* : \s* (.+) /x and do {
        node;
        next;
    };

    ($shape, $short, $long) = $line =~ m/^ \s* \((\w+)\) \s* (\w+) \s* : \s* (.+) /x and do {
        node_with_shape;
        next;
    };

    ($source, $short, $label) = $line =~ m/^ (\w+) \s* -> \s* (\w+?) \s* = \s* (.+) /x and do {
        edge_with_label;
        next;
    };
    ($source, $short, $long) = $line =~ m/^ (\w+) \s* -> \s* (\w+?) \s* : \s* (.+) /x and do {
        node;
        edge;
        next;
    };
    ($source, $short) = $line =~ m/^ (\w+) \s* -> \s* (\w+) /x and do {
        edge;
        next;
    };
    die "line $. unparsable: $line";
}

$graph .= graph->footer;

$graph = $pre_graph . $graph;

open my $out, '>', '/tmp/tmp.xvcg' or die $!;
$out->print($graph) or die $!;
close $out or die $!;

unlink '/tmp/minivcg.out.ppm';
unlink '/tmp/minivcg.out.ps';
# open $out, '|-', 'xvcg', '-xdpi', 100, '-ydpi', 100, '-color',  '-paper', '11x17', '-ppmoutput', '/tmp/minivcg.out.ppm', '-' or die $?;
# open $out, '|-', 'xvcg', '-xdpi', 100, '-ydpi', 100, '-color',  '-paper', '11x17', '-ppmoutput', '/tmp/minivcg.out.ppm', '/tmp/tmp.xvcg' or die $?;
# open $out, '|-', 'xvcg', '-xdpi', 300, '-ydpi', 300, '-color',  '-paper', '11x17', '-psoutput', '/tmp/minivcg.out.ps', '/tmp/tmp.xvcg' or die $?;
# open $out, '|-', 'xvcg', '-xdpi', 300, '-ydpi', 300, '-color',  '-width', '200 in', '-psoutput', '/tmp/minivcg.out.ps', '/tmp/tmp.xvcg' or die $?;
# open $out, '|-', 'xvcg', '-xdpi', 300, '-ydpi', 300, '-color',  '-width', '50 in', '-psoutput', '/tmp/minivcg.out.ps', '/tmp/tmp.xvcg' or die $?;
open $out, '|-', 'xvcg', '-xdpi', 300, '-ydpi', 300, '-color',  '-width', '40 in', '-psoutput', '/tmp/minivcg.out.ps', '/tmp/tmp.xvcg' or die $?;
$out->print($graph) or die $!;
close $out or die $!;
# not yet
# system 'pnmcrop -white < /tmp/minivcg.out.ppm > /tmp/.ppm';
# rename '/tmp/tmp.ppm', '/tmp/minivcg.out.ppm';

#
# graph
#

# xvcg currently; dot was consuming all memory and dragging the machine very narrowly to the gates of hell on a graph 20 or 40 nodes.

package graph;

my $last_legend;

sub header {
    return <<EOF;
graph: {
  title: "Dispatch Order"
  color: lightcyan
  edge.color: lilac
  display_edge_labels: yes
  port_sharing: yes
  splines: yes
EOF
  # layoutalgorithm: minbackward
  # scaling: 10.0
  # layoutalgorithm: tree
  # layoutalgorithm: maxdepth
  # arrowmode: free 
}

sub footer {
    return "}\n";
}

sub node {
    my ($self, $name, $label, $shape) = @_;
    $label or die;
    my $node = qq<node: { title:"A1" label: "LISTOP" level:1 shape:box horizontal_order:1 }\n>;
    $node =~ s{A1}{$name};
    $node =~ s{LISTOP}{$label};
    $node =~ s{level:1}{level:$level};
    if( $shape and $shape eq 'legend' ) {
        # $horizontal_order = 1;
        $horizontal_order == 1 or die $horizontal_order;
        # $node =~ s{shape:box}{shape:box horizontal_order:1 borderwidth:0 }; 
        $node =~ s{shape:box}{shape:rhomb borderwidth:2 }; 
        $node .= graph->edge($last_legend, $name, undef, 'linestyle:invisible priority:1000') if $last_legend;  # connect them together with invisible edges; bumping this to high priority and specifiying hoz/vert order for everything seems to have *finally* locked down the legend to the left side
        $last_legend = $name;
    }
    $node =~ s{horizontal_order:1}{horizontal_order:$horizontal_order};  $horizontal_order++;
    $node =~ s{shape:box}{shape:$shape} if $shape and $shape ne 'legend';
    return $node;
}

sub edge {
    my ($self, $src, $dest, $label, $extra) = @_;
    $extra ||= '';
    my $edge = qq<edge: { sourcename: "A1" targetname: "A2" label: "sibling" $extra}\n>;
    $edge =~ s{A1}{$src};
    $edge =~ s{A2}{$dest};
    $edge =~ s{label: "sibling"}{label: "$label"} if $label;
    $edge =~ s{label: "sibling"}{} if ! $label;
    return $edge;
}