このアーカイブは同期化されません。 mixi の日記が更新されても、このアーカイブには反映されません。
BMP なら Web で利用しづらいため、
今日は脱線して GIF での書き出しをしてみる。
昨日ダウンしていた分、気合入れて実装してみた。
GIF は、カラーテーブルを持つ表現のみ可能であり、
原則として最大 256 色しか表示できない。
しかしながら、ピクセルあたりの表現ビット数は、
1, 2, 3, 4, 5, 6, 7, 8 と細かく調整できる。
また、データに LZW をベースとした圧縮が掛かっているので、
単純な画像であればサイズが小さくなりやすい特長がある。
use strict;
use warnings;
use integer; # 符号付演算に注意
sub compress_vcl_lzw ($$);
# 基本情報
my $width = 100;
my $height = 75;
my $bit_count = 2;
# カラーテーブル。0:黒, 1:赤, 2:緑, 3:青
my @colors = (
0x00000000, 0x00ff0000,
0x0000ff00, 0x000000ff
);
# 左から右、上から下へ並ぶ非圧縮画像データを作る。
# この時点では、ピクセルあたり 1 文字のスカラベクタ。
my $data = pack('C', 2) x $width x int($height / 3) # 緑
. pack('C', 1) x $width x int($height / 3) # 赤
. pack('C', 3) x $width x int($height / 3); # 青
binmode(select);
# GIF 識別子
print pack("a3a3", "GIF", "89a");
# 論理領域ヘッダ
print pack("vvCCC", $width, $height,
(0x80 | ($bit_count - 1) << 4 | ($bit_count - 1)), 0, 0);
# グローバル色テーブル
print substr(pack("N", $_), 1, 3) foreach @colors;
# 画像情報ヘッダ
print pack("CvvvvC", 0x2c, 0, 0, $width, $height, 0);
# 可変長 LZW で圧縮
my $ref_compressed = compress_vcl_lzw(\$data, $bit_count);
# LZW の初期項目数
print pack("C", $bit_count);
# イメージデータを最大 255 バイトごとに区切り、
# 長さを前につけてサブブロックを出力。
print pack("Ca*", length($&), $&)
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) = @_;
# GIF の場合、バイト内では右から順に埋めていく。
# 例えば 3 ビットずつなら、22111000, 54443332 となる。
# ちょっと面倒なので、逆順のビット文字列を使い、
# 強制的に連結して処理をサボる。（凄く遅い）
my $bit_length = $source_bit_count + 1;
# $bit_length 長のビット文字列を返す無名関数
my $to_bit_string = sub {
unpack("b$bit_length", pack("V", $_[0]));
};
my $dest = ''; # 圧縮バイナリデータ
my $dest_bit = ''; # 上記ビット端数（文字列で保持！）
my @codes = (); # 出力バッファ
# @codes を書き出す無名関数
my $flush = sub {
# ビット文字列へ変換
$dest_bit .=
join('', map { $to_bit_string->($_) } @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;
# クリアコードを出力しておく（冗長だが）
push(@codes, $clear_code);
my $sp = 0;
COMPRESS: {
# 辞書を初期化
my %table = ( map { chr $_, $_ }
0..(2 ** $source_bit_count - 1));
my $freed_code = $eoi_code + 1;
# ビット長を初期値に
$bit_length = $source_bit_count + 1;
my $matched = '';
while ($sp < length $$ref_source) {
# 辞書にマッチしないバイト列を探す
my $next_char = substr($$ref_source, $sp++, 1);
while (exists $table{$matched . $next_char}) {
$matched .= $next_char;
last COMPRESS if $sp >= length $$ref_source;
$next_char = substr($$ref_source, $sp++, 1);
}
# ビット長が変わる場合、@codes バッファをフラッシュ
if ($table{$matched} >= 2 ** $bit_length) {
$flush->();
$bit_length++;
}
push @codes, $table{$matched};
# 辞書に空がない場合リセットする。
if ($freed_code >= 0x1000) {
push(@codes, $clear_code);
$flush->();
$sp--; # 現在文字からやりなおし。
redo COMPRESS;
}
$table{$matched . $next_char} = $freed_code++;
$matched = $next_char;
}
push(@codes, $table{$matched}) if length($matched) > 0;
}
# 最後に終了コードを出力
push(@codes, $eoi_code);
$flush->();
# 端数ビットも出力する
$dest .= pack("b*", $dest_bit);
\$dest;
}