# MyTestImageBase.pm -- some tests for Image::Base subclasses

# Copyright 2010, 2011, 2012 Kevin Ryde

# MyTestImageBase.pm is shared by several distributions.
#
# MyTestImageBase.pm 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.
#
# MyTestImageBase.pm 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 this file.  If not, see <http://www.gnu.org/licenses/>.


# wide/high ellipse cases
# fill check no gaps
# fill check concave


package MyTestImageBase;
BEGIN { require 5 }
use strict;

use vars '$white', '$white_expect', '$black', '$skip', '$handle_input';
$white = 'white';
$black = 'black';
$skip = undef;
$handle_input = sub {};

use vars '@CARP_NOT';
@CARP_NOT = ('Test');

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


sub min {
  my $ret = shift;
  while (@_) {
    my $n = shift;
    if ($ret > $n) {
      $ret = $n;
    }
  }
  return $ret;
}
sub max {
  my $ret = shift;
  while (@_) {
    my $n = shift;
    if ($ret < $n) {
      $ret = $n;
    }
  }
  return $ret;
}

sub is {
  &$handle_input();
  if (eval { Test::More->can('is') }) {
    if (defined $skip) {
    SKIP: {
        &Test::More::skip ($skip, 1); # no prototypes
      }
    } else {
      &Test::More::is (@_); # no prototypes
    }
  } else {
    &Test::skip ($skip, @_); # no prototypes
  }
  # if (Test->can('is')) {
  #   } else {
  #     die "Oops, neither Test nor Test::More loaded";
  #   }
}

sub mung_colour {
  my ($colour) = @_;
  if ($colour eq '#000000' || $colour eq '#000000000000') {
    return $black;
  }
  if ($colour eq '#FFFFFF' || $colour eq '#FFFFFFFFFFFF') {
    return $white;
  }
  return $colour;
}

sub dump_image {
  my ($image) = @_;
  if (defined $skip) {
    return;
  }
  require MyTestHelpers;
  my $width = $image->get('-width');
  my $height = $image->get('-height');
  MyTestHelpers::diag("dump_image");
  my $y;
  foreach $y (0 .. $height-1) {
    my $str = '';
    my $x;
    foreach $x (0 .. $width-1) {
      my $colour = $image->xy($x,$y);
      if (! defined $colour) {
        $str .= 'U';
      } else {
        $colour = mung_colour($colour);
        if ($colour eq $black) {
          $str .= '_';
        } else {
          $str .= substr ($colour, 0,1);
        }
      }
    }
    MyTestHelpers::diag($str);
  }

  if (my $canvas = $image->get('-tkcanvas')) {
    my @items = $canvas->find('all');
    MyTestHelpers::diag("item count ",scalar(@items));
    my $item;
    foreach $item (@items) {
      my $type = $canvas->type($item);
      my @coords = $canvas->coords($item);
      my @opts;
      my $spec;
      foreach $spec ($canvas->itemconfigure($item)) {
        my $key = $spec->[0];
        if ($key eq '-fill') {
          my $value = $canvas->itemcget($item,$key);
          if (! defined $value) { $value = '[undef]'; }
          push @opts, " $key=$value";
        }
      }
      MyTestHelpers::diag("item $item $type @opts ",join(',',@coords));
    }
  }
}

#-----------------------------------------------------------------------------

sub is_pixel {
  my ($image, $x,$y, $colour, $name) = @_;
  my $width = $image->get('-width');

  my $got = mung_colour($image->xy($x,$y));
  is ($got, $colour,
      "pixel $x,$y  $colour  on $name");
  my $bad = ($got ne $colour);
  ### $bad
  return $bad;
}

sub is_hline {
  my ($image, $x1,$x2, $y, $colour, $name) = @_;
  return 0 if $x1 > $x2;
  my $width = $image->get('-width');
  return 0 if $y < 0 || $y >= $image->get('-height');
  return 0 if $x2 < 0 || $x1 >= $width;

  my $bad = 0;
  my $x;
  foreach $x (max(0,$x1) .. min($x2,$width-1)) {
    my $got = mung_colour($image->xy($x,$y));
    is ($got, $colour,
        "hline $x,$y  $colour  on $name");
    $bad += ($got ne $colour);
  }
  ### $bad
  return $bad;
}

sub is_vline {
  my ($image, $x, $y1,$y2, $colour, $name) = @_;
  return 0 if $y1 > $y2;
  return 0 if $x < 0 || $x >= $image->get('-width');
  my $height = $image->get('-height');
  return 0 if $y2 < 0 || $y1 >= $height;

  my $bad = 0;
  my $y;
  foreach $y (max(0,$y1) .. min($y2,$height-1)) {
    my $got = mung_colour($image->xy($x,$y));
    is ($got, $colour,
        "vline x=$x,y=$y want $colour  on $name");
    $bad += ($got ne $colour);
  }
  ### $bad
  return $bad;
}

sub is_rect {
  my ($image, $x1,$y1, $x2,$y2, $colour, $name) = @_;
  if ($x1 > $x2 || $y1 > $y2) {
    return 0;
  }
  my $bad = is_hline ($image, $x1,$x2, $y1, $colour, $name);
  if ($y2 != $y1) {
    $bad += is_hline ($image, $x1,$x2, $y2, $colour, $name);
  }
  $bad += is_vline ($image, $x1, $y1+1,$y2-1, $colour, $name);
  if ($x2 != $x1) {
    $bad += is_vline ($image, $x2, $y1+1,$y2-1, $colour, $name);
  }
  return $bad;
}

sub is_filled_rect {
  my ($image, $x1,$y1, $x2,$y2, $colour, $name) = @_;
  my $bad = 0;
  my $y;
  foreach $y ($y1 .. $y2) {
    $bad += is_hline ($image, $x1,$x2, $y, $colour, $name);
  }
  return $bad;
}

# demand that one or more pixels in hline have $colour
sub some_hline {
  my ($image, $x1,$x2, $y, $colour, $name) = @_;
  my $bad = 1;
  ($x1,$x2) = ($x2,$x1) if $x1 > $x2;
  my $x;
  foreach $x ($x1 .. $x2) {
    ### some_hline look at: "$x,$y"
    my $got = mung_colour($image->xy($x,$y));
    if ($got eq $colour) {
      $bad = 0;
      last;
    }
  }
  is ($bad, 0,
      "some_hline x=$x1..$x2,y=$y  $colour  on $name");
  return $bad;
}

sub some_vline {
  my ($image, $x, $y1,$y2, $colour, $name) = @_;
  my $bad = 1;
  ($y1,$y2) = ($y2,$y1) if $y1 > $y2;
  my $y;
  foreach $y ($y1 .. $y2) {
    my $got = mung_colour($image->xy($x,$y));
    if ($got eq $colour) {
      $bad = 0;
      last;
    }
  }
  is ($bad, 0,
      "some_vline x=$x,y=$y1..$y2  $colour  on $name");
  return $bad;
}

# demand that all pixels $x1 to $x2 inclusive have $colour
sub all_hline {
  my ($image, $x1,$x2, $y, $colour, $name) = @_;
  my $bad = 0;
  ($x1,$x2) = ($x2,$x1) if $x1 > $x2;
  my $x;
  foreach $x ($x1 .. $x2) {
    ### all_hline look at: "$x,$y c=".$image->xy($x,$y)
    my $got = mung_colour($image->xy($x,$y));
    if ($got ne $colour) {
      $bad = 1;
    }
  }
  is ($bad, 0,
      "all_hline x=$x1..$x2,y=$y  $colour  on $name");
  return $bad;
}

# demand that all pixels $y1 to $y2 inclusive have $colour
sub all_vline {
  my ($image, $x, $y1,$y2, $colour, $name) = @_;
  my $bad = 0;
  ($y1,$y2) = ($y2,$y1) if $y1 > $y2;
  my $y;
  foreach $y ($y1 .. $y2) {
    ### all_hline look at: "$x,$y"
    my $got = mung_colour($image->xy($x,$y));
    if ($got ne $colour) {
      $bad = 1;
    }
  }
  is ($bad, 0,
      "all_vline x=$x,y=$y1..$y2  $colour  on $name");
  return $bad;
}


#-----------------------------------------------------------------------------

my @sizes = ([0,0, 0,0],    # 1x1
             [5,7, 5,7],

             [3,2, 4,2],    # thin horiz
             [3,2, 13,2],
             [3,3, 4,3],
             [3,3, 13,3],

             [5,2, 5,3],    # thin vert
             [5,2, 5,9],
             [6,2, 6,3],
             [6,2, 6,9],

             [1,1, 2,2],    # 2x2
             [5,6, 7,8],

             [1,1, 18,8],   # big
            );

sub check_xy {
  my ($image, %options) = @_;
  ### check_xy() ...
  my $big_fetch_expect = $options{'big_fetch_expect'};

  {
    my $big_negative = -2**16 + 2;
    ### $big_negative
    # exercise some negatives
    $image->xy ($big_negative,0, $white);
    $image->xy (0,$big_negative, $white);
    $image->xy ($big_negative,$big_negative, $white);
    is (scalar($image->xy($big_negative,$big_negative)), $big_fetch_expect,
        'xy() negative fetch');
    is (scalar($image->xy(0,$big_negative)), $big_fetch_expect,
        'xy() negative fetch');
    is (scalar($image->xy($big_negative,0)), $big_fetch_expect,
        'xy() negative fetch');
  }
  {
    my $big_positive = 2**16 + 2;
    ### $big_positive
    $image->xy ($big_positive,$big_positive, $white);
    $image->xy (0,$big_positive, $white);
    $image->xy ($big_positive,0, $white);
    is (scalar($image->xy(0,$big_positive)), $big_fetch_expect,
        'xy() big positive fetch');
    is (scalar($image->xy($big_positive,0)), $big_fetch_expect,
        'xy() big positive fetch');
    is (scalar($image->xy($big_positive,$big_positive)), $big_fetch_expect,
        'xy() big positive fetch');
  }
}

sub check_line {
  my ($image, %options) = @_;
  my ($width, $height) = $image->get('-width','-height');
  my $image_clear_func = $options{'image_clear_func'};

  my $elem;
  foreach $elem (@sizes) {
    my ($x1,$y1, $x2,$y2) = @$elem;

    {
      my $name = "line $x1,$y1 $x2,$y2";
      &$image_clear_func();
      $image->line ($x1,$y1, $x2,$y2, $white);

      my $bad = (
                 # endpoints
                 is_pixel ($image, $x1,$y1, $white, $name)
                 + is_pixel ($image, $x2,$y2, $white, $name)

                 # nothing in surrounding rectangle
                 + is_rect ($image, $x1-1,$y1-1, $x2+1,$y2+1, $black, $name));
      if ($bad) {
        dump_image ($image);
      }
    }
    {
      my $name = "line $x2,$y2 $x1,$y1, reversal";
      &$image_clear_func();
      $image->line ($x2,$y2, $x1,$y1, $white);

      my $bad = (
                 # endpoints
                 is_pixel ($image, $x1,$y1, $white, $name)
                 + is_pixel ($image, $x2,$y2, $white, $name)

                 # nothing in surrounding rectangle
                 + is_rect ($image, $x1-1,$y1-1, $x2+1,$y2+1, $black, $name));
      if ($bad) {
        dump_image ($image);
      }
    }
  }
}

sub rect_using_Other {
  my ($image, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
  $image->Image_Base_Other_rectangles ($colour, $fill, $x1, $y1, $x2, $y2);
}

sub check_rectangle {
  my ($image, %options) = @_;
  my ($width, $height) = $image->get('-width','-height');
  my $image_clear_func = $options{'image_clear_func'};

  my $method;
  foreach $method ('rectangle',
                   ($image->can('Image_Base_Other_rectangles')
                    ? ('MyTestImageBase::rect_using_Other')
                    : ())) {

    # exercise some negatives
    foreach my $fill (0,1) {
      $image->$method (-100,-100,-10,-10, $white, $fill);
      $image->$method (-100,-100,5,5, $white, $fill);
      $image->$method (5,5,200,200, $white, $fill);
    }


    my $elem;
    foreach $elem (@sizes) {
      my ($x1,$y1, $x2,$y2) = @$elem;

      {
        my $name = "$method unfilled $x1,$y1, $x2,$y2";
        my $fill = undef;
        &$image_clear_func();

        my @args = ($x1,$y1, $x2,$y2, $white, $fill);
        if ($method eq 'Image_Base_Other_rectangles') {
          unshift @args, splice @args, -2, 2;
        }
        $image->$method (@args);

        my $bad
          = (is_rect ($image, $x1,$y1, $x2,$y2, $white_expect, $name)
             # outside
             + is_rect ($image, $x1-1,$y1-1, $x2+1,$y2+1, $black, $name)
             # inside
             + is_rect ($image, $x1+1,$y1+1, $x2-1,$y2-1, $black, $name));
        if ($bad) { dump_image($image); }
      }
      {
        my $name = "$method filled $x1,$y1, $x2,$y2";
        my $fill = 123;
        &$image_clear_func();

        my @args = ($x1,$y1, $x2,$y2, $white, $fill);
        if ($method eq 'Image_Base_Other_rectangles') {
          unshift @args, splice @args, -2, 2;
        }
        $image->$method (@args);

        my $bad
          = (is_filled_rect ($image, $x1,$y1, $x2,$y2, $white_expect, $name)
             # outside
             + is_rect ($image, $x1-1,$y1-1, $x2+1,$y2+1, $black, $name));
        if ($bad) { dump_image($image); }
      }
    }
  }
}

sub check_ellipse {
  my ($image, %options) = @_;
  my ($width, $height) = $image->get('-width','-height');
  my $image_clear_func = $options{'image_clear_func'};
  my $basefunc = $options{'base_ellipse_func'} || sub { 0 };

  my $elem;
  foreach $elem (@sizes) {
    my ($x1,$y1, $x2,$y2) = @$elem;

    my $fillaref;
    foreach $fillaref ([], [1]) {
      my $fill = ($fillaref->[0] || 0);
      my $name = "ellipse $x1,$y1, $x2,$y2, fill=$fill";
      # MyTestHelpers::diag($name);

      # if ($options{'base_ellipse'}
      #     || $basefunc->($x1,$y1, $x2,$y2)) {
      #   next if $name eq 'ellipse 3,2, 4,2';   # dodgy
      #   next if $name eq 'ellipse 3,2, 13,2';  # dodgy
      #   next if $name eq 'ellipse 1,1, 18,8';  # dodgy
      #   next if $name eq 'ellipse 3,3, 4,3';   # dodgy
      #   next if $name eq 'ellipse 1,1, 2,2';   # dodgy
      #   next if $name eq 'ellipse 3,3, 13,3';  # dodgy
      # }

        &$image_clear_func();
      $image->ellipse ($x1,$y1, $x2,$y2, $white, @$fillaref);

      my $bad = some_hline ($image, $x1,$x2, $y1, $white_expect, $name);
      if ($y2 != $y1) {
        $bad += some_hline ($image, $x1,$x2, $y2, $white_expect, $name);
      }
      $bad += some_vline ($image, $x1, $y1,$y2, $white_expect, $name);
      if ($x2 != $x1) {
        $bad += some_vline ($image, $x2, $y1,$y2, $white_expect, $name);
      }
      $bad += is_rect ($image, $x1-1,$y1-1, $x2+1,$y2+1, $black, $name);

      if ($fill) {
        $bad += (all_hline ($image, $x1,$x2, int(($y1+$y2)/2), $white_expect,$name)
                 + all_hline ($image, $x1,$x2, int(($y1+$y2+1)/2), $white_expect,$name)
                 + all_vline ($image, int(($x1+$x2)/2), $y1,$y2, $white_expect,$name)
                 + all_vline ($image, int(($x1+$x2+1)/2), $y1,$y2, $white_expect,$name)
                );
      }
      if ($bad) { dump_image($image); }
    }
  }
}

sub check_diamond {
  my ($image, %options) = @_;
  MyTestHelpers::diag("check_diamond()");

  $options{'image_clear_func'} ||= do {
    my ($width, $height) = $image->get('-width','-height');
    sub {
      $image->rectangle (0,0, $width-1,$height-1, $black, 1);
    }
  };

  my ($width, $height) = $image->get('-width','-height');
  my $image_clear_func = $options{'image_clear_func'};
  local $white_expect = $white_expect || $white;

  my $elem;
  foreach $elem (@sizes) {
    my ($x1,$y1, $x2,$y2) = @$elem;

    my $fillaref;
    foreach $fillaref ([],
                       ($options{'skip_fill'} ? () : ([1])),
                      ) {
      my $fill = ($fillaref->[0] || 0);
      my $name = "diamond $x1,$y1, $x2,$y2, fill=$fill";
      # MyTestHelpers::diag($name);

      &$image_clear_func();
      $image->diamond ($x1,$y1, $x2,$y2, $white, @$fillaref);

      my $bad;

      if ($options{'pngwriter_exceptions'} && $fill) {
        # dodgy top line of filled filleddiamond()
      } else {
        $bad = some_hline ($image, $x1,$x2, $y1, $white_expect, $name);
      }
      if ($y2 != $y1) {
        $bad += some_hline ($image, $x1,$x2, $y2, $white_expect, $name);
      }

      if ($options{'pngwriter_exceptions'}
          && $fill && $x1+1==$x2 && $y1+1==$y2) {
        # dodgy left side of 2x2 filleddiamond()
      } else {
        $bad += some_vline ($image, $x1, $y1,$y2, $white_expect, $name);
      }
      if ($x2 != $x1) {
        $bad += some_vline ($image, $x2, $y1,$y2, $white_expect, $name);
      }

      $bad += is_rect ($image, $x1-1,$y1-1, $x2+1,$y2+1, $black, $name);
      if ($bad) { dump_image($image); }
    }
  }
}

sub check_image {
  my ($image, %options) = @_;
  MyTestHelpers::diag("check_image()");

  local $white_expect = $white_expect || $white;

  $options{'image_clear_func'} ||= do {
    my ($width, $height) = $image->get('-width','-height');
    sub {
      $image->rectangle (0,0, $width-1,$height-1, $black, 1);
      # { print "blank to\n"; dump_image($image); }
    }
  };

  ### $white
  ### $black
  ### $white_expect

  check_xy ($image, %options);
  check_line ($image, %options);
  check_rectangle ($image, %options);
  check_ellipse ($image, %options);
}

1;
__END__