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
  78 my %options = (debug           => 0,
  79                help            => 0,
  80                man             => 0,
  81                wordlist        => '/usr/share/dict/words',
  82                database_dir    => User->Home.'/.acromang/',
  83                show_all        => 0,
  84                multiword       => 0,
  85                );
  86
  87 my @puzzle_types = qw(acrostic anagram substitution);
  88
  89
  90
  91 GetOptions(\%options,
  92            'wordlist=s','database_dir|database-dir=s',
  93            @puzzle_types,
  94            'debug|d+','help|h|?','man|m');
  95
  96 pod2usage() if $options{help};
  97 pod2usage({verbose=>2}) if $options{man};
  98
  99 $DEBUG = $options{debug};
 100
 101 my @USAGE_ERRORS;
 102 if (not grep {exists $options{$_}} @puzzle_types) {
 103     $options{acrostic} = 1
 104 }
 105
 106 if (1 != grep {exists $options{$_}} @puzzle_types) {
 107     push @USAGE_ERRORS, "You must pass exactly one of ".join(', ',map {"--$_ "} @puzzle_types);
 108 }
 109
 110 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
 111
 112 my $text;
 113 { local $/;
 114   $text = <>;
 115 }
 116 my @words = map {s/[^A-Za-z\?]//g; length $_?$_:();} split /[\s\n]+/, $text;
 117 if (not @words) {
 118     print STDERR "There were no words in the input\n";
 119     exit 1;
 120 }
 121
 122 # letter order
 123 my @l_o = ('a'..'z');
 124 my %l_o;
 125 @l_o{@l_o} = (0 .. 25);
 126
 127 my $database = update_and_load_database($options{database_dir},$options{wordlist});
 128
 129 # run through and use the database
 130
 131 # for now, concentrate on finding single word solutions
 132 if ($options{acrostic}) {
 133     foreach my $word (@words) {
 134         my $length = length($word);
 135         my @let = split //, $word;
 136         my %pos;
 137         for my $p (0..$#let) {
 138             next if $let[$p] eq '?';
 139             $pos{$p} = $let[$p];
 140         }
 141         my @allowable_words = find_allowable_words(database => $database,position => \%pos,length => $length);
 142         if (@allowable_words > 200 and not $options{show_all}) {
 143             print STDERR "Only showing 200 of the " . @allowable_words . " possible words\n";
 144             @allowable_words = @allowable_words[0..199];
 145         }
 146         while ((@allowable_words == 0 or $options{multiword}) and
 147                (@allowable_words < 200 or $options{show_all})
 148               ) {
 149             # try for multiple word solutions, start with the longest
 150             # words possible
 151
 152             # try to split the number of known letters in half, and
 153             # start increasing and decreasing in both directions
 154
 155             # don't attempt to split each part into bits unless there
 156             # are no solutions
 157
 158             # avoid searching for words when we only have a length and
 159             # no position information
 160         }
 161         print map {$_,qq(\n)} sort @allowable_words;
 162     }
 163 }
 164 elsif ($options{anagram}) {
 165     foreach my $word (@words) {
 166         my $length = length($word);
 167         my $sorted_word = join ('', sort split //, $word);
 168         my @allowable_words = find_allowable_words(database => $database,
 169                                                    anagram => $sorted_word,
 170                                                   );
 171         print map {$_,qq(\n)} sort @allowable_words;
 172     }
 173 }
 174
 175 sub find_allowable_words {
 176     my %param = validate_with(params => \@_,
 177                               spec   => {database => {type => HASHREF,
 178                                                      },
 179                                          position => {type => HASHREF,
 180                                                       optional => 1,
 181                                                      },
 182                                          length   => {type => SCALAR,
 183                                                       optional => 1,
 184                                                      },
 185                                          substitution => {type => SCALAR,
 186                                                           optional => 1,
 187                                                          },
 188                                          rotation     => {type => SCALAR,
 189                                                           optional => 1,
 190                                                          },
 191                                          anagram      => {type => SCALAR,
 192                                                           optional => 1,
 193                                                          },
 194                                         },
 195                              );
 196
 197     my $database = $param{database};
 198     my $must_match = 0;
 199     if (exists $param{length} and defined $param{length} and $param{length} > 0) {
 200         $must_match++;
 201     }
 202     if (exists $param{position} and defined $param{position}) {
 203         $must_match += scalar keys %{$param{position}};
 204     }
 205     if (exists $param{anagram} and defined $param{anagram}) {
 206         $must_match++;
 207     }
 208
 209     if ($must_match <= 0) {
 210         die "There must be something to try matching against";
 211     }
 212     my %words;
 213     if (exists $param{length} and defined $param{length} and $param{length} > 0) {
 214         for my $word (@{$database->{length}{$param{length}}}) {
 215             $words{$word}++;
 216         }
 217     }
 218     if (exists $param{position} and defined $param{position}) {
 219         for my $position (keys %{$param{position}}) {
 220             for my $word (@{$database->{position}{$position . ' ' . $param{position}{$position}}}) {
 221                 $words{$word}++;
 222             }
 223         }
 224     }
 225     if (exists $param{anagram} and defined $param{anagram}) {
 226         for my $word (@{$database->{anagram}{$param{anagram}}}) {
 227             $words{$word}++;
 228         }
 229     }
 230     return grep {$words{$_} >= $must_match} keys %words;
 231 }
 232
 233
 234 sub update_and_load_database {
 235     my ($dir,$wordlist) = @_;
 236     # check to see if the wordlist is newer than our database
 237     my @dbs = qw(length position substitution rotation anagram);
 238     my $update_required = 0;
 239     my $wordlist_time = 1;
 240     if (! -r $wordlist) {
 241         die "Word list $wordlist doesn't exist or isn't readable";
 242     }
 243     my $wordlist_stat = stat($wordlist);
 244     $wordlist_time = max($wordlist_time,$wordlist_stat->mtime);
 245     for my $db (@dbs) {
 246         if (! -e "$dir/db_${db}") {
 247             $update_required = 1;
 248         }
 249         elsif (stat($wordlist)->mtime < $wordlist_time) {
 250             $update_required = 1;
 251         }
 252     }
 253     my $database;
 254     if ($update_required) {
 255         my $disk_db = {};
 256         if (not -d "$dir") {
 257             mkdir($dir) or die "Unable to create directory $dir: $!";
 258         }
 259         for my $db (@dbs) {
 260             $database->{$db} = {};
 261             $disk_db->{$db} = {};
 262             tie %{$disk_db->{$db}}, MLDBM => "$dir/db_${db}",
 263                 O_RDWR|O_CREAT|O_TRUNC, 0666
 264                     or die "Unable to open/create $dir/db_${db}: $!";
 265         }
 266         my $wordlist_fh = IO::File->new($wordlist,'r') or
 267             die "Unable to open $wordlist for reading: $!";
 268         my %seen_words;
 269         while (<$wordlist_fh>) {
 270             chomp;
 271             next unless length $_;
 272             my $word = lc($_);
 273             $word =~ s/[^a-z]//;
 274             next unless length $_;
 275             next if exists $seen_words{$word};
 276             $seen_words{$word} = 1;
 277             if ((keys %seen_words) % 100 == 0) {
 278                 print STDERR "Handled ".(keys %seen_words) . " words, on $word\n";
 279             }
 280             my @l = split //, $word;
 281             my $l = length($word);
 282             for my $p (0..$#l) {
 283                 # position from the beginning
 284                 my $temp = $database->{position}{"$p $l[$p]"};
 285                 $temp = [] if not defined $temp;
 286                 push @{$temp}, $word;
 287                 $database->{position}{"$p $l[$p]"} = $temp;
 288                 # this is the position from the end
 289                 $temp = $database->{position}{$p-$l . " " . $l[$p-$l]};
 290                 $temp = [] if not defined $temp;
 291                 push @{$temp}, $word;
 292                 $database->{position}{$p-$l . " " . $l[$p-$l]} = $temp;
 293             }
 294             my $temp = $database->{length}{$l};
 295             $temp = [] if not defined $temp;
 296             push @{$temp}, $word;
 297             $database->{length}{$l} = $temp;
 298             # this is the substitution database
 299             # in it, hello and giddy both become abccd
 300             my %uc = ();
 301             my @uc_order = map {
 302                 if (exists $uc{$_}) {
 303                     ();
 304                 } else {
 305                     $uc{$_} = 1;
 306                     $_;
 307                 }
 308             } @l;
 309             my %s_map;
 310             @s_map{@uc_order} = ('a'..'z')[0..$#uc_order] if @uc_order;
 311             my $mapped_word = join('',map {$s_map{$_}} @l);
 312             $temp = $database->{substitution}{$mapped_word};
 313             $temp = [] if not defined $temp;
 314             push @{$temp}, $word;
 315             $database->{substitution}{$mapped_word} = $temp;
 316
 317             # this is the rotation database (for ceaser cyphers)
 318             # in it, hello becomes axeeh, giddy acxxs
 319             my $fl = $l[0];
 320             my $index = $l_o{$fl};
 321             if (not defined $index or grep {not exists $l_o{$_}} @l) {
 322                 print STDERR "Problem with some letters in '$word'\n";
 323             }
 324             $mapped_word = join('',map {$l_o[($l_o{$_} - $index + 26) % 26]} @l);
 325             $temp = $database->{rotation}{$mapped_word};
 326             $temp = [] if not defined $temp;
 327             push @{$temp}, $word;
 328             $database->{rotation}{$mapped_word} = $temp;
 329
 330             # this is the anagram database
 331             # in it, hello becomes ehllo, giddy ddgiy
 332             $mapped_word = join('',sort @l);
 333             $temp = $database->{anagram}{$mapped_word};
 334             $temp = [] if not defined $temp;
 335             push @{$temp}, $word;
 336             $database->{anagram}{$mapped_word} = $temp;
 337         }
 338         for my $key1 (keys %{$database}) {
 339             for my $key2 (keys %{$database->{$key1}}) {
 340                 $disk_db->{$key1}{$key2} = $database->{$key1}{$key2};
 341             }
 342         }
 343     }
 344     else {
 345         for my $db (@dbs) {
 346             $database->{$db} = {};
 347             tie %{$database->{$db}}, MLDBM => "$dir/db_${db}",
 348                 O_RDONLY, 0666
 349                     or die "Unable to open $dir/db_${db}: $!";
 350         }
 351     }
 352     return $database;
 353
 354 }
 355
 356
 357 __END__