VBCode を perl で実装してみた。

vbcode.pl

=comment
実行結果：
gotou-no-MacBook-Air:perl kiyotakagoto$ ll packed_ints; ll vbcoded; ll gapped_vbcoded;    ll packed_ints_random; ll vbcoded_random; ll gapped_vbcoded_random;
-rw-r--r--  1 kiyotakagoto  staff  40004  2  5 23:37 packed_ints
-rw-r--r--  1 kiyotakagoto  staff  20002  2  5 23:37 vbcoded
-rw-r--r--  1 kiyotakagoto  staff  10002  2  5 23:37 gapped_vbcoded
-rw-r--r--  1 kiyotakagoto  staff  40000  2  5 23:37 packed_ints_random
-rw-r--r--  1 kiyotakagoto  staff  39589  2  5 23:37 vbcoded_random
-rw-r--r--  1 kiyotakagoto  staff  20151  2  5 23:37 gapped_vbcoded_random
gotou-no-MacBook-Air:perl kiyotakagoto$ 

ランダムだと vbcode だけでは意外と小さくならなかった。
ギャップで持つときの圧縮の安定感すごい。
=cut

use strict;
use warnings;
use integer;

######################################################
# sequencial numbers
######################################################
my $num_array         = [ 5000 .. 15000 ];

my $vbcoded_num_array        = compose_vbcode( $num_array );
my $gapped_vbcoded_num_array = compose_gapped_vbcode( $num_array );
my $packed_ints              = compose_int( $num_array );

out( $vbcoded_num_array, 'vbcoded' );
out( $gapped_vbcoded_num_array, 'gapped_vbcoded' );
out( $packed_ints, 'packed_ints' );

######################################################
# discrete numbers
######################################################
my @random_num;
for my $count ( 1..10000 ) {
    push @random_num, int( rand( 50_000_000 ) );
}

my $vbcoded_random_num_array        = compose_vbcode( \@random_num );
my $gapped_vbcoded_random_num_array = compose_gapped_vbcode( \@random_num );
my $packed_random_ints              = compose_int( \@random_num );

out( $vbcoded_random_num_array, 'vbcoded_random' );
out( $gapped_vbcoded_random_num_array, 'gapped_vbcoded_random' );
out( $packed_random_ints, 'packed_ints_random' );


sub vbencode {
    my $number = shift;
    my @bytes;

    while ( 1 ) {
        unshift @bytes, $number % 128;
        last if $number < 128;
        $number /= 128;
    }
    $bytes[ $#bytes ] += 128;

    for my $byte ( @bytes ) {
        $byte = pack('C1', $byte);
    }

    return wantarray ? @bytes : \@bytes;
}

sub compose_vbcode {
    my $num_array = shift;

    my @vbcoded_num;
    my @vbcoded_num_array = map {
        @vbcoded_num = vbencode( $_ );
        @vbcoded_num;
    } @$num_array;

    return \@vbcoded_num_array;
}

sub compose_gapped_vbcode {
    my $num_array = shift;
    my @sorted_num_array = sort { $a <=> $b } @$num_array;

    my (@vbcoded_gapped_num, $current_num, $last_num, $gap);
    $last_num = 0;
    my @gapped_vbcoded_num_array = map {
        $gap      = $_ - $last_num;
        $last_num = $_;
        @vbcoded_gapped_num = vbencode( $gap );
        @vbcoded_gapped_num;
    } @sorted_num_array;

    return \@gapped_vbcoded_num_array;
}

sub compose_int {
    my $num_array = shift;

    my @packed_ints = map {
        pack('i1', $_ );
    } @$num_array;

    return \@packed_ints;
}

sub out {
    my ($data, $filename) = @_;

    open my $output_file, '>', $filename or die;

    print $output_file @$data;

    close $output_file;
}

sub vbdecode {
}