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 $
17 acromang - try to solve acrostics
21 acromang m??s??c??o [options]
24 --debug, -d debugging level (Default 0)
25 --help, -h display this help
26 --man, -m display manual
34 Default wordlist, should be gigantic; defaults to
37 =item B<--database-dir>
39 Directory for storing databases; defaults to ~/.acromang
43 Debug verbosity. (Default 0)
47 Display brief useage information.
66 use Params::Validate qw(:types validate_with);
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);
76 use List::Util qw(min max);
79 my %options = (debug => 0,
82 wordlist => '/usr/share/dict/words',
83 database_dir => User->Home.'/.acromang/',
88 my @puzzle_types = qw(acrostic anagram substitution);
93 'wordlist=s','database_dir|database-dir=s',
95 'debug|d+','help|h|?','man|m');
97 pod2usage() if $options{help};
98 pod2usage({verbose=>2}) if $options{man};
100 $DEBUG = $options{debug};
103 if (not grep {exists $options{$_}} @puzzle_types) {
104 $options{acrostic} = 1
107 if (1 != grep {exists $options{$_}} @puzzle_types) {
108 push @USAGE_ERRORS, "You must pass exactly one of ".join(', ',map {"--$_ "} @puzzle_types);
111 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
117 my @words = map {s/[^A-Za-z\?]//g; length $_?$_:();} split /[\s\n]+/, $text;
119 print STDERR "There were no words in the input\n";
124 my @l_o = ('a'..'z');
126 @l_o{@l_o} = (0 .. 25);
128 return map {tr/A-Z/a-z/; tr/éüöáí/euoai/; $_ } @_
131 my $database = update_and_load_database($options{database_dir},$options{wordlist});
133 # run through and use the database
135 # for now, concentrate on finding single word solutions
136 if ($options{acrostic}) {
138 elsif ($options{acrostic}) {
139 foreach my $word (@words) {
140 my $length = length($word);
141 my @let = split //, $word;
143 for my $p (0..$#let) {
144 next if $let[$p] eq '?';
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];
152 # multiword currently not enabled
153 # while ((@allowable_words == 0 or $options{multiword}) and
154 # (@allowable_words < 200 or $options{show_all})
156 # # try for multiple word solutions, start with the longest
159 # # try to split the number of known letters in half, and
160 # # start increasing and decreasing in both directions
162 # # don't attempt to split each part into bits unless there
165 # # avoid searching for words when we only have a length and
166 # # no position information
168 print map {$_,qq(\n)} sort @allowable_words;
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,
178 print map {$_,qq(\n)} sort @allowable_words;
182 sub find_allowable_words {
183 my %param = validate_with(params => \@_,
184 spec => {database => {type => HASHREF,
186 position => {type => HASHREF,
189 length => {type => SCALAR,
192 substitution => {type => SCALAR,
195 rotation => {type => SCALAR,
198 anagram => {type => SCALAR,
204 my $database = $param{database};
206 if (exists $param{length} and defined $param{length} and $param{length} > 0) {
209 if (exists $param{position} and defined $param{position}) {
210 $must_match += scalar keys %{$param{position}};
212 if (exists $param{anagram} and defined $param{anagram}) {
216 if ($must_match <= 0) {
217 die "There must be something to try matching against";
220 if (exists $param{length} and defined $param{length} and $param{length} > 0) {
221 for my $word (@{$database->{length}{$param{length}}}) {
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}}}) {
232 if (exists $param{anagram} and defined $param{anagram}) {
233 for my $word (@{$database->{anagram}{$param{anagram}}}) {
237 return grep {$words{$_} >= $must_match} keys %words;
242 # need to find unsolved words
244 # if there are multiple intersecting unsolved locations, try to
245 # solve the hard ones first, then the easy ones.
247 # given the current state of the board, find all possible words
248 # that fit the fixed positions
250 # find unsolved words
252 # find positions with _ or ?, * or | are unsolved bits
254 # scan the puzzle from left to right, top to bottom (across
255 # answers), then top to bottom, left to right (down answers)
257 my $current_answer=0;
259 sub __add_to_answers {
260 my ($acrostic,$current_answer,$in_word,$pos) = @_;
261 if ($acrostic->{grid}[$pos] !~ /^\*\|$/) {
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;
280 for my $width (0..($acrostic->{width}-1)) {
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);
287 for my $height (0..($acrostic->{height}-1)) {
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);
295 # for all possible answers which are unsolved, find allowable words
296 for my $answer (0..$#{$acrostic->{answers}}) {
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
303 # for all crossing positions, eliminate words which do not share a
304 # letter in common with a word in the opposite direction
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";
317 my $wordlist_stat = stat($wordlist);
318 $wordlist_time = max($wordlist_time,$wordlist_stat->mtime);
320 if (! -e "$dir/db_${db}") {
321 $update_required = 1;
323 elsif (stat("$dir/db_${db}")->mtime < $wordlist_time) {
324 $update_required = 1;
328 if ($update_required) {
331 mkdir($dir) or die "Unable to create directory $dir: $!";
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}: $!";
340 my $wordlist_fh = IO::File->new($wordlist,'r') or
341 die "Unable to open $wordlist for reading: $!";
343 while (<$wordlist_fh>) {
345 next unless length $_;
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";
355 my @l = split //, $word;
356 my $l = length($word);
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;
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
377 if (exists $uc{$_}) {
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;
392 # this is the rotation database (for ceaser cyphers)
393 # in it, hello becomes axeeh, giddy acxxs
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";
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;
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;
413 for my $key1 (keys %{$database}) {
414 for my $key2 (keys %{$database->{$key1}}) {
415 $disk_db->{$key1}{$key2} = $database->{$key1}{$key2};
421 $database->{$db} = {};
422 tie %{$database->{$db}}, MLDBM => "$dir/db_${db}",
424 or die "Unable to open $dir/db_${db}: $!";