File Coverage

lib/Graph/Easy/As_vcg.pm

Criterion	Covered	Total	%
statement	144	178	80.9
branch	54	86	62.7
condition	21	41	51.2
subroutine	12	12	100.0
pod	0	2	0.0
total	231	319	72.4

#############################################################################
# Output the graph as VCG or GDL text.
#
#############################################################################

package Graph::Easy::As_vcg;

$VERSION = '0.75';

#############################################################################
#############################################################################

package Graph::Easy;

use strict;
use warnings;

my $vcg_remap = {
  node => {
    align => \&_vcg_remap_align,
    autolabel => undef,
    autolink => undef,
    autotitle => undef,
    background => undef,
    basename => undef,
    class => undef,
    colorscheme => undef,
    columns => undef,
    flow => undef,
    fontsize => undef,
    format => undef,
    group => undef,
    id => undef,
    link => undef,
    linkbase => undef,
    offset => undef,
    origin => undef,
    pointstyle => undef,
    rank => 'level',
    rotate => undef,
    rows => undef,
    shape => \&_vcg_remap_shape,
    size => undef,
    textstyle => undef,
    textwrap => undef,
    title => undef,
    },
  edge => {
    color => 'color',			# this entry overrides 'all'!
    align => undef,
    arrowshape => undef,
    arrowstyle => undef,
    autojoin => undef,
    autolabel => undef,
    autolink => undef,
    autosplit => undef,
    autotitle => undef,
    border => undef,
    bordercolor => undef,
    borderstyle => undef,
    borderwidth => undef,
    colorscheme => undef,
    end => undef,
    fontsize => undef,
    format => undef,
    id => undef,
    labelcolor => 'textcolor',
    link => undef,
    linkbase => undef,
    minlen => undef,
    start => undef,
    # XXX TODO: remap unknown styles
    style => 'linestyle',
    textstyle => undef,
    textwrap => undef,
    title => undef,
    },
  graph => {
    align => \&_vcg_remap_align,
    flow => \&_vcg_remap_flow,
    label => 'title',
    type => undef,
    },
  group => {
    },
  all => {
    background => undef,
    color => 'textcolor',
    comment => undef,
    fill => 'color',
    font => 'fontname',
    },
  always => {
    },
  # this routine will handle all custom "x-dot-..." attributes
  x => \&_remap_custom_vcg_attributes,
  };

sub _remap_custom_vcg_attributes
  {
  my ($self, $name, $value) = @_;

  # drop anything that is not starting with "x-vcg-..."
  return (undef,undef) unless $name =~ /^x-vcg-/;

  $name =~ s/^x-vcg-//;			# "x-vcg-foo" => "foo"
  ($name,$value);
  }

my $vcg_shapes = {
  rect => 'box',
  diamond => 'rhomb',
  triangle => 'triangle',
  invtriangle => 'triangle',
  ellipse => 'ellipse',
  circle => 'circle',
  hexagon => 'hexagon',
  trapezium => 'trapeze',
  invtrapezium => 'uptrapeze',
  invparallelogram => 'lparallelogram',
  parallelogram => 'rparallelogram',
  };

sub _vcg_remap_shape
  {
  my ($self, $name, $shape) = @_;

  return ('invisible','yes') if $shape eq 'invisible';

  ('shape', $vcg_shapes->{$shape} || 'box');
  }

sub _vcg_remap_align
  {
  my ($self, $name, $style) = @_;

  # center => center, left => left_justify, right => right_justify
  $style .= '_justify' unless $style eq 'center';

  ('textmode', $style);
  }

my $vcg_flow = {
  'south' => 'top_to_bottom',
  'north' => 'bottom_to_top',
  'down' => 'top_to_bottom',
  'up' => 'bottom_to_top',
  'east' => 'left_to_right',
  'west' => 'right_to_left',
  'right' => 'left_to_right',
  'left' => 'right_to_left',
  };

sub _vcg_remap_flow
  {
  my ($self, $name, $style) = @_;

  ('orientation', $vcg_flow->{$style} || 'top_to_bottom');
  }

sub _class_attributes_as_vcg
  {
  # convert a hash with attribute => value mappings to a string
  my ($self, $a, $class) = @_;


  my $att = '';
  $class = '' if $class eq 'graph';
  $class .= '.' if $class ne '';

  # create the attributes as text:
  for my $atr (sort keys %$a)
    {
    my $v = $a->{$atr};
    $v =~ s/"/\\"/g;            # '2"' => '2\"'
    $v = '"' . $v . '"' unless $v =~ /^[0-9]+\z/;       # 1, "1a"
    $att .= "  $class$atr: $v\n";
    }
  $att =~ s/,\s$//;             # remove last ","

  $att = "\n$att" unless $att eq '';
  $att;
  }

#############################################################################

sub _generate_vcg_edge
  {
  # Given an edge, generate the VCG code for it
  my ($self, $e, $indent) = @_;

  # skip links from/to groups, these will be done later
  return '' if
    $e->{from}->isa('Graph::Easy::Group') ||
    $e->{to}->isa('Graph::Easy::Group');

  my $edge_att = $e->attributes_as_vcg();

  $e->{_p} = undef;				# mark as processed
  "  edge:$edge_att\n";				# return edge text
  }

use Graph::Easy::Util qw(ord_values);

sub _as_vcg
  {
  my ($self) = @_;

  # convert the graph to a textual representation
  # does not need a layout() beforehand!

  # gather all edge classes to build the classname attribute from them:
  $self->{_vcg_edge_classes} = {};
  for my $e (ord_values ( $self->{edges} ))
    {
    my $class = $e->sub_class();
    $self->{_vcg_edge_classes}->{$class} = undef if defined $class && $class ne '';
    }
  # sort gathered class names and map them to integers
  my $class_names = '';
  if (keys %{$self->{_vcg_edge_classes}} > 0)
    {
    my $i = 1;
    $class_names = "\n";
    for my $ec (sort keys %{$self->{_vcg_edge_classes}})
      {
      $self->{_vcg_edge_classes}->{$ec} = $i;	# remember mapping
      $class_names .= "  classname $i: \"$ec\"\n";
      $i++;
      }
    }

  # generate the class attributes first
  my $label = $self->label();
  my $t = ''; $t = "\n  title: \"$label\"" if $label ne '';

  my $txt = "graph: {$t\n\n" .
            "  // Generated by Graph::Easy $Graph::Easy::VERSION" .
	    " at " . scalar localtime() . "\n" .
	    $class_names;

  my $groups = $self->groups();

  # to keep track of invisible helper nodes
  $self->{_vcg_invis} = {};
  # name for invisible helper nodes
  $self->{_vcg_invis_id} = 'joint0';

  my $atts = $self->{att};
  # insert the class attributes
  for my $class (qw/edge graph node/)
    {
    next if $class =~ /\./;		# skip subclasses

    my $out = $self->_remap_attributes( $class, $atts->{$class}, $vcg_remap, 'noquote');
    $txt .= $self->_class_attributes_as_vcg($out, $class);
    }

  $txt .= "\n" if $txt ne '';		# insert newline

  ###########################################################################
  # output groups as subgraphs

  # insert the edges into the proper group
  $self->_edges_into_groups() if $groups > 0;

  # output the groups (aka subclusters)
  my $indent = '    ';
  for my $group (sort { $a->{name} cmp $b->{name} } values %{$self->{groups}})
    {
    # quote special chars in group name
    my $name = $group->{name}; $name =~ s/([\[\]\(\)\{\}\#"])/\\$1/g;

#    # output group attributes first
#    $txt .= "  subgraph \"cluster$group->{id}\" {\n${indent}label=\"$name\";\n";

    # Make a copy of the attributes, including our class attributes:
    my $copy = {};
    my $attribs = $group->get_attributes();

    for my $a (keys %$attribs)
      {
      $copy->{$a} = $attribs->{$a};
      }
#    # set some defaults
#    $copy->{'borderstyle'} = 'solid' unless defined $copy->{'borderstyle'};

    my $out = {};
#    my $out = $self->_remap_attributes( $group->class(), $copy, $vcg_remap, 'noquote');

    # Set some defaults:
    $out->{fillcolor} = '#a0d0ff' unless defined $out->{fillcolor};
#    $out->{labeljust} = 'l' unless defined $out->{labeljust};

    my $att = '';
    # we need to output style first ("filled" and "color" need come later)
    for my $atr (reverse sort keys %$out)
      {
      my $v = $out->{$atr};
      $v = '"' . $v . '"';
      $att .= "    $atr: $v\n";
      }
    $txt .= $att . "\n" if $att ne '';

#    # output nodes (w/ or w/o attributes) in that group
#    for my $n ($group->sorted_nodes())
#      {
#      my $att = $n->attributes_as_vcg();
#      $n->{_p} = undef;			# mark as processed
#      $txt .= $indent . $n->as_graphviz_txt() . $att . "\n";
#      }

#    # output node connections in this group
#    for my $e (ord_values ( $group->{edges} ))
#      {
#      next if exists $e->{_p};
#      $txt .= $self->_generate_edge($e, $indent);
#      }

    $txt .= "  }\n";
    }

  my $root = $self->attribute('root');
  $root = '' unless defined $root;

  my $count = 0;
  # output nodes with attributes first, sorted by their name
  for my $n (sort { $a->{name} cmp $b->{name} } values %{$self->{nodes}})
    {
    next if exists $n->{_p};
    my $att = $n->attributes_as_vcg($root);
    if ($att ne '')
      {
      $n->{_p} = undef;			# mark as processed
      $count++;
      $txt .= "  node:" . $att . "\n";
      }
    }

  $txt .= "\n" if $count > 0;		# insert a newline

  my @nodes = $self->sorted_nodes();

  foreach my $n (@nodes)
    {
    my @out = $n->successors();
    my $first = $n->as_vcg_txt();
    if ((@out == 0) && ( (scalar $n->predecessors() || 0) == 0))
      {
      # single node without any connections (unless already output)
      $txt .= "  node: { title: " . $first . " }\n" unless exists $n->{_p};
      }
    # for all outgoing connections
    foreach my $other (reverse @out)
      {
      # in case there is more than one edge going from N to O
      my @edges = $n->edges_to($other);
      foreach my $e (@edges)
        {
        next if exists $e->{_p};
        $txt .= $self->_generate_vcg_edge($e, '  ');
        }
      }
    }

  # insert now edges between groups (clusters/subgraphs)

#  foreach my $e (ord_values ( $self->{edges} ))
#    {
#    $txt .= $self->_generate_group_edge($e, '  ')
#     if $e->{from}->isa('Graph::Easy::Group') ||
#        $e->{to}->isa('Graph::Easy::Group');
#    }

  # clean up
  for my $n ( ord_values ( $self->{nodes} ), ord_values ( $self->{edges} ))
    {
    delete $n->{_p};
    }
  delete $self->{_vcg_invis};		# invisible helper nodes for joints
  delete $self->{_vcg_invis_id};	# invisible helper node name
  delete $self->{_vcg_edge_classes};

  $txt .  "\n}\n";			# close the graph
  }

package Graph::Easy::Node;

sub attributes_as_vcg
  {
  # return the attributes of this node as text description
  my ($self, $root) = @_;
  $root = '' unless defined $root;

  my $att = '';
  my $class = $self->class();

  return '' unless ref $self->{graph};

  my $g = $self->{graph};

  # get all attributes, excluding the class attributes
  my $a = $self->raw_attributes();

  # add the attributes that are listed under "always":
  my $attr = $self->{att};
  my $base_class = $class; $base_class =~ s/\..*//;
  my $list = $vcg_remap->{always}->{$class} || $vcg_remap->{always}->{$base_class};

  for my $name (@$list)
    {
    # for speed, try to look it up directly

    # look if we have a code ref, if yes, simple set the value to undef
    # and let the coderef handle it later:
    if ( ref($vcg_remap->{$base_class}->{$name}) ||
         ref($vcg_remap->{all}->{$name}) )
      {
      $a->{$name} = $attr->{$name};
      }
    else
      {
      $a->{$name} = $attr->{$name};
      $a->{$name} = $self->attribute($name) unless defined $a->{$name} && $a->{$name} ne 'inherit';
      }
    }

  $a = $g->_remap_attributes( $self, $a, $vcg_remap, 'noquote');

  if ($self->isa('Graph::Easy::Edge'))
    {
    $a->{sourcename} = $self->{from}->{name};
    $a->{targetname} = $self->{to}->{name};
    my $class = $self->sub_class();
    $a->{class} = $self->{graph}->{_vcg_edge_classes}->{ $class } if defined $class && $class ne '';
    }
  else
    {
    # title: "Bonn"
    $a->{title} = $self->{name};
    }

  # do not needlessly output labels:
  delete $a->{label} if !$self->isa('Graph::Easy::Edge') &&		# not an edge
	exists $a->{label} && $a->{label} eq $self->{name};

  # bidirectional and undirected edges
  if ($self->{bidirectional})
    {
    delete $a->{dir};
    my ($n,$s) = Graph::Easy::_graphviz_remap_arrow_style(
	$self,'', $self->attribute('arrowstyle'));
    $a->{arrowhead} = $s;
    $a->{arrowtail} = $s;
    }
  if ($self->{undirected})
    {
    delete $a->{dir};
    $a->{arrowhead} = 'none';
    $a->{arrowtail} = 'none';
    }

  # borderstyle: double:
  if (!$self->isa('Graph::Easy::Edge'))
    {
    my $style = $self->attribute('borderstyle');
    $a->{peripheries} = 2 if $style =~ /^double/;
    }

  # For nodes with shape plaintext, set the fillcolor to the background of
  # the graph/group
  my $shape = $a->{shape} || 'rect';
  if ($class =~ /node/ && $shape eq 'plaintext')
    {
    my $p = $self->parent();
    $a->{fillcolor} = $p->attribute('fill');
    $a->{fillcolor} = 'white' if $a->{fillcolor} eq 'inherit';
    }

  $shape = $self->attribute('shape') unless $self->isa_cell();

  # for point-shaped nodes, include the point as label and set width/height
  if ($shape eq 'point')
    {
    require Graph::Easy::As_ascii;		# for _u8 and point-style

    my $style = $self->_point_style( $self->attribute('pointstyle') );

    $a->{label} = $style;
    # for point-shaped invisible nodes, set height/width = 0
    $a->{width} = 0, $a->{height} = 0 if $style eq '';
    }
  if ($shape eq 'invisible')
    {
    $a->{label} = ' ';
    }

  $a->{rank} = '0' if $root ne '' && $root eq $self->{name};

  # create the attributes as text:
  for my $atr (sort keys %$a)
    {
    my $v = $a->{$atr};
    $v =~ s/"/\\"/g;		# '2"' => '2\"'
    $v = '"' . $v . '"' unless $v =~ /^[0-9]+\z/;	# 1, "1a"
    $att .= "$atr: $v ";
    }
  $att =~ s/,\s$//;             # remove last ","

  # generate attribute text if nec.
  $att = ' { ' . $att . '}' if $att ne '';

  $att;
  }

sub as_vcg_txt
  {
  # return the node itself (w/o attributes) as VCG representation
  my $self = shift;

  my $name = $self->{name};

  # escape special chars in name (including doublequote!)
  $name =~ s/([\[\]\(\)\{\}"])/\\$1/g;

  # quote:
  '"' . $name . '"';
  }

1;
__END__