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