File Coverage

blib/lib/Data/Region.pm

Criterion	Covered	Total	%
statement	126	126	100.0
branch	16	18	88.8
condition			n/a
subroutine	20	20	100.0
pod	17	17	100.0
total	179	181	98.9

package Data::Region;
use strict;

our $VERSION = '1.0';
our $REVISION = '$Id: Region.pm,v 1.5 2002/11/09 02:32:19 gdf Exp $ ';


# Reading the perldoc at the end is probably a better place to start
# than reading these inline comments...

our @_Keys = qw( warnings data );

sub new {
  my $class = shift;
  my $self = bless {}, $class;
  $self->_init(@_);
  return $self;
}

#
# warnings => if true, bounds errors generate gripes
# data => ref to some random data to associate with this region
# x =>
# y => specify top left corner (defaults to 0,0)
#
# coords start from top left, and proceed to lower right
#
sub _init {
  my $self = shift;
  my( $w, $h, $opt ) = @_;

  my $x = (defined($opt->{x}) ? $opt->{x} : 0);
  my $y = (defined($opt->{y}) ? $opt->{y} : 0);

  #w; warn "DIAG Creating $w x $h @ ($x, $y)\n";
  $self->{tl} = [$x,$y];
  $self->{br} = [$x+$w,$y+$h];
  $self->{_kids} = [];
  $self->{_calls} = [];

  foreach my $k (@_Keys) {
    $self->{$k} = $opt->{$k};
  }
}

# Returns a list of sub-areas, tiled vertically into $self,
#  where each successive area has a height given by the list of args.
# A final area will be returned comprising the remaining height of $self,
#  if the arguments do not entirely fill $self.
# eg, if $self->height()==13, then
#   @a = $self->split_vertical( 2, 5, 1 );
#   $a[0]->height() == 2 # y=[0..2]
#   $a[1]->height() == 5 # y=[2..7]
#   $a[2]->height() == 1 # y=[7..8]
#   $a[3]->height() == 5 # y=[8..13], ie all the rest of $self
#
sub split_vertical {
  my $self = shift;
  my( @offs ) = @_;
  my @ret;

  my($x,$w) = ($self->{tl}->[0], ($self->{br}->[0] - $self->{tl}->[0]));
  my $yc = $self->{tl}->[1];
  for( my $i=0; $i<@offs; $i++ ) {
    push( @ret, $self->_spawn($x,$yc, $w, $offs[$i]) );
    $yc += $offs[$i];
  }
  if ( $yc < $self->{br}->[1] ) { # any area of $self left?
    push( @ret, $self->_spawn($x,$yc, $w, ($self->{br}->[1]-$yc)) );
  }
  return @ret;

}


sub split_horizontal {
  my $self = shift;
  my( @offs ) = @_;
  my @ret;

  my($y,$h) = ($self->{tl}->[1], ($self->{br}->[1] - $self->{tl}->[1]));
  my $xc = $self->{tl}->[0];
  for( my $i=0; $i<@offs; $i++) {
    push(@ret, $self->_spawn($xc,$y, $offs[$i],$h) );
    $xc+=$offs[$i];
  }
  if ( $xc < $self->{br}->[0] ) {
    push(@ret, $self->_spawn($xc,$y, ($self->{br}->[0]-$xc),$h) );
  }
  return @ret;
}

# returns list of sub-areas, tiled vertically into $self,
# with successive Y coordinates given by @stops
sub split_vertical_abs {
  my $self = shift;
  my( @stops ) = @_;
  my @ret;

  my($x,$w) = ($self->{tl}->[0], ($self->{br}->[0] - $self->{tl}->[0]));
  for( my $i=0; $i<@stops; $i++ ) {
    my $yc = $stops[$i];
    my $nexty = $stops[$i+1];
    $nexty = $self->{br}->[1] unless defined($nexty);
    my $hc = $nexty-$yc;
    push(@ret, $self->_spawn($x,$yc, $w,$hc));
  }
  return @ret;
}

# returns list of sub-areas, tiled horizontally into $self,
# with successive X coordinates given by @stops
# XXX rename this split_horizontal_abs, and create a non-abs one
sub split_horizontal_abs {
  my $self = shift;
  my( @stops ) = @_;
  my @ret;

  my($y, $h) = ($self->{tl}->[1], ($self->{br}->[1] - $self->{tl}->[1]));
  for( my $i=0; $i<@stops; $i++) {
    my $xc = $stops[$i];
    my $nextx = $stops[$i+1];
    # last area fills to the right
    $nextx = $self->{br}->[0] unless defined($nextx);
    my $wc = ($nextx-$xc);
    push(@ret, $self->_spawn($xc,$y, $wc,$h));
  }
  return @ret;
}


# returns a list of new regions tiled into this one, with the given size
# may not fill this entire region (only whole regions will be created)
sub subdivide {
  my $self = shift;
  my( $w, $h ) = @_;
  my @ret = ();

  #w; warn "DIAG entering subd\n";

  my($xc,$yc) = @{$self->{tl}};
  while( $yc+$h <= $self->{br}->[1] ) {
    while( $xc+$w <= $self->{br}->[0] ) {
      push(@ret, $self->_spawn($xc,$yc,$w,$h));
      $xc += $w;
    }
    $xc = $self->{tl}->[0];
    $yc += $h;
  }

  return @ret;
}

# returns new region with coords relative to this one
sub area {
  my $self = shift;
  my( $x1,$y1, $x2,$y2 ) = @_;

  #w; warn "DIAG entering area ( $x1,$y1, $x2,$y2 )\n";

  my( $x,$y ) = ( $self->{tl}->[0]+$x1, $self->{tl}->[1]+$y1 );
  #w; warn "DIAG tl corner = ($x,$y)\n";
  # allow second (x,y) to be negative (=back off from br corner)
  my( $brx, $bry );
  if ( $x2<0 ) {
    $brx = $self->{br}->[0] + $x2;
  } else {
    $brx = $self->{tl}->[0] + $x2;
  }
  if ( $y2<0 ) {
    $bry = $self->{br}->[1] + $y2;
  } else {
    $bry = $self->{tl}->[1] + $y2;
  }
  #w; warn "DIAG br corner = ($x2,$y2)\n";
  my( $w,$h ) = ( $brx-$x, $bry-$y );

  # should warn here if warnings on and this w/h > $self->w/h
  #     or if the tlc>brc

  return $self->_spawn($x,$y,$w,$h);
}


# _spawn( $x,$y, $w,$h );
# x, y absolute
sub _spawn {
  my $self = shift;
  my( $x,$y,$w,$h ) = @_;

  my $new = ref($self)->new( $w,$h, {x=>$x, y=>$y} );
  foreach my $k (@_Keys) { # inherit parent's attributes
    $new->{$k} = $self->{$k};
  }
  push(@{$self->{_kids}}, $new);
  return $new;
}


# returns the coords of the top left, bottom right corners of this region
sub coords {
  my $self = shift;
  return (@{$self->{tl}}, @{$self->{br}});
}

sub width {
  my $self = shift;
  return $self->{br}->[0] - $self->{tl}->[0];
}

sub height {
  my $self = shift;
  return $self->{br}->[1] - $self->{tl}->[1];
}

sub top_left {
  my $self = shift;
  return @{$self->{tl}};
}

sub top_right {
  my $self = shift;
  return ($self->{br}->[0], $self->{tl}->[1]);
}

sub bottom_right {
  my $self = shift;
  return @{$self->{br}};
}

sub bottom_left {
  my $self = shift;
  return ($self->{tl}->[0], $self->{br}->[1]);
}

sub data {
  my $self = shift;
  if (defined(my $arg = shift)) {
    return $self->{data} = $arg;
  } else {
    return $self->{data};
  }
}

sub action {
  my $self = shift;
  my $subref = shift;

  push( @{$self->{_calls}}, $subref );
}

sub render {
  my $self = shift;

  foreach my $s (@{$self->{_calls}}) {
    $s->($self);
  }
  foreach my $child (@{$self->{_kids}}) {
    $child->render();
  }
}


1;
__END__