Word search

You are given a grid of characters and a string. Write a script to determine whether the given string can be found in the given grid of characters. You may start anywhere and take any orthogonal path, but may not reuse a grid cell.

Examples

Example 1
Input: @chars = (['A', 'B', 'D', 'E'],
                 ['C', 'B', 'C', 'A'],
                 ['B', 'A', 'A', 'D'],
                 ['D', 'B', 'B', 'C'])
      $str = 'BDCA'
Output: true

Example 2
Input: @chars = (['A', 'A', 'B', 'B'],
                 ['C', 'C', 'B', 'A'],
                 ['C', 'A', 'A', 'A'],
                 ['B', 'B', 'B', 'B'])
      $str = 'ABAC'
Output: false

Example 3
Input: @chars = (['B', 'A', 'B', 'A'],
                 ['C', 'C', 'C', 'C'],
                 ['A', 'B', 'A', 'B'],
                 ['B', 'B', 'A', 'A'])
      $str = 'CCCAA'
Output: true

Analysis

This is another challenge where recursion is the compact solution.

First, we loop over all the cells to find occurrences of the first character of $str.

From each of these, we check the cells above, below, to the left and to the right (if they exist) to see whether they contain the next character of $str.

If so, and if this is the last character, we have an answer.

If not we recurse over the last 2 paragraphs until we either find an answer, or run out of options - in which case there is no solution.

Recursion is relatively slow in Perl, but in this case provided there are few false trails it will complete quickly. I tried it with a 20 x 20 grid and a 20 letter word zigzagging up from the bottom right, and it completed in negligible time.

One-liner from Peter? Yes, you heard me correctly. Don't forget to DIY. Brilliant work.

This review may cover either or both challenges for this week.

Try it 

Try running the script with any input:

Your @grid =

example:
A, B, C, D, E
F, G, H, R, J
K, T, S, I, O
P, Q, A, S, T
U, V, M, T, Y

Your $string =

example: CHRISTMAS

⤡

#!/usr/bin/perl

# Blog: http://ccgi.campbellsmiths.force9.co.uk/challenge

use v5.26;    # The Weekly Challenge - 2024-12-09
use utf8;     # Week 299 - task 2 - Word search
use warnings; # Peter Campbell Smith
binmode STDOUT, ':utf8';

my ($end, $x_max, $y_max);

word_search([['A', 'B', 'D', 'E'],
             ['C', 'B', 'C', 'A'],
             ['B', 'A', 'A', 'D'],
             ['D', 'B', 'B', 'C']], 'BDCA');

word_search([['A', 'B', 'D', 'E'],
             ['C', 'B', 'C', 'A'],
             ['B', 'A', 'A', 'D'],
             ['D', 'B', 'B', 'C']], 'BDCF');
             
word_search([['A', 'P', 'R', 'E'],
             ['C', 'R', 'U', 'S'],
             ['B', 'I', 'A', 'D'],
             ['E', 'S', 'B', 'C']], 'SURPRISE');
             
word_search([['W', 'Y', 'C', 'E', 'N'],
             ['E', 'L', 'H', 'L', 'G'],
             ['E', 'K', 'A', 'L', 'E']], 'WEEKLYCHALLENGE');

sub word_search {
    
    my ($chars, $str, @grid, $x, $y, $save);
    
    # initialise
    ($chars, $str) = @_;
    $y_max = @$chars - 1;
    $x_max = @{$chars->[0]} - 1;
    $end = '';
    print_matrix('Input: @chars = ', $chars);
    say qq[       \$str =    $str];
    
    # make @grid
    for $x (0 .. $x_max) {
        for $y (0 .. $y_max) {
            $grid[$y][$x] = $chars->[$y]->[$x];
        }
    }
    
    # find all locations of the first letter
    SEARCH: for $x (0 .. $x_max) {
        for $y (0 .. $y_max) {
            if ($grid[$y][$x] eq substr($str, 0, 1)) {
                
                # blank it out and look for the rest
                $save = $grid[$y][$x];
                $grid[$y][$x] = '*';
                keep_searching(\@grid, substr($str, 1), $x, $y);
                
                # success!
                if ($end) {
                    say qq[Output: true, from ($x, $y) $end];                   
                    last SEARCH;
                }
                $grid[$y][$x] = $save;
            }
        }
    }
    say qq[Output: false] unless $end;
}

sub keep_searching {
    
    my (@grid, $str, $x, $y, $xx, $yy, $save);
    
    # recursive search for next letter
    @grid = @{$_[0]};
    $str = $_[1];
    ($x, $y) = ($_[2], $_[3]);
    
    # check cells above, below, left and right (if they exist)
    for $xx ($x - 1 .. $x + 1) {
        for $yy ($y - 1 .. $y + 1) {
            next if ($xx < 0 or $yy < 0 or $xx > $x_max or $yy > $y_max);
            next unless ($xx == $x or $yy == $y);
            
            # do they contain the next letter?
            if ($grid[$yy][$xx] eq substr($str, 0, 1)) {
                
                # have we found all the letters yet?
                if (length($str) == 1) {
                    $end = qq[to ($xx, $yy)];
                    return;
                }
                
                # no, so recurse to find the rest
                $save = $grid[$yy][$xx];
                $grid[$yy][$xx] = '*';
                keep_searching(\@grid, substr($str, 1), $xx, $yy);
                $grid[$yy][$xx] = $save;
            }
        }
    }
}

sub print_matrix {
    
    my ($legend, $matrix, $j);

    # format matrix
    ($legend, $matrix) = @_;
    say '';
    for $j (0 .. @$matrix - 1) {
        say qq{$legend [} . join(', ', @{$matrix->[$j]}) . qq(]);
        $legend = ' ' x length($legend);
    }
}

46 lines of code

Output from script

Input: @chars =  [A, B, D, E]
                 [C, B, C, A]
                 [B, A, A, D]
                 [D, B, B, C]
       $str =    BDCA
Output: true, from (1, 0) to (2, 2)

Input: @chars =  [A, B, D, E]
                 [C, B, C, A]
                 [B, A, A, D]
                 [D, B, B, C]
       $str =    BDCF
Output: false

Input: @chars =  [A, P, R, E]
                 [C, R, U, S]
                 [B, I, A, D]
                 [E, S, B, C]
       $str =    SURPRISE
Output: true, from (3, 1) to (0, 3)

Input: @chars =  [W, Y, C, E, N]
                 [E, L, H, L, G]
                 [E, K, A, L, E]
       $str =    WEEKLYCHALLENGE
Output: true, from (0, 0) to (4, 2)