File Coverage

blib/lib/Image/Base/Prima/Drawable.pm

Criterion	Covered	Total	%
statement	15	87	17.2
branch	0	40	0.0
condition	0	12	0.0
subroutine	5	15	33.3
pod	7	8	87.5
total	27	162	16.6

# Copyright 2010, 2011, 2012, 2015 Kevin Ryde

# This file is part of Image-Base-Prima.
#
# Image-Base-Prima is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# Image-Base-Prima is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Image-Base-Prima.  If not, see .


# Prima::Drawable -- drawing operations
#
# fillpoly()
# polyline()
#
# Crib: think automatic clip to 2^15 or so ...

package Image::Base::Prima::Drawable;
use 5.005;
use strict;
use Carp;
use vars '$VERSION', '@ISA';

use Image::Base;
@ISA = ('Image::Base');

$VERSION = 9;

# uncomment this to run the ### lines
#use Devel::Comments '###';

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

my %get_methods = (-width  => 'width',
                   -height => 'height',
                   # these two not documented yet
                   -depth  => 'get_bpp',
                   -bpp    => 'get_bpp',
                  );
sub _get {
  my ($self, $key) = @_;
  ### Prima-Drawable _get(): $key
  if (my $method = $get_methods{$key}) {
    return $self->{'-drawable'}->$method;
  }
  return $self->SUPER::_get($key);
}

sub set {
  my ($self, %params) = @_;
  my $width  = delete $params{'-width'};
  my $height = delete $params{'-height'};

  %$self = (%$self, %params);

  my $drawable = $self->{'-drawable'};
  if (defined $width) {
    if (defined $height) {
      $drawable->size ($width, $height);
    } else {
      $drawable->width ($width);
    }
  } elsif (defined $height) {
    $drawable->height ($height);
  }
}

sub xy {
  my ($self, $x, $y, $colour) = @_;
  my $drawable = $self->{'-drawable'};
  $y = $drawable->height - 1 - $y;
  if (@_ == 4) {
    #### xy store: $x,$y
    $drawable->pixel ($x,$y, $self->colour_to_pixel($colour));
  } else {
    #### fetch: $x,$y
    return sprintf '#%06X', $drawable->pixel($x,$y);
  }
}

sub line {
  my ($self, $x1,$y1, $x2,$y2, $colour) = @_ ;
  ### Image-Base-Prima-Drawable line(): "$x1,$y1, $x2,$y2"
  my $y_top = $self->{'-drawable'}->height - 1;
  _set_colour($self,$colour)->line ($x1, $y_top-$y1,
                                    $x2, $y_top-$y2);
}

sub rectangle {
  my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;

  # In Prima 1.28 under X, if lineWidth==0 then a one-pixel unfilled
  # rectangle x1==x2 and y1==y2 draws nothing.  This will be just the usual
  # server-dependent behaviour on a zero-width line.  Use bar() for this
  # case so as to be sure of getting pixels drawn whether lineWidth==0 or
  # lineWidth==1.
  #
  my $method = ($fill || ($x1==$x2 && $y1==$y2)
                ? 'bar'
                : 'rectangle');
  my $y_top = $self->{'-drawable'}->height - 1;
  ### Image-Base-Prima-Drawable rectangle(): $method
  _set_colour($self,$colour)->$method ($x1, $y_top - $y1,
                                       $x2, $y_top - $y2);
}
sub ellipse {
  my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;

  # In Prima 1.28 under X, if lineWidth==0 then a one-pixel ellipse x1==x2
  # and y1==y2 draws nothing, the same as for an unfilled rectangle above.
  # Also trouble with diameter==1 when filled draws one pixel short at the
  # right.  Do any width<=2 or height<=2 as a rectangle.
  #
  my $drawable = _set_colour($self,$colour);
  my $y_top = $drawable->height - 1;
  my $dx = $x2-$x1+1; # diameters
  my $dy = $y2-$y1+1;
  if ($dx <= 2 || $dy <= 2) {
    $drawable->bar ($x1, $y_top - $y1,
                    $x2, $y_top - $y2);
  } else {
    # For an even diameter the X,Y centre is rounded down to the next lower
    # integer.  (To be documented in a Prima post 1.28, perhaps.)  For the Y
    # coordinate that rounding down can be applied after flipping $y_top-$y1
    # puts Y=0 at the bottom per Prima coordinates.
    #
    my $method = ($fill ? 'fill_ellipse' : 'ellipse');

    ### Prima ellipse()
    ### $dx
    ### $dy
    ### x centre: $x1 + int(($dx-1)/2)
    ### y centre: ($y_top - $y1) - int($dy/2)
    ### $method

    $drawable->$method ($x1 + int(($dx-1)/2),
                        ($y_top - $y1) - int($dy/2),
                        $dx, $dy);
  }
}

sub diamond {
  my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
  ### Drawable diamond(): $x1, $y1, $x2, $y2, $colour

  my $drawable = $self->{'-drawable'};
  $y1 = $drawable->height - 1 - $y1;
  $y2 = $drawable->height - 1 - $y2;

  if ($x1==$x2 && $y1==$y2) {
    # 1x1 polygon draws nothing, do it as a point instead
    $drawable->pixel ($x1,$y1, $self->colour_to_pixel($colour));

  } else {
    _set_colour($self,$colour);

    my $xh = ($x2 - $x1);
    my $yh = ($y1 - $y2);   # y1 bigger
    my $xeven = ($xh & 1);
    my $yeven = ($yh & 1);
    $xh = int($xh / 2);
    $yh = int($yh / 2);
    ### assert: $x1+$xh+$xeven == $x2-$xh
    ### assert: $y2+$yh+$yeven == $y1-$yh

    my $poly = [$x1+$xh, $y1,  # top centre

                # left
                $x1, $y1-$yh,
                ($yeven ? ($x1, $y2+$yh) : ()),

                # bottom
                $x1+$xh, $y2,
                ($xeven ? ($x2-$xh, $y2) : ()),

                # right
                ($yeven ? ($x2, $y2+$yh) : ()),
                $x2, $y1-$yh,

                ($xeven ? ($x2-$xh, $y1) : ()),
                $x1+$xh, $y1];  # back to start in X11 PolyLine style
    if ($fill) {
      $drawable->fillpoly ($poly) or croak $@;
    }
    $drawable->polyline ($poly) or croak $@;
  }
}

sub _set_colour {
  my ($self, $colour) = @_;
  my $drawable = $self->{'-drawable'};
  if ($colour ne $self->{'_set_colour'}) {
    ### Image-Base-Prima-Drawable _set_colour() change to: $colour
    $self->{'_set_colour'} = $colour;
    $drawable->color ($self->colour_to_pixel ($colour));
  }
  return $drawable;
}

# not documented yet
sub colour_to_pixel {
  my ($self, $colour) = @_;
  ### colour_to_pixel(): $colour

  # Crib: [:xdigit:] new in 5.6, so only 0-9A-F, and in any case as of perl
  # 5.12.4 [:xdigit:] matches some wide chars but hex() doesn't accept them
  if ($colour =~ /^#([0-9A-F]{6})$/i) {
    return hex(substr($colour,1));
  }
  if ($colour =~ /^#([0-9A-F]{2})[0-9A-F]{2}([0-9A-F]{2})[0-9A-F]{2}([0-9A-F]{2})[0-9A-F]{2}$/i) {
    return hex($1.$2.$3);
  }

  (my $c = $colour) =~ s/^cl:://;
  if (my $coderef = (cl->can($c) || cl->can(ucfirst($c)))) {
    ### coderef: &$coderef()
    return &$coderef();
  }

  ### $c
  croak "Unrecognised colour: $colour";
}

# is prima_allocate_color() meant to be public?  It's not normally reached
# unless in a paint anyway ...
#
# sub add_colours {
#  ...
# }

1;
__END__