1use strict;
2use warnings;
3
4use Test::More;
5use Prima::sys::Test qw(noX11);
6
7my @types = (
8	['bpp1', im::Mono],
9	['bpp1 gray', im::BW],
10	['bpp4', im::bpp4],
11	['bpp4 gray', im::bpp4|im::GrayScale],
12	['bpp8', im::bpp8],
13	['bpp8 gray', im::Byte],
14	['rgb', im::RGB],
15	['int16', im::Short],
16	['int32', im::Long],
17	['float', im::Float],
18	['double', im::Double],
19);
20
21my @filters;
22for ( sort keys %ict:: ) {
23	next if /^(AUTOLOAD|Constant)$/i;
24	push @filters, [ $_, &{$ict::{$_}}() ];
25}
26
27sub bytes { unpack('H*', shift ) }
28sub is_bytes
29{
30	my ( $bytes_actual, $bytes_expected, $name ) = @_;
31	my $ok = $bytes_actual eq $bytes_expected;
32	ok( $ok, $name );
33	warn "#   " . bytes($bytes_actual) . " (actual)\n#   " . bytes($bytes_expected) . " (expected)\n" unless $ok;
34#	exit unless $ok;
35}
36
37my $i = Prima::Image->create(
38	width  => 2,
39	height => 2,
40	type   => im::Byte,
41	data   => "\x{00}\x{ff}**\x{ff}\x{00}**",
42);
43$i-> size( 32, 32 );
44
45# generic conversion
46for ( @types ) {
47	my ( $typename, $type ) = @$_;
48	my $j = $i-> clone( type => $type, conversion => ict::None);
49	for ( @types ) {
50		my ( $typename2, $type2 ) = @$_;
51		for ( @filters ) {
52			my ( $filtername, $filter ) = @$_;
53			my $k = $j-> clone( type => $type2, conversion => $filter);
54			$k-> set( type => im::Byte, conversion => ict::None);
55			is_bytes( $i->data, $k-> data, "$typename -> $typename2 $filtername");
56
57			$k = $j-> clone( type => $type2, conversion => $filter, palette => 2); # will be reduced automatically
58			$k-> set( type => im::Byte, conversion => ict::None);
59			is_bytes( $i->data, $k-> data, "$typename -> $typename2 $filtername with reduced palette colors");
60
61			$k = $j-> clone( type => $type2, conversion => $filter, palette => [0,0,0,255,255,255]); # will be reduced automatically
62			$k-> set( type => im::Byte, conversion => ict::None);
63			is_bytes( $i->data, $k-> data, "$typename -> $typename2 $filtername with predefined palette");
64		}
65	}
66}
67
68$i = Prima::Image->create(
69	width   => 4,
70	height  => 4,
71	type    => im::bpp8,
72	data    => "\0\1\2\3\4\5\6\7\x{8}\x{9}\x{a}\x{b}\x{c}\x{d}\x{e}\x{f}",
73	colormap => [ map { $_*17 } 0..15 ],
74);
75
76# check palette stability during color reduction
77for ( @types ) {
78	my ( $typename, $type ) = @$_;
79	is_deeply( [$i->clone(type => $type)-> clone( type => im::BW )->colormap], [0, 0xffffff], "color $typename->BW");
80	if ( $type & im::GrayScale ) {
81		is_deeply( [$i->clone(type => $type)-> clone( type => im::Mono )->colormap], [0, 0xffffff], "color $typename->mono is gray");
82		if (( $type & im::BPP ) > 1 ) {
83			my @cm = $i->clone(type => $type)-> clone( type => im::bpp4, palette => 2 )->colormap;
84			# 0xff/3(blue)=0x55, but 0x55+/-0x11 is good too, color tree is unstable on unexact matches as palette size changes
85			$cm[1] = 0x555555 if $cm[1] == 0x666666 || $cm[1] == 0x444444;
86			is_deeply( \@cm, [0, 0x555555], "color $typename->nibble is gray");
87			if (( $type & im::BPP ) > 4 ) {
88				@cm = $i->clone(type => $type)-> clone( type => im::bpp8, palette => 2 )->colormap;
89				$cm[1] = 0x555555 if $cm[1] == 0x666666 || $cm[1] == 0x444444;
90				is_deeply( \@cm, [0, 0x555555], "color $typename->byte is gray");
91			}
92		}
93	} else {
94		is_deeply( [$i->clone(type => $type)-> clone( type => im::Mono )->colormap], [0, 0x0000ff], "color $typename->mono is blue");
95		if (( $type & im::BPP ) > 1 ) {
96			is_deeply( [$i->clone(type => $type)-> clone( type => im::bpp4, palette => 2 )->colormap], [0, 0x0000ff], "color $typename->nibble is blue");
97			if (( $type & im::BPP ) > 4 ) {
98				is_deeply( [$i->clone(type => $type)-> clone( type => im::bpp8, palette => 2 )->colormap], [0, 0x0000ff], "color $typename->byte is blue");
99			}
100		}
101	}
102}
103
104# check dithering capacity to sustain image statistics (grayscale, easy)
105$i = Prima::Image->create(
106	width   => 16,
107	height  => 16,
108	type    => im::Byte,
109	data    => join '', map { chr } 0..255,
110);
111$i->size(128,128);
112
113for my $src_type (im::RGB, im::Byte, im::bpp4|im::GrayScale, im::BW) {
114	my $src = $i->clone(type => $src_type);
115	for (
116		['bpp1', im::Mono],
117		['bpp1 gray', im::BW],
118		['bpp4', im::bpp4],
119		['bpp4 gray', im::bpp4|im::GrayScale],
120		['bpp8', im::bpp8],
121		['bpp8 gray', im::Byte]
122	) {
123		my ($typename, $type) = @$_;
124		next if ($src_type & im::BPP) < ($type & im::BPP);
125		for (@filters) {
126			my ( $filtername, $filter ) = @$_;
127			my %extras;
128			my $src_type = $src->type & im::BPP;
129			if (($type & im::BPP) == $src_type) { # noop otheriwse
130				$extras{palette} = 1 << $src_type;
131				$extras{palette}-- if $extras{palette} > 2;
132			}
133			my $j = $src->clone(type => $type, conversion => $filter, %extras)->clone(type => im::Byte);
134			for (qw(rangeHi rangeLo)) {
135				is( $j->$_(), $i->$_(), "dithering $src_type->$typename with $filtername, $_ ok");
136			}
137			my $diff = abs($i->mean - $j->mean);
138			# src  dst err
139			# 0 -> 0   0
140			# 1 -> 0   1
141			# 2 -> 0   2
142			# 3 -> 0   3
143			# 4 -> 1   0
144			# etc      7*64 per 256 pixels = 1.75 per pixel
145			cmp_ok( $diff, '<', 1.75, "dithering $src_type->$typename with $filtername, mean ok");
146		}
147	}
148}
149
150done_testing;
151