Experimental Image::BoxFind module:    Image/t/04-dump_rects-is_rect-is_rect_list.t

     # Test created outside of h2xs framework.
# Run this like so: `perl Image-BoxFind.t'
#   doom@kzsu.stanford.edu     2007/10/13 03:50:28

#########################

# change 'tests => 1' to 'tests => last_test_to_print';

use warnings;
use strict;
$|=1;
my $DEBUG = 1;
use Data::Dumper;

use Test::More;
BEGIN { plan tests => 9 };

use FindBin qw( $Bin );
use lib "$Bin/../..";
my $lib = "$Bin/../..";

BEGIN {
  use_ok( 'Image::BoxFind' );
}

### TODO
### work over new primitives:
###
### print_box_to_string
### is_aref_three_deep
### is_aref_two_deep
### is_dupe_box_list_croaker


{
  my $test_name = "print_box_to_string";
  my $bf = Image::BoxFind->new( {
                                  DEBUG       => $DEBUG,
                                } );

  my ($r1, $r2, $text1, $expect1, $text2, $expect2);

  $r1 = [ [9, 3], [9, 29], [29, 29], [29, 3] ];
  $r2 = [ [8, 4], [10, 28], [28, 30], [30, 4] ];

  $text1 = $bf->print_box_to_string( $r1 );
  # print "text:>>$text1<<\n";

  $expect1 = "(    9,    3 ), (    9,   29 ), (   29,   29 ), (   29,    3 )";

  is( $text1, $expect1, "Testing $test_name: $text1");

  $text2 = $bf->print_box_to_string( $r2 );
  # print "text: $text2\n";

  $expect2 = "(    8,    4 ), (   10,   28 ), (   28,   30 ), (   30,    4 )";

  is( $text2, $expect2, "Testing )$test_name: $text2");

  my $code = define_code(); # print_box
  my $cmd = define_cmd( $code );
  chomp(
        my $ret = `$cmd`
        );
  # print "ret: $ret\n";

  is( $ret, $expect1, "print_box: $text1");

}

{
  my $test_name = "dump_boxes_to_string";
  my $rl1 = define_rectangle_list_1();
  my $expected =<< "EXPECTORANT";
(    2,    5 ), (    0,    8 ), (    1,    1 ), (    0,    5 )
(   20,   66 ), (   20,   99 ), (  130,   99 ), (  130,   66 )
(  200,  500 ), (    0,  800 ), (  100,  100 ), (    0,  500 )
( 1520,  564 ), (  518,  601 ), (  630,  603 ), (  628,  562 )
EXPECTORANT

  my $bf = Image::BoxFind->new( {
                                  DEBUG       => $DEBUG,
                                } );

  my $text = $bf->dump_boxes_to_string( $rl1 );
  #print ">>\n$text<<\n";
  is( $text, $expected, "Testing $test_name");
}


{
  my $test_name = "is_aref_two_deep";
  my $bf = Image::BoxFind->new( {
                                  DEBUG       => $DEBUG,
                                } );
  my $ret;
  my $r1 = [ [9, 3], [9, 29], [29, 29], [29, 3] ];
  $ret = $bf->is_aref_two_deep( $r1 );
  is( $ret, 1, "Testing $test_name: yes, this is a rectangle");

  my $rl1 = define_rectangle_list_1();
  $ret = $bf->is_aref_two_deep( $rl1 );
  is( $ret, undef, "Testing $test_name: no, this is a rectangle list");
}


{
  my $test_name = "is_aref_three_deep";
  my $bf = Image::BoxFind->new( {
                                  DEBUG       => $DEBUG,
                                } );
  my $ret;
  my $rl1 = define_rectangle_list_1();
  $ret = $bf->is_aref_three_deep( $rl1 );
  is( $ret, 1, "Testing $test_name: yes, this is a rectangle list");

  my $r1 = [ [9, 3], [9, 29], [29, 29], [29, 3] ];
  $ret = $bf->is_aref_three_deep( $r1 );
  is( $ret, undef, "Testing $test_name: no, this is a rectangle");

}

### TODO add some harder cases -- if you can think of any --
### and tune up the code to cover them... if you care.




### heredoc ghetto

# code snippet, sends print_box output to STDOUT
sub define_code {
  my $code =<<'PERL';
  my $bf = Image::BoxFind->new;
  $bf->print_box( [ [9, 3], [9, 29], [29, 29], [29, 3] ] );
PERL
  return $code;
}

sub define_cmd {
  my $code = shift;
  my $cmd = "perl -I$lib -MImage::BoxFind -e'$code'";
  return $cmd;
}

sub define_rectangle_list_1 {
  my $expected =
    [
     [ [ 2, 5 ],
       [ 0, 8 ],
       [ 1, 1 ],
       [ 0, 5 ]
     ],
     [ [ 20, 66 ],
       [ 20, 99 ],
       [ 130, 99 ],
       [ 130, 66 ]
     ],
     [ [ 200, 500 ],
       [ 0, 800 ],
       [ 100, 100 ],
       [ 0, 500 ]
     ],
     [ [ 1520, 564 ],
       [ 518, 601 ],
       [ 630, 603 ],
       [ 628, 562 ]
     ]
    ];
  return $expected;
}

sub define_rectangle_list_2 {
  my $rl;
  my (@rects, $r);
  $r = [ [8, 4], [10, 28], [28, 30], [30, 4] ];
  push @rects, $r;
  $r = [ [10, 9], [8, 30], [30, 28], [28, 2] ];
  push @rects, $r;
  $r = [ [9, 3], [9, 30], [29, 29], [29, 3] ];
  push @rects, $r;
  $r = [ [9, 3], [9, 29], [29, 29], [29, 3] ];
  push @rects, $r;
  $r = [ [9, 3], [9, 29], [29, 29], [29, 3] ];
  push @rects, $r;
  $r = [ [10, 4], [8, 30], [30, 28], [28, 2] ];
  push @rects, $r;

  $rl = \@rects;
  return $rl;
}