File Coverage

blib/lib/Encode/Wechsler.pm

Criterion	Covered	Total	%
statement	77	77	100.0
branch	22	28	78.5
condition	5	5	100.0
subroutine	8	8	100.0
pod	3	3	100.0
total	115	121	95.0

package Encode::Wechsler;
use strict;
use warnings FATAL => 'all';
our $VERSION = '0.03';

my $i = 0;
# {0, 1, 2, ..., 8, 9, a, b, ..., v} correspond to the bitstrings {'00000', '00001', '00010', ..., '11111'}.
our %bits = map { $_ => sprintf("%05d", unpack( 'B32', pack( 'N', $i++ ) ) ) } 0 .. 9, 'a' .. 'v';
our %stib = reverse %bits;

$i = 4;
# We use the characters 'w' and 'x' to abbreviate '00' and '000'
# the symbols {'y0', 'y1', y2', ..., 'yx', 'yy', 'yz'} correspond to runs of between 4 and 39 consecutive '0's.
our %zero = map { 'y' . $_ => 0 x $i++ } 0 .. 9, 'a' .. 'z';
$zero{w} = '00';
$zero{x} = '000';
#our %orez = reverse %zero;

sub new {
    my $self = shift;
    return bless {@_}, $self;
}


sub encode {
    my $self   = shift;
    my %args   = @_;
    my $thingy = $args{board};

    # multi-line string
    $thingy = [ split "\n", $thingy ] unless ref( $thingy );

    # array of strings
    $thingy = [ map [ split //, $_ ], @$thingy ] unless ref( $thingy->[0] );

    # all become 2D array of true or false values
    $thingy = [ map [ map { $_ eq '.' ? 0 : 1 } @$_ ], @$thingy ];

=for later
    my @chunks;
    my $start_pruning;
    for (my $i = 0; $i < @$thingy; $i += 5) {
        # all zeros are ok until we found our first non all zeros
        # then prune all zeros that are "trailing"
        my @chunk;
        for (@$thingy[ $i .. $i + 4 ]) {
            $start_pruning ||= int( join '', @$_ );
            if ($start_pruning) {
                push @chunk, $_ if ref($_) && int( join '', @$_ );
            } else {
                push @chunk, $_ if ref($_);
            }
        }
        push @chunks, [@chunk] if @chunk;
    }
=cut
    my @chunks;
    for (my $i = 0; $i < @$thingy; $i += 5) {
        my @chunk = map {
            ref( $_ ) && int( join '', @$_ ) ? $_ : ()
        } @$thingy[ $i .. $i + 4 ];
        push @chunks, [@chunk];
    }

    @chunks = map _transpose( $_ ), @chunks;

    #TODO: detect consecutive zero runs
    my @bits;
    for my $chunk (@chunks) {
        push @bits, join '',
            map { $stib{$_} }
            map { sprintf '%05d', join '', reverse @$_ } @$chunk
        ;
    }

    # this could be removed by detecting consecutive zero runs
    my $str = join 'z', @bits;
    $str =~ s/0*$//;

    return $str;
}

sub decode {
    my ($self,$code) = @_;

    $code =~ s/^\s+//;
    $code =~ s/\s+$//;
    die "invalid format: $code\n" unless $code =~ /x[spq][0-9]+_[0-9a-z]+/;

    my ($prefix,$format) = split '_', $code, 2;

    $self->{max} = 0;
    $format = join 'z', map {
        s/(w|x|y.)/$zero{$1}/g;
        $self->{max} = length($_) if length($_) > $self->{max};
        $_;
    } split 'z', $format;

    my @grid;
    for my $part (split 'z', $format ) {

        if (length($part) < $self->{max}) {
            $part .= '0' x ( $self->{max} - length($part) );
        }

        # pad left and right
        $part = ('0' x $self->{pad}) . $part . ('0' x $self->{pad}) if $self->{pad};

        my $i = 0;
        for (split '', $part) {
            push @{ $grid[$i] }, map int $_, reverse split //, $bits{$_};
            $i++;
        }
    }

    my @trans;
    for my $i (reverse 0 .. $#{ $grid[0] }) {
        push @trans, [ map $_->[$i] || 0, @grid ];
    }

    #remove leading blank rows
    for (@trans) {
        if (_sum( @$_ )) {
            last;
        }
        shift @trans;
    }

    @grid = reverse @trans;


    if ($self->{pad}) {
        unshift @grid, ([(0) x ($self->{max} + (2 * $self->{pad}))]) x $self->{pad} if _sum( $grid[ 0] );
        push    @grid, ([(0) x ($self->{max} + (2 * $self->{pad}))]) x $self->{pad} if _sum( $grid[-1] );
    }

    return wantarray ? @grid : $self->_to_string( @grid );
}

sub _to_string {
    my $self = shift;
    my $str = '';
    for (@_) {
        $str .= $_ ? '*' : '.' for @$_;
        $str .= "\n";
    }
    return $str;
}

sub _sum {
    my $s = 0;
    $s += $_ for @_;
    return $s;
}

# credit: Math::Matrix
sub _transpose {
    my $data = shift;
    my @trans;
    for my $i (0 .. $#{ $data->[0] }) {
        push @trans, [ map $_->[$i], @$data ]
    }
    return \@trans;
}

1;

__END__