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 my $database = update_and_load_database($options{database_dir},$options{wordlist});
 123
 124 # letter order
 125 my @l_o = ('a'..'z');
 126 my %l_o;
 127 @l_o{@l_o} = (0 .. 25);
 128
 129
 130 # run through and use the database
 131
 132 # for now, concentrate on finding single word solutions
 133 if ($options{acrostic}) {
 134     foreach my $word (@words) {
 135         my $length = length($word);
 136         my @let = split //, $word;
 137         my %pos;
 138         for my $p (0..$#let) {
 139             next if $let[$p] eq '?';
 140             $pos{$p} = $let[$p];
 141         }
 142         my @allowable_words = find_allowable_words($database,\%pos,$length);
 143         if (@allowable_words > 200 and not $options{show_all}) {
 144             print STDERR "Only showing 200 of the " . @allowable_words . " possible words\n";
 145             @allowable_words = @allowable_words[0..199];
 146         }
 147         while ((@allowable_words == 0 or $options{multiword}) and
 148                (@allowable_words < 200 or $options{show_all})
 149               ) {
 150             # try for multiple word solutions, start with the longest
 151             # words possible
 152
 153             # try to split the number of known letters in half, and
 154             # start increasing and decreasing in both directions
 155
 156             # don't attempt to split each part into bits unless there
 157             # are no solutions
 158
 159             # avoid searching for words when we only have a length and
 160             # no position information
 161         }
 162         print map {$_,qq(\n)} sort @allowable_words;
 163     }
 164 }
 165 elsif ($options{anagram}) {
 166     foreach my $word (@words) {
 167         my $length = length($word);
 168         my $sorted_word = join ('', sort split //, $word);
 169         my @allowable_words = find_allowable_words(database => $database,
 170                                                    anagram => $sorted_word,
 171                                                   );
 172         print map {$_,qq(\n)} sort @allowable_words;
 173     }
 174 }
 175
 176 sub find_allowable_words {
 177     my %param = validate_with(params => \@_,
 178                               spec   => {database => {type => HASHREF,
 179                                                      },
 180                                          position => {type => HASHREF,
 181                                                       optional => 1,
 182                                                      },
 183                                          length   => {type => SCALAR,
 184                                                       optional => 1,
 185                                                      },
 186                                          substitution => {type => SCALAR,
 187                                                           optional => 1,
 188                                                          },
 189                                          rotation     => {type => SCALAR,
 190                                                           optional => 1,
 191                                                          },
 192                                          anagram      => {type => SCALAR,
 193                                                           optional => 1,
 194                                                          },
 195                                         },
 196                              );
 197
 198     my $database = $param{database};
 199     my $must_match = 0;
 200     if (exists $param{length} and defined $param{length} and $param{length} > 0) {
 201         $must_match++;
 202     }
 203     if (exists $param{position} and defined $param{position}) {
 204         $must_match += scalar keys %{$param{position}};
 205     }
 206     if (exists $param{anagram} and defined $param{anagram}) {
 207         $must_match++;
 208     }
 209
 210     if ($must_match <= 0) {
 211         die "There must be something to try matching against";
 212     }
 213     my %words;
 214     if (exists $param{length} and defined $param{length} and $param{length} > 0) {
 215         for my $word (@{$database->{length}{$param{length}}}) {
 216             $words{$word}++;
 217         }
 218     }
 219     if (exists $param{position} and defined $param{position}) {
 220         for my $position (keys %{$param{position}}) {
 221             for my $word (@{$database->{position}{$position . ' ' . $param{position}{$position}}}) {
 222                 $words{$word}++;
 223             }
 224         }
 225     }
 226     if (exists $param{anagram} and defined $param{anagram}) {
 227         for my $word (@{$database->{anagram}{$param{anagram}}}) {
 228             $words{$word}++;
 229         }
 230     }
 231     return grep {$words{$_} >= $must_match} keys %words;
 232 }
 233
 234
 235 sub update_and_load_database {
 236     my ($dir,$wordlist) = @_;
 237     # check to see if the wordlist is newer than our database
 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 (qw(length position)) {
 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 (qw(length position substitution rotation anagram)) {
 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             next if exists $seen_words{$word};
 274             $seen_words{$word} = 1;
 275             if ((keys %seen_words) % 100 == 0) {
 276                 print STDERR "Handled ".(keys %seen_words) . "words, on $word\n";
 277             }
 278             my @l = split //, $word;
 279             my $l = length($word);
 280             for my $p (0..$#l) {
 281                 # position from the beginning
 282                 my $temp = $database->{position}{"$p $l[$p]"};
 283                 $temp = [] if not defined $temp;
 284                 push @{$temp}, $word;
 285                 $database->{position}{"$p $l[$p]"} = $temp;
 286                 # this is the position from the end
 287                 $temp = $database->{position}{$p-$l . " " . $l[$p-$l]};
 288                 $temp = [] if not defined $temp;
 289                 push @{$temp}, $word;
 290                 $database->{position}{$p-$l . " " . $l[$p-$l]} = $temp;
 291             }
 292             my $temp = $database->{length}{$l};
 293             $temp = [] if not defined $temp;
 294             push @{$temp}, $word;
 295             $database->{length}{$l} = $temp;
 296             # this is the substitution database
 297             # in it, hello and giddy both become abccd
 298             my %uc = ();
 299             my @uc_order = map {
 300                 if (exists $uc{$_}) {
 301                     ();
 302                 } else {
 303                     $uc{$_} = 1;
 304                     $_;
 305                 }
 306             } @l;
 307             my %s_map;
 308             @s_map{@uc_order} = ('a'..'z')[0..$#uc_order] if @uc_order;
 309             my $mapped_word = join('',map {$s_map{$_}} @l);
 310             $temp = $database->{substitution}{$mapped_word};
 311             $temp = [] if not defined $temp;
 312             push @{$temp}, $word;
 313             $database->{substitution}{$mapped_word} = $temp;
 314
 315             # this is the rotation database (for ceaser cyphers)
 316             # in it, hello becomes axeeh, giddy acxxs
 317             my $fl = $l[0];
 318             my $index = $l_o{$fl};
 319             $mapped_word = join('',map {$l_o[($l_o{$_} - $index + 26) % 26]} @l);
 320             $temp = $database->{rotation}{$mapped_word};
 321             $temp = [] if not defined $temp;
 322             push @{$temp}, $word;
 323             $database->{rotation}{$mapped_word} = $temp;
 324
 325             # this is the anagram database
 326             # in it, hello becomes ehllo, giddy ddgiy
 327             $mapped_word = join('',sort @l);
 328             $temp = $database->{anagram}{$mapped_word};
 329             $temp = [] if not defined $temp;
 330             push @{$temp}, $word;
 331             $database->{anagram}{$mapped_word} = $temp;
 332         }
 333         for my $key1 (keys %{$database}) {
 334             for my $key2 (keys %{$database->{$key1}}) {
 335                 $disk_db->{$key1}{$key2} = $database->{$key1}{$key2};
 336             }
 337         }
 338     }
 339     else {
 340         for my $db (qw(length position)) {
 341             $database->{$db} = {};
 342             tie %{$database->{$db}}, MLDBM => "$dir/db_${db}",
 343                 O_RDONLY, 0666
 344                     or die "Unable to open $dir/db_${db}: $!";
 345         }
 346     }
 347     return $database;
 348
 349 }
 350
 351
 352 __END__