File Coverage

blib/lib/Game/Deckar.pm

Criterion	Covered	Total	%
statement	157	157	100.0
branch	56	58	96.5
condition	20	21	95.2
subroutine	27	27	100.0
pod	11	11	100.0
total	271	274	98.9

# -*- Perl -*-
# a module for managing decks of cards
package Game::Deckar;
our $VERSION = '0.02';
use 5.26.0;
use warnings;
use Object::Pad 0.66;

sub fisher_yates_shuffle {
    my ($deck) = @_;
    my $i;
    for ( $i = @$deck; --$i; ) {
        my $j = int rand( $i + 1 );
        next if $i == $j;
        @$deck[ $i, $j ] = @$deck[ $j, $i ];
    }
}

class Game::Deckar::Card {
    field $data :param :reader;
    field %meta;

    BUILD {
        my (%param) = @_;
        %meta = $param{meta}->%* if exists $param{meta};
    }

    method meta ($name) { $meta{$name} }

    method set_meta ( $name, $value ) {
        my $old = $meta{$name};
        $meta{$name} = $value;
        return sub { $self->set_meta( $name, $old ); };
    }
}

class Game::Deckar {
    use Carp 'croak';
    field %decks;

    BUILD {
        my (%param) = @_;
        if ( exists $param{decks} ) {
            for my $d ( $param{decks}->@* ) {
                $decks{$d} = [];
            }
        }
        if ( exists $param{initial} ) {
            for my $d ( keys $param{initial}->%* ) {
                croak "no such deck $d" unless exists $decks{$d};
                push $decks{$d}->@*, $param{initial}->{$d}->@*;
            }
        }
        if ( exists $param{initial_cards} ) {
            for my $d ( keys $param{initial_cards}->%* ) {
                push $decks{$d}->@*, map {
                    Game::Deckar::Card->new(
                        data => $_,
                        ( exists $param{meta} ? ( meta => $param{meta} ) : () )
                    )
                } $param{initial_cards}->{$d}->@*;
            }
        }
    }

    method add_deck ($name) {
        croak 'deck already exists' if exists $decks{$name};
        $decks{$name} = [];
        return sub { $self->del_deck($name); };
    }

    method del_deck ($name) {
        croak 'no such deck' unless exists $decks{$name};
        croak 'deck is not empty' if $decks{$name}->@*;
        my $orig = $decks{$name};
        delete $decks{$name};
        return sub { $decks{$name} = $orig; };
    }

    method collect ( $name, @rest ) {
        croak 'not enough decks' unless @rest;
        for my $d ( $name, @rest ) {
            croak "no such deck $d" unless exists $decks{$d};
        }
        my @rcards = [ $decks{$name}, [ $decks{$name}->@* ] ];
        for my $d (@rest) {
            next if $d eq $name;    # so can collect on "get_decks"
            push @rcards, [ $decks{$d}, [ $decks{$d}->@* ] ];
            # cards are put onto the "top" of the target deck, which is
            # how some humans might do it with real stacks of cards
            unshift $decks{$name}->@*, splice $decks{$d}->@*;
        }
        return sub {
            for my $r (@rcards) { $r->[0]->@* = $r->[1]->@* }
        };
    }

    method deal ( $src, $dst, $index = 0, $top = 1 ) {
        croak 'no such deck'
          unless exists $decks{$src} and exists $decks{$dst};
        my ( $sref, $dref ) = @decks{ $src, $dst };
        croak 'index out of range' if $index < 0 or $index > $sref->$#*;
        my $card = splice $sref->@*, $index, 1;
        splice $dref->@*, ( $top ? 0 : $dref->@* ), 0, $card;
        return $card, sub {
            splice $sref->@*, $index, 0, splice $dref->@*, ( $top ? 0 : $dref->$#* ), 1;
        };
    }

    method empty ($name) {
        croak 'no such deck'  unless exists $decks{$name};
        croak 'deck is empty' unless $decks{$name}->@*;
        my @orig = $decks{$name}->@*;
        $decks{$name}->@* = ();
        return sub { $decks{$name}->@* = @orig; };
    }

    method get_decks () {
        croak 'no decks' unless %decks;
        return sort keys %decks;
    }

    method get ($name) {
        croak 'no such deck' unless exists $decks{$name};
        return $decks{$name};
    }

    method move ( $src, $dst, $count, $index = 0, $top = 1 ) {
        croak 'no such deck'
          unless exists $decks{$src} and exists $decks{$dst};
        my ( $sref, $dref ) = @decks{ $src, $dst };
        croak 'index out of range' if $index < 0 or $index > $sref->$#*;
        croak 'count out of range' if $count < 1 or $index + $count > @$sref;
        my @cards = splice $sref->@*, $index, $count;
        splice $dref->@*, ( $top ? 0 : $dref->@* ), 0, @cards;
        return \@cards, sub {
            splice $decks{$src}->@*, $index, 0, splice $dref->@*,
              ( $top ? 0 : $dref->@* - $count ), $count;
        };
    }

    method pick ( $src, $dst, $indices, $top = 1 ) {
        croak 'no such deck'
          unless exists $decks{$src} and exists $decks{$dst};
        croak 'no indices' unless $indices->@*;
        my ( $sref, $dref ) = @decks{ $src, $dst };
        croak 'too many indices' if $indices->@* > $sref->@*;
        my ( @icard, %seen );
        for my $index ( $indices->@* ) {
            croak 'index out of range' if $index < 0 or $index > $sref->$#*;
            croak 'duplicate index'    if $seen{$index}++;
            push @icard, [$index];
        }
        for my $r ( sort { $b->[0] <=> $a->[0] } @icard ) {
            $r->[1] = splice $sref->@*, $r->[0], 1;
        }
        my @cards = map { $_->[1] } @icard;
        splice $dref->@*, ( $top ? 0 : $dref->@* ), 0, @cards;
        return \@cards, sub {
            my $len = @icard;
            splice $dref->@*, ( $top ? 0 : -$len ), $len;
            for my $r ( sort { $a->[0] <=> $b->[0] } @icard ) {
                splice $sref->@*, $r->[0], 1, $r->[1];
            }
        };
    }

    method shuffle ($name) {
        croak 'no such deck' unless exists $decks{$name};
        my $deck = $decks{$name};
        croak 'deck is empty' unless $deck->@*;
        my @orig = $deck->@*;
        fisher_yates_shuffle( $decks{$name} );
        return sub { $deck->@* = @orig; };
    }
}

1;
__END__