Task — Contiguous block

You are given a rectangular matrix where all the cells contain either x or o. Write a script to determine the size of the largest contiguous block. A contiguous block consists of elements containing the same symbol which share an edge (not just a corner) with other elements in the block, and where there is a path between any two of these elements that crosses only those shared edges.

Examples

Example 1
    Input: $matrix = [
                       ['x', 'x', 'x', 'x', 'o'],
                       ['x', 'o', 'o', 'o', 'o'],
                       ['x', 'o', 'o', 'o', 'o'],
                       ['x', 'x', 'x', 'o', 'o'],
                     ]
    Output: 11
        Block of 9 contiguous cells containing 'x'.
        Block of 11 contiguous cells containing 'o'.

Example 2
    Input: $matrix = [
                       ['x', 'x', 'x', 'x', 'x'],
                       ['x', 'o', 'o', 'o', 'o'],
                       ['x', 'x', 'x', 'x', 'o'],
                       ['x', 'o', 'o', 'o', 'o'],
                     ]
    Output: 11
        Block of 11 contiguous cells containing 'x'.
        Block of 9 contiguous cells containing 'o'.

Example 3
    Input: $matrix = [
                       ['x', 'x', 'x', 'o', 'o'],
                       ['o', 'o', 'o', 'x', 'x'],
                       ['o', 'x', 'x', 'o', 'o'],
                       ['o', 'o', 'o', 'x', 'x'],
                     ]
    Output: 7
        Block of 7 contiguous cells containing 'o'.
        There are two other 2-cell blocks of 'o'.
        and three 2-cell blocks of 'x' and one 3-cell.

Analysis

Caveat: I suggested this challenge as it was similar to something I had to do elsewhere, but this code is new.

Broadly my strategy is to examine each cell in turn. If it contains an x or an o I change that to a number and then call sub number_neighbours to put the same number in the cells above, below, to the left and to the right of the current cell if they contain the same symbol (x or o). Then, number_neighbours recursively calls itself to deal with neighbours of neighbours and so on.

Recursion is relatively slow in Perl, but this works in negligible time for quite large matrices as the number of recursive calls falls off quite rapidly.

Try it 

#!/usr/bin/perl

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

use v5.26;    # The Weekly Challenge - 2024-09-23
use utf8;     # Week 288 - task 2 - Contiguous block
use warnings; # Peter Campbell Smith
binmode STDOUT, ':utf8';

my ($matrix, $last_x, $last_y, @count, $number, $symbol);

contiguous_block(
[['x', 'x', 'x', 'x', 'o'],
 ['x', 'o', 'o', 'o', 'o'],
 ['x', 'o', 'o', 'o', 'o'],
 ['x', 'x', 'x', 'o', 'o']]);
 
contiguous_block(
[['x', 'x', 'x', 'x', 'x', 'x'],
 ['x', 'o', 'o', 'o', 'o', 'o'],
 ['x', 'x', 'x', 'x', 'x', 'x'],
 ['o', 'o', 'o', 'o', 'o', 'x'],
 ['o', 'x', 'x', 'x', 'o', 'x'],
 ['x', 'o', 'o', 'o', 'o', 'x'],
 ['x', 'x', 'x', 'x', 'x', 'x']]); 

sub contiguous_block {
    
    my ($x, $y, $most, $block, $j);
    
    $matrix = shift;
    print_matrix(qq[Input: ], $matrix);
    $last_x = @$matrix - 1;
    $last_y = @{$matrix->[0]} - 1;
    $number = 0;
    @count = ();
    
    # loop over cells
    for $x (0 .. $last_x) {
        for $y (0 .. $last_y) {

            # if cell contains a number, skip it
            next if $matrix->[$x]->[$y] =~ m|^\d+$|;
            $symbol = $matrix->[$x]->[$y];
            
            # else number it
            $matrix->[$x]->[$y] = ++ $number;
            $count[$number] ++;
            
            # and number all its unnumbered neighbours recursively
            number_neighbours($x, $y);
        }
    }
    
    # find largest
    $most = 0;
    for $j (1 .. @count - 1) {
        if ($count[$j] > $most) {
            $most = $count[$j];
            $block = $j;
        }
    }
    say qq[\nOutput: largest block size is $most (block $block)];   
    print_matrix(qq[Blocks:], $matrix);
    say qq[-----];
}

sub number_neighbours {
    
    my ($x, $y, $xx, $yy, $neighbour);
    
    ($x, $y) = @_;
    
    # cells above, below, left and right of $x, $y
    for $neighbour (1 .. 4) {
        if    ($neighbour == 1) {$xx = $x - 1; $yy = $y    }
        elsif ($neighbour == 2) {$xx = $x;     $yy = $y + 1}
        elsif ($neighbour == 3) {$xx = $x;     $yy = $y - 1}
        elsif ($neighbour == 4) {$xx = $x + 1; $yy = $y    }
        next if ($xx < 0 or $xx > $last_x or $yy < 0 or $yy > $last_y);
        
        # number them the same if they are not already numbered
        if ($matrix->[$xx]->[$yy] eq $symbol) {
            $matrix->[$xx]->[$yy] = $number;
            $count[$number] ++;
            number_neighbours($xx, $yy);
        }
    }
}

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);
    }
}

Output

Input:  [x, x, x, x, o]
        [x, o, o, o, o]
        [x, o, o, o, o]
        [x, x, x, o, o]

Output: largest block size is 11 (block 2)

Blocks: [1, 1, 1, 1, 2]
        [1, 2, 2, 2, 2]
        [1, 2, 2, 2, 2]
        [1, 1, 1, 2, 2]
-----

Input:  [x, x, x, x, x, x]
        [x, o, o, o, o, o]
        [x, x, x, x, x, x]
        [o, o, o, o, o, x]
        [o, x, x, x, o, x]
        [x, o, o, o, o, x]
        [x, x, x, x, x, x]

Output: largest block size is 23 (block 1)

Blocks: [1, 1, 1, 1, 1, 1]
        [1, 2, 2, 2, 2, 2]
        [1, 1, 1, 1, 1, 1]
        [3, 3, 3, 3, 3, 1]
        [3, 4, 4, 4, 3, 1]
        [1, 3, 3, 3, 3, 1]
        [1, 1, 1, 1, 1, 1]
-----