Perl Monk, Perl Meditation PerlMonks

Recognizing pattern in 2D grid

by pwagyi (Monk)
 on Jan 16, 2018 at 02:42 UTC Need Help??

pwagyi has asked for the wisdom of the Perl Monks concerning the following question:

Greeting monks!

I am facing a problem in recognizing a pattern in 2 dimensional grid. 2D grid is represented by hash of hash (X,Y coordinate as key, and value). I need to recognize some patterns like (horizontal, vertical, or diagonal) example data (x,y coordinate and value (a,b,c,..))

```recognize( pattern => 'horizontal', min => 3);  # recognize 3 or more
+consecutive horizontal pattern
recognize( pattern => 'vertical',  min => 5);
|a|a|b|a|c|
|a|a|c|e|f|
|e|f|a|1|b|

Replies are listed 'Best First'.
Re: Recognizing pattern in 2D grid
by Athanasius (Archbishop) on Jan 16, 2018 at 03:49 UTC

Hello pwagyi,

I think an array of arrays (AoA) is a better data structure for this task than a hash of hashes (HoH). And if each datum is only a single character, as in the example given, you can use regular expressions to do the searching. The following script lacks proper error checking, etc., but should give you an idea of how to proceed:

```use strict;
use warnings;

my @grid =
(
[ qw( a a b a c ) ],
[ qw( a a a c f ) ],
[ qw( a f c 1 b ) ],
[ qw( a w x c z ) ],
[ qw( a q q q c ) ],
);

recognize( pattern => 'horizontal', min => 3 );
recognize( pattern => 'vertical',   min => 5 );
recognize( pattern => 'diagonal',   min => 2 );

sub recognize
{
my %config  = @_;
my \$pattern = \$config{pattern} // 'horizontal';
my \$min     = \$config{min}     //  3;
my \$reps    = \$min - 1;

if    (\$pattern eq 'horizontal')
{
for my \$row (0 .. \$#grid)
{
my \$string;
\$string .= \$_ for \$grid[\$row]->@*;

print "Found \$pattern pattern '\$&' in row \$row\n"
while \$string =~ /(.)\1{\$reps,}/g;
}
}
elsif (\$pattern eq 'vertical')
{
for my \$col (0 .. \$#{ \$grid[0] })
{
my \$string;
\$string .= \$_->[\$col] for @grid;

print "Found \$pattern pattern '\$&' in column \$col\n"
while \$string =~ /(.)\1{\$reps,}/g;
}
}
elsif (\$pattern eq 'diagonal')
{
my \$string;
\$string .= \$grid[\$_][\$_] for 0 .. \$#grid;

print "Found \$pattern pattern '\$&' in left-right diagonal\n"
while \$string =~ /(.)\1{\$reps,}/g;

my \$col = \$#grid;
\$string = '';

for my \$row (0 .. \$#grid)
{
\$string .= \$grid[\$row][\$col--];
}

print "Found \$pattern pattern '\$&' in right-left diagonal\n"
while \$string =~ /(.)\1{\$reps,}/g;
}
else
{
die "Unknown pattern '\$pattern', stopped";
}
}

Output:

```13:48 >perl 1862_SoPW.pl
Found horizontal pattern 'aaa' in row 1
Found horizontal pattern 'qqq' in row 4
Found vertical pattern 'aaaaa' in column 0
Found diagonal pattern 'aa' in left-right diagonal
Found diagonal pattern 'ccc' in left-right diagonal
Found diagonal pattern 'ccc' in right-left diagonal

13:57 >

Update: It occurs to me, belatedly, that a “diagonal” pattern might mean a sequence on any diagonal, and not just one of the two major diagonals, as I naïvely assumed. Extending the code to allow for matches on any diagonal is hereby left as the proverbial exercise for the reader. :-)

Hope that helps,

 Athanasius <°(((>< contra mundum Iustus alius egestas vitae, eros Piratica,

Re: Recognizing pattern in 2D grid
by tybalt89 (Monsignor) on Jan 16, 2018 at 07:29 UTC

Form a multiline string and play with the \$gap.

```#!/usr/bin/perl

# http://perlmonks.org/?node_id=1207332

use strict;
use warnings;

my @grid =
(
[ qw( a a b a c ) ],
[ qw( a a a c f ) ],
[ qw( a f c 1 b ) ],
[ qw( a w x c z ) ],
[ qw( a q q q c ) ],
);

\$_ = join '', map join('', @\$_) . "\n", @grid; # convert to string
print;

recognize( pattern => 'horizontal', min => 3 );
recognize( pattern => 'vertical',   min => 5 );
recognize( pattern => 'diagonal',   min => 2 );

sub recognize
{
my %args = @_;
my ( \$direction, \$min) = @args{ qw( pattern min ) };
\$min // die "min not defined";
my \$reps = \$min - 1;
my \$linesize = /\n/ && \$+[0];
my \$gapref = { horizontal => [0], vertical => [\$linesize - 1],
diagonal => [\$linesize - 2, \$linesize]}->{\$direction} //
die "invalid direction \$direction";

for my \$gap ( @\$gapref )
{
print "\n";
print "\$direction @{[ 1 + length(\$2) / (\$gap + 1) ]} '\$1' at ",
\$-[1] % \$linesize, ' ', int \$-[1] / \$linesize, "\n"
while /(\w)(?=((?:.{\$gap}\1){\$reps,}))/gs;
}
}

Outputs:

```aabac
aaacf
afc1b
awxcz
aqqqc

horizontal 3 'a' at 0 1
horizontal 3 'q' at 1 4

vertical 5 'a' at 0 0

diagonal 2 'a' at 1 0
diagonal 2 'a' at 3 0
diagonal 3 'c' at 4 0
diagonal 2 'a' at 1 1
diagonal 2 'c' at 3 1

diagonal 2 'a' at 0 0
diagonal 2 'a' at 1 0
diagonal 3 'c' at 2 2
diagonal 2 'c' at 3 3
Re: Recognizing pattern in 2D grid
by Eily (Monsignor) on Jan 16, 2018 at 15:23 UTC

Hello pwagyi.

I wanted to try a on a flat string, with a regex that would do something like /A(.*)B.{N}C.{N}D/ where (.*) would be of length 0 (row), width (column) or width+1 (diagonal from top left to bottom right), and N would somehow be equal to that length.

I managed to do that using (??{ CODE }) patterns, which makes it possible to embed a new sub pattern in a regex while it is being run. But it is not available by default: you need use re "eval";.

Since the regex is build from the searched pattern, this ended up being a function that takes a pattern as a parameter, and returns a closure that will search that pattern in a grid. Maybe that's too many advanced perl feature for usable code ^^" .

```use strict;
use warnings;
use re qw( eval );
use Data::Dump qw( pp );

sub finder_maker
{
my \$pattern = shift;
my @chars = split //, \$pattern;
die unless @chars > 1;

my (\$first_char, \$second_char, @tail) = @chars;

# Each character after the first two will be followed by (??{'.{'.le
+ngth(\$1).'}'})
# This means that the code '.{'.length(\$1).'}' will be run while the
+ regex is executed
# and be replaced by .{N} with N the length of the first interval
my \$regex_tail = join "", map "(??{'.{'.length(\\$1).'}'})\$_", @tail;

# Return a sub that will search for this pattern in a grid
return sub {
my \$data = \$_[0];
my \$width = @{ \$data->[0] };
say "Searching for \$pattern in:\n", pp(\$data);

# To avoid the string "ABCD" for
# A B
# C D
# giving a false row on BC, we add dummy values to onl
+y keep the actual rows as valid
# So we will have "AB__CD__" instead
my \$string = "";
\$string .= join "", @\$_, "_" x @\$_, "\n" for @\$data;

my %directions = (
0          => "Row",
2*\$width   => "Column",
2*\$width+1 => "Diagonal"
);

# Allow a distance that matches a row, column or diago
+nal for the first interval
my \$first_interval = join "|", map ".{\$_}", keys %dire
+ctions;

# Find the first char, then the second, separated by a
+n allowed interval
\$string =~ /\$first_char (\$first_interval) \$second_char
+ \$regex_tail/xs
or say "Not found\n\n" and return { };

my \$out =  {
x => int(\$-[0]%(1+2*\$width)),
y => int(\$-[0]/(1+2*\$width)),
Direction =>  \$directions{length \$1}
};

say "Found:\n", pp(\$out), "\n\n";
return \$out;
};
}

my \$grid = [
[ qw( a a b a c ) ],
[ qw( a a a c f ) ],
[ qw( a f c 1 b ) ],
[ qw( a w x c z ) ],
[ qw( a q h q c ) ]
];

my \$afx = finder_maker("afx");
\$afx->(\$grid);

finder_maker("fc1b")->(\$grid);

my \$smaller = [
['w', 'a'],
['a', 'q']
];

my \$wq = finder_maker("wq");
\$wq->(\$grid);
\$wq->(\$smaller);

finder_maker("Nothing")->(\$smaller);
```Searching for afx in:
[
["a", "a", "b", "a", "c"],
["a", "a", "a", "c", "f"],
["a", "f", "c", 1, "b"],
["a", "w", "x", "c", "z"],
["a", "q", "h", "q", "c"],
]
Found:
{ Direction => "Diagonal", x => 0, y => 1 }

Searching for fc1b in:
[
["a", "a", "b", "a", "c"],
["a", "a", "a", "c", "f"],
["a", "f", "c", 1, "b"],
["a", "w", "x", "c", "z"],
["a", "q", "h", "q", "c"],
]
Found:
{ Direction => "Row", x => 1, y => 2 }

Searching for wq in:
[
["a", "a", "b", "a", "c"],
["a", "a", "a", "c", "f"],
["a", "f", "c", 1, "b"],
["a", "w", "x", "c", "z"],
["a", "q", "h", "q", "c"],
]
Found:
{ Direction => "Column", x => 1, y => 3 }

Searching for wq in:
[["w", "a"], ["a", "q"]]
Found:
{ Direction => "Diagonal", x => 0, y => 0 }

Searching for Nothing in:
[["w", "a"], ["a", "q"]]

Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlquestion [id://1207332]
Approved by Athanasius
Front-paged by haukex
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others sharing their wisdom with the Monastery: (3)
As of 2024-02-25 13:02 GMT
Voting Booth?
My favourite way to spend a leap day ...

Results (23 votes). Check out past polls.