The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;

use Test::More;
use Prima::Test qw(noX11);

plan tests => 1133;

sub bits  { join ':', map { sprintf "%08b", ord } split '', shift }
sub bytes { unpack('H*', shift ) }

sub is_bits
{
	my ( $bits_actual, $bits_expected, $name ) = @_;
	my $ok = $bits_actual eq $bits_expected;
	ok( $ok, $name );
	warn "#   " . bits($bits_actual) . " (actual)\n#   " . bits($bits_expected) . " (expected)\n" unless $ok;
#	exit unless $ok;
}

sub is_bytes
{
	my ( $bytes_actual, $bytes_expected, $name ) = @_;
	my $ok = $bytes_actual eq $bytes_expected;
	ok( $ok, $name );
	warn "#   " . bytes($bytes_actual) . " (actual)\n#   " . bytes($bytes_expected) . " (expected)\n" unless $ok;
#	exit unless $ok;
}

# 1 bit

my $i = Prima::Image->create(
	width  => 32,
	height => 1,
	type   => im::BW,
	color  => cl::White,
);

my @revbits;
for ( my $i = 0; $i < 256; $i++) {
	my ($r,$x) = (0,$i);
	for (0..7) {
		$r |= 0x100 if $x & 0x80;
		$x <<= 1;
		$r >>= 1;
	}
	push @revbits, $r;
}

for my $w ( 1..31 ) {
	for my $offset ( 0 .. 32 - $w ) {
		my $vec = "\0\0\0\0";
		vec( $vec, $_, 1) = 1 for $offset .. $offset + $w - 1;
		$vec = join('', map { chr $revbits[ord $_] } split '', $vec);
		$i->data("\0\0\0\0");
		$i->rop(rop::CopyPut);
		$i-> bar( $offset, 0, $w + $offset - 1, 0 );
		is_bits( $i->data, $vec, "imbpp1/ropCopy $w bits at $offset");

		$vec = "\xaa\xaa\xaa\xaa";
		vec( $vec, $_, 1) = !vec( $vec, $_, 1) for $offset .. $offset + $w - 1;
		$vec = join('', map { chr $revbits[ord $_] } split '', $vec);
		$i->data("\x55\x55\x55\x55");
		$i->rop(rop::Invert);
		$i-> bar( $offset, 0, $w + $offset - 1, 0 );
		is_bits( $i->data, $vec, "imbpp1/ropInvert $w bits at $offset");
	}
}

# 1-bit color 
$i-> set(
	colormap => [ 0xff0000, 0x00ff00 ],
	type     => im::bpp1,
	data     => "\xff\xff\xff\xff",
	rop      => rop::CopyPut,
	color    => 0xff0000,
);
$i->bar(0,0,31,0);
is_bits( $i->data, "\0\0\0\0", "imbpp1 color find");

# 4-bit 
$i->set(
	type     => im::bpp4,
	color    => 0x00ff00,
	width    => 8,
	data     => "\0\0\0\0",
);
$i->bar(0,0,7,0);
is_bits( $i->data, "\x11\x11\x11\x11", "imbpp4 color find");

$i->set(
	type     => im::bpp4 | im::GrayScale,
	color    => 0x808080,
);
$i->bar(0,0,7,0);
is_bits( $i->data, "\x88\x88\x88\x88", "imbpp4 gray color find");

$i->color(cl::White);
for my $w ( 1..7 ) {
	for my $offset ( 0 .. 8 - $w ) {
		my $vec = "\0\0\0\0";
		vec( $vec, $_, 4) = 15 for $offset .. $offset + $w - 1;
		$vec = join('', map { chr $revbits[ord $_] } split '', $vec);
		$i->data("\0\0\0\0");
		$i->rop(rop::CopyPut);
		$i->bar( $offset, 0, $w + $offset - 1, 0 );
		is_bytes( $i->data, $vec, "imbpp4/ropCopy $w nibbles at $offset");

		$vec = "\xaa\xaa\xaa\xaa";
		vec( $vec, $_, 4) = ~vec( $vec, $_, 4) for $offset .. $offset + $w - 1;
		$vec = join('', map { chr $revbits[ord $_] } split '', $vec);
		$i->data("\x55\x55\x55\x55");
		$i->rop(rop::Invert);
		$i-> bar( $offset, 0, $w + $offset - 1, 0 );
		is_bytes( $i->data, $vec, "imbpp4/ropInvert $w nibbles at $offset");
	}
}

# 8-bit
$i->set(
	width    => 4,
	type     => im::bpp8,
	colormap => [0..255],
	color    => 0x12,
	rop      => rop::CopyPut,
);
$i->bar(0,0,7,0);
is_bytes( $i->data, "\x12\x12\x12\x12", "imbpp8 color find");

$i->set(
	type     => im::Byte,
	color    => 0x808080,
);
$i->bar(0,0,3,0);
is_bytes( $i->data, "\x80\x80\x80\x80", "imByte color find");

# rgb

$i->set(
	type     => im::RGB,
	color    => 0x563412,
);
$i->bar(0,0,3,0);
is_bytes( $i->data, "\x12\x34\x56" x 4, "imRGB ropCopy");

$i->color( 0xf0f0f0);
$i->rop( rop::OrPut);
$i->bar(0,0,3,0);
is_bytes( $i->data, "\xf2\xf4\xf6" x 4, "imRGB ropOrPut");

# short, long
$i->set(
	rop      => rop::CopyPut,
	type     => im::Short,
	color    => 1023,
);
$i->bar(0,0,3,0);
is( $i->pixel(0,0), 1023, "imShort");
$i->set(
	type     => im::Long,
	color    => 0x123456,
);
$i->bar(0,0,3,0);
is( $i->pixel(0,0), 0x123456, "imLong");