#!/usr/bin/perl use strict; use warnings; my $alphabet = uc('ADEFGMSTV'); my $N = length($alphabet); my $L = $N - 1; my @ltr_lkup = $alphabet =~ /./g; my %idx_lkup = map { substr($alphabet, $_, 1) => $_ } 0..$L; sub tupple { return join '', @ltr_lkup[ sort { $a <=> $b } @_ ]; } sub find { my ($counts) = @_; my %solutions; local *try_straight_tupple = sub { my ($counts, $i, $solution) = @_; my $instances = $counts->[$i]; if ($instances == 0) { process($counts, $i+1, $solution); return; } return if $i+3 > $L || $counts->[$i+1] < $instances || $counts->[$i+2] < $instances || $counts->[$i+3] < $instances; my @counts = @$counts; my @solution = ( @$solution, tupple( $i+0 .. $i+3 ) ); $counts[$i+$_] -= $instances for 0..3; process(\@counts, $i+1, \@solution); }; local *try_quad_tupple = sub { my ($counts, $i, $solution) = @_; try_straight_tupple($counts, $i, $solution); if ($counts->[$i] < 4) { return; } my @counts = @$counts; my @solution = ( @$solution, tupple( ($i) x 4 ) ); while ($counts[$i] >= 4) { $counts[$i] -= 4; try_straight_tupple(\@counts, $i, \@solution); } }; local *process = sub { my ($counts, $i, $solution) = @_; if (!grep $_, @$counts) { ++$solutions{ join(';', @$solution) }; return; } if ($i > $L) { return; } try_quad_tupple($counts, $i, $solution); }; try_quad_tupple($counts, 0, []); return [ sort keys %solutions ]; } { my ($input) = @ARGV or die("usage: $0 string\n"); $input = uc($input); my @counts; while ($input =~ /(.)/g) { defined($idx_lkup{$1}) or die("'$1' not in alphabet\n"); ++$counts[ $idx_lkup{$1} ]; } $counts[$_] ||= 0 for 0..$L; # Avoid warnings. my $solutions = find(\@counts); die "No solution\n" if !@$solutions; print("$_\n") for @$solutions; } #### $ perl all.pl AAAAADDDDDEFFGMMSSTVVVVV AAAA;ADEF;DDDD;FGMS;MSTV;VVVV perl all.pl AADDDEEEEFFFFGGMMMMMMMMMMSTV ADEF;DEFG;EFGM;MMMM;MSTV $ perl all.pl AAAADDDDEEEEFFFFGGGG AAAA;DDDD;EEEE;FFFF;GGGG AAAA;DEFG ADEF;GGGG