#!/usr/bin/perl --
use strict;
use warnings;
use GraphViz;

Main(@ARGV);
exit(0);

BEGIN {

  package CompassGraphViz;
  use parent qw' GraphViz ';

#~ perl -le "use Regexp::Assemble; my( $re ) = Regexp::Assemble->new; 
+$re->add($_) for qw( compass_pt to  from  name  cluster  from_port  t
+o_port );     $re=$re->re;     print qq!\n\n$re\n!; "
#~ (?-xism:(?:c(?:ompass_pt|luster)|from(?:_port)?|to(?:_port)?|name))
#~ perl -le "use Regex::PreSuf; print presuf(qw( compass_pt to  from  
+name  cluster  from_port  to_port ) ); "
#~ (?:c(?:luster|ompass_pt)|from(?:_port)?|name|to(?:_port)?)

  sub _attributes {
    my $thing = shift;

    my @attributes;

    foreach my $key ( keys %$thing ) {
      next if $key =~ /^_/;

#~         next if $key =~ /^(to|from|name|cluster|from_port|to_port)$
+/;
      next
        if $key =~
/^((?-xism:(?:c(?:ompass_pt|luster)|from(?:_port)?|to(?:_port)?|name))
+)$/;

      my $value = $thing->{$key};
      $value =~ s|"|\"|g;
      $value = '"' . $value . '"'
        unless ( $key eq 'label' && $value =~ /^<</ );
      $value =~ s|\n|\\n|g;

      $value = '""' if not defined $value;
      push @attributes, "$key=$value";
    } ## end foreach my $key ( keys %$thing)

    if (@attributes) {
      return ' [' . ( join ', ', sort @attributes ) . "]";
    } else {
      return "";
    }
  } ## end sub _attributes

  sub _as_debug {
    my $self = shift;

    my $dot;

    my $graph_type = $self->{DIRECTED} ? 'digraph' : 'graph';

    $dot .= $graph_type . " " . $self->{NAME} . " {\n";

# the direction of the graph
    $dot .= "\trankdir=LR;\n" if $self->{RANK_DIR};

# the size of the graph
    $dot .= "\tsize=\"" . $self->{WIDTH} . "," . $self->{HEIGHT} . "\"
+;\n"
      if $self->{WIDTH} && $self->{HEIGHT};
    $dot .=
      "\tpage=\"" . $self->{PAGEWIDTH} . "," . $self->{PAGEHEIGHT} . "
+\";\n"
      if $self->{PAGEWIDTH} && $self->{PAGEHEIGHT};

# Ratio setting
    $dot .= "\tratio=\"" . $self->{RATIO} . "\";\n";

# edge merging
    $dot .= "\tconcentrate=true;\n" if $self->{CONCENTRATE};

# epsilon
    $dot .= "\tepsilon=" . $self->{EPSILON} . ";\n" if $self->{EPSILON
+};

# random start
    $dot .= "\tstart=rand;\n" if $self->{RANDOM_START};

# overlap
    $dot .= "\toverlap=\"" . $self->{OVERLAP} . "\";\n" if $self->{OVE
+RLAP};

# color, bgcolor
    $dot .= "\tbgcolor=\"" . $self->{BGCOLOR} . "\";\n" if $self->{BGC
+OLOR};

# Global node, edge and graph attributes
    $dot .= "\tnode" . _attributes( $self->{NODE_ATTRS} ) . ";\n"
      if exists( $self->{NODE_ATTRS} );
    $dot .= "\tedge" . _attributes( $self->{EDGE_ATTRS} ) . ";\n"
      if exists( $self->{EDGE_ATTRS} );
    $dot .= "\tgraph" . _attributes( $self->{GRAPH_ATTRS} ) . ";\n"
      if exists( $self->{GRAPH_ATTRS} );

    my %clusters      = ();
    my %cluster_nodes = ();
    my %clusters_edge = ();

    my $arrow = $self->{DIRECTED} ? ' -> ' : ' -- ';

# Add all the nodes
    my @nodelist = @{ $self->{NODELIST} };
    @nodelist = sort @nodelist if $self->{SORT};

    foreach my $name (@nodelist) {
      my $node = $self->{NODES}->{$name};

# Note all the clusters
      if ( exists $node->{cluster} && $node->{cluster} ) {

# map "name" to value in case cluster attribute is not a simple string
        $clusters{ $node->{cluster} } = $node->{cluster};
        push @{ $cluster_nodes{ $node->{cluster} } }, $name;
        next;
      } ## end if ( exists $node->{cluster...})

      $dot .= "\t" . $node->{_code} . _attributes($node) . ";\n";
    } ## end foreach my $name (@nodelist)

# Add all the edges
    foreach
      my $edge ( sort { $a->{from} cmp $b->{from} || $a->{to} cmp $b->
+{to} }
      @{ $self->{EDGES} } )
    {

      my $from = $self->{NODES}->{ $edge->{from} }->{_code};
      my $to   = $self->{NODES}->{ $edge->{to} }->{_code};

# Deal with ports
      if ( exists $edge->{from_port} ) {
        $from = '"' . $from . '"' . ':port' . $edge->{from_port};
      }
      if ( exists $edge->{to_port} ) {
        $to = '"' . $to . '"' . ':port' . $edge->{to_port};

#~ $ perl -MRegex::PreSuf -le"print presuf( qw( n   ne   e   se   s   
+sw   w    nw   c   _ ) ) "
#~ (?:n[ew]|s[ew]|[_censw])
        if ( exists $edge->{compass_pt}
          and $edge->{compass_pt} =~ /^(n[ew]|s[ew]|[_censw])$/ )
        {
          $to = $to . ':' . $1;
        }
      } ## end if ( exists $edge->{to_port...})

      if ( exists $self->{NODES}->{$from}
        && exists $self->{NODES}->{$from}->{cluster}
        && exists $self->{NODES}->{$to}
        && exists $self->{NODES}->{$to}->{cluster}
        && $self->{NODES}->{$from}->{cluster} eq
        $self->{NODES}->{$to}->{cluster} )
      {

        $clusters_edge{ $self->{NODES}->{$from}->{cluster} } .=
          "\t\t" . $from . $arrow . $to . _attributes($edge) . ";\n";
      } else {
        $dot .= "\t" . $from . $arrow . $to . _attributes($edge) . ";\
+n";
      }
    } ## end foreach my $edge ( sort { $a...})

    foreach my $clustername ( sort keys %cluster_nodes ) {
      my $cluster = $clusters{$clustername};
      my $attrs;
      my $name;
      if ( ref($cluster) eq 'HASH' ) {
        if ( exists $cluster->{label} ) {
          $name = $cluster->{label};
        } elsif ( exists $cluster->{name} ) {

# "coerce" name attribute into label attribute
          $name = $cluster->{name};
          $cluster->{label} = $name;
          delete $cluster->{name};
        } ## end elsif ( exists $cluster->...)
        $attrs = _attributes($cluster);
      } else {
        $name = $cluster;
        $attrs = _attributes( { label => $cluster } );
      }

# rewrite attributes string slightly
      $attrs =~ s/^\s\[//o;
      $attrs =~ s/,/;/go;
      $attrs =~ s/\]$//o;

      $dot .= "\tsubgraph cluster_" . $self->_quote_name($name) . " {\
+n";
      $dot .= "\t\t$attrs;\n";
      $dot .= join "", map {
            "\t\t"
          . $self->{NODES}->{$_}->{_code}
          . _attributes( $self->{NODES}->{$_} ) . ";\n";
      } ( @{ $cluster_nodes{$cluster} } );
      $dot .= $clusters_edge{$cluster} if exists $clusters_edge{$clust
+er};
      $dot .= "\t}\n";
    } ## end foreach my $clustername ( sort...)

# Deal with ranks
    my %ranks;
    foreach my $name (@nodelist) {
      my $node = $self->{NODES}->{$name};
      next unless exists $node->{rank};
      push @{ $ranks{ $node->{rank} } }, $name;
    }

    foreach my $rank ( keys %ranks ) {
      $dot .= qq|\t{rank=same; |;
      $dot .= join '; ', map { $self->_quote_name($_) } @{ $ranks{$ran
+k} };
      $dot .= qq|}\n|;
    }

# {rank=same; Paris; Boston}

    $dot .= "}\n";

    return $dot;
  } ## end sub _as_debug

# Call dot / neato / twopi / circo / fdp with the input text and any p
+arameters

} ## end BEGIN

sub Main {

  {
    my $g = GraphViz->new();

    $g->add_node('a');
    $g->add_node( 'b', label => [ '0', '1' ] );
    $g->add_edge( 'a' => 'b', to_port => '0', );

    print "\n\n######\n\n";
    print $g->_as_debug;
    print $g->as_text;
    print "\n\nSee port1.png\n";
    $g->as_png("port1.png");

  }

  {
    my $g = CompassGraphViz->new();

    $g->add_node('a');
    $g->add_node( 'b', label => [ '0', '1' ] );
    $g->add_edge( 'a' => 'b', to_port => '0', compass_pt => 'se' );

    print "\n\n######\n\n";
    print $g->_as_debug;
    print $g->as_text;
    print "\n\nSee port2.png\n";
    $g->as_png("port2.png");

  }

} ## end sub Main

__END__


######

digraph test {
    ratio="fill";
    a [label="a"];
    b [label="<port0>0|<port1>1", shape="record"];
    a -> "b":port0;
}
digraph test {

    graph [ratio=fill];

    node [label="\N"];

    graph [bb="0,0,68,110"];

    a [label=a, pos="27,92", width="0.75", height="0.5"];

    b [label="<port0>0|<port1>1", shape=record, pos="41,19", rects="14
+,1,41,37 41,1,68,37", width="0.75", height="0.51389"];

    a -> b:port0 [pos="e,27,37 27,73.667 27,65.896 27,56.513 27,47.275
+"];

}



See port1.png


######

digraph test {
    ratio="fill";
    a [label="a"];
    b [label="<port0>0|<port1>1", shape="record"];
    a -> "b":port0:se;
}
digraph test {

    graph [ratio=fill];

    node [label="\N"];

    graph [bb="0,0,60.099,116.25"];

    a [label=a, pos="27,98.247", width="0.75", height="0.5"];

    b [label="<port0>0|<port1>1", shape=record, pos="27,25.247", rects
+="0,7.2471,27,43.247 27,7.2471,54,43.247", width="0.75", height="0.51
+389"];

    a -> b:port0:se [pos="e,27,6.2471 37.352,81.617 43.525,71.332 50.7
+72,57.31 54,43.747 57.757,27.966 65.257,18.928 54,7.2471 48.402,1.437
+5 41.971,-0.84985\

 35.778,0.84985"];

}



See port2.png
[download]