File Coverage

blib/lib/Treemap.pm

Criterion	Covered	Total	%
statement	19	76	25.0
branch	2	26	7.6
condition	1	9	11.1
subroutine	5	10	50.0
pod	2	4	50.0
total	29	125	23.2

package Treemap;

use 5.006;
use strict;
use warnings;
use Carp;

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT_OK = (  );
our @EXPORT = qw( );
our $VERSION = '0.02';


# ------------------------------------------
# Methods:
# ------------------------------------------


# ------------------------------------------
# new() - Create and return new Treemap
#         object:
# ------------------------------------------
sub new
{
   my $proto = shift;
   my $class = ref( $proto ) || $proto;
   my $self = {
      RECT => undef,
      TEXT => undef,
      CACHE => 1,
      INPUT => undef,
      OUTPUT => undef,
      PADDING => 5,
      SPACING => 5,
      @_,               # Override previous attributes
   };

   die "No 'INPUT' object was specified in call to " . $class . "::new, cannot proceed.\nSee: perldoc Treemap\nError occured" if ( ! $self->{INPUT} );
   die "No 'OUTPUT' object was specified in call to " . $class . "::new, cannot proceed.\nSee: perldoc Treemap\nError occured" if ( ! $self->{OUTPUT} );

   # set default "draw" functions
#   $self->{ RECT } = \▭
#   $self->{ TEXT } = \&text;

   bless $self, $class;
   return $self;
}

sub rect
{
   print " ";
   print "rect: @_\n";
}

sub text
{
   print " ";
   print "text: @_\n";
}

sub map
{
   my $self = shift;

   # Get dimensions from OUTPUT object
   my $width = $self->{OUTPUT}->width;
   my $height=  $self->{OUTPUT}->height;

   # Call _map function with tree data from INPUT object.
   $self->_map( $self->{INPUT}->treedata, 0, 0, $width-1, $height-1 );
}

sub _map
{
   my $self = shift;
   my ( @p, @q, $tree, $o );
   ( $tree, $p[0], $p[1], $q[0], $q[1], $o ) = @_;
   $o = $o || 0;  # Orientation of our slicing

   # Draw our rectangle
   #&{$self->{ RECT }}( $p[0], $p[1], $q[0], $q[1], $tree->{colour} );
   $self->{ OUTPUT }->rect( $p[0], $p[1], $q[0], $q[1], $tree->{colour} );

   # Shrink the space available to children
   my( $pt, $qt ) = $self->_shrink( \@p, \@q, $self->{PADDING} );
   my @r = @$pt; my @s = @$qt;

   # Non-empty Set, Descend
   if( $tree->{children} )
   {
      my $width = abs($r[$o] - $s[$o]);
      my $size = $tree->{size};

      # Process each child
      foreach my $child( @{$tree->{children}} )
      {
         # Give this child a percentage of the parent's space, based on
         # parent's size (make sure we don't cause divide by zero errors)
         $s[$o] = $r[$o] + $width * ( $child->{size} / $size ) if ( $size > 0 );

         # Rotate the space by 90 degrees, by xor'ing the 'o'rientation
         {
            my( $rt, $st ) = $self->_shrink( \@r, \@s, $self->{SPACING} );
            my @r = @{$rt}; my @s = @{$st};
            $self->_map( $child, $r[0], $r[1], $s[0], $s[1], ($o xor 1) );
         }
         $r[$o] = $s[$o];
      }
   }
   # Draw label
   #&{ $self->{ TEXT } }( $tree->{name} );
   $self->{ OUTPUT }->text( $p[0], $p[1], $q[0], $q[1], $tree->{name}, ($tree->{children}?1:undef) );
}

sub _shrink
{
   my $self = shift;
   my ( $p, $q, $shr ) = @_;
   my ( $w, $h, $r, $s );
   my ( $w_shrink, $h_shrink ) = ( 0, 0 );

   $w = $q->[0] - $p->[0];
   $h = $q->[1] - $p->[1];

# Shrinking by %
#
# +----------W1-----------+
# |                       |
# |  +-------W2--------+  |
# |  |                 |  |
# H1 H2                |  |
# |  |              A2 |  |
# |  +-----------------+  |
# |                    A1 |
# +-----------------------+
#
# A2 = A1*PCT
# H2*W2 = H1*W1*PCT  (1)
#
# Since aspect ratio is constant:
#
# H2/W2 = H1/W1
# H2 = (H1*W2)/W1
#
# From (1):
#
# H2*W2 = H1*W1*PCT
# W2*(H1*W2)/W1 = H1*W1*PCT
# W2^2*H1/W1 = H1*W1*PCT
# W2^2 = W1^2*PCT
# W2 = (W1^2*PCT)^0.5
#
   if ( $shr =~ /^([\d]+)%$/ )
   {
      my $pct = ( 100 - $1 ) / 100;
      my $w2 = (($w**2)*$pct)**0.5;
      $shr = ( abs($w) - $w2 ) / 2;
   }

# SLOPPY!!!
# These two if structures should be in a simple loop.....
# SLOPPY!!!
   if ( abs( $w ) >= $shr )
   {
      if ( $w > 0 )
      {
         $w_shrink = $shr;
      }
      elsif( $w < 0 )
      {
         $w_shrink = - $shr;
      }
   }
   # We can't shrink by that factor, so shrink as much as we can
   else
   {
      $w_shrink = $w / 2;
   }

   if ( abs( $h ) >= $shr )
   {
      if ( $h > 0 )
      {
         $h_shrink = $shr;
      }
      elsif( $h < 0 )
      {
         $h_shrink = - $shr;
      }
   }
   # We can't shrink by that factor, so shrink as much as we can
   else
   {
      $h_shrink = $h / 2;
   }

   # Perfomr shrink
   $self->{DEBUG} && print "Shrinking by $w_shrink, $h_shrink\n";
   $r->[0] = $p->[0] + $w_shrink;
   $r->[1] = $p->[1] + $h_shrink;

   $s->[0] = $q->[0] - $w_shrink;
   $s->[1] = $q->[1] - $h_shrink;
   return ( $r, $s );
}

1;

__END__