File Coverage

blib/lib/Game/TextPatterns.pm

Criterion	Covered	Total	%
statement	292	296	98.6
branch	84	108	77.7
condition	31	54	57.4
subroutine	37	37	100.0
pod	26	27	96.3
total	470	522	90.0

# -*- Perl -*-
#
# generate patterns of text. run perldoc(1) on this file for documentation

package Game::TextPatterns;
our $VERSION = '1.47';

use 5.24.0;
use warnings;
use Carp qw(croak);
use Game::TextPatterns::Util ();
use List::Util qw(min);
use Moo;
use namespace::clean;
use Scalar::Util qw(looks_like_number);

with 'MooX::Rebuild';    # for ->rebuild (which differs from ->clone)

has pattern => (
    is     => 'rw',
    coerce => sub {
        my $type = ref $_[0];
        if ($type eq "") {
            my @pat = split $/, $_[0];
            my $len = length $pat[0];
            for my $i (1 .. $#pat) {
                die "columns must be of equal length" if length $pat[$i] != $len;
            }
            return \@pat;
        } elsif ($type eq 'ARRAY') {
            my $len = length $_[0]->[0];
            for my $i (1 .. $_[0]->$#*) {
                die "columns must be of equal length" if length $_[0]->[$i] != $len;
            }
            return [ $_[0]->@* ];
        } elsif ($_[0]->can("pattern")) {
            return [ $_[0]->pattern->@* ];
        } else {
            die "unknown pattern type '$type'";
        }
    },
);

sub BUILD {
    my ($self, $param) = @_;
    croak "a pattern must be supplied" unless exists $param->{pattern};
}

########################################################################
#
# METHODS

sub append_cols {
    my ($self, $fill, $pattern) = @_;
    croak "need append_cols(fill, pattern)" if !defined $pattern;
    my ($fill_cur, $fill_new);
    if (ref $fill eq 'ARRAY') {
        ($fill_cur, $fill_new) = $fill->@*;
    } else {
        $fill_cur = $fill_new = $fill;
    }
    my $pat     = $self->pattern;
    my @cur_dim = (length $_[0]->pattern->[0], scalar $_[0]->pattern->@*);
    my @new_dim = $pattern->dimensions;
    if ($cur_dim[1] > $new_dim[1]) {
        for my $i (1 .. $cur_dim[1] - $new_dim[1]) {
            $pat->[ -$i ] .= $fill_new x $new_dim[0];
        }
    } elsif ($cur_dim[1] < $new_dim[1]) {
        for my $i (1 .. $new_dim[1] - $cur_dim[1]) {
            push $pat->@*, $fill_cur x $cur_dim[0];
        }
    }
    my $new = $pattern->pattern;
    for my $i (0 .. $new_dim[1] - 1) {
        $pat->[$i] .= $new->[$i];
    }
    return $self;
}

sub append_rows {
    my ($self, $fill, $pattern) = @_;
    croak "need append_rows(fill, pattern)" if !defined $pattern;
    my ($fill_cur, $fill_new);
    if (ref $fill eq 'ARRAY') {
        ($fill_cur, $fill_new) = $fill->@*;
    } else {
        $fill_cur = $fill_new = $fill;
    }
    my $pat     = $self->pattern;
    my @cur_dim = (length $_[0]->pattern->[0], scalar $_[0]->pattern->@*);
    my @new_dim = $pattern->dimensions;
    push $pat->@*, $pattern->pattern->@*;
    if ($cur_dim[0] > $new_dim[0]) {
        for my $i (0 .. $new_dim[1] - 1) {
            $pat->[ $cur_dim[1] + $i ] .= $fill_new x ($cur_dim[0] - $new_dim[0]);
        }
    } elsif ($cur_dim[0] < $new_dim[0]) {
        for my $i (0 .. $cur_dim[1] - 1) {
            $pat->[$i] .= $fill_cur x ($new_dim[0] - $cur_dim[0]);
        }
    }
    return $self;
}

sub as_array {
    my ($self) = @_;
    my $pat = $self->pattern;
    my @array;
    for my $row ($pat->@*) {
        push @array, [ split //, $row ];
    }
    return \@array;
}

sub border {
    my ($self, $width, $char) = @_;
    if (defined $width) {
        die "width must be a positive integer"
          if !looks_like_number($width)
          or $width < 1;
        $width = int $width;
    } else {
        $width = 1;
    }
    if (defined $char and length $char) {
        $char = substr $char, 0, 1;
    } else {
        $char = '#';
    }
    my $pat = $self->pattern;
    my ($cols, $rows) = (length $pat->[0], scalar $pat->@*);
    my ($newcols, $newrows) = map { $_ + ($width << 1) } $cols, $rows;
    my @np = ($char x $newcols) x $width;
    for my $row ($pat->@*) {
        push @np, ($char x $width) . $row . ($char x $width);
    }
    push @np, ($char x $newcols) x $width;
    $self->pattern(\@np);
    return $self;
}

sub clone { __PACKAGE__->new(pattern => $_[0]->pattern) }

sub cols       { length $_[0]->pattern->[0] }
sub dimensions { length $_[0]->pattern->[0], scalar $_[0]->pattern->@* }
sub rows       { scalar $_[0]->pattern->@* }

sub _normalize_rectangle {
    my ($self, $p1, $p2, $cols, $rows) = @_;
    for my $p ($p1, $p2) {
        $p->[0] += $cols if $p->[0] < 0;
        $p->[1] += $rows if $p->[1] < 0;
        if ($p->[0] < 0 or $p->[0] >= $cols or $p->[1] < 0 or $p->[1] >= $rows) {
            local $" = ',';
            return undef, "crop point @$p out of bounds";
        }
    }
    ($p1->[0], $p2->[0]) = ($p2->[0], $p1->[0]) if $p1->[0] > $p2->[0];
    ($p1->[1], $p2->[1]) = ($p2->[1], $p1->[1]) if $p1->[1] > $p2->[1];
    return $p1, $p2;
}

sub crop {
    my ($self, $p1, $p2) = @_;
    my $pat = $self->pattern;
    my ($cols, $rows) = (length $pat->[0], scalar $pat->@*);
    if (!$p2) {
        $p2 = $p1;
        $p1 = [ 0, 0 ];
    }
    ($p1, $p2) = $self->_normalize_rectangle($p1, $p2, $cols, $rows);
    croak $p2 unless defined $p1;
    my @new;
    unless ($p2->[0] == 0 or $p2->[1] == 0) {
        for my $rnum ($p1->[1] .. $p2->[1]) {
            push @new, substr $pat->[$rnum], $p1->[0], $p2->[0] - $p1->[0] + 1;
        }
    }
    $self->pattern(\@new);
    return $self;
}

sub draw_in {
    my ($self, $p1, $p2, $pattern) = @_;
    my $pat = $self->pattern;
    my ($cols, $rows) = (length $pat->[0], scalar $pat->@*);
    if (!defined $pattern) {
        $pattern = $p2;
        croak "need pattern to draw into the object" if !defined $pattern;
        $p2 = [ $cols - 1, $rows - 1 ];
    }
    ($p1, $p2) = $self->_normalize_rectangle($p1, $p2, $cols, $rows);
    my $draw = $pattern->pattern;
    my ($draw_cols, $draw_rows) = (length $draw->[0], scalar $draw->@*);
    my $ccount = min($draw_cols, $p2->[0] - $p1->[0] + 1);
    my $rcount = min($draw_rows, $p2->[1] - $p1->[1] + 1);
    for my $rnum (0 .. $rcount - 1) {
        substr($pat->[ $p1->[1] + $rnum ], $p1->[0], $ccount) =
          substr($draw->[$rnum], 0, $ccount);
    }
    return $self;
}

sub _fill {
    my ($self, $p, $char, $adjfn) = @_;
    my $ref     = $self->as_array;
    my $max_col = $ref->[0]->$#*;
    my $max_row = $ref->$#*;
    if (   $p->[0] < 0
        or $p->[0] > $max_col
        or $p->[1] < 0
        or $p->[1] > $max_row) {
        croak "point @$p out of bounds";
    }
    my @queue   = $p;
    my $replace = $ref->[ $p->[1] ][ $p->[0] ];
    while (my $p = pop @queue) {
        if ($ref->[ $p->[1] ][ $p->[0] ] eq $replace) {
            $ref->[ $p->[1] ][ $p->[0] ] = $char;
            push @queue, $adjfn->($p, $max_col, $max_row);
        }
    }
    $self->from_array($ref);
    return $self;
}

sub fill_4way { push @_, \&Game::TextPatterns::Util::adj_4way; return &_fill }
sub fill_8way { push @_, \&Game::TextPatterns::Util::adj_8way; return &_fill }

# "mirrors are abominable" (Jorge L. Borges. "Tlön, Uqbar, Orbis Tertuis")
# so the term flip is here used instead
sub flip_both {
    my ($self) = @_;
    my $pat = $self->pattern;
    for my $row ($pat->@*) {
        $row = reverse $row;
    }
    $pat->@* = reverse $pat->@* if $pat->@* > 1;
    return $self;
}

sub flip_cols {
    my ($self) = @_;
    for my $row ($self->pattern->@*) {
        $row = reverse $row;
    }
    return $self;
}

sub flip_four {
    my ($self, $reduce_col, $reduce_row) = @_;
    $reduce_row //= $reduce_col;
    my $q1 = $self->clone;
    my $q2 = $q1->clone->flip_cols;
    if ($reduce_col) {
        $q2->crop([ 0, 0 ], [ -2, -1 ]);
    }
    my $q3 = $q2->clone->flip_rows;
    my $q4 = $q1->clone->flip_rows;
    if ($reduce_row) {
        $q3->crop([ 0, 1 ], [ -1, -1 ]);
        $q4->crop([ 0, 1 ], [ -1, -1 ]);
    }
    $q2->append_cols('?', $q1);
    $q3->append_cols('?', $q4);
    $q2->append_rows('?', $q3);
    return $q2;
}

sub flip_rows {
    my ($self) = @_;
    my $pat = $self->pattern;
    $pat->@* = reverse $pat->@* if $pat->@* > 1;
    return $self;
}

sub four_up {
    my ($self, $fill, $do_crop, $reduce) = @_;
    if (defined $fill) {
        croak "fill to four_up must not be a ref" if ref $fill;
    } else {
        $fill = '?';
    }
    my @quads = $self->clone;
    my $pat   = $quads[0]->pattern;
    my ($cols, $rows) = (length $pat->[0], scalar $pat->@*);
    if ($do_crop) {
        my $rownum = $rows - 1;
        if ($cols > $rows) {    # wide
            $quads[0]->crop([ 0, 0 ], [ $rownum, $rownum ]);
        } elsif ($cols < $rows) {    # tall
            my $colnum = $cols - 1;
            $quads[0]->crop([ 0, $rownum - $colnum ], [ $colnum, $rownum ]);
        }
    } else {
        if ($cols > $rows) {         # wide
            my $add = $cols - $rows;
            my $pad = __PACKAGE__->new(pattern => $fill)->multiply($cols, $add)
              ->append_rows($fill, $quads[0]);
            $quads[0] = $pad;
        } elsif ($cols < $rows) {    # tall
            my $add = $rows - $cols;
            my $pad = __PACKAGE__->new(pattern => $fill)->multiply($add, $rows);
            $quads[0]->append_cols($fill, $pad);
        }
    }
    for my $r (1 .. 3) {
        push @quads, $quads[0]->clone->rotate($r);
    }
    $quads[1]->append_cols($fill, $quads[0]);
    $quads[2]->append_cols($fill, $quads[3]);
    $quads[1]->append_rows($fill, $quads[2]);
    return $quads[1];
}

sub from_array {
    my ($self, $array) = @_;
    my @pat;
    for my $row ($array->@*) {
        push @pat, join('', $row->@*);
    }
    $self->pattern(\@pat);
    return $self;
}

sub mask {
    my ($self, $mask, $pattern) = @_;
    my $pat = $self->pattern;
    my ($cols, $rows) = (length $pat->[0], scalar $pat->@*);
    my $rep = $pattern->pattern;
    for my $r (0 .. $rows - 1) {
        $pat->[$r] =~ s{([$mask]+)}{substr($rep->[$r], $-[0], $+[0] - $-[0]) || $1}eg;
    }
    return $self;
}

sub multiply {
    my ($self, $cols, $rows) = @_;
    die "cols must be a positive integer"
      if !defined $cols
      or !looks_like_number($cols)
      or $cols < 1;
    $cols = int $cols;
    if (defined $rows) {
        die "rows must be a positive integer"
          if !looks_like_number($rows)
          or $rows < 1;
        $rows = int $rows;
    } else {
        $rows = $cols;
    }
    if ($cols > 1) {
        for my $row ($self->pattern->@*) {
            $row = $row x $cols;
        }
    }
    if ($rows > 1) {
        $self->pattern([ ($self->pattern->@*) x $rows ]);
    }
    return $self;
}

sub overlay {
    my ($self, $p, $overlay, $mask) = @_;
    my ($cols, $rows) = $self->dimensions;
    $p->[0] += $cols - 1 if $p->[0] < 0;
    $p->[1] += $rows - 1 if $p->[1] < 0;
    if ($p->[0] < 0 or $p->[0] >= $cols or $p->[1] < 0 or $p->[1] >= $rows) {
        local $" = ',';
        croak "point @$p out of bounds";
    }
    my ($colnum, $rownum) = map { $_ - 1 } $overlay->dimensions;
    my $subpat =
      $self->clone->crop($p,
        [ min($p->[0] + $colnum, $cols - 1), min($p->[1] + $rownum, $rows - 1) ]);
    my $to_draw = $overlay->clone->mask($mask, $subpat);
    $self->draw_in($p, $to_draw);
    return $self;
}

sub randomly {
    my ($self, $re, $percent, $fn) = @_;
    my $pat = $self->pattern;
    my ($cols, $rows) = (length $pat->[0], scalar $pat->@*);
    my $total   = $cols * $rows;
    my $to_fill = int($total * $percent);
    $cols--;
    $rows--;
    if ($to_fill > 0) {
        while (my ($r, $row) = each $pat->@*) {
            for my $c (0 .. $cols) {
                if (substr($row, $c, 1) =~ m/$re/ and rand() < $to_fill / $total) {
                    # NOTE exposes internals but I have no plans of
                    # changing them
                    $fn->($pat, [ $c, $r ], $cols, $rows);
                    $to_fill--;
                }
                $total--;
            }
        }
    }
    return $self;
}

sub rotate {
    my ($self, $rotate_by) = @_;
    $rotate_by %= 4;
    if ($rotate_by == 0) {    # zero degrees
        return $self;
    } elsif ($rotate_by == 2) {    # 180 degrees
        return $self->flip_both;
    }
    my $pat = $self->pattern;
    my ($cols, $rows) = (length $pat->[0], scalar $pat->@*);
    my @new;
    if ($rotate_by == 1) {         # 90 degrees
        for my $char (split //, $pat->[0]) {
            unshift @new, $char;
        }
        if ($rows > 1) {
            for my $rnum (1 .. $rows - 1) {
                for my $cnum (0 .. $cols - 1) {
                    $new[ $cols - $cnum - 1 ] .= substr $pat->[$rnum], $cnum, 1;
                }
            }
        }
    } elsif ($rotate_by == 3) {    # 270 degrees
        for my $char (split //, $pat->[-1]) {
            push @new, $char;
        }
        if ($rows > 1) {
            for my $rnum (reverse 0 .. $rows - 2) {
                for my $cnum (0 .. $cols - 1) {
                    $new[$cnum] .= substr $pat->[$rnum], $cnum, 1;
                }
            }
        }
    }
    $self->pattern(\@new);
    return $self;
}

sub string {
    my ($self, $sep) = @_;
    $sep //= $/;
    return join($sep, $self->pattern->@*) . $sep;
}

sub trim {
    my ($self, $amount) = @_;
    # -1 is the last index, so need at least one more than that
    my $neg = -($amount + 1);
    return $self->crop([ $amount, $amount ], [ $neg, $neg ]);
}

sub white_noise {
    my ($self, $char, $percent) = @_;
    my $pat = $self->pattern;
    my ($cols, $rows) = (length $pat->[0], scalar $pat->@*);
    my $total   = $cols * $rows;
    my $to_fill = int($total * $percent);
    if ($to_fill > 0) {
        for my $row ($pat->@*) {
            for my $i (0 .. $cols - 1) {
                if (rand() < $to_fill / $total) {
                    substr($row, $i, 1) = $char;
                    $to_fill--;
                }
                $total--;
            }
        }
    }
    return $self;
}

1;
__END__