Buffer2d.pm

use v5.36;

use Data::Dumper;
use Test::More;
use Test::Exception;
no autovivification;

sub aref { \@_ }

sub getters(@fields) {
    no strict 'refs';
    my $pkg = caller;
    for my $field (@fields) {
        *{"${pkg}::${field}"} = sub ($self) {
            $self->{$field};
        };
    }
}

package Buffer2d {
    use Carp;

    ::getters qw(
        H
        W
        bsize
        buf
        defaults
        packstr
        size
        stride
        zeroed
    );

    sub new($W, $H, $packstr, $defaults) {
        my $stride = length(pack($packstr));
        my $size = $W * $H;
        my $bsize = $size * $stride;
        my $buf = pack($packstr, $defaults->@*) x $size;
        my $zeroed = $buf;
        bless {
            H => $H,
            W => $W,
            _updated_rows => {},
            bsize => $bsize,
            buf => $buf,
            defaults => $defaults,
            packstr => $packstr,
            size => $size,
            stride => $stride,
            zeroed => $zeroed,
        }, __PACKAGE__;
    }

    sub from_other($other) {
        # This 
        my $self = { $other->%* };
        $self->{defaults} = [ $other->defaults->@* ];
        $self->{_updated_rows} = {};
        return bless $self, __PACKAGE__;

        # Instead of this;
        return bless {
            H => $other->H,                     # int
            W => $other->W,                     # int
            _updated_rows => {},
            bsize => $other->bsize,             # int
            buf => $other->buf,                 # string (Cow)
            defaults => [$other->defaults->@*], # array ref
            packstr => $other->packstr,         # string (CoW)
            size => $other->size,               # int
            stride => $other->stride,           # int
            zeroed => $other->zeroed,
        }, __PACKAGE__;
    }

    sub copy($self) {
        Buffer2d::from_other($self);
    }

    sub valid($self, $col, $row) {
        0 <= $col && $col < $self->W
            && 0 <= $row && $row < $self->H;
    }

    sub getp($self, $col, $row) {
        confess "invalid access" unless $self->valid($col, $row);
        my $idx = ($row * $self->W + $col) * $self->stride;
        substr($self->buf, $idx, $self->stride);
    }

    sub get($self, $col, $row) {
        confess "invalid access" unless $self->valid($col, $row);
        my $idx = ($row * $self->W + $col) * $self->stride;
        unpack($self->packstr, substr($self->buf, $idx, $self->stride));
    }

    sub setp($self, $col, $row, $payload) {
        confess "invalid access" unless $self->valid($col, $row);
        $self->{_updated_rows}->{$row}++;
        my $idx = ($row * $self->W + $col) * $self->stride;
        substr($self->{buf}, $idx, $self->stride) = $payload;
    }

    sub set($self, $col, $row, $values) {
        confess "invalid access" unless $self->valid($col, $row);
        my $idx = ($row * $self->W + $col) * $self->stride;
        substr($self->{buf}, $idx, $self->stride) = pack($self->packstr, $values->@*);
        $self->{_updated_rows}->{$row}++;
    }

    sub get_multi($self, $col, $row, $n) {
        confess "invalid access" unless
            $self->valid($col, $row) &&
            $self->valid($col + $n - 1, $row);
        my $stride = $self->stride;
        my $idx = ($row * $self->W + $col) * $stride;
        my $payloads = substr($self->{buf}, $idx, $n * $stride);
        my @values;
        for (0 .. $n - 1) {
            my $payload = substr($payloads, $_ * $stride);
            push @values, [ unpack($self->packstr, $payload) ];
        }

        @values;
    }

    sub set_multi($self, $col, $row, @values) {
        confess "invalid access" unless
            $self->valid($col, $row) &&
            $self->valid($col + $#values, $row);
        my $stride = $self->stride;
        my $payload = pack(sprintf("(%s)*", $self->packstr), map { $_->@* } @values);
        my $idx = ($row * $self->W + $col) * $stride;
        substr($self->{buf}, $idx, (scalar @values) * $stride) = $payload;
        $self->{_updated_rows}->{$row}++;
    }

    sub xor_inplace($self, $other) {
        $self->{buf} ^.= $other->buf;
    }

    sub diff($self, $other) {
        my $delta = $self->copy;
        $delta->xor_inplace($other);
        my @indexes;
        my $zero = "\0" x $delta->stride;
        for my $row (sort { $a <=> $b } keys $self->{_updated_rows}->%*) {
            for my $col(0 .. $self->{W} - 1) {
                my $pack = $delta->getp($col, $row);
                confess if !defined $pack;
                if ($pack ne $zero) {
                    my $payload = $self->getp($col, $row);
                    my $last = $indexes[$#indexes];

                    if (defined $last && $last->{row} == $row 
                        && $last->{col} + $last->{size} == $col
                    ) {
                        push $last->{payload}->@*, unpack($self->packstr, $payload);
                        $last->{size}++;
                        next;
                    }

                    my @payload = unpack($self->packstr, $payload);
                    push @indexes, { 
                        col => $col, 
                        row => $row, 
                        payload => \@payload,
                        size => 1,
                    };
                }
            }
        }
        $self->{_updated_rows} = {};
        @indexes;
    }
    
    sub sync($self, $other) {
        $self->{buf} = $other->buf;
    }

    sub to_string($self, @ignored) {
        my @lines;
        for my $row (0 .. $self->H - 1) {
            push @lines, unpack("H*", 
                    substr($self->buf,
                        $row * $self->W * $self->stride,
                        $self->stride * $self->W));

        }
        join "\n", @lines;
    }

    sub reset($self) {
        $self->{buf} = $self->zeroed;
    }

}

# Double buffering is a technique where instead of drawing
# to the terminal/screen you write to the memory in a buffer, compare 
# the buffer with what is the in the screen and then issue
# only the changes to the screen.
#
# To know "what is the screen" you use another buffer, so the
# name "Double buffering".


# Back buffer holds the rendering frame
my $back = Buffer2d::new(4, 3, "l3", [0,0,0]);
# Front buffer holds what is in the screen
my $front = $back->copy;

subtest 'single cell diff' => sub {
    $back->set(0, 0, [0,2,3]);

    is_deeply(
        [$back->diff($front)],
        [{ col => 0, row => 0, payload => [0,2,3], size => 1 }],
        'diff returns single updated cell'
    );

    $front->sync($back);
};

subtest 'multiple independent updates' => sub {
    $back->set(0, 0, [0,0,0]);
    $back->set(2, 2, [9,0,8]);

    is_deeply(
        [$back->diff($front)],
        [
            { payload => [0,0,0], col => 0, row => 0, size => 1 },
            { payload => [9,0,8], col => 2, row => 2, size => 1 },
        ],
        'diff returns multiple independent updates'
    );

    $front->sync($back);
};

subtest 'last write wins' => sub {
    $back->set(1, 0, [1,1,1]);
    $back->set(1, 0, [2,2,2]);

    is_deeply(
        [$back->diff($front)],
        [
            { payload => [2,2,2], col => 1, row => 0, size => 1 },
        ],
        'only last write is reported'
    );

    $front->sync($back);
};

subtest 'no-op update produces no diff' => sub {
    $back->set(1, 0, [0,0,0]);
    $back->set(1, 0, [2,2,2]);

    is_deeply(
        [$back->diff($front)],
        [],
        'no diff when buffer matches front'
    );

    $front->sync($back);
};

subtest 'set_multi and merged payload diff' => sub {
    $back->reset();
    $front->sync($back);

    $back->set_multi(0, 0, [1,2,3], [4,5,6]);

    is_deeply(
        [ $back->get_multi(0, 0, 2) ],
        [[1,2,3], [4,5,6]],
        'get_multi returns correct values'
    );

    my @diff = $back->diff($front);

    is_deeply(
        \@diff,
        [{
            payload => [1,2,3,4,5,6],
            size    => 2,
            row     => 0,
            col     => 0
        }],
        'contiguous payloads are merged'
    );

    is(($diff[0]->{payload}->@* / $diff[0]->{size}), 3,
        "step size == lenght / size");
};

subtest 'bounds checking and exceptions' => sub {
    dies_ok  { $back->set(5, 0, [1,1,1]) }      'set out of bounds dies';
    dies_ok  { $back->get(5, 0) }               'get out of bounds dies';
    lives_ok { $back->set(3, 0, [1,2,3]) }      'set at boundary lives';
    lives_ok { $back->set_multi(3, 0, [1,2,3]) }'set_multi single at boundary lives';
    dies_ok  { $back->set_multi(3, 0, [1,2,3], [4,5,6]) }
                                                   'set_multi overflow dies';
    lives_ok { $back->get_multi(3, 0, 1) }      'get_multi single lives';
    dies_ok  { $back->get_multi(3, 0, 2) }      'get_multi overflow dies';
};

done_testing;