# Copyright 2010, 2011, 2012, 2019 Kevin Ryde

# This file is part of Image-Base-Imager.
#
# Image-Base-Imager 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-Imager 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-Imager.  If not, see <http://www.gnu.org/licenses/>.



# cf Imager::Draw -- drawing operations
# Seems to auto-clip to width,height.

package Image::Base::Imager;
use 5.004;
use strict;
use Carp;

# maybe Imager 0.39 of Nov 2001 for oop style tags, or something post 0.20
# for the oopery, but don't think need to force that here (just list in the
# Makefile.PL PREREQ_PM)
use Imager;

use vars '$VERSION', '@ISA';

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

$VERSION = 14;

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


# As of Imager 0.79 there's nothing to set the Zlib compression level for a
# -zlib_compression attribute.
#
# An -allow_partial could set allow_partial=> on read().
#

sub new {
  my ($class, %params) = @_;
  ### Image-Base-Imager new(): %params

  # $obj->new(...) means make a copy, with some extra settings
  if (ref $class) {
    my $self = $class;
    $class = ref $class;
    if (! defined $params{'-imager'}) {
      $params{'-imager'} = $self->get('-imager')->copy;
    }
    # inherit everything else
    %params = (%$self, %params);
    ### copy params: \%params
  }

  my $want_load = 1;
  if (! defined $params{'-imager'}) {
    my $width  = delete $params{'-width'};
    my $height = delete $params{'-height'};
    my $filename = $params{'-file'};
    if (! defined $filename) {
      # default 1x1 image since xsize=>undef,ysize=>undef is a 0x0
      # nothingness where settag() won't store -file_format
      if (! defined $width) { $width = 1; }
      if (! defined $height) { $height = 1; }
    }
    $params{'-imager'} = Imager->new (xsize => $width,
                                      ysize => $height,
                                      file  => $filename)
      || croak "Cannot create image: ",Imager->errstr;
    # set -file as filename, but have already loaded
    $want_load = 0;
  }
  my $self = bless {}, $class;
  $self->set (%params);

  if ($want_load && defined $params{'-file'}) {
    $self->load;
  }

  ### new made: $self
  return $self;
}


my %attr_to_tag = (-hotx => 'cur_hotspotx', # get and set
                   -hoty => 'cur_hotspoty',
                  );
my %attr_to_get_method = (-width    => 'getwidth',
                          -height   => 'getheight',
                          -ncolours => 'colorcount',
                          -file_format => \&_imager_get_file_format,
                         );
sub _get {
  my ($self, $key) = @_;
  ### Image-Base-Imager _get(): $key

  if (my $tag = $attr_to_tag{$key}) {
    ### $tag
    ### is: [$self->{'-imager'}->tags(name=>$tag)]
    return scalar(($self->{'-imager'}->tags(name=>$tag))[0]);
  }
  if (my $method = $attr_to_get_method{$key}) {
    ### $method
    ### is: $self->{'-imager'}->$method()
    return  $self->{'-imager'}->$method();
  }
  return $self->SUPER::_get ($key);
}
sub _imager_get_file_format {
  my ($i) = @_;
  ### _imager_get_file_format() from tags: [$i->tags]
  # tags() returns a list of the values
  return scalar(($i->tags (name => 'i_format'))[0]);
}

my %attr_to_img_set = (-width  => 'xsize',
                       -height => 'ysize',
                      );
sub set {
  my ($self, %param) = @_;
  ### Image-Base-Imager set(): \%param

  foreach my $key ('-ncolours') {
    if (exists $param{$key}) {
      croak "Attribute $key is read-only";
    }
  }

  # apply this first
  if (my $i = delete $param{'-imager'}) {
    $self->{'-imager'} = $i;
  }

  my $i = $self->{'-imager'};
  if (exists $param{'-file_format'}) {
    my $format = delete $param{'-file_format'};
    if (defined $format) { $format = lc($format); }
    ### apply -file_format with settag() i_format: $format
    $i->settag (name => 'i_format', value => $format);
    ### tags now: [$i->tags]
  }
  foreach my $key (keys %param) {
    if (my $tag = $attr_to_tag{$key}) {
      ### settag: $tag
      $i->settag (name => $tag, value => delete $param{$key});
      ### tags now: [$i->tags]
    }
  }

  my @set;
  foreach my $key (keys %param) {
    if (my $attribute = $attr_to_img_set{$key}) {
      push @set, $attribute, delete $param{$key};
    }
  }
  if (@set) {
    ### @set
    $i->img_set(@set);
  }

  %$self = (%$self, %param);
}

sub load {
  my ($self, $filename) = @_;
  ### Image-Base-Imager load(): @_
  if (@_ == 1) {
    $filename = $self->get('-file');
  } else {
    $self->set('-file', $filename);
  }
  my $i = $self->{'-imager'};
  $i->read (file => $filename)
    or croak "Cannot load: ",$i->errstr;
  ### $i
  ### size: $i->getwidth.'x'.$i->getheight
  ### tags: [$i->tags]
}

# not yet documented ...
sub load_fh {
  my ($self, $fh) = @_;
  my $i = $self->{'-imager'};
  $i->read (fh => $fh)
    or croak "Cannot load: ",$i->errstr;
}

sub save {
  my ($self, $filename) = @_;
  ### Image-Base-Imager save(): @_
  if (@_ == 2) {
    $self->set('-file', $filename);
  } else {
    $filename = $self->get('-file');
  }
  my $i = $self->{'-imager'};
  my $type = _imager_get_file_format($i);
  my $quality = $self->{'-quality_percent'};
  ### file: $filename
  ### type: $type

  # think it's ok to pass undef as $quality, and that the options can be
  # passed even when not saving to the respective formats
  $i->write (file => $filename,
             type => $type,
             jpegquality      => $quality,
             tiff_jpegquality => $quality)
    or croak "Cannot save: ",$i->errstr;
}

# not yet documented ...
sub save_fh {
  my ($self, $fh) = @_;
  my $i = $self->{'-imager'};
  $i->write (fh => $fh,
             type => _imager_get_file_format($i))
    or croak "Cannot save: ",$i->errstr;
}

sub xy {
  my ($self, $x, $y, $colour) = @_;
  ### Image-Base-Imager xy: $x,$y,$colour
  my $i = $self->{'-imager'};
  if (@_ == 4) {
    $i->setpixel (x => $x, y => $y, color => $colour);

  } else {
    my $cobj = $i->getpixel (x => $x, y => $y);
    if (! defined $cobj) {
      # getpixel() returns undef if x,y outside image size
      return undef;
    }
    my @rgba = $cobj->rgba;
    ### @rgba
    # if ($a == 0) {
    #   return 'None';
    # }
    return sprintf ('#%02X%02X%02X', @rgba[0,1,2]);
  }
}
sub line {
  my ($self, $x1, $y1, $x2, $y2, $colour) = @_;
  ### Image-Base-Imager line: @_
  $self->{'-imager'}->line (x1 => $x1,
                            y1 => $y1,
                            x2 => $x2,
                            y2 => $y2,
                            color => $colour);
}
sub rectangle {
  my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
  ### Image-Base-Imager rectangle: @_

  $self->{'-imager'}->box (xmin => $x1,
                           ymin => $y1,
                           xmax => $x2,
                           ymax => $y2,
                           color => $colour,
                           filled => $fill);
}

sub ellipse {
  my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
  ### Image-Base-Imager ellipse: "$x1, $y1, $x2, $y2, $colour"

  my $diam = $x2-$x1;
  if (! ($diam & 1) && $y2-$y1 == $diam) {
    ### use circle
    $self->{'-imager'}->circle (x => ($x2+$x1)/2,
                                y => ($y2+$y1)/2,
                                r => $diam/2,
                                color => $colour,
                                filled => $fill);
  } else {
    ### use superclass ellipse
    shift->SUPER::ellipse (@_);
  }
}

sub diamond {
  my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
  ### Image-Base-Imager diamond() ...

  # $imager->polygon() for filled poly is always anti-alias, but don't want
  # that, or not by default, so polyline() for unfilled and Image::Base for
  # filled

  if ($fill) {
    shift->SUPER::diamond(@_);

  } else {
    # 0 1 2 3 4
    # x1=0, x2=4 -> xh=2
    #
    # 0 1 2 3 4 5
    # x1=0, x2=5 -> xh=2
    #
    my $xh = ($x2 - $x1);
    my $yh = ($y2 - $y1);
    my $xeven = ($xh & 1);
    my $yeven = ($yh & 1);
    $xh = int($xh / 2);
    $yh = int($yh / 2);
    ### assert: $x1+$xh == $x2-$xh || $x1+$xh+1 == $x2-$xh
    ### assert: $y1+$yh == $y2-$yh || $y1+$yh+1 == $y2-$yh

    $self->{'-imager'}->polyline (points => [ [$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] : ()),
                                              ($fill ? () : [$x1+$xh,$y1]),
                                            ],
                                  color => $colour);
  }
}

#------------------------------------------------------------------------------
# colours

sub add_colours {
  my $self = shift;
  ### add_colours: @_
  $self->{'-imager'}->addcolors (colors => \@_);
}


# sub _validate_file_format {
#   my ($format) = @_;
#   if (! defined $format) {
#     return; # undef is ok
#   }
# 
#   # in Imager 0.80 'cur' works but isn't in the types lists
#   my $lform = lc($format);
#   foreach my $f ('cur', Imager->read_types, Imager->write_types) {
#     if ($lform eq $f) {
#       return;
#     }
#   }
# 
#   croak 'Unrecognised -file_format: ',$format;
# }

1;
__END__

=for stopwords PNG Imager filename Ryde Zlib Imager RGB JPEG PNM GIF BMP ICO Paletted paletted pre-load png jpeg imager hotspot Image-Base-Imager paletted non-paletted ie packbits

=head1 NAME

Image::Base::Imager -- draw images using Imager

=head1 SYNOPSIS

 use Image::Base::Imager;
 my $image = Image::Base::Imager->new (-width => 100,
                                       -height => 100);
 $image->rectangle (0,0, 99,99, 'white');
 $image->xy (20,20, 'black');
 $image->line (50,50, 70,70, '#FF00FF');
 $image->line (50,50, 70,70, '#0000AAAA9999');
 $image->save ('/some/filename.png');

=head1 CLASS HIERARCHY

C<Image::Base::Imager> is a subclass of C<Image::Base>,

    Image::Base
      Image::Base::Imager

=head1 DESCRIPTION

C<Image::Base::Imager> extends C<Image::Base> to create or
update image files using the C<Imager> module.

As of Imager 0.80 the supported file formats for read and write include the
following.  See L<Imager::Files> for the full list.

    PNG
    JPEG
    TIFF
    PNM
    GIF
    BMP
    ICO  (including CUR)

The Imager "raw" format is the image RGB bytes and nothing else.  It can't
be read with C<load()> here since the read requires size and further
parameters describing the data.  Writing a raw file with C<save()> works.

=head2 Colour Names

Colour names are anything recognised by C<Imager::Color>.  As of Imager 0.80
this means named colours from

    /usr/share/gimp/palettes/Named_Colors   GIMP, if available
    /usr/share/X11/rgb.txt                  X11, if available
    Imager::Color::Table                    copy of rgb.txt

Or hex forms

    "#RGB"
    "#RRGGBB"
    
An C<Imager::Color> object can also be given instead of a string.

=head2 Paletted Images

For a paletted image, if Imager is given a colour not already in the palette
then it converts the whole image to RGB.  C<Image::Base::Imager> doesn't try
do anything about that yet.  An C<add_colours()> can pre-load the palette.

The C<Image::Base> intention is just to throw colour names at drawing
functions, so perhaps C<Image::Base::Imager> should extend the palette when
necessary, or choose a close colour if full.  But an
C<$imager-E<gt>to_paletted()> after drawing might give close-colour merging
rather than allocating as drawing proceeds.

=head1 FUNCTIONS

See L<Image::Base/FUNCTIONS> for the behaviour common to all Image-Base
classes.

=over 4

=item C<$image = Image::Base::Imager-E<gt>new (key=E<gt>value,...)>

Create and return a new image object.  A new image can be started with
C<-width> and C<-height>,

    $image = Image::Base::Imager->new (-width => 200, -height => 100);

Or an existing file can be read,

    $image = Image::Base::Imager->new (-file => '/some/filename.png');

Or an C<Imager> object can be given,

    $image = Image::Base::Imager->new (-imager => $iobj);

=item C<$image-E<gt>ellipse ($x1,$y1, $x2,$y2, $colour, $fill)>

Draw an ellipse within the rectangle with top-left corner C<$x1>,C<$y1> and
bottom-right C<$x2>,C<$y2>.  Optional C<$fill> true means a filled ellipse.

In the current implementation circles with an odd number of pixels
(ie. width==height and odd) are drawn with Imager and ellipses and even
circles go to C<Image::Base>.  This is a bit inconsistent but uses the
features of Imager as far as possible and its drawing should be faster.

=item C<$i-E<gt>diamond ($x0, $y0, $x1, $y1, $colour)>

=item C<$i-E<gt>diamond ($x0, $y0, $x1, $y1, $colour, $fill)>

Draw a diamond shape within the rectangle top left C<$x0,$y0> and bottom
right C<$x1,$y1> using C<$colour>.  If optional argument C<$fill> is true
then the diamond is filled.

For reference, in the current implementation unfilled diamonds use the
Imager C<polyline()> but filled diamonds use the C<Image::Base> code since
the Imager filled C<polygon()> is always blurred by anti-aliasing and don't
want that (or not by default).

=item C<$image-E<gt>save ()>

=item C<$image-E<gt>save ($filename)>

Save to C<-file>, or with a C<$filename> argument set C<-file> then save to
that.

The file format is taken from C<-file_format> (see below) if that was set by
a C<load()> or explicit C<set()>, otherwise Imager follows the filename
extension.  In both cases if format or extension is unrecognised then
C<save()> croaks.

=item C<$image-E<gt>add_colours ($name, $name, ...)>

Add colours to the image palette.  Colour names are the same as to the
drawing functions.

    $image->add_colours ('red', 'green', '#FF00FF');

For a non-paletted image C<add_colours()> does nothing since in that case
each pixel has RGB component values, rather than an index into a palette.

=back

=head1 ATTRIBUTES

=over

=item C<-width> (integer)

=item C<-height> (integer)

Setting these changes the size of the image.

=item C<-imager>

The underlying C<Imager> object.

=item C<-file_format> (string or C<undef>)

The file format as a string like "png" or "jpeg"; or C<undef> if unknown or
never set.

After C<load()> the C<-file_format> is the format read.  Setting
C<-file_format> can change the format for a subsequent C<save()>.

This is held in the imager "i_format" tag and passed as the C<type> when
saving.  If C<undef> when saving then Imager will look at the filename
extension.

There's no attempt to check or validate the C<-file_format> value, since
it's possible to add new formats to Imager at run time.  Expect C<save()> to
croak if the format is unknown.

=item C<-hotx> (integer or C<undef>, default C<undef>)

=item C<-hoty> (integer or C<undef>, default C<undef>)

The cursor hotspot in CUR images (variant of ICO).  These are the
C<cur_hotspotx> and C<cur_hotspoty> tags in the Imager object.

=item C<-ncolours> (integer, read-only)

The number of colours allocated in the palette, or C<undef> on a
non-paletted image.  (The Imager C<colorcount()>.)

This is similar to the C<-ncolours> of C<Image::Xpm>.

=item C<-quality_percent> (0 to 100 or C<undef>)

The image quality when saving to JPEG format, or to TIFF format with jpeg
compression method.  JPEG compresses by reducing colours and resolution in
ways that are not too noticeable to the human eye.  100 means full quality,
no such reductions.  C<undef> means the Imager default, which is 75.

C<-quality_percent> becomes C<jpegquality> and C<tiff_jpegquality> options
to the Imager C<write()> (see L<Imager::Files/JPEG> and
L<Imager::Files/TIFF>).  TIFF is only affected if its C<tiff_compression>
tag is set to "jpeg" using Imager C<settag()> (the default is "packbits").

=back

There's no C<-zlib_compression> currently since believe Imager version 0.79
doesn't have anything to apply that to PNG saving.

=head1 SEE ALSO

L<Image::Base>,
L<Imager>

=head1 HOME PAGE

http://user42.tuxfamily.org/image-base-imager/index.html

=head1 LICENSE

Image-Base-Imager is Copyright 2010, 2011, 2012, 2019 Kevin Ryde

Image-Base-Imager 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-Imager 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-Imager.  If not, see <http://www.gnu.org/licenses/>.

=cut
