File Coverage

blib/lib/Curses/Toolkit/Object/Coordinates.pm

Criterion	Covered	Total	%
statement	15	147	10.2
branch	0	64	0.0
condition	0	21	0.0
subroutine	5	34	14.7
pod	19	24	79.1
total	39	290	13.4

#
# This file is part of Curses-Toolkit
#
# This software is copyright (c) 2011 by Damien "dams" Krotkine.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use warnings;
use strict;

package Curses::Toolkit::Object::Coordinates;
{
  $Curses::Toolkit::Object::Coordinates::VERSION = '0.211';
}
# ABSTRACT: simple coordinates class

use Params::Validate qw(SCALAR ARRAYREF HASHREF CODEREF GLOB GLOBREF SCALARREF HANDLE BOOLEAN UNDEF validate validate_pos);

use parent qw(Curses::Toolkit::Object);

use overload
    '+'  => '_clone_add',
    '-'  => '_clone_subtract',
    '""' => '_stringify',
    '==' => '_equals';


# -- attributes


# -- constructor, builder & initializer


# called before object is built, to normalize the arguments.
sub new {
    my $class  = shift;

    my %params;

    if ( ref($_[0]) && $_[0]->isa(__PACKAGE__) ) {
        # case: Coordinates->new( $clone );
        my $c    = $_[0];
        %params = (
            x1 => $c->{x1}, y1 => $c->{y1},
            x2 => $c->{x2}, y2 => $c->{y2},
            normalize => $c->{normalize},
        );
    } else {
        %params = @_;
        if ( exists $params{width} || exists $params{height} ) {
            # case: width and height arguments
            %params = validate( @_,
                {   x1        => { type => SCALAR }, y1     => { type => SCALAR },
                    width     => { type => SCALAR }, height => { type => SCALAR },
                    normalize => { type => BOOLEAN, default => 1 },
                }
            );
            $params{x2} = $params{x1} + $params{width};
            $params{y2} = $params{y1} + $params{height};
        } else {
            %params = validate( @_,
                {   x1 => { type => SCALAR|CODEREF }, y1 => { type => SCALAR|CODEREF },
                    x2 => { type => SCALAR|CODEREF }, y2 => { type => SCALAR|CODEREF },
                    normalize => { type => BOOLEAN, default => 1 },
                }
            );
        }

        foreach (qw( x1 x2 y1 y2 )) {
            ref $params{$_} eq 'CODE'
              or $params{$_} = int($params{$_});
        }
    }
    my $self = bless \%params, $class;
    $self->_normalize();
    return $self;
}


sub new_zero {
    my ($class) = @_;
    return $class->new(
        x1 => 0, y1 => 0,
        x2 => 0, y2 => 0
    );
}



sub clone {
    my ($self) = @_;
    return ref($self)->new($self);
}

sub get_x1 { my $v = shift->{x1}; ref $v eq 'CODE' ? $v->() : $v }
sub get_y1 { my $v = shift->{y1}; ref $v eq 'CODE' ? $v->() : $v }
sub get_x2 { my $v = shift->{x2}; ref $v eq 'CODE' ? $v->() : $v }
sub get_y2 { my $v = shift->{y2}; ref $v eq 'CODE' ? $v->() : $v }
sub get_normalize { shift->{normalize} }

# -- public methods


sub set {
    my $self   = shift;

    # checks on params
    my %params = validate(
        @_,
        {   x1 => { type => SCALAR | CODEREF, optional => 1 }, y1 => { type => SCALAR | CODEREF, optional => 1 },
            x2 => { type => SCALAR | CODEREF, optional => 1 }, y2 => { type => SCALAR | CODEREF, optional => 1 },
            normalize => { type => BOOLEAN, default => 1 },
        }
    );
    keys %params or die "One of (x1, y1, x2, y2, normalize) argument must be passed";

    # set the new coords
    foreach my $k ( keys %params ) {
        $self->{$k} = $params{$k};
    }
    $self->_normalize();
    return $self;
}



sub width {
    my ($self) = @_;
    return $self->get_x2() - $self->get_x1();
}



sub height {
    my ($self) = @_;
    return $self->get_y2() - $self->get_y1();
}



sub add {
    my ( $self, $c ) = @_;

    # FIXME: callbacks loose their coderef status

    if ( !ref $c ) {
        # argument is a constant
        @{$self}{qw(x1 y1 x2 y2)} = (
            $self->get_x1 + $c, $self->get_y1 + $c,
            $self->get_x2 + $c, $self->get_y2 + $c,
        );

    } elsif ( ref $c eq __PACKAGE__ ) {
        # argument is a coordinate object
        @{$self}{qw(x1 x2 y1 y2)} = (
            $self->get_x1 + $c->get_x1, $self->get_x2 + $c->get_x2,
            $self->get_y1 + $c->get_y1, $self->get_y2 + $c->get_y2,
        );

    } elsif ( ref $c eq 'HASH' ) {
        # argument is a hash
        while ( my ( $k, $v ) = each %$c ) {
            my $meth = "get_$k";
            $self->{$k} = $self->$meth + $v;
        }

    } else {
        die "Argument type ('" . ref($c) . "') is not supported in Coordinate addition";
    }
    $self->_normalize();
    return $self;
}



sub subtract {
    my ( $self, $c ) = @_;

    # FIXME: callbacks loose their coderef status

    if ( !ref $c ) {
        # argument is a constant
        @{$self}{qw(x1 y1 x2 y2)} = (
            $self->get_x1 - $c, $self->get_y1 - $c,
            $self->get_x2 - $c, $self->get_y2 - $c,
        );

    } elsif ( ref $c eq __PACKAGE__ ) {
        # argument is a coordinate object
        @{$self}{qw(x1 x2 y1 y2)} = (
            $self->get_x1 - $c->get_x1, $self->get_x2 - $c->get_x2,
            $self->get_y1 - $c->get_y1, $self->get_y2 - $c->get_y2,
        );

    } elsif ( ref $c eq 'HASH' ) {

        # argument is a hash
        while ( my ( $k, $v ) = each %$c ) {
            my $meth = "get_$k";
            $self->{$k} = $self->$meth - $v;
        }

    } else {
        die "Argument type ('" . ref($c) . "') is not supported in Coordinate addition";
    }
    $self->_normalize();
    return $self;
}



sub restrict_to {
    my $self = shift;
    my ($c) = validate_pos( @_, { isa => 'Curses::Toolkit::Object::Coordinates' } );

    $self->get_x1 < $c->get_x1 and $self->{x1} = $c->{x1};
    $self->get_x1 > $c->get_x2 and $self->{x1} = $c->{x2};

    $self->get_x2 > $c->get_x2 and $self->{x2} = $c->{x2};
    $self->get_x2 < $c->get_x1 and $self->{x2} = $c->{x1};

    $self->get_y1 < $c->get_y1 and $self->{y1} = $c->{y1};
    $self->get_y1 > $c->get_y2 and $self->{y1} = $c->{y2};

    $self->get_y2 > $c->get_y2 and $self->{y2} = $c->{y2};
    $self->get_y2 < $c->get_y1 and $self->{y2} = $c->{y1};

    $self->_normalize();

    return $self;
}



sub grow_to {
    my $self = shift;
    my ($c) = validate_pos( @_, { isa => 'Curses::Toolkit::Object::Coordinates' } );

    $self->get_x1 > $c->get_x1 and $self->{x1} = $c->{x1};
    $self->get_x2 < $c->get_x2 and $self->{x2} = $c->{x2};

    $self->get_y1 > $c->get_y1 and $self->{y1} = $c->{y1};
    $self->get_y2 < $c->get_y2 and $self->{y2} = $c->{y2};

    $self->_normalize();

    return $self;
}



sub translate {
    my $self = shift;

    # FIXME: callbacks loose their coderef status

    my %params = validate(
        @_,
        {   x => { type => SCALAR, optional => 1 },
            y => { type => SCALAR, optional => 1 },
        }
    );
    defined $params{x} || $params{y}
        or die "needs at least one of 'x' or 'y'";

    if ( defined $params{x} ) {
        $self->{x1} += $params{x};
        $self->{x2} += $params{x};
    }
    if ( defined $params{y} ) {
        $self->{y1} += $params{y};
        $self->{y2} += $params{y};
    }

    $self->_normalize();

    return $self;
}



sub translate_up {
    my ( $self, $value ) = @_;
    return $self->translate( y => -abs $value );
}



sub translate_down {
    my ( $self, $value ) = @_;
    return $self->translate( y => abs $value );
}



sub translate_left {
    my ( $self, $value ) = @_;
    return $self->translate( x => -abs $value );
}



sub translate_right {
    my ( $self, $value ) = @_;
    return $self->translate( x => abs $value );
}



sub contains {
    my $self = shift;
    my ($c) = validate_pos( @_, { isa => 'Curses::Toolkit::Object::Coordinates' } );
    return
           $self->get_x1() <= $c->get_x1()
        && $self->get_y1() <= $c->get_y1()
        && $self->get_x2() >= $c->get_x2()
        && $self->get_y2() >= $c->get_y2();
}



sub is_inside {
    my $self = shift;
    my ($c) = validate_pos( @_, { isa => 'Curses::Toolkit::Object::Coordinates' } );
    return $c->contains($self);
}



sub is_in_widget {
    my ( $self, $widget ) = @_;
    my $w_coord = $widget->get_coordinates();
    return
           $w_coord->get_x1 <= $self->get_x1
        && $w_coord->get_x2 >= $self->get_x2
        && $w_coord->get_y1 <= $self->get_y1
        && $w_coord->get_y2 >= $self->get_y2;
}


sub is_in_widget_visible_shape {
    my ( $self, $widget ) = @_;
    my $w_coord = $widget->get_visible_shape();
    return
           $w_coord->get_x1 <= $self->get_x1
        && $w_coord->get_x2 >= $self->get_x2
        && $w_coord->get_y1 <= $self->get_y1
        && $w_coord->get_y2 >= $self->get_y2;
}


# -- private methods

#
# my $c3 = $c1->_clone_add( $c2 );
# my $c3 = $c1 + $c2;   # overloaded
#
# clone a coord and add another to the new object.
#
sub _clone_add {
    my $self  = shift;
    my $clone = $self->clone();
    $clone->add(@_);
    return $clone;
}


#
# my $c3 = $c1->_clone_subtract( $c2 );
# my $c3 = $c1 - $c2;   # overloaded
#
# clone a coord and subtract another to the new object.
#
sub _clone_subtract {
    my $self  = shift;
    my $clone = $self->clone();
    $clone->subtract(@_);
    return $clone;
}


#
# my $bool = $c1->_equals( $c2 );
# my $bool = $c1 == $c2;    # overloaded
#
# return true if both $c1 and $c2 point to the same coords. they can
# point to different objects, though.
#
sub _equals {
    my ( $c1, $c2 ) = @_;
    return
           $c1->get_x1 == $c2->get_x1
        && $c1->get_y1 == $c2->get_y1
        && $c1->get_x2 == $c2->get_x2
        && $c1->get_y2 == $c2->get_y2;
}


#
# my $str = $self->_stringify;
# my $str = "$self";     # overloaded
#
# return the string 'WxH+XxY' with:
#   W = width
#   H = height,
#   X = top left x coord
#   Y = top left y coord
#
sub _stringify {
    my ($self) = @_;
    return $self->width . 'x' . $self->height . '+' . $self->get_x1 . 'x' . $self->get_y1;
}


#
# $self->_normalize;
#
# make sure the coordinate is positive. in effect:
#  - swap x1 and x2 to make sure x1 <= x2
#  - swap y1 and y2 to make sure y1 <= y2
#
sub _normalize {
    my ($self) = @_;
    $self->get_normalize() or return;
    $self->get_x1() <= $self->get_x2() or ( $self->{x1}, $self->{x2} ) = ( $self->{x2}, $self->{x1} );
    $self->get_y1() <= $self->get_y2() or ( $self->{y1}, $self->{y2} ) = ( $self->{y2}, $self->{y1} );
    return;
}

1;

__END__