DouKaku?beta

challenge いちばん長いしりとり

単語のリストを読み込んで、そのリストにある単語で「しりとり」をします。
一番長くしりとりを続けるためのプログラムを書いてください。
また、単語数に対して、計算量がどのように増えていくかも考えて下さい。

なお、単語リストの一例として
http://www.ais.riec.tohoku.ac.jp/lab/wordlist/index-j.htmlで公開されている
http://www.ais.riec.tohoku.ac.jp/lab/wordlist/fam55_40.txtがあります。

ただし、
・一度使った単語は使わないこと(リストに重複がある可能性は考えなくてよい)
・「ん」で終わる単語を使用するか、リスト内にしりとりを続けられる単語がなくなったときに、しりとりは終了する
・一番最初は、好きな単語から初めてもよい
・「一番長くしりとりを続ける」とは、しりとりが終了するまでに使用する単語数が最大になるよう、しりとりの単語を選ぶことをいう

see: 難聴者のための単語了解度試験用単語リスト

post comment

Posted feedbacks - Perl

とりあえず。検証もしてないのですが、お題の単語リストの先頭「アイアイ」から始めて350個繋がりました。 
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
use strict;
use warnings;
use utf8;

use Encode;

my $input_enc = shift || 'utf-8';
my $output_enc = shift || 'cp932';

my $words = readwords();
my $table = maketable($words);

my $total = @$words;
my $count = 0;
#my $next = $words->[int rand $total];
my $next = $words->[0];
erase($next, $table);
print encode($output_enc, "begin from [$next]\n");
while ( 1 ) {
  ++$count;
  last if is_stop($next);
  my $prev = $next;

  $next = draw_next($prev, $table);
  last if !defined $next;

  print encode($output_enc, "next -> [$next]\n");
}    
print encode($output_enc, "END ($count/$total)\n");

sub readwords
{
  [ map { tr/ア-ン/あ-ん/; $_ }
    map { decode($input_enc, $_) }
    map { chomp; split /\s+/ } <STDIN> ];
}    

sub maketable
{
  my $words = shift;

  my %table;
  for my $w ( @$words ) {
    my $first = substr $w, 0, 1;

    $table{$first} = [0,0,[]] if !exists $table{$first};

    ++$table{$first}[0];
    if ( is_stop($w) ) {
      ++$table{$first}[1];
    }
    push @{$table{$first}[2]}, $w;
  }
  \%table;
}

sub erase
{
  my ($word, $table) = @_;

  my $first = substr $word, 0, 1;

  --$table->{$first}[0];
  if ( is_stop($word) ) {
    --$table->{$first}[1];
  }

  @{$table->{$first}[2]} = grep { $_ ne $word } @{$table->{$first}[2]};
}

sub draw_next
{
  my ($word, $table) = @_;
  my $next = get_candidate($word, $table)->[0];
  erase($next, $table) if defined $next;
  $next;
}

sub is_stop
{
  my $word = shift;
  (length($word)>1 ? substr $word, -1, 1 : $word) eq 'ん';
}

sub get_candidate
{
  my ($word, $table) = @_;

  my $last = substr $word, -1, 1;

  my $candidate = [undef, -1];
  for my $next ( @{$table->{$last}[2]} ) {
    my $next_last = substr $next, -1, 1;

    my $point = exists $table->{$next_last}
    ? $table->{$next_last}[0] - $table->{$next_last}[1]
    : 0;
    if ( $point > $candidate->[1] ) {
      $candidate = [$next, $point];
    }
  }
  $candidate;
}


map万歳！

最悪計算量はO(N!)のはず。
お題に挙げられている単語リストだと110語あたりが限界です。

$ time perl doukaku227.pl fam55_40.txt 100
セイギハ -> ハゲヤマ -> マヤカシ -> ショウワル -> ルイベツ -> ツジツマ -> マタシタ -> タチノミ -> ミズヒキ -> キャクアシ -> シャクナゲ -> ゲレツサ -> サンバシ -> シールド -> ドウナガ -> ガイユウ -> ウワバリ -> リンセツ -> ツユザム -> ムスビメ -> メイフク

real	0m0.585s
user	0m0.561s
sys	0m0.012s

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
#!/usr/bin/env perl

use strict;
use warnings;
use utf8;
use List::Util qw/reduce/;

my @katakanas = split //, 'アイウエオカキクケコガキグゲゴサシスセソ'
                        . 'ザジズゼゾタチツテトダヂヅデドナニヌネノ'
                        . 'ハヒフヘホバビブベボパピプペポマミムメモ'
                        . 'ヤユオワヲン';

sub head_and_tail($) {
  my $word = shift;
  $word =~ tr/ァィゥェォッャュョヮ/アイウエオツヤユヨワ/;
  $word =~ s/ー$//;
  (substr($word, 0, 1), substr($word, -1, 1));
}

sub longest_chain(\%;$);
sub longest_chain(\%;$) {
  no warnings qw/recursion/;
  my ($dict, $word) = @_;
  my @words = defined $word
              ? ($word)
              : map { map { $_->[0] } values %$_ } values %$dict;
  reduce {
    @$a > @$b ? $a : $b;
  } ([],
     map {
       my $word = $_;
       my (undef, $next_head) = head_and_tail $word;
       map {
         my $available_words = $dict->{$next_head}{$_};
         my $next_word = pop @$available_words;
         my $chain = longest_chain(%$dict, $next_word);
         push @$available_words, $next_word;
         unshift @$chain, $word;
         $chain;
       } grep { @{ $dict->{$next_head}{$_} } } keys %{ $dict->{$next_head} };
     } @words);
}

binmode STDOUT, ':utf8';
open my $words_file, '<:encoding(shiftjis)', shift or die $!;
my @words = (map { chomp; split /\s+/ } <$words_file>);
$#words = shift() - 1 if @ARGV;
my %dict;
for my $word (@words) {
  my ($head, $tail) = head_and_tail $word;
  $dict{$head}{$tail} = [] unless exists $dict{$head}{$tail};
  push @{ $dict{$head}{$tail} }, $word;
}
local ($,, $\) = (' -> ', "\n");
print @{ longest_chain(%dict) };

Index

Feed

Other

Link

Pathtraq

loading...
Creative Commons License このサイトの内容は、 クリエイティブ・コモンズ・ライセンスの下でライセンスされています。 [詳細]