File Coverage

blib/lib/Acme/Grep2D.pm

Criterion	Covered	Total	%
statement	249	255	97.6
branch	21	34	61.7
condition	10	12	83.3
subroutine	23	25	92.0
pod	16	16	100.0
total	319	342	93.2

package Acme::Grep2D;

use warnings;
use strict;
use Data::Dumper;
use Perl6::Attributes;

=head1 NAME

Acme::Grep2D - Grep in 2 dimensions

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';


=head1 SYNOPSIS

    use Acme::Grep2D;

    my $foo = Acme::Grep2D->new(text => ??);
    ...

=head1 DESCRIPTION

For testing another module, I needed the ability to grep in 2 dimensions,
hence this module.

This module can grep forwards, backwards, up, down, and diagonally in a
given text string. Given the text:

  THIST  T S
  .H  H H  II
  ..I II SIHTH
  ...SS    T  T

We can find all occurances of THIS.

Full Perl regexp is allowed, with a few limitations. Unlike regular
grep, you get back (for each match) an array containing array
references with the following contents:

  [$length, $x, $y, $dx, $dy, ??]

Operational note: there is one more argument at the end of the
returned array reference (as indicated by ??). Don't mess with
this. It's reserved for future use.

=head1 METHODS

=cut

=head2 B

  $g2d = Acme::Grep2D->new(text => ??);

Constructor. Specify text pattern to be grepped
(multiline, with newlines).

Example:

  my $text = <<'EOF';
  foobarf
  .o,,,o
  ,,o?f?fr
  <<,b ooa
  ##a#a ob
  @r@@@rbo
  ------ao
  ~~~~~~rf
  EOF

  $g2d = Acme::Grep2D->new(text => $text);

Now, our grep will have no problem finding all of the "foobar"
strings in the text (see B or other more directional methods).

The author is interested in any novel use you might find for this
module (other than solving newspaper puzzles).

=cut

sub new {
    my ($class, %opts) = @_;
    my $self = \%opts;
    bless $self, $class;
    $.Class = $class;
    ./_required('text');
    ./_init();
    return $self;
}

# check for mandatory options
sub _required {
    my ($self, $name) = @_;
    die "$.Class - $name is required\n" unless defined $self->{$name};
}

# adjust dimensions to be rectangular, and figure out what's
# in there in all directions
sub _init {
    my ($self) = @_;
    my $text = $.text;
    my @text;

    # split on newlines, preserving them spatially
    while ((my $n = index($text, "\n")) >= 0) {
        my $chunk = substr($text, 0, $n);
        push(@text, $chunk);
        $text = substr($text, $n+1);
    }
    chomp foreach @text;

    my @len;
    push(@len, length($_)) foreach @text;
    my $maxlen = $len[0];
    my $nlines = @text;

    #determine max length of each string
    map {
        $maxlen = $len[$_] if $len[$_] > $maxlen;
    } 0..($nlines-1);

    # make all lines same length
    map {
        $text[$_] .= ' ' x ($maxlen-$len[$_]);
    } 0..($nlines-1);
    #print Dumper(\@text);

    my @diagLR;
    my @diagRL;
    my @vertical;
    my $x = 0;
    my $y = 0;
    my $max = $nlines;
    $max = $maxlen if $maxlen < $nlines;

    # find text along diagonal L->R
    for (my $char=0; $char < $maxlen; $char++) {
        my @d;
        $x = $char;
        my $y = 0;
        my @origin = ($x, $y);
        map {
            if ($y < $nlines && $x < $maxlen) {
                my $char = substr($text[$y], $x, 1);
                push(@d, $char) if defined $char;
            }
            $x++;
            $y++;
        } 0..$nlines-1;
        unshift(@d, \@origin);
        push(@diagLR, \@d) if @d;
    }

    for (my $line=1; $line < $nlines; $line++) {
        my @d;
        $x = 0;
        my $y = $line;
        my @origin = ($x, $y);
        map {
            if ($y < $nlines && $x < $maxlen) {
                my $char = substr($text[$y], $x, 1);
                push(@d, $char) if defined $char;
            }
            $x++;
            $y++;
        } 0..$nlines-1;
        unshift(@d, \@origin);
        push(@diagLR, \@d) if @d;
    }

    # find text along diagonal R->L
    for (my $char=0; $char < $maxlen; $char++) {
        my @d;
        $x = $char;
        my $y = 0;
        my @origin = ($x, $y);
        map {
            if ($y < $nlines && $x >= 0) {
                my $char = substr($text[$y], $x, 1);
                push(@d, $char) if defined $char;
            }
            $x--;
            $y++;
        } 0..$nlines-1;
        unshift(@d, \@origin);
        push(@diagRL, \@d) if @d;
    }

    for (my $line=1; $line < $nlines; $line++) {
        my @d;
        $x = $maxlen-1;
        my $y = $line;
        my @origin = ($x, $y);
        map {
            if ($y < $nlines && $x >= 0) {
                my $char = substr($text[$y], $x, 1);
                push(@d, $char) if defined $char;
            }
            $x--;
            $y++;
        } 0..$nlines-1;
        unshift(@d, \@origin);
        push(@diagRL, \@d) if @d;
    }

    # find text along vertical
    for (my $char=0; $char < $maxlen; $char++) {
        my @d;
        my @origin = ($char, $y);
        push(@d, substr($text[$_], $char, 1)) for 0..$nlines-1;
        unshift(@d, \@origin);
        push(@vertical, \@d);
    }

    # correct LR to make text greppable
    map {
        my ($coords, @text) = @$_;
        my $text = join('', @text);
        $_ = [$text, $coords];
    } @diagLR;

    # correct RL to make text greppable
    map {
        my ($coords, @text) = @$_;
        my $text = join('', @text);
        $_ = [$text, $coords];
    } @diagRL;

    # correct vertical to make text greppable
    map {
        my ($coords, @text) = @$_;
        my $text = join('', @text);
        $_ = [$text, $coords];
    } @vertical;
    $.diagLR   = \@diagLR;
    $.diagRL   = \@diagRL;
    $.vertical = \@vertical;
    $.maxlen = $maxlen;
    $.nlines = $nlines;
    $.text   = \@text;
}

# reverse a string
sub _reverse {
    my ($self, $text) = @_;
    my @text = split //, $text;
    return join '', reverse(@text);
}

=head2 B

  $g2d->Grep($re);

Find the regular expression ($re) no matter where it occurs in
text.

The difference from a regular grep is that "coordinate" information
is returned for matches. This is the length of the
found match, x and y coordinates, along with
directional movement information (dx, dy).
It's easiest to use B to access matches.

=cut

sub Grep {
    my ($self, $re) = @_;
    my @matches;

    # find things "normally," like a regular grep
    push(@matches, ./grep_h($re));

    # find things in the L->R diagonal vector
    push(@matches, ./grep_lr($re));

    # find things in the R->L diagonal vector
    push(@matches, ./grep_rl($re));

    # find things in the vertical vector
    push(@matches, ./grep_v($re));

    return @matches;
}

sub _ref {
    my ($self, $ref) = @_;
    return \$ref if ref($ref) eq 'SCALAR';
    return \$ref->[0] if ref($ref) eq 'ARRAY';
}

=head2 B

  @matches = $g2d->grep_hf($re);

Search text normally, left to right.

=cut

sub grep_hf {
    my ($self, $re) = @_;
    my @matches;
    my $n = 0;
    # find things "normally," like a regular grep
    foreach (@{$.text}) {
        my $text = $_;
        while ($text =~/($re)/g) {
            push(@matches, [length($1), _start(\$text,$1), $n, 1, 0, \$_])
        }
        $n++;
    };
    return @matches;
}

=head2 B

  @matches = $g2d->grep_hf($re);

Search text normally, but right to left.

=cut

sub grep_hr {
    my ($self, $re) = @_;
    my @matches;
    my $n = 0;
    # find things "normally," like a regular grep
    foreach (@{$.text}) {
        my $text = $_;
        $text = ./_reverse($text);
        while ($text =~/($re)/g) {
            push(@matches,
                [length($1), length($text)-(_start(\$text,$1)+1),
                $n, -1, 0, \$_])
        }
        $n++;
    };
    return @matches;
}

=head2 B

  @matches = $g2d->grep_h($re);

Search text normally, in both directions.

=cut

sub grep_h {
    my ($self, $re) = @_;
    my @matches;
    push(@matches, ./grep_hf($re));
    push(@matches, ./grep_hr($re));
    return @matches;
}


=head2 B

  @matches = grep_vf($re);

Search text vertically, down.

=cut

sub grep_vf {
    my ($self, $re) = @_;
    my @matches;
    # find things in the vertical vector
    foreach (@{$.vertical}) {
        my ($text, $coords) = @$_;
        my ($x, $y) = @$coords;
        push(@matches, [length($1), $x, _start(\$text, $1),
            0, 1, \$_]) while ($text =~ /($re)/g);
    }
    return @matches;
}

=head2 B

  @matches = grep_vr($re);

Search text vertically, up.

=cut

sub grep_vr {
    my ($self, $re) = @_;
    my @matches;
    # find things in the vertical vector
    foreach (@{$.vertical}) {
        my ($text, $coords) = @$_;
        my ($x, $y) = @$coords;
        $text = ./_reverse($text);
        push(@matches, [length($1),$x, length($text)-_start(\$text, $1)-1,
            0, -1, \$_]) while ($text =~ /($re)/g);
    }
    return @matches;
}

=head2 B

  @matches = $g2d->grep_v($re);

Search text vertically, both directions.

=cut

sub grep_v {
    my ($self, $re) = @_;
    my @matches;
    push(@matches, ./grep_vf($re));
    push(@matches, ./grep_vr($re));
    return @matches;
}

=head2 B

  @matches = $g2d->grep_rlf($re);

Search the R->L vector top to bottom.

=cut

sub grep_rlf {
    my ($self, $re) = @_;
    my @matches;
    # find things in the R->L diagonal vector
    foreach (@{$.diagRL}) {
        my ($text, $coords) = @$_;
        my ($x, $y) = @$coords;
        while ($text =~ /($re)/g) {
            my $off = _start(\$text, $1);
            my $length = length($1);
            push(@matches, [$length, $x-$off, $off+$y, -1, 1, \$_]);
        }
    }
    return @matches;
}

=head2 B

  @matches = $g2d->grep_rlr($re);

Search the R->L vector bottom to top.

=cut

sub grep_rlr {
    my ($self, $re) = @_;
    my @matches;
    # find things in the R->L diagonal vector
    foreach (@{$.diagRL}) {
        my ($text, $coords) = @$_;
        my ($x, $y) = @$coords;
        $text = ./_reverse($text);
        $x -= length($text);
        $y += length($text);
        $x++;
        $y--;
        while ($text =~ /($re)/g) {
            my $off = _start(\$text, $1);
            my $length = length($1);
            push(@matches, [$length, $x+$off, $y-$off, 1, -1, \$_]);
        }
    }
    return @matches;
}

=head2 B

  @matches = $g2d->grep_rlf($re);

Search the R->L both directions.

=cut

sub grep_rl {
    my ($self, $re) = @_;
    my @matches;
    push(@matches, ./grep_rlf($re));
    push(@matches, ./grep_rlr($re));
    return @matches;
}

=head2 B

  @matches = $g2d->grep_lrf($re);

Search the L->R top to bottom.

=cut

sub grep_lrf {
    my ($self, $re) = @_;
    my @matches;
    # find things in the L->R diagonal vector
    foreach (@{$.diagLR}) {
        my ($text, $coords) = @$_;
        my ($x, $y) = @$coords;
        while ($text =~ /($re)/g) {
            my $off = _start(\$text,$1);
            push(@matches,
                [length($1), $x+$off, $off+$y, 1, 1, \$_])
        }
    }
    return @matches;
}

=head2 B

  @matches = $g2d->grep_lrr($re);

Search the L->R bottom to top.

=cut

sub grep_lrr {
    my ($self, $re) = @_;
    my @matches;
    # find things in the L->R diagonal vector
    foreach (@{$.diagLR}) {
        my ($text, $coords) = @$_;
        my ($x, $y) = @$coords;
        $text = ./_reverse($text);
        while ($text =~ /($re)/g) {
            my $off = _start(\$text,$1);
            my $length = length($1);
            $x += length($text);
            $y += length($text);
            $x--;
            $y--;
            push(@matches,
                [length($1), $x-$off, $y-$off, -1, -1, \$_])
        }
    }
    return @matches;
}

=head2 B

  @matches = $g2d->grep_lr($re);

Search the L->R both directions.

=cut

sub grep_lr {
    my ($self, $re) = @_;
    my @matches;
    push(@matches, ./grep_lrf($re));
    push(@matches, ./grep_lrr($re));
    return @matches;
}

=head2 B

  $result = $g2d->extract($info);

Extract pattern match described by $info, which is a single return
from B. E.g.

  my @matches = $g2d->Grep(qr(foo\w+));
  map {
      print "Matched ", $g2d->extract($_), "\n";
  } @matches;

=cut

sub extract {
    my ($self, $info) = @_;
    my ($length, $x, $y, $dx, $dy) = @$info;
    my @result;
    map {
        push(@result, substr($.text->[$y], $x, 1));
        $x += $dx;
        $y += $dy;
    } 1..$length;
    return join('', @result);
}

sub _start {
    my ($textRef, $one) = @_;
    return pos($$textRef) - length($one);
}

=head2 B

  $textRef = $g2d->text();

Return an array reference to our internal text buffer. This
is for future use. Don't mess with the return, or bad things
may happen.

=cut

sub text {
    my ($self) = @_;
    return $.text;
}

=head1 AUTHOR

X Cramps, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to
C, or through
the web interface at
L.
I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Acme::Grep2D

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back


=head1 ACKNOWLEDGEMENTS

Captain Beefheart and the Magic Band. Fast & bulbous. Tight, also.

=head1 COPYRIGHT & LICENSE

Copyright 2009 X Cramps, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;