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 $update_required = 0;
 238     my $wordlist_time = 1;
 239     if (! -r $wordlist) {
 240         die "Word list $wordlist doesn't exist or isn't readable";
 241     }
 242     my $wordlist_stat = stat($wordlist);
 243     $wordlist_time = max($wordlist_time,$wordlist_stat->mtime);
 244     for my $db (qw(length position)) {
 245         if (! -e "$dir/db_${db}") {
 246             $update_required = 1;
 247         }
 248         elsif (stat($wordlist)->mtime < $wordlist_time) {
 249             $update_required = 1;
 250         }
 251     }
 252     my $database;
 253     if ($update_required) {
 254         my $disk_db = {};
 255         if (not -d "$dir") {
 256             mkdir($dir) or die "Unable to create directory $dir: $!";
 257         }
 258         for my $db (qw(length position substitution rotation anagram)) {
 259             $database->{$db} = {};
 260             $disk_db->{$db} = {};
 261             tie %{$disk_db->{$db}}, MLDBM => "$dir/db_${db}",
 262                 O_RDWR|O_CREAT|O_TRUNC, 0666
 263                     or die "Unable to open/create $dir/db_${db}: $!";
 264         }
 265         my $wordlist_fh = IO::File->new($wordlist,'r') or
 266             die "Unable to open $wordlist for reading: $!";
 267         my %seen_words;
 268         while (<$wordlist_fh>) {
 269             chomp;
 270             next unless length $_;
 271             my $word = lc($_);
 272             $word =~ s/[^a-z]//;
 273             next unless length $_;
 274             next if exists $seen_words{$word};
 275             $seen_words{$word} = 1;
 276             if ((keys %seen_words) % 100 == 0) {
 277                 print STDERR "Handled ".(keys %seen_words) . "words, on $word\n";
 278             }
 279             my @l = split //, $word;
 280             my $l = length($word);
 281             for my $p (0..$#l) {
 282                 # position from the beginning
 283                 my $temp = $database->{position}{"$p $l[$p]"};
 284                 $temp = [] if not defined $temp;
 285                 push @{$temp}, $word;
 286                 $database->{position}{"$p $l[$p]"} = $temp;
 287                 # this is the position from the end
 288                 $temp = $database->{position}{$p-$l . " " . $l[$p-$l]};
 289                 $temp = [] if not defined $temp;
 290                 push @{$temp}, $word;
 291                 $database->{position}{$p-$l . " " . $l[$p-$l]} = $temp;
 292             }
 293             my $temp = $database->{length}{$l};
 294             $temp = [] if not defined $temp;
 295             push @{$temp}, $word;
 296             $database->{length}{$l} = $temp;
 297             # this is the substitution database
 298             # in it, hello and giddy both become abccd
 299             my %uc = ();
 300             my @uc_order = map {
 301                 if (exists $uc{$_}) {
 302                     ();
 303                 } else {
 304                     $uc{$_} = 1;
 305                     $_;
 306                 }
 307             } @l;
 308             my %s_map;
 309             @s_map{@uc_order} = ('a'..'z')[0..$#uc_order] if @uc_order;
 310             my $mapped_word = join('',map {$s_map{$_}} @l);
 311             $temp = $database->{substitution}{$mapped_word};
 312             $temp = [] if not defined $temp;
 313             push @{$temp}, $word;
 314             $database->{substitution}{$mapped_word} = $temp;
 315
 316             # this is the rotation database (for ceaser cyphers)
 317             # in it, hello becomes axeeh, giddy acxxs
 318             my $fl = $l[0];
 319             my $index = $l_o{$fl};
 320             $mapped_word = join('',map {$l_o[($l_o{$_} - $index + 26) % 26]} @l);
 321             $temp = $database->{rotation}{$mapped_word};
 322             $temp = [] if not defined $temp;
 323             push @{$temp}, $word;
 324             $database->{rotation}{$mapped_word} = $temp;
 325
 326             # this is the anagram database
 327             # in it, hello becomes ehllo, giddy ddgiy
 328             $mapped_word = join('',sort @l);
 329             $temp = $database->{anagram}{$mapped_word};
 330             $temp = [] if not defined $temp;
 331             push @{$temp}, $word;
 332             $database->{anagram}{$mapped_word} = $temp;
 333         }
 334         for my $key1 (keys %{$database}) {
 335             for my $key2 (keys %{$database->{$key1}}) {
 336                 $disk_db->{$key1}{$key2} = $database->{$key1}{$key2};
 337             }
 338         }
 339     }
 340     else {
 341         for my $db (qw(length position)) {
 342             $database->{$db} = {};
 343             tie %{$database->{$db}}, MLDBM => "$dir/db_${db}",
 344                 O_RDONLY, 0666
 345                     or die "Unable to open $dir/db_${db}: $!";
 346         }
 347     }
 348     return $database;
 349
 350 }
 351
 352
 353 __END__