Generating Images with Graphics Primitives in Perl

At work we’ve had the need to view diagrams showing the data flow from one “thread” to another within a Cloverleaf Site. For quite some time we’ve used Visio diagrams, however there are a number of issues with this approach. Philosophically and practically I have an issue with the file formats being a proprietary binary format. We can’t parse them ourselves or edit them in a script easily. They have to be updated tediously by hand. Then in order to incorporate them with our web tools, we have to save as images and manually copy them to our web server. This is prone to mistakes and neglect.

Yesterday I installed the GD Perl interface to GD on my workstation. This took a bit of time since I was installing on Solaris which had none of the dependancies. On a Linux workstation it would have taken me just a few minutes.

Today I wrote some code to generate the images. I realize I’m processing a proprietary file format for the configuration of a Cloverleaf site, but the interesting part is the generation of the image. Click below to see the code and the results.

#!/opt/apps/ActivePerl-5.8/bin/perl -w

use GD;
use Data::Dumper;

$sitedir   = $ENV{'HCISITEDIR'};
$netconfig = "$sitedir/NetConfig";
$view      = "test.view";

$arrow_width = 7;
$box_height  = 35;
$debug       = 0;
$max_x       = 0;
$max_y       = 0;

open VIEW, $view or die "Cannot open $view:$!";

while (<VIEW>) {
    if (/host .*? ([wd]+).*?COORDS .*?(d+) (d+)/) {
        my $thread = $1;
        my $x = $2;
        my $y = $3;

        $max_x = $x if ($x > $max_x);
        $max_y = $y if ($y > $max_y);

        $coords->{$thread} = [$x,$y];
    }
}

open NETCONFIG, $netconfig or die "Cannot open $netconfig:$!";

{ local $/;
    $_ = <NETCONFIG>;
}

close NETCONFIG;

# Split the NetConfig into sections
@sections = split /^(?=[^s{}])/m;

# Get only the protocol Sections
@sections = grep /^protocolb/, @sections;

# Get list of destinations for each thread
for (@sections) {
    my $thread;
    my @destinations;
    my %dest;

    @lines = split /
/;

    for (@lines) {
        $thread = $1 if /protocol ([wd]+)/;
        $dest{$1}++ if /bDESTs+([wd]+)/;
    }

    @destinations = keys %dest;

    $site->{$thread}->{'destinations'} = @destinations;
    $site->{$thread}->{'coordinates'}  = $coords->{$thread};
}

print Dumper($site) if $debug;

#create the image
$image = new GD::Image($max_x + 80, $max_y + 40);

# allocate some colors
$white = $image->colorAllocate(255,255,255);
$black = $image->colorAllocate(0,0,0);
$red   = $image->colorAllocate(255,0,0);
$blue  = $image->colorAllocate(0,0,255);

for my $thread (keys %$site) {
    draw_box($site->{$thread}->{'coordinates'}[0],
             $site->{$thread}->{'coordinates'}[1],
             $thread);
    my $dest_ref = $site->{$thread}->{'destinations'};
    for my $destination (@$dest_ref) {
        draw_arrow($thread, $destination);
    }
}

# make sure we are writing to a binary stream
binmode STDOUT;

# Convert the image to PNG and print it on standard output
print $image->png unless $debug;

sub draw_box {
    my ($x, $y, $thread_name) = @_;
    $image->filledRectangle($x, $y, $x + box_width($thread_name), $y + $box_height, $blue);
    $image->string(gdSmallFont, $x + 3, $y + $box_height / 2 - 6, $thread_name, $white);
}

sub box_width {
    my $name = shift;
    return (length $name) * 7;
}

sub draw_arrow {
    my ($source, $destination) = @_;

    print "source: $source
" if $debug;
    print "destination: $destination
" if $debug;

    @s_coord = @{$site->{$source}->{'coordinates'}};
    @d_coord = @{$site->{$destination}->{'coordinates'}};

    print "s_coord: @s_coord
" if $debug;
    print "d_coord: @d_coord
" if $debug;

    $SLx = $s_coord[0];
    $SRx = $SLx + box_width($source);
    $STx = $SLx + box_width($source) / 2;
    $SBx = $STx;

    $STy = $s_coord[1];
    $SBy = $STy + $box_height;
    $SLy = $STy + $box_height / 2;
    $SRy = $SLy;

    $DLx = $d_coord[0];
    $DRx = $DLx + box_width($destination);
    $DTx = $DLx + box_width($destination) / 2;
    $DBx = $DTx;

    $DTy = $d_coord[1];
    $DBy = $DTy + $box_height;
    $DLy = $DTy + $box_height / 2;
    $DRy = $DLy;

    if ($SLx > $DRx) {
        $image->line($SLx, $SLy, $DRx + $arrow_width, $DRy, $red);
        draw_triangle($DRx, $DRy,
                      $DRx + $arrow_width, $DRy - $arrow_width,
                      $DRx + $arrow_width, $DRy + $arrow_width);
    } elsif ($SRx < $DLx) {
        $image->line($SRx, $SRy, $DLx - $arrow_width, $DLy, $red);
        draw_triangle($DLx, $DLy,
                      $DLx - $arrow_width, $DLy - $arrow_width,
                      $DLx - $arrow_width, $DLy + $arrow_width);
    } elsif ($SBy < $DBy) {
        $image->line($SBx, $SBy, $DTx, $DTy - $arrow_width, $red);
        draw_triangle($DTx, $DTy,
                      $DTx - $arrow_width, $DTy - $arrow_width,
                      $DTx + $arrow_width, $DTy - $arrow_width);
    } else {
        $image->line($STx, $STy, $DBx, $DBy + $arrow_width, $red);
        draw_triangle($DBx, $DBy,
                      $DBx - $arrow_width, $DBy + $arrow_width,
                      $DBx + $arrow_width, $DBy + $arrow_width);
    }

}

sub draw_triangle {
    my ($x1, $y1, $x2, $y2, $x3, $y3) = @_;

    # make a polygon
    my $poly = new GD::Polygon;
    $poly->addPt($x1, $y1);
    $poly->addPt($x2, $y2);
    $poly->addPt($x3, $y3);

    # draw the polygon, filling it with a color
    $image->filledPolygon($poly, $red);
}

The results look like this

Next step will be to put some more information in the image and create an image map so we can click on the boxes and control the interface. I’ll also have it generate different coloured boxes to show the state the thread is in (up, down, error, etc.).

Tags: Perl