view release on metacpan or  search on metacpan

lib/Acme/Grep2D.pm  view on Meta::CPAN

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<Grep> 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<Grep>

  $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<extract> 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<grep_hf>

lib/Acme/Grep2D.pm  view on Meta::CPAN

                [length($1), $x+$off, $off+$y, 1, 1, \$_]) 
        }
    }
    return @matches;
}

=head2 B<grep_lrr>

  @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<grep_lr>

  @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<extract>

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

Extract pattern match described by $info, which is a single return
from B<Grep>. 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<text>

  $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<< <cramps.the at gmail.com> >>

=head1 BUGS

Please report any bugs or feature requests to 
C<bug-acme-grep2d at rt.cpan.org>, or through
the web interface at 
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Acme-Grep2D>.  
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<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Acme-Grep2D>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Acme-Grep2D>

=item * CPAN Ratings