Perl: Pure BMP to GIF converter

bmp2gif.pl

#!/usr/bin/perl

use strict;
use warnings;
use bmp_io;

sub compress_vcl_lzw ($$);

my $transparent = @ARGV ? $ARGV[0] : undef;

my ($data, $bit_count, $colors) = read_bmp;

$bit_count <= 8 or die 'Too large bit count.';

# 利用頻度を調べる。
my @freq = (0) x @$colors;

foreach my $line (@$data) {
    foreach my $pixel (@$line) {
        $freq[$pixel]++;
    }
}

# 使っている色順にソート。
my @move_from = sort { $freq[$b] <=> $freq[$a] } (0 .. $#freq);
@$colors = @$colors[@move_from];

# ピクセルも反映させる。
my @move_to = (0) x @freq;
@move_to[@move_from] = (0 .. $#freq);

foreach my $line (@$data) {
    foreach my $pixel (@$line) {
        $pixel = $move_to[$pixel];
    }
}

# 透明色も反映させる。
$transparent = $move_to[$transparent] if defined $transparent;

# パレットの最適化。grep, map 遊び。

# 色を数える。
my $unique = grep { $_ } @freq;

# 最低限必要なビット数を得る。
$bit_count = grep { $unique > $_ } map { 2 ** $_ } 0 .. 8;

$bit_count <= 8 or die 'Too large colors.';

# デバッグ用
$bit_count = 2 if $bit_count == 1;


# カラーテーブルのサイズを調整。
$#$colors = 2 ** $bit_count - 1;
foreach (@$colors) { $_ = 0 if not defined $_ }

# 8 ビットでベクタに詰め込んだデータを作成。
my $vector = join('', map { pack('C*', @$_) } @$data);

my $width  = @{$data->[0]};
my $height = @$data;

# GIF 出力。


=pod

typedef struct _gif_header {
    char signature[3]; /* GIF */
    char version[3];   /* 87a or 89a */
} GIF_HEADER;

typedef struct _gif_screen_descriptor {
    unsigned short width;
    unsigned short height;
    unsigned       hasColorTable           : 1; /* global */
    unsigned       colorResolution         : 3;
    unsigned       colorSortedByImportance : 1;
    unsigned       colorTableSize          : 3; /* size or guess */
    unsigned char  backGroundColorIndex;
    unsigned char  aspectRatio; /* (aspectRatio + 15) / 64 */
} GIF_SCREEN_DESCRIPTOR;

typedef struct _gif_image_descriptor {
    unsigned char  signature; /* 0x2c */
    unsigned short left;
    unsigned short top;
    unsigned short width;
    unsigned short height;
    unsigned       hasColorTable           : 1; /* local */
    unsigned       isInterlaced            : 1;
    unsigned       colorSortedByImportance : 1;
    unsigned       reserved                : 2;
    unsigned       colorTableSize          : 3; /* size or zero */
} GIF_IMAGE_DESCRIPTOR;

typedef struct _gif_color_entry {
    unsigned char red;
    unsigned char blue;
    unsigned char green;
} GIF_COLOR_ENTRY;

typedef struct _gif_color_table {
    GIF_COLOR_ENTRY colors[1];
} GIF_COLOR_TABLEY;

typedef struct _gif_data_block {
    unsigned char size;    /* 0 to 255, 0 for terminator */
    unsigned char data[1]; /* size bytes */
} GIF_DATA_BLOCK;

typedef struct _gif_image_data_header {
    unsigned char lzwMinimumCodeSize;
    GIF_DATA_BLOCK blocks[1];
} GIF_IMAGE_DATA_HEADER;


typedef struct _gif_graphic_control_extension {
    unsigned char  introducer;  /* 0x21 */
    unsigned char  signature;   /* 0xf9 */
    unsigned char  dataSize;    /* 4 */
    unsigned       reserved             : 3;
    unsigned       disposalMethod       : 3; /* 0: n/a, 1: stay, 2: erase, 3: restore */
    unsigned       processwaitUserInput : 1;
    unsigned       hasTransparentIndex  : 1;
    unsigned short delayTime;   /* # of hundredths of a second */
    unsigned char  transparentIndex;
} GIF_GRAPHIC_CONTROL_EXTENSION;

typedef struct _gif_comment_extension {
    unsigned char  introducer;  /* 0x21 */
    unsigned char  signature;   /* 0xfe */
} GIF_GRAPHIC_CONTROL_EXTENSION;


typedef struct _gif_trailer {
    unsigned char signature; /* 0x3b */
} GIF_TRAILER;


<GIF Data Stream> ::=     Header <Logical Screen> <Data>* Trailer

<Logical Screen> ::=      Logical Screen Descriptor [Global Color Table]

<Data> ::=                <Graphic Block>  |
                          <Special-Purpose Block>

<Graphic Block> ::=       [Graphic Control Extension] <Graphic-Rendering Block>

<Graphic-Rendering Block> ::=  <Table-Based Image>  |
                               Plain Text Extension

<Table-Based Image> ::=   Image Descriptor [Local Color Table] Image Data

<Special-Purpose Block> ::=    Application Extension  |
                               Comment Extension

=cut


binmode(select);

# 識別子
print pack('a3a3', 'GIF', '89a');

my $flags = 0x88; # グローバルカラーテーブル有＋ソート済み。

# 論理領域ヘッダ
print pack('vvCCC', $width, $height, ($flags | ($bit_count - 1) << 4 | ($bit_count - 1)), 0, 0);

# グローバル色テーブル
print substr(pack('N', $_), 1, 3) foreach @$colors;

if (defined $transparent) {
    # グラフィック制御拡張
    print pack('CCCCvCC', 0x21, 0xf9, 4, 0x01, 0, $transparent, 0);
}

# 画像情報ヘッダ
print pack('CvvvvC', 0x2c, 0, 0, $width, $height, 0x00);

# 可変長 LZW で圧縮
my $ref_compressed = compress_vcl_lzw(\$vector, $bit_count);

# LZW の初期項目数
print pack('C', $bit_count);

# イメージデータを最大 255 バイトごとに区切り、
# 長さを前につけてサブブロックを出力。
print pack('C/a*', $1) while $$ref_compressed =~ /(.{1,255})/sg;

# サブブロックの終了
print pack('C', 0);

# 画像の終了
print pack('C', 0x3b);

exit;

sub compress_vcl_lzw ($$) {
    my ($ref_source, $source_bit_count) = @_;

    if ($source_bit_count == 1) { $source_bit_count = 2 }

    # GIF の場合、バイト内では右から順に埋めていく。
    # 例えば 3 ビットずつなら、22111000, 54443332 となる。
    # ちょっと面倒なので、逆順のビット文字列を使い、
    # 強制的に連結して処理をサボる。（凄く遅い）

    my $bit_length = $source_bit_count + 1;

    # $bit_length 長のビット文字列を返すクロージャ。
    my $binary = sub {
        unpack("b$bit_length", pack('V', $_[0]));
    };

    my $dest     = ''; # 圧縮バイナリデータ
    my $dest_bit = ''; # 圧縮バイナリデータのビット端数（文字列で保持！）
    my @codes = ();    # 出力バッファ

    # @codes を書き出すクロージャ
    my $flush = sub {
        # ビット文字列へ変換
        $dest_bit .= join('', map { $binary->($_) } @codes);

        @codes = ();

        # このまま溜め込むと、恐ろしいサイズになるので、
        # 書き出せる分はバイナリに変換。
        my $octet_length = length($dest_bit) & 0xfffffff8;
        if ($octet_length > 0) {


            $dest .= pack('b*', substr($dest_bit, 0, $octet_length));
            $dest_bit = substr($dest_bit, $octet_length);
        }
    };

    my $clear_code = 2 ** $source_bit_count;
    my $eoi_code = $clear_code + 1;

    my $sp = 0;

    # 辞書のリセット単位のループ。
    while ($sp < length $$ref_source) {

        # クリアコードを出力しておく。（冗長だが最初も出力）
        push(@codes, $clear_code);

        # コードが溜まってればフラッシュ。
        $flush->();


        # 辞書を初期化。
        my %table = ( map { chr $_ => $_ } (0 .. 2 ** $source_bit_count - 1));

        # ビット長を初期値に。
        $bit_length = $source_bit_count + 1;

        # 次に割り当てるコード。
        my $next_code = $eoi_code + 1;


        # 出力コード単位のループ。
        while ($sp < length $$ref_source) {
 
            # 最長一致文字列。最初は 1 文字。
            my $matched = substr($$ref_source, $sp++, 1);


            my $next_char = '';

            # 辞書に登録されている最長のバイト列を探す。
            while ($sp < length $$ref_source) {

                # 1 文字読み込み、
                $next_char = substr($$ref_source, $sp, 1);

                # 現時点の最長一致と合わせて辞書にあるかどうか調べる。
                last if not exists $table{$matched . $next_char};

                # 見つかれば最長一致文字列を更新する。
                $matched .= $next_char;
                ++$sp;
            }

            # 見つかったコードを出力。
            push(@codes, $table{$matched});

            # 直後の文字を追加して新規コードを割り当てる。
            $table{$matched . $next_char} = $next_code++;

            # 辞書に空きがなくなった場合は辞書をリセットする。
          last if $next_code > 0x1000;

            # ビット長が変わる場合、@codes バッファをフラッシュ
            if ($next_code > 2 ** $bit_length) {
                $flush->();
                $bit_length++;
            }

        }

    }

    # 最後に終了コードを出力。
    push(@codes, $eoi_code);
    $flush->();

    # 端数ビットも忘れずに出力する。
    $dest .= pack('b*', $dest_bit);

    \$dest;
}

bmp_io.pm

package bmp_io;

require 5.6.0;

use strict;
use warnings;
use integer;

BEGIN {
	use Exporter;
	our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);

	$VERSION     = '1.00';
	@ISA         = qw/ Exporter /;
	@EXPORT      = qw/ read_bmp write_bmp write_bmp_data /;
	@EXPORT_OK   = ();
	%EXPORT_TAGS = ();
}

# 標準入力から BMP を読み込む
sub read_bmp () {
	use integer;

	# 必ずバイナリで。
	binmode(STDIN);

	# 読み取りバッファ。
	my $chunk;

	# 読み取り位置。
	my $pos = 0;
 
	# $chunk に指定バイト標準入力から読み込むクロージャ。
	# 読んだ分だけ $pos を加算。指定長読めないと die する。
	# $chunk, $pos を束縛。
	my $read_exact = sub ($) {
		my $size = shift;
		my $read = read(STDIN, $chunk, $size);
		defined $read or die $!; 
		$read == $size or die 'Data truncated.';
		$pos += $read;
	};

	# BITMAPFILEHEADER 読み込み。
	$read_exact->(14);
	my ($signature, $data_offset) = unpack('a2x8V', $chunk);

	# 'BM' チェック。
	$signature eq 'BM' or die 'Invalid signature.';

	# BITMAPINFOHEADER 読み込み。
	$read_exact->(40);
	my ($bih_size, $width, $height, $planes,
		$bit_count, $compression, $color_count)
	  = unpack('VVVvvVx12Vx4', $chunk);

	# 40 未満のサイズは古い形式なので対応しない。
	$bih_size >= 40 or die 'OS/2 bitmaps not supported.';

	# BMP は必ず 1 プレーン（面）。
	$planes == 1 or die 'Invalid bitmap.';

	# ビット数は 1, 4, 8, 24, 32 のどれか。
	grep { $bit_count == $_ } (1, 4, 8, 24, 32)
	  or die 'Not supported bit count.';

	# 圧縮は今回扱わない。
	$compression == 0 or die 'Not supported compression.';

	# 8 ビット以下の BMP はカラーテーブルを持つ。
	if ($color_count == 0 and $bit_count <= 8) {
		$color_count = 2 ** $bit_count;
	}

	# ヘッダ全体を読み飛ばす。
	if ($bih_size > 40) {
		$read_exact->(40);
	}

	# カラーテーブル。
	my $colors;

	# カラーテーブルがあれば読み込む。
	if ($color_count) {
		$read_exact->($color_count * 4);
		# "V256" などのテンプレートで配列化。
		$colors = [ unpack("V$color_count", $chunk) ];
	}

	# 標準入力は seek できないのでデータ部まで読み捨て。
	if ($data_offset - $pos) {
		$read_exact->($data_offset - $pos);
	}

	# 行のデータ部まで読み飛ばす。
	my $line_size = int(($width * $bit_count + 31) / 32) * 4;

	# 行リファレンスの配列。ここに結果が入る。
	my @data = ();

	# トップダウンの BMP の場合高さが負の値。
	# 順番に処理した場合、配列に追加する場所が異なる。
	# そこで @data を束縛する行追加用のクロージャを作る。
	my $insert = $height < 0
	  ? sub { push(@data, $_[0]) } 
	  : sub { unshift(@data, $_[0]) }
	;

	# 行データ処理用のクロージャを作る。
	# $chunk, $width, $insert を束縛。

	my $process_line = 
	  $bit_count == 32 ?
		sub {
			$insert->([ unpack('V*', $chunk) ]);
		}
	: $bit_count == 24 ?
		sub {
			my $line = [
			  map { unpack('V', $_ . "\0") }
				$chunk =~ /.{3}/sg
			];
			$#$line = $width - 1;
			$insert->($line);
		}
	: $bit_count == 16 ?
		sub {
			my $line = [ unpack('v*', $chunk) ];
			$#$line = $width - 1;
			$insert->($line);
		}
	: # $bit_count <= 8
		sub {
			my $bits = unpack('B*', $chunk);
			my $line = [
			  map { ord pack('b8', scalar reverse $_) }
				$bits =~ /.{$bit_count}/sg
			];
			$#$line = $width - 1;
			$insert->($line);
		}
	;

	# データを読み込む。
	$height = -$height if $height < 0;
	foreach (1 .. $height) {
		$read_exact->($line_size);
		$process_line->();
	}

	wantarray ? (\@data, $bit_count, $colors) : \@data;
}

sub write_bmp_data ($$;$) {
	my ($data, $bit_count) = @_;

	use integer;

	my ($width, $height) = (scalar(@{$data->[0]}), scalar(@$data));

	my $line_size = int(($width * $bit_count + 31) / 32) * 4;
	my $ctable_size = $bit_count > 8 ? 0 : 2 ** $bit_count * 4;

	foreach my $line (reverse @$data) {
		if ($bit_count == 32) {
			print pack("V*", @$line);
		} elsif ($bit_count == 24) {
			my @bytes = map { substr(pack("V", $_), 0, int($bit_count / 8)) } @$line;
			print pack("a*\@$line_size", join('', @bytes));
		} elsif ($bit_count == 16) {
			my @bytes = ();
			foreach (@$line) {
				my ($red, $green, $blue) = unpack('xCCC', pack('N', $_));
				push @bytes, pack("v", $red >> 3 << 10 | $green >> 3 << 5 | $blue >> 3);
			}
			print pack("a*\@$line_size", join('', @bytes));
		} else {
			my @bits = map { substr(unpack("B8", pack("C", $_)), -$bit_count) } @$line;
			print pack("B*\@$line_size", join('', @bits));
		}
	}

}

sub write_bmp ($$;$) {
	my ($data, $bit_count, $colors) = @_;

	use integer;

	my ($width, $height) = (scalar(@{$data->[0]}), scalar(@$data));

	my $line_size = int(($width * $bit_count + 31) / 32) * 4;
	my $ctable_size = $bit_count > 8 ? 0 : 2 ** $bit_count * 4;

	binmode(select);

	# BITMAPFILEHEADER
	print pack("a2Vx4V", "BM", 54 + $ctable_size + $line_size * $height, 54 + $ctable_size);

	# BITMAPINFOHEADER
	print pack("VVVvvx24", 40, $width, $height, 1, $bit_count);

	# RGBQUAD (カラーテーブル)
	if ($ctable_size > 0) {
		print pack("V", $_) foreach @$colors;
	}

	write_bmp_data($data, $bit_count);

}

1;