As it is an interesting problem to solve, I had a go at finding the exact fit solutions.
The code below will handle up 31 schools. Actually it will handle 31 unique values which means it would handle more schools if any of them have the same requirements. It would probably handle more if you used Math::BigInt in the appropriate places, but the resultant slowdown would probably make it painful to use.
As it it, it solves 20 unique values in around 2 minutes and 23 in around 16 minutes. I haven't tried it on 31, as I think it would take many hours. I guess I ought to be able to estimate it, but my brain has given up for now.
#! perl -sw
use strict;
use Data::Dumper;
sub listm{ grep{ $_[0] & (1 << $_) }0 .. 31 }
#! build test data
my %table;
my $n=0;
for my $c ('A' .. 'T') {
$table{ +sprintf '%s%03d', $c, ++$n } = int(20+rand 100);
}
print Dumper \%table, $/;
print scalar localtime, $/;
#! Invert table
my %reqs;
while (my ($key, $value)= each %table) {
push @{$reqs{$value}}, $key;
}
#print Dumper \%reqs, $/;
#! get array of unique requirements
my @reqs = keys %reqs;
print 'checking permutations of ', scalar @reqs, " unique values\n@req
+s\n\n";
#! test the permutations and capture those with a $total <= 400
my ($perms, @ok) = (0);
for my $perm (1 .. (2 ** @reqs)-1 ) {
$perms++;
my $total = 0;
$total += $_ for @reqs[ listm($perm) ];
next if $total > 400;
push @ok, [$total, @reqs[ listm($perm) ] ];
# print $total, ' : ', do{local $"='|'; "@{[ @reqs[ listm($perm)] ]
+}";}; #!"
}
print 'Checked ', $perms, ' possible permutations', $/;
#! sort the possible solutions
@ok = sort{ $b->[0] <=> $a->[0] } @ok;
#! check for one (or more) complete solutions
my $count=0;
1 while $ok[$count++][0] == 400;
print 'There are at least ', --$count, ' complete solutions', $/;
#! Generate solutions.
my @solutions;
for my $sol (0 .. $count-1) {
my @n = [];
for my $val ( @{ $ok[$sol] }[ 1..$#{$ok[$sol]} ] ) {
my $schools = @{$reqs{$val}};
if ($schools > 1) {
my @m = @n;
@n = map{
my $school = $_;
map{ [ @{$_}, $school ] } @m
} @{$reqs{$val}};
}
else {
push @{$_}, @{ $reqs{$val} }[0] for @n;
}
}
push @solutions, @n;
}
print 'There are actually ', scalar @solutions, ' possible solutions.
+Alpha-sorted, the first 20 are:', $/;
@solutions = sort{ "@{$a}" cmp "@{$b}" } map { [ sort @{$_} ] } @solut
+ions;
printf "%-50s %30s = %d\n"
, "@{$_}"
, "@table{ @{$_} }"
, do{ my $t=0; $t += $_ for @table{ @{$_} }; $t; }
for @solutions[0 .. 19];
print scalar localtime, $/;
Some sample output
Maybe you will find it useful.
Examine what is said, not who speaks.
The 7th Rule of perl club is -- pearl clubs are easily damaged. Use a diamond club instead. |