File Coverage

blib/lib/Game/TextPatterns.pm

Criterion	Covered	Total	%
statement	292	296	98.6
branch	105	128	82.0
condition	40	63	63.4
subroutine	37	37	100.0
pod	25	26	96.1
total	499	550	90.7

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

package Game::TextPatterns;

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

our $VERSION = '1.24';

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 _adj_4way {
    my ( $p, $max_col, $max_row ) = @_;
    my @adj;
    push @adj, [ $p->[0] - 1, $p->[1] ] unless $p->[0] == 0;
    push @adj, [ $p->[0] + 1, $p->[1] ] unless $p->[0] == $max_col;
    push @adj, [ $p->[0], $p->[1] - 1 ] unless $p->[1] == 0;
    push @adj, [ $p->[0], $p->[1] + 1 ] unless $p->[1] == $max_row;
    return @adj;
}

sub _adj_8way {
    my ( $p, $max_col, $max_row ) = @_;
    my @adj;
    push @adj, [ $p->[0] - 1, $p->[1] ] unless $p->[0] == 0;
    push @adj, [ $p->[0] + 1, $p->[1] ] unless $p->[0] == $max_col;
    push @adj, [ $p->[0], $p->[1] - 1 ] unless $p->[1] == 0;
    push @adj, [ $p->[0], $p->[1] + 1 ] unless $p->[1] == $max_row;
    push @adj, [ $p->[0] - 1, $p->[1] - 1 ] unless $p->[0] == 0 or $p->[1] == 0;
    push @adj, [ $p->[0] - 1, $p->[1] + 1 ]
      unless $p->[0] == 0
      or $p->[1] == $max_row;
    push @adj, [ $p->[0] + 1, $p->[1] - 1 ]
      unless $p->[0] == $max_col
      or $p->[1] == 0;
    push @adj, [ $p->[0] + 1, $p->[1] + 1 ]
      unless $p->[0] == $max_col
      or $p->[1] == $max_row;
    return @adj;
}

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 @_, \&_adj_4way; return &_fill }
sub fill_8way { push @_, \&_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 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__