anamang

   1 #! /usr/bin/perl
   2 # acromang tries to solve acrostics, and is released
   3 # under the terms of the GPL version 2, or any later version, at your
   4 # option. See the file README and COPYING for more information.
   5 # Copyright 2008 by Don Armstrong <don@donarmstrong.com>.
   6 # $Id: perl_script 1153 2008-04-08 00:04:20Z don $
   7
   8
   9 use warnings;
  10 use strict;
  11
  12 use Getopt::Long;
  13 use Pod::Usage;
  14
  15 =head1 NAME
  16
  17 acromang - try to solve acrostics
  18
  19 =head1 SYNOPSIS
  20
  21 acromang m??s??c??o [options]
  22
  23  Options:
  24   --debug, -d debugging level (Default 0)
  25   --help, -h display this help
  26   --man, -m display manual
  27
  28 =head1 OPTIONS
  29
  30 =over
  31
  32 =item B<--wordlist>
  33
  34 Default wordlist, should be gigantic; defaults to
  35 /usr/share/dict/words
  36
  37 =item B<--database-dir>
  38
  39 Directory for storing databases; defaults to ~/.acromang
  40
  41 =item B<--debug, -d>
  42
  43 Debug verbosity. (Default 0)
  44
  45 =item B<--help, -h>
  46
  47 Display brief useage information.
  48
  49 =item B<--man, -m>
  50
  51 Display this manual.
  52
  53 =back
  54
  55 =head1 EXAMPLES
  56
  57
  58 =cut
  59
  60
  61 use vars qw($DEBUG);
  62
  63 use User;
  64
  65
  66 use Params::Validate qw(:types validate_with);
  67 use IO::File;
  68 use DB_File;
  69 use MLDBM qw(DB_File Storable);
  70 use Fcntl qw/O_RDWR O_RDONLY O_CREAT O_TRUNC/;
  71 # Use portable Storable images
  72 $MLDBM::DumpMeth=q(portable);
  73
  74
  75 use File::stat;
  76 use List::Util qw(min max);
  77 use POSIX qw(floor);
  78
  79 my %options = (debug           => 0,
  80                help            => 0,
  81                man             => 0,
  82                wordlist        => '/usr/share/dict/words',
  83                database_dir    => User->Home.'/.acromang/',
  84                show_all        => 0,
  85                multiword       => 0,
  86                );
  87
  88 my @puzzle_types = qw(acrostic anagram substitution);
  89
  90
  91
  92 GetOptions(\%options,
  93            'wordlist=s','database_dir|database-dir=s',
  94            @puzzle_types,
  95            'debug|d+','help|h|?','man|m');
  96
  97 pod2usage() if $options{help};
  98 pod2usage({verbose=>2}) if $options{man};
  99
 100 $DEBUG = $options{debug};
 101
 102 my @USAGE_ERRORS;
 103 if (not grep {exists $options{$_}} @puzzle_types) {
 104     $options{acrostic} = 1
 105 }
 106
 107 if (1 != grep {exists $options{$_}} @puzzle_types) {
 108     push @USAGE_ERRORS, "You must pass exactly one of ".join(', ',map {"--$_ "} @puzzle_types);
 109 }
 110
 111 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
 112
 113 my $text;
 114 { local $/;
 115   $text = <>;
 116 }
 117 my @words = map {s/[^A-Za-z\?]//g; length $_?$_:();} split /[\s\n]+/, $text;
 118 if (not @words) {
 119     print STDERR "There were no words in the input\n";
 120     exit 1;
 121 }
 122
 123 # letter order
 124 my @l_o = ('a'..'z');
 125 my %l_o;
 126 @l_o{@l_o} = (0 .. 25);
 127 sub word_sanitize{
 128     return map {tr/A-Z/a-z/; tr/éüöáí/euoai/; $_ } @_
 129 }
 130
 131 my $database = update_and_load_database($options{database_dir},$options{wordlist});
 132
 133 # run through and use the database
 134
 135 # for now, concentrate on finding single word solutions
 136 if ($options{acrostic}) {
 137 }
 138 elsif ($options{acrostic}) {
 139     foreach my $word (@words) {
 140         my $length = length($word);
 141         my @let = split //, $word;
 142         my %pos;
 143         for my $p (0..$#let) {
 144             next if $let[$p] eq '?';
 145             $pos{$p} = $let[$p];
 146         }
 147         my @allowable_words = find_allowable_words(database => $database,position => \%pos,length => $length);
 148         if (@allowable_words > 200 and not $options{show_all}) {
 149             print STDERR "Only showing 200 of the " . @allowable_words . " possible words\n";
 150             @allowable_words = @allowable_words[0..199];
 151         }
 152         # multiword currently not enabled
 153         # while ((@allowable_words == 0 or $options{multiword}) and
 154         #        (@allowable_words < 200 or $options{show_all})
 155         #       ) {
 156         #     # try for multiple word solutions, start with the longest
 157         #     # words possible
 158         #
 159         #     # try to split the number of known letters in half, and
 160         #     # start increasing and decreasing in both directions
 161         #
 162         #     # don't attempt to split each part into bits unless there
 163         #     # are no solutions
 164         #
 165         #     # avoid searching for words when we only have a length and
 166         #     # no position information
 167         # }
 168         print map {$_,qq(\n)} sort @allowable_words;
 169     }
 170 }
 171 elsif ($options{anagram}) {
 172     foreach my $word (@words) {
 173         my $length = length($word);
 174         my $sorted_word = join ('', sort split //, $word);
 175         my @allowable_words = find_allowable_words(database => $database,
 176                                                    anagram => $sorted_word,
 177                                                   );
 178         print map {$_,qq(\n)} sort @allowable_words;
 179     }
 180 }
 181
 182 sub find_allowable_words {
 183     my %param = validate_with(params => \@_,
 184                               spec   => {database => {type => HASHREF,
 185                                                      },
 186                                          position => {type => HASHREF,
 187                                                       optional => 1,
 188                                                      },
 189                                          length   => {type => SCALAR,
 190                                                       optional => 1,
 191                                                      },
 192                                          substitution => {type => SCALAR,
 193                                                           optional => 1,
 194                                                          },
 195                                          rotation     => {type => SCALAR,
 196                                                           optional => 1,
 197                                                          },
 198                                          anagram      => {type => SCALAR,
 199                                                           optional => 1,
 200                                                          },
 201                                         },
 202                              );
 203
 204     my $database = $param{database};
 205     my $must_match = 0;
 206     if (exists $param{length} and defined $param{length} and $param{length} > 0) {
 207         $must_match++;
 208     }
 209     if (exists $param{position} and defined $param{position}) {
 210         $must_match += scalar keys %{$param{position}};
 211     }
 212     if (exists $param{anagram} and defined $param{anagram}) {
 213         $must_match++;
 214     }
 215
 216     if ($must_match <= 0) {
 217         die "There must be something to try matching against";
 218     }
 219     my %words;
 220     if (exists $param{length} and defined $param{length} and $param{length} > 0) {
 221         for my $word (@{$database->{length}{$param{length}}}) {
 222             $words{$word}++;
 223         }
 224     }
 225     if (exists $param{position} and defined $param{position}) {
 226         for my $position (keys %{$param{position}}) {
 227             for my $word (@{$database->{position}{$position . ' ' . $param{position}{$position}}}) {
 228                 $words{$word}++;
 229             }
 230         }
 231     }
 232     if (exists $param{anagram} and defined $param{anagram}) {
 233         for my $word (@{$database->{anagram}{$param{anagram}}}) {
 234             $words{$word}++;
 235         }
 236     }
 237     return grep {$words{$_} >= $must_match} keys %words;
 238 }
 239
 240 sub solve_acrostic {
 241     my ($acrostic) = @_;
 242     # need to find unsolved words
 243
 244     # if there are multiple intersecting unsolved locations, try to
 245     # solve the hard ones first, then the easy ones.
 246
 247     # given the current state of the board, find all possible words
 248     # that fit the fixed positions
 249
 250     # find unsolved words
 251
 252     # find positions with _ or ?, * or | are unsolved bits
 253
 254     # scan the puzzle from left to right, top to bottom (across
 255     # answers), then top to bottom, left to right (down answers)
 256     my $in_word=0;
 257     my $current_answer=0;
 258
 259     sub __add_to_answers {
 260         my ($acrostic,$current_answer,$in_word,$pos) = @_;
 261         if ($acrostic->{grid}[$pos] !~ /^\*\|$/) {
 262             if (not $$in_word) {
 263                 $$current_answer++;
 264             }
 265             $$in_word = 1;
 266             $acrostic->{answers}[$$current_answer]{letters} .= $acrostic->{grid}[$pos];
 267             $acrostic->{answers}[$$current_answer]{length}++;
 268             $acrostic->{answers}[$$current_answer]{unsolved} = 0;
 269             push @{$acrostic->{answers}[$current_answer]{positions}}, $pos;
 270             push @{$acrostic->{answer_grid}[$pos]}, $current_answer;
 271             if ($acrostic->{grid}[$pos] =~ /^\_\?$/) {
 272                 $acrostic->{answers}[$$current_answer]{unsolved} = 1;
 273             }
 274         }
 275         else {
 276             $$in_word = 0;
 277         }
 278     }
 279
 280     for my $width (0..($acrostic->{width}-1)) {
 281         $in_word = 0;
 282         for my $height (0..($acrostic->{height}-1)) {
 283             my $pos = $height*$acrostic->{height} + $width;
 284             __add_to_answers($acrostic,\$current_answer,\$in_word,$pos);
 285         }
 286     }
 287     for my $height (0..($acrostic->{height}-1)) {
 288         $in_word = 0;
 289         for my $width (0..($acrostic->{width}-1)) {
 290             my $pos = $height*$acrostic->{height} + $width;
 291             __add_to_answers($acrostic,\$current_answer,\$in_word,$pos);
 292         }
 293     }
 294
 295     # for all possible answers which are unsolved, find allowable words
 296     for my $answer (0..$#{$acrostic->{answers}}) {
 297     }
 298
 299     # for all crossing positions, find allowed letters and eliminate
 300     # words which do not share a letter in common with a word in the
 301     # opposite direction
 302
 303     # for all crossing positions, eliminate words which do not share a
 304     # letter in common with a word in the opposite direction
 305 }
 306
 307
 308 sub update_and_load_database {
 309     my ($dir,$wordlist) = @_;
 310     # check to see if the wordlist is newer than our database
 311     my @dbs = qw(length position substitution rotation anagram);
 312     my $update_required = 0;
 313     my $wordlist_time = 1;
 314     if (! -r $wordlist) {
 315         die "Word list $wordlist doesn't exist or isn't readable";
 316     }
 317     my $wordlist_stat = stat($wordlist);
 318     $wordlist_time = max($wordlist_time,$wordlist_stat->mtime);
 319     for my $db (@dbs) {
 320         if (! -e "$dir/db_${db}") {
 321             $update_required = 1;
 322         }
 323         elsif (stat("$dir/db_${db}")->mtime < $wordlist_time) {
 324             $update_required = 1;
 325         }
 326     }
 327     my $database;
 328     if ($update_required) {
 329         my $disk_db = {};
 330         if (not -d "$dir") {
 331             mkdir($dir) or die "Unable to create directory $dir: $!";
 332         }
 333         for my $db (@dbs) {
 334             $database->{$db} = {};
 335             $disk_db->{$db} = {};
 336             tie %{$disk_db->{$db}}, MLDBM => "$dir/db_${db}",
 337                 O_RDWR|O_CREAT|O_TRUNC, 0666
 338                     or die "Unable to open/create $dir/db_${db}: $!";
 339         }
 340         my $wordlist_fh = IO::File->new($wordlist,'r') or
 341             die "Unable to open $wordlist for reading: $!";
 342         my %seen_words;
 343         while (<$wordlist_fh>) {
 344             chomp;
 345             next unless length $_;
 346             utf8::upgrade($_);
 347             my ($word) = word_sanitize($_);
 348             $word =~ s/[^a-z]//g;
 349             next unless length $_;
 350             next if exists $seen_words{$word};
 351             $seen_words{$word} = 1;
 352             if ((keys %seen_words) % 100 == 0) {
 353                 print STDERR "Handled ".(keys %seen_words) . " words, on $word\n";
 354             }
 355             my @l = split //, $word;
 356             my $l = length($word);
 357             for my $p (0..$#l) {
 358                 # position from the beginning
 359                 my $temp = $database->{position}{"$p $l[$p]"};
 360                 $temp = [] if not defined $temp;
 361                 push @{$temp}, $word;
 362                 $database->{position}{"$p $l[$p]"} = $temp;
 363                 # this is the position from the end
 364                 $temp = $database->{position}{$p-$l . " " . $l[$p-$l]};
 365                 $temp = [] if not defined $temp;
 366                 push @{$temp}, $word;
 367                 $database->{position}{$p-$l . " " . $l[$p-$l]} = $temp;
 368             }
 369             my $temp = $database->{length}{$l};
 370             $temp = [] if not defined $temp;
 371             push @{$temp}, $word;
 372             $database->{length}{$l} = $temp;
 373             # this is the substitution database
 374             # in it, hello and giddy both become abccd
 375             my %uc = ();
 376             my @uc_order = map {
 377                 if (exists $uc{$_}) {
 378                     ();
 379                 } else {
 380                     $uc{$_} = 1;
 381                     $_;
 382                 }
 383             } @l;
 384             my %s_map;
 385             @s_map{@uc_order} = ('a'..'z')[0..$#uc_order] if @uc_order;
 386             my $mapped_word = join('',map {$s_map{$_}} @l);
 387             $temp = $database->{substitution}{$mapped_word};
 388             $temp = [] if not defined $temp;
 389             push @{$temp}, $word;
 390             $database->{substitution}{$mapped_word} = $temp;
 391
 392             # this is the rotation database (for ceaser cyphers)
 393             # in it, hello becomes axeeh, giddy acxxs
 394             my $fl = $l[0];
 395             my $index = $l_o{$fl};
 396             if (not defined $index or grep {not exists $l_o{$_}} @l) {
 397                 print STDERR "Problem with some letters in '$word'\n";
 398             }
 399             $mapped_word = join('',map {$l_o[($l_o{$_} - $index + 26) % 26]} @l);
 400             $temp = $database->{rotation}{$mapped_word};
 401             $temp = [] if not defined $temp;
 402             push @{$temp}, $word;
 403             $database->{rotation}{$mapped_word} = $temp;
 404
 405             # this is the anagram database
 406             # in it, hello becomes ehllo, giddy ddgiy
 407             $mapped_word = join('',sort @l);
 408             $temp = $database->{anagram}{$mapped_word};
 409             $temp = [] if not defined $temp;
 410             push @{$temp}, $word;
 411             $database->{anagram}{$mapped_word} = $temp;
 412         }
 413         for my $key1 (keys %{$database}) {
 414             for my $key2 (keys %{$database->{$key1}}) {
 415                 $disk_db->{$key1}{$key2} = $database->{$key1}{$key2};
 416             }
 417         }
 418     }
 419     else {
 420         for my $db (@dbs) {
 421             $database->{$db} = {};
 422             tie %{$database->{$db}}, MLDBM => "$dir/db_${db}",
 423                 O_RDONLY, 0666
 424                     or die "Unable to open $dir/db_${db}: $!";
 425         }
 426     }
 427     return $database;
 428
 429 }
 430
 431
 432 __END__