CodeIQ Q594

codeiq-q594-pangram.pl

#!/bin/perl
#---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8----+----9----+----0
=pod

=encoding UTF-8

=head1 213個の単語からパングラムを作ろう - 解答

=head2 提出要件

=over

=item * プログラミング言語

Perl

=item * パングラムの結果

34 文字で、4 通りの答えが見つかりました。

    AVG BY FETCH JOIN MAX PAD SIZE SQL SUM WORK
    AVG BY FETCH JOIN MAX SIZE SQL UPDATE WORK
    AVG BY FETCH JOIN MAX PAD SQL SUM WORK ZONE
    AVG BY FETCH JOIN MAX SQL UPDATE WORK ZONE

=item * 計算に要した時間

診断テキストも出力しているので揺らぎますが、約 2 秒です。

=item * 依存関係

文字出力折り返しに拡張正規表現を使っているので
Strawberry Perl 等では問題が起こるかもしれません。

=back

=head2 方針

基本は全探索。
出現回数が少ないアルファベットを含む単語から順に辿ることで探索数の広がりを防ぐ。
また、最短文字数を記憶しておき、それより長くなると分かった時点で枝の探索を打ち切る。

=head2 工夫

計算を単純化するため、単語の文字を A = 0, B = 1, C = 2, ... Z = 25 とビット番号にマッピングし
単語の文字に対応するビットを立てた値をコードとする
複数のコードを OR した結果が 0x03ffffff であれば全ての文字を網羅したことになる。

=cut
#---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8----+----9----+----0

use v5.10;
use strict;
use integer;

#---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8----+----9----+----0
# 問題に直接関係ない関数
#---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8----+----9----+----0

# 整数の合計を返す
sub sum (@) { unpack('%32V*', pack('V*', @_)); }

# 最小値を返す
sub min (@) { return undef unless @_; my $v = $_[0]; foreach (@_) { $v = $_ if $_ < $v } $v; }

# 重複する要素を排除して返す。要素の順番は維持しない。
sub unique (@) { my %u; @u{@_} = (); keys %u; }

# 単純折り返し
sub fold ($$$) {
	our ($maxlength, $c);
	(my $text, local $maxlength, my $indent) = @_;
	local $c = 0;
	$text =~ s/
		\G
		( # $1: 文字カウンタ
			(?:
				( \s++ | \S++ ) # $2
				(?{ local $c = $c + length $2 })
			)*?
		)
		\s++ # 折り返し可能空白は消費
		(?(?= (\S++) ) # $3: 次の単語を先読み
			# 既に文字数超過か、次の単語を含めても超過しない場合失敗
			(?(?{ $c > $maxlength or $c < $maxlength - length $3 }) (?!) )
		)
		(?! \n | $ )
	/$1\n/gix;
	$text =~ s/\n/\n$indent/g;
	$text;
}

#---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8----+----9----+----0
# 単語読み込み・分析
#---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8----+----9----+----0

# 全行読み込み、改行を落とす
chomp (my @WORDS = <>);

#
# 分析
#

# マッピング作成: 単語 => コード
my %CODE = map { $_ => sum(map { 1 << (ord() - 0x41) } unique split //) } @WORDS;

# マッピング作成: 単語 => 文字数（スコア）
my %SCORE = map { $_ => length $_ } @WORDS;


# 自分より文字数が多いが構成文字が同じ単語があれば除外する
# 例: TRANSACTION は CONSTRAINT と構成文字が同じで文字数が多いので除外

# 構成文字が同じ単語グループの一覧
my @SIMILARS =
		grep { @$_ > 1 } # 要素が 2 つ以上のものだけ抽出
		map { my $code = $_; [ grep { $CODE{$_} == $code } @WORDS ] } # 同じコードを持つ単語をグループにし
		unique values %CODE; # コードの一覧から

# 構成文字が同じ単語のうち、文字数が最短でないものを除外するリストを作る
my %EXCLUDED =
		map { $_ => $_ } # キーで参照できるように連想配列に
		map {
			my $min = min map { length } @$_; # 最短の長さを求め
			grep { length > $min } @$_; # 最短より長いものを残す
		}
		@SIMILARS; # 構成文字が同じ単語

# @WORDS から除外する
@WORDS = grep { not exists $EXCLUDED{$_} } @WORDS;

#
# 統計
#

# マッピング作成: ビット番号 => ビットが立っている単語の配列（文字数の少ない順）
my @INDEX =
		map {
			my $v = 1 << $_;
			[ sort { $SCORE{$a} <=> $SCORE{$b} } grep { $CODE{$_} & $v } @WORDS ];
		}
		0 .. 25;

# ビット番号を、そのビットを含む単語が少ない（選択肢が限定される）順に並べる
my @ORDERED = sort { @{$INDEX[$a]} <=> @{$INDEX[$b]} } 0 .. 25;

# コード表を出力（確認用）
{
	say '=' x 76;
	say '  Code map';
	say '=' x 76;
	say;
	say ' * Mapping';
	say;
	say '  Code  ZYXWVUTSRQPONMLKJIHGFEDCBA  Score  Word';
	say '  --------------------------------  -----  -------------------------------';
	foreach (sort @WORDS) {
		say sprintf '  %032b  %5d  %s', $CODE{$_}, $SCORE{$_}, $_;
	}
	say '  --------------------------------  -----  -------------------------------';
	say sprintf '  %d word(s)', scalar @WORDS;
	say;

	say ' * Exclusion';
	say;
	say '  Word                              Similar to';
	say '  --------------------------------  --------------------------------------';
	my $count = 0;
	foreach my $words (@SIMILARS) {
		foreach my $word (grep { $EXCLUDED{$_} } @$words) {
			say sprintf '  %-32s  %s', $word, fold join(', ', sort grep { $word ne $_ } @$words), 37, ' ' x 36;
			++$count;
		}
	}
	say '  --------------------------------  --------------------------------------';
	say sprintf '  %d word(s)', $count;
	say;
}

# 頻度表を出力（確認用）
{
	say '=' x 76;
	say '  Frequency map';
	say '=' x 76;
	say;
	say '  @  Count  Words';
	say '  -  -----  --------------------------------------------------------------';
	foreach (@ORDERED) {
		say sprintf '  %1s  %5d  %s',
				chr($_ + 0x41),
				scalar @{$INDEX[$_]},
				fold join(', ', @{$INDEX[$_]}), 62, (' ' x 12);
	}
	say;
}

#---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8----+----9----+----0
# 探索処理
#---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8----+----9----+----0

# 最終目的
my $GOAL = 0x03ffffff; # A-Z 全て

# 仮スコアを計算（単語の文字数合計）
my $highscore = sum(values %SCORE);

# 再帰探索用
sub discover ($$@) {

	my ($step, $score, $coverage, %words) = @_;

	# 答え発見？
	if ($coverage == $GOAL) {

		say sprintf '  %5d  %s', $score, fold join(' ', sort keys %words), 65, ' ' x 9;

		# スコアを更新
		if ($highscore > $score) {
			$highscore = $score;
		}
		return;
	}

	if ($step >= @ORDERED) {
		# あれ？ 文字が足りない？
		return;
	}

	# 次に探索する文字（ビット番号）
	my $number = $ORDERED[$step];

	# 既に含まれている場合は次のステップへ
	if ((1 << $number) & $coverage) {
		return discover($step + 1, $score, $coverage, %words);
	}

	# 単語を含む候補全てを探索
	foreach (@{$INDEX[$number]}) {

		# 候補を選ぶとハイスコアを超える場合、その先は探索しない
		next if $score + $SCORE{$_} > $highscore;

		# 次のステップへ
		discover($step + 1, $score + $SCORE{$_}, $coverage | $CODE{$_}, (%words, $_ => undef));

	}

}

# Go!

{
	say '=' x 76;
	say '  Discovery';
	say '=' x 76;
	say;
	say '  Score  Words';
	say '  -----  -----------------------------------------------------------------';
}

discover(0, 0, 0);

{
	say '  -----  -----------------------------------------------------------------';
	say;
}

say 'Done.';