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