File Coverage

blib/lib/Data/Petitcom/BMP.pm

Criterion	Covered	Total	%
statement	134	134	100.0
branch	29	48	60.4
condition	18	37	48.6
subroutine	21	21	100.0
pod	0	9	0.0
total	202	249	81.1

package Data::Petitcom::BMP;

use strict;
use warnings;

use parent qw{Exporter};
our @EXPORT_OK = qw{ DATA2BMP BMP2DATA Load Dump RGB555toRGB888 RGB888toRGB555 };

use bytes ();
use Carp ();

use constant CHR_WIDTH => 8;
use constant CHR_SIZE  => CHR_WIDTH * CHR_WIDTH;

use constant DEFAULT_COLORMAP => [
    0x000000,0x383838,0xf81800,0xf858c0,0x0038f0,0x7838f8,0x00b8f8,0x905828,0xf8a000,0xf8c8a0,0x007800,0x00f018,0xf8e000,0xb8b8b8,0x000000,0xf8f8f8,
    0x000000,0x282828,0x883028,0x985880,0x203880,0x604890,0x287088,0x584030,0x886028,0xa09080,0x104010,0x208030,0x887828,0x808080,0xf8f8f8,0x000000,
    0xf8f8f8,0xf8f8c8,0xf8f898,0xf8f860,0xf8f830,0xf8f800,0xf8c8f8,0xf8c8c8,0xf8c898,0xf8c860,0xf8c830,0xf8c800,0xf898f8,0xf898c8,0xf89898,0xf89860,
    0xf89830,0xf89800,0xf860f8,0xf860c8,0xf86098,0xf86060,0xf86030,0xf86000,0xf830f8,0xf830c8,0xf83098,0xf83060,0xf83030,0xf83000,0xf800f8,0xf800c8,
    0xf80098,0xf80060,0xf80030,0xf80000,0xc8f8f8,0xc8f8c8,0xc8f898,0xc8f860,0xc8f830,0xc8f800,0xc8c8f8,0xc8c8c8,0xc8c898,0xc8c860,0xc8c830,0xc8c800,
    0xc898f8,0xc898c8,0xc89898,0xc89860,0xc89830,0xc89800,0xc860f8,0xc860c8,0xc86098,0xc86060,0xc86030,0xc86000,0xc830f8,0xc830c8,0xc83098,0xc83060,
    0xc83030,0xc83000,0xc800f8,0xc800c8,0xc80098,0xc80060,0xc80030,0xc80000,0x98f8f8,0x98f8c8,0x98f898,0x98f860,0x98f830,0x98f800,0x98c8f8,0x98c8c8,
    0x98c898,0x98c860,0x98c830,0x98c800,0x9898f8,0x9898c8,0x989898,0x989860,0x989830,0x989800,0x9860f8,0x9860c8,0x986098,0x986060,0x986030,0x986000,
    0x9830f8,0x9830c8,0x983098,0x983060,0x983030,0x983000,0x9800f8,0x9800c8,0x980098,0x980060,0x980030,0x980000,0x60f8f8,0x60f8c8,0x60f898,0x60f860,
    0x60f830,0x60f800,0x60c8f8,0x60c8c8,0x60c898,0x60c860,0x60c830,0x60c800,0x6098f8,0x6098c8,0x609898,0x609860,0x609830,0x609800,0x6060f8,0x6060c8,
    0x606098,0x606060,0x606030,0x606000,0x6030f8,0x6030c8,0x603098,0x603060,0x603030,0x603000,0x6000f8,0x6000c8,0x600098,0x600060,0x600030,0x600000,
    0x30f8f8,0x30f8c8,0x30f898,0x30f860,0x30f830,0x30f800,0x30c8f8,0x30c8c8,0x30c898,0x30c860,0x30c830,0x30c800,0x3098f8,0x3098c8,0x309898,0x309860,
    0x309830,0x309800,0x3060f8,0x3060c8,0x306098,0x306060,0x306030,0x306000,0x3030f8,0x3030c8,0x303098,0x303060,0x303030,0x303000,0x3000f8,0x3000c8,
    0x300098,0x300060,0x300030,0x300000,0x00f8f8,0x00f8c8,0x00f898,0x00f860,0x00f830,0x00f800,0x00c8f8,0x00c8c8,0x00c898,0x00c860,0x00c830,0x00c800,
    0x0098f8,0x0098c8,0x009898,0x009860,0x009830,0x009800,0x0060f8,0x0060c8,0x006098,0x006060,0x006030,0x006000,0x0030f8,0x0030c8,0x003098,0x003060,
    0x003030,0x003000,0x0000f8,0x0000c8,0x000098,0x000060,0x000030,0xe8e8e8,0xd8d8d8,0xb8b8b8,0xa8a8a8,0x888888,0x707070,0x505050,0x404040,0x202020,
];
use constant SPRITE_SIZE => {
    8  => [ 8, 16, 32 ],
    16 => [ 8, 16, 32 ],
    32 => [ 8, 16, 32, 64 ],
    64 => [ 32, 64 ],
};

sub is_valid_width  { $_[0] && $_[0] <= 256 && $_[0] % CHR_WIDTH == 0 }
sub is_valid_height { $_[0] && $_[0] <= 192 && $_[0] % CHR_WIDTH == 0 }
sub is_valid_spsize {
    my ($width, $height) = @_;
    return unless ($width && $height);
    for ( @{ SPRITE_SIZE->{$width} } ) { return 1 if ( $height == $_ ) }
}

sub _xy(&;%) {
    my $code = shift;

    my %opts      = @_;
    my $width     = delete $opts{width} || 256;
    my $height    = delete $opts{height} || 64;
    my $sp_width  = delete $opts{sp_width} || 16;
    my $sp_height = delete $opts{sp_height} || 16;
    my $vflip     = delete $opts{vflip};
    my $debug     = delete $opts{debug};
    Carp::croak "invalid sp_width: $sp_width"
        if ( $sp_width > $width || $width % $sp_width );
    Carp::croak "invalid sp_height: $sp_height"
        if ( $sp_height > $height || $height % $sp_height );

    my $sp_cols = $width / $sp_width;
    my $sp_rows = $height / $sp_height;
    my $sp_nums = $sp_cols * $sp_rows;
    my $sp_size = $sp_width * $sp_height;

    my $chr_cols = $sp_width / CHR_WIDTH;
    my $chr_rows = $sp_height / CHR_WIDTH;
    my $chr_nums = $chr_cols * $chr_rows;

    my $flip_y = ($vflip) ? ($height - 1) : 0;
    for my $i ( 0 .. ( $sp_nums - 1 ) ) {
        my $sp_x = $i % $sp_cols * $sp_width;
        my $sp_y = int( $i / $sp_cols ) * $sp_height;

        for my $j ( 0 .. ( $chr_nums - 1 ) ) {
            my $chr_x = $sp_x + ( $j % $chr_cols * CHR_WIDTH );
            my $chr_y = $sp_y + ( int( $j / $chr_cols ) * CHR_WIDTH );

            for my $k ( 0 .. ( CHR_SIZE - 1 ) ) {
                my $x = $chr_x + ( $k % CHR_WIDTH );
                my $y = abs( $flip_y - ( $chr_y + ( int( $k / CHR_WIDTH ) ) ) );

                print STDERR sprintf("(% 3d, % 3d)\n", $x, $y) if ($debug);

                my $pixel = $code->( $x, $y, {
                    width     => $width,
                    height    => $height,
                    sp_width  => $sp_width,
                    sp_height => $sp_height,
                    count     => ( $sp_size * $i ) + ( CHR_SIZE * $j ) + $k,
                } );
            }

        }

    }
}

sub DATA2BMP {
    my ($data, %opts) = @_;
    my $width     = delete $opts{width}     || 256;
    Carp::croak "invalid width: $width"
        unless ( is_valid_width($width) );
    my $height    = delete $opts{height}    || 64;
    Carp::croak "invalid height: $height"
        unless ( is_valid_height($height) );
    my $sp_width  = delete $opts{sp_width}  || 16;
    my $sp_height = delete $opts{sp_height} || 16;
    Carp::croak "invalid sprite size: $sp_width x $sp_height "
        unless( is_valid_spsize($sp_width, $sp_height ) );

    my @pixels;
    _xy {
        my ( $x, $y, $info ) = @_;
        my $index = $width * $y + $x;
        $pixels[$index] = bytes::substr $data, $info->{count}, 1;
    }
    width     => $width,
    height    => $height,
    sp_width  => $sp_width,
    sp_height => $sp_height,
    vflip     => 1,
    debug     => 0;

    return Dump(
        width  => $width,
        height => $height,
        pixels => [ map { unpack 'C', $_ } @pixels ],
    );
}

sub BMP2DATA {
    my ($raw_bmp, %opts) = @_;
    my $sp_width   = delete $opts{sp_width}   || 16;
    my $sp_height  = delete $opts{sp_height}  || 16;
    Carp::croak "invalid sprite size: $sp_width x $sp_height "
        unless( is_valid_spsize($sp_width, $sp_height ) );

    my $bmp = Load($raw_bmp);
    my $data;
    _xy {
        my ( $x, $y ) = @_;
        my $offset = $bmp->{width} * ( ( $bmp->{height} - 1 ) - $y ) + $x;
        $data .= pack( 'C', $bmp->{pixels}->[$offset] );
    }
    width     => $bmp->{width},
    height    => $bmp->{height},
    sp_width  => $sp_width,
    sp_height => $sp_height,
    debug     => 0;

    return $data;
}

sub Load {
    my $raw_bmp = shift;

    my @file_header = unpack 'a2VvvV', bytes::substr( $raw_bmp, 0, 14 );
    my $type = $file_header[0];
    Carp::croak "invalid type: $type"
        if ( $type ne 'BM' );

    my @info_header = unpack 'VVVvvVVVVVV', bytes::substr( $raw_bmp, 0x0E, 40 );
    my $width = $info_header[1];
    Carp::croak "invalid width: $width"
        unless ( is_valid_width($width) );
    my $height = $info_header[2];
    Carp::croak "invalid height: $height"
        unless ( is_valid_height($height) );
    my $bit = $info_header[4];
    Carp::croak "invalid bit: $bit"
        if ( $bit != 8 );

    my @colormap = unpack 'V*', bytes::substr( $raw_bmp, 0x36,   256 * 4 );
    my @pixels   = unpack 'C*', bytes::substr( $raw_bmp, 0x0436, $width * $height );
    if ( my $lack = ( $width * $height ) - @pixels ) {
        push @pixels, 0x00 for ( 1 .. $lack );
    }

    return +{
        width    => $width,
        height   => $height,
        colormap => \@colormap,
        pixels   => \@pixels,
    };
}

sub Dump {
    my $bmp = ( ref $_[0] eq 'HASH' ) ? shift : {@_};

    my $width    = delete $bmp->{width};
    Carp::croak "invalid width: $width"
        unless ( is_valid_width($width) );
    my $height   = delete $bmp->{height};
    Carp::croak "invalid height: $height"
        unless ( is_valid_height($height) );
    my $colormap = delete $bmp->{colormap} || DEFAULT_COLORMAP;
    Carp::croak "invalid colormap: " . scalar @$colormap
        if ( scalar @$colormap != 256 );
    my $pixels   = delete $bmp->{pixels};
    Carp::croak "pixels mismatch: " . scalar @$pixels
        if ( scalar @$pixels != $width * $height );

    my $size = 14 + 40 + 256 * 4 + $width * $height;
    my $raw_bmp = pack 'a2VvvV', "BM", $size, 0, 0, 14 + 40;
    $raw_bmp .= pack "VVVvvVVVVVV", 40, $width, $height, 1, 8, 0, 0, 0, 0, 0, 0;
    $raw_bmp .= pack 'V*', @$colormap;
    $raw_bmp .= pack 'C*', @$pixels;

    return $raw_bmp;
}

sub RGB888toRGB555 {
    my $rgb888 = (ref $_[0] eq 'ARRAY') ? shift : [ @_ ];
    my @rgb555 = map {
        my $rgb = $_;
        my ( $r, $g, $b ) = map { $_ >> 3 } (
            ($rgb >> 16 ) & 0xFF,
            ($rgb >> 8 ) & 0xFF,
            $rgb & 0xFF,
        );
        # Unused(1), Blue(5), Green(5), Red(5)
        ( $b << 10 ) | ( $g << 5 ) | $r;
    } @$rgb888;
    return \@rgb555;
}

sub RGB555toRGB888 {
    my $rgb555 = (ref $_[0] eq 'ARRAY') ? shift : [ @_ ];
    my @rgb888 = map {
        my $rgb = $_;
        my ($r, $g, $b) = map { $_ << 3 | $_ >> 2 } (
            $rgb & 0x1F,
            ($rgb >> 5) & 0x1F,
            ($rgb >> 10) & 0x1F,
        );
        # Reserved(8), Red(8), Green(8), Blue(8)
        ($r << 16) | ($g << 8) | $b;
    } @$rgb555;
    return \@rgb888;
}



1;