path: root/challenge-336/athanasius/perl/ch-1.pl

#!perl

################################################################################
=comment

Perl Weekly Challenge 336
=========================

TASK #1
-------
*Equal Group*

Submitted by: Mohammad Sajid Anwar

You are given an array of integers.

Write a script to return true if the given array can be divided into one or more
groups: each group must be of the same size as the others, with at least two
members, and with all members having the same value.

Example 1

  Input: @ints = (1,1,2,2,2,2)
  Output: true

  Groups: (1,1), (2,2), (2,2)

Example 2

  Input: @ints = (1,1,1,2,2,2,3,3)
  Output: false

  Groups: (1,1,1), (2,2,2), (3,3)

Example 3

  Input: @ints = (5,5,5,5,5,5,7,7,7,7,7,7)
  Output: true

  Groups: (5,5,5,5,5,5), (7,7,7,7,7,7)

Example 4

  Input: @ints = (1,2,3,4)
  Output: false

Example 5

  Input: @ints = (8,8,9,9,10,10,11,11)
  Output: true

  Groups: (8,8), (9,9), (10,10), (11,11)

=cut
################################################################################

#--------------------------------------#
# Copyright © 2025 PerlMonk Athanasius #
#--------------------------------------#

#===============================================================================
=comment

Interface
---------
1. If no command-line arguments are given, the test suite is run. Otherwise:
2. A non-empty list of integers is entered on the command-line.

Algorithm
---------
The integers in the input list are merely markers -- they could just as well be
characters or words. The order in which they appear is also irrelevant. What
matters is the frequency with which they appear in the list:

(1) If any list element occurs only once, no solution is possible.

(2) Otherwise, a solution is possible if and only if the frequencies share a
    common divisor greater than 1. This gives rise to the following algorithm:

    1. For each element in the list, find its frequency, f.
    2. For each f, find the bag (multiset) containing the prime factors of f.
    3. Find X, the intersection of all bags found in step 2.
    4. If X is empty, no solution is possible.
    5. Otherwise, find p, the product of all the members of X.
    6. A solution may now be generated by partitioning the elements of the
       original list into same-element bags, each of size p.

=cut
#===============================================================================

use v5.38.2;          # Enables strictures
use warnings;
use Const::Fast;
use Math::Prime::Util qw( factor );
use Regexp::Common    qw( number );
use Set::Bag;
use Test::More;

const my $USAGE => <<END;
Usage:
  perl $0 [<ints> ...]
  perl $0

    [<ints> ...]    A non-empty list of integers
END
#-------------------------------------------------------------------------------
BEGIN
#-------------------------------------------------------------------------------
{
    $| = 1;
    print "\nChallenge 336, Task #1: Equal Group (Perl)\n\n";
}

#===============================================================================
MAIN:
#===============================================================================
{
    if (scalar @ARGV == 0)
    {
        run_tests();
    }
    else
    {
        my @ints = @ARGV;

        for (@ints)
        {
            / ^ $RE{num}{int} $ /x or error( qq["$_" is not a valid integer] );
        }

        printf "Input:  \@ints = (%s)\n", join ',', @ints;

        my ($result, $groups) = equal_groups( \@ints );

        printf "Output: %s\n", $result ? 'true' : 'false';

        if ($result)
        {
            printf "\nGroups: %s\n",
                    join ', ', map { '(' . join( ',', @$_ ) . ')' } @$groups;
        }
    }
}

#-------------------------------------------------------------------------------
sub equal_groups
#-------------------------------------------------------------------------------
{
    my ($ints)  = @_;
    my  $result = '';
    my  $groups = [];
    my  %count;
      ++$count{ $_ } for @$ints;

    my  @counts = sort { $a <=> $b } values %count;

    if ($counts[ 0 ] > 1)  # If the smallest count is 1, no solution is possible
    {
        my $common_prime_factors = Set::Bag->new;
           $common_prime_factors->insert( $_ => 1 ) for factor( $counts[  0 ] );

        for my $i (1 .. $#counts)
        {
            my $prime_factors    = Set::Bag->new;
               $prime_factors   ->insert( $_ => 1 ) for factor( $counts[ $i ] );

            $common_prime_factors &= $prime_factors;     # Keep the intersection
        }

        my @factors = $common_prime_factors->elements;

        if (scalar @factors > 0)
        {
            $result = 1;
            $groups = make_groups( \%count, \@factors );
        }
    }

    return ($result, $groups);
}

#-------------------------------------------------------------------------------
sub make_groups
#-------------------------------------------------------------------------------
{
    my ($count, $factors) = @_;
    my  @groups;
    my  $product  = 1;
        $product *= $_ for @$factors;

    for my $n (sort { $a <=> $b } keys %$count)
    {
        my $multiplier = $count->{ $n } / $product;

        push @groups, [ ($n) x $product ] for 1 .. $multiplier;
    }

    return \@groups;
}

#-------------------------------------------------------------------------------
sub run_tests
#-------------------------------------------------------------------------------
{
    print "Running the test suite\n";

    while (my $line = <DATA>)
    {
        chomp $line;

        my  ($test_name, $ints_str, $expected_str, $groups_str) =
             split / \| /x, $line;

        for ($test_name, $ints_str, $expected_str, $groups_str)
        {
            s/ ^ \s+   //x;
            s/   \s+ $ //x;
        }

        my  @ints             = split / \s+ /x, $ints_str;
        my ($result, $groups) = equal_groups( \@ints );
        my  $expected         = $expected_str eq 'true';
        my  @group_str        = split / \; \s* /x, $groups_str;
        my  @exp_groups       = map { [ split / \s+ /x, $_ ] } @group_str;

        is        $result,  $expected,   "$test_name: Result";
        is_deeply $groups, \@exp_groups, "$test_name: Groups" if $result;
    }

    done_testing;
}

#-------------------------------------------------------------------------------
sub error
#-------------------------------------------------------------------------------
{
    my ($message) = @_;

    die "ERROR: $message\n$USAGE";
}

################################################################################

__DATA__
Example 1|1 1 2 2 2 2            |true |1 1; 2 2; 2 2
Example 2|1 1 1 2 2 2 3 3        |false|1 1 1; 2 2 2; 3 3
Example 3|5 5 5 5 5 5 7 7 7 7 7 7|true |5 5 5 5 5 5; 7 7 7 7 7 7
Example 4|1 2 3 4                |false|
Example 5|8 8 9 9 10 10 11 11    |true |8 8; 9 9; 10 10; 11 11