#!/usr/bin/perl -- -*- cperl -*-
# These you must set for your system:
$dictfile = "/usr/share/dict/words";
my $workdir = "wordsearch-workdir";
# Non-POSIX users (e.g., Win32) need to make additional changes, e.g.,
# to pathnames (as I've assumed a dirseparator of /) and possibly
# other small things like that, but I've gotten it working on
# ActiveState Perl on Win98, so it's definitely possible. I
# supplemented it with a batch file that changes directories and at
# the end opens the document in OO.o. The whole thing could be made
# more portable by extracting more of those things into variables or
# by using more advanced filesystem tree stuff, but for this prototype
# version I haven't done that.
# Some defaults:
my $title = "demonstration"; # What to call this specific wordsearch (used in filename, so stick to alphanumeric characters).
my $mingridx = 5;
my $mingridy = 5;
my $maxgridx = 60; # There's no max y, because it expands as necessary to fit all the words.
my $maxredo = 5; # Set to the max number of times to _redo_ the grid.
# Setting $maxredo to 0 makes easy puzzles because the grid stays cramped the whole time
# (especially so for low values of $mingridx and $mingridy).
# For really sparse puzzles, raise $mingridx and $mingridy to the desired puzzle size.
# Any characters that you want to be used for filler, whether they're in the words or not, put them in @extrachars:
my @extrachars = ();#('A'..'Z');
my @orientations =
(
# Each orientation is like this: [deltax, deltay]
[ 1, 0], [ 0, 1], [-1, 0], [ 0,-1],
# LTR down RTL up
[ 1, 1], [ 1,-1], [-1, 1], [-1,-1],
# the four major diagonals
# If you set both deltax and deltay to 0 in the same orientation, you may be dissatisfied with the results.
# With delta values greater than 1, difficult puzzles may ensue, and the solution may be hard to follow.
);
@words = getwords();
print "Words read in: @words\n";
@wordlist = @words; # Preserve this so we can also print it later.
# Once we have the words, we want counts of how many times each letter occurs.
my %charcount = ();
for ((join"",@extrachars), @words) {
for (split//,$_) { ++$charcount{$_}; }
}
# (This info will be used later when deciding what letters to use filling in the empty spots.)
# Initialise some things:
$gridx = $mingridx; $gridy = $mingridy;
my $grown=1; my $fillcount=0; # So we go through the loop the first time at least.
while (($fillcount <= $maxredo) and ($grown)) {
if ($fillcount) {
# If we're cramped enough to have to retry, let's loosen it up a bit...
$gridy+=2; $gridx+=2 if (($gridx+1)<$maxgridx);
print "Re-starting with larger grid size ($gridx by $gridy) because grid was cramped last time around.\n";
print "This is the $fillcount"."th retry (out of $maxredo possible)\n";
}
@words = @wordlist; ++$fillcount; $grown=0; undef @grid;
while (scalar @words) { # while and pop instead of foreach because sometimes we unshift a word back on (see below).
$w = pop @words;
# Will the word even fit in the physical dimensions of the grid?
while (($gridx < length $w) and ($gridy < length $w)) {
print "Cannot fit $w in $gridx by $gridy grid; grid too small; growing.\n";
++$grown; ++$gridy; ++$gridx if ($gridx<$maxgridx);
}
# We want to try it at all positions, in all orientations, taking
# the first place where it fits, but to prevent utter predictability
# we want to randomly order the positions and orientations first.
# (If it fits nowhere, we'll push it back on @words and grow the grid.)
# So, a list of all the positions/orientations...
# my @posn = randomorder (map { my $y=$_; map { my $x=$_; map {[$x,$y,$_]} @orientations } 1..$gridx } 1..$gridy);
# That first try totally randomized all the positions, and the
# words ended up mostly being parallel (because they fit easiest
# that way). So I want to try all positions in a given
# orientation first before moving on to another orientation...
my @posn = map { my ($x,$y)=($$_[0],$$_[1]); map { [$x,$y,$_] } randomorder(@orientations)
} randomorder (map { my $y=$_; map { my $x=$_; [$x,$y] } 1..$gridx } 1..$gridy);
# (That could be golfed down some, if legibility didn't matter, but...)
my $placed = undef; my $tried=0;
for (@posn) {
++$tried;
if (place($w,$_)) {
$placed = $_;
last;
}
}
if ($placed) {
my ($x,$y,$o) = @$placed;
my ($xd,$yd) = @$o;
print "Placed $w at position [$x,$y] orientation [$xd,$yd] (${tried}th position tried)\n";
} else {
push @words, $w;
print "Could not place $w; no room left in the $gridx by $gridy grid; enlarging.\n";
++$grown; ++$gridy; ++$gridx if ($gridx<$maxgridx);
}
}
}
# Great, so we now have all the words placed. It remains to fill in
# the blanks, but let's take note of the solution first:
print "Final grid is $gridx by $gridy (after $fillcount retries)\n";
print "-"x(int $gridx/2-4);
print "SOLUTION:";
print "-"x(int $gridx/2-4);
print "\n";
for $y (1..$gridy) {
for $x (1..$gridx) {
print " " . ($grid[$x][$y] or " ");
}
print$/
}
my @solutiongrid;
for $x (1..$gridx) {
for $y (1..$gridy) {
$solutiongrid[$x][$y] = $grid[$x][$y];
}
}
# Okay, that gives us the solution, so we no longer have to preserve
# the grid with only the solution. i.e., we can now fill in the
# remaining spots:
my @c = randomorder(map { my $c=$_; map {$c} 1..$charcount{$c} } keys %charcount);
for $y (1..$gridy) {
for $x (1..$gridx) {
if (not defined $grid[$x][$y]) {
my $c = pop @c;
$grid[$x][$y] = $c;
unshift @c, $c; # Just in case we run out.
}
}
}
print "-"x(int $gridx/2-5);
print "WORDLIST:";
print "-"x(int $gridx/2-5);
print "$/@wordlist$/";
# Let's also construct the XML wordlist...
my $xmlwordlist=<<"XMLWORDLIST";
Word List:
XMLWORDLIST
;
{
my @w = sort { $b cmp $a } @wordlist;
while (@w) {
my ($x, $y, $z) = map {pop@w} 1..3;
$xmlwordlist .= "
$x
$y
$z
\n";
}
}
$xmlwordlist .= "\n";
print "-"x(int $gridx/2-4);
print "PUZZLE:";
print "-"x(int $gridx/2-4);
print "\n";
for $y (1..$gridy) {
for $x (1..$gridx) {
print " " . ($grid[$x][$y] or " ");
}
print$/
}
mkdir $workdir;
open XML, ">$workdir/content.xml";
print XML <<"CONTENTXML";
CONTENTXML
;
print XML "
".table('Solution','Table2', \@solutiongrid)."
".table('Puzzle', 'Table1', \@grid)."
$xmlwordlist
".#table('','Table3', [[" ", "A"],["B", "C"]]).
# I had some bit of XML wrong, causing the last table to have its contents reduced to only the first cell.
# This blank table was a workaround until I figured out what I did wrong.
"
\n";
writefiles();
# Great, so now let's zip 'er up:
use Archive::Zip qw(:ERROR_CODES :CONSTANTS);
my $zipfile = "wordsearch-$title.sxw";
open ZIPFILE, ">$zipfile";
my $zip = Archive::Zip->new();
foreach my $memberName ('content.xml', #'layout-cache',
'META-INF', 'meta.xml', 'settings.xml', 'styles.xml') {
chdir "$workdir"; # This may be unnecessary, depending on how you set things up.
if (-e $memberName) {
warn "Good: member does in fact exist: $memberName\n" if ($debug>1);
if (-d $memberName ) {
warn "Member is directory: $memberName\n" if ($debug>1);
warn "Can't add tree $memberName\n"
if ($zip->addTree( $memberName, $memberName ) != AZ_OK);
}
else {
warn "Member must be file (is not dir): $memberName\n" if ($debug>1);
$zip->addFile( $memberName )
or warn "Can't add file $memberName\n";
}
} else {
warn "Member does not exist: $memberName\n";
}
}
my $status = $zip->writeToFileHandle(*ZIPFILE);
close ZIPFILE;
print "Wrote $zipfile (status: $status)\n";
exit 0; # Subroutines follow...
sub table {
my ($title, $table, $grid) = @_;
my $rval =<<"TABLETABLE";
$title:
TABLETABLE
;
$rval .= tablebody($table, $grid)." ";
return $rval;
}
sub tablebody {
my ($table, $grid) = @_;
my @grid = @$grid;
my $xml = "";
for $y (1..$gridy) {
$xml .= " \n";
for $x (1..$gridx) {
$xml .= " \n";
if ($grid[$x][$y]) {
$xml .= " $grid[$x][$y]\n";
} else {
$xml .= " \n";
}
$xml .= " \n";
}
$xml .= " \n";
}
return $xml;
}
sub place {
my ($word, $posn) = @_;
my ($x,$y,$o) = @$posn;
my ($xd,$yd) = @$o;
my @c = split//, $word;
# Test everything before doing anything...
for $i (1..(length $word)) {
my $xp = $x + ($xd * ($i - 1));
my $yp = $y + ($yd * ($i - 1));
if (($xp <= 0) or ($yp <= 0) or ($xp > $gridx) or ($yp > $gridy)) {
# Won't fit in this position, because it goes off the grid.
return undef;
}
if (($grid[$xp][$yp]) and ($grid[$xp][$yp] ne $c[$i-1])) {
# Won't fit in this position due to collision.
return undef;
}
}
# If we didn't go off the grid or collide, it must fit. Place it.
for $i (1..(length $word)) {
my $xp = $x + ($xd * ($i - 1));
my $yp = $y + ($yd * ($i - 1));
$grid[$xp][$yp] = $c[$i-1];
}
return $word if $word;
return "$word but true";
}
sub randomorder {
return map {
$$_[0]
} sort {
$$a[1] <=> $$b[1]
} map {
[$_, rand(17931)]
} @_;
}
sub wordsfromdictionary {
my ($numofwords) = @_;
open DICT, "<$dictfile";
my @dict = map {chomp;lc $_} ; close DICT;
return map { $dict[rand @dict] } 1..$numofwords;
}
sub getwords {
# A GUI frontend could be substituted here...
my $choice = menu('What words should be used for the wordsearch?',
[[dict=>'Use random words from a dictionary'],
[user=>'Let me type in some words to use'],
]);
if ($choice eq 'dict') {
print "How many words should be taken from the dictionary?\n";
my ($w) = =~ /(\d+)/;
while (not ($w>0)) {
print " Please enter a number of words to use in the dictionary. ==> ";
($w) = =~ /(\d+)/;
}
return wordsfromdictionary($w);
} elsif ($choice eq 'user') {
print "Please type one word per line. When you are finished typing words, enter a blank line.\n";
my $w = 1; my @w;
while ($w) {
($w) = =~ /(\w+)/;
push @w, $w if $w;
}
return @w;
} else {
die "Whoah, I got confused. My menu subroutine didn't return the kind of value I expected.
This is certainly a bug in my program code. Get Nathan.\n\n";
}
}
sub menu {
$|++;
my ($question, $c) = @_;
my @choice = @$c;
my $response = 0;
while (($response<1) or ($response>@choice)) {
print "\n\n\t$question\n"; my $choicenum=0;
print ((join$/,map{sprintf"\t% 2d. $$_[1]",++$choicenum} @choice)."\n\nEnter choice number: ==> ");
($response) = =~ /(\d+)/;
if ($debug) {
print "You said: $response\n";
if ($response<1) { print "Response less than 1.\n"; }
if ($response>@choice) { print "Response greater than ".@choice.".\n"; }
}
}
my $choice = $choice[$response-1]; # Perl arrays are zero-indexed; I started my choice numbers at 1, for added end-user comfort.
return $$choice[0];
}
sub writefiles {
# Writes the other files (besides content.xml) needed for the SXW document:
open XML, ">$workdir/meta.xml";
print XML <<'METAXML';
Original base document created using OpenOffice.org 1.0.2 (Linux); data interpolated by Perl script.
2003-09-22T13:30:15
2003-09-22T15:21:13
2003-09-22T14:13:40
en-US
3
PT1H51M13S
METAXML
;close XML;
open XML, ">$workdir/settings.xml";
print XML <<'SETTINGSXML';
11763
0
23661
13951
true
false
false
false
view2
14887
21059
0
11763
23659
25712
3
103
false
false
false
1
0
false
false
true
true
true
true
ugL+/zxBZmljaW8+AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAU0dFTlBSVAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAWAAMAAAIAAAAA//8BAAhSAAAEdAAASm9iRGF0YSAxCnByaW50ZXI9PEFmaWNpbz4Kb3JpZW50YXRpb249UG9ydHJhaXQKY29waWVzPTEKc2NhbGU9MAptYXJnaW5kYWp1c3RtZW50PTAsMCwwLDAKY29sb3JkZXB0aD0yNApwc2xldmVsPTAKY29sb3JkZXZpY2U9MApQUERDb250ZXhEYXRhClBhZ2VTaXplOkE0AABlcgAANAAAIDA6IGRyaXZlciBzZXR0aW5nLCAxOiBsZXZlbCAxLCAyOiBsZXZlbDIA8AYAAFgAAAD4BgAAWHcoRcDQU0AYdyhFAQAAAEAAAAAYAAAAEHcoRRB3KEU7ICAgICAgICAgaWYga2V5IGlzIGFic2VudCB0aGUgZGVmYXVsdCBpcyAwAG4AQQA4AAAAUAcAAJB3KEXA0FNAcHcoRQEAQwAgAAAAGAAAAGh3KEVodyhFOyBQU0xldmVsPTAAIGtleRgAAACIBwAAqHcoRcDQU0DA0FNAAXQgdngAAACgBwAAIHgoRcDQU0DAdyhFAWljAGAAAAAYAAAAuHcoRbh3KEU7IFBQRF9QYWdlU2l6ZTogdGhlIGRlZmF1bHQgcGFnZSBzaXplIHRvIHVzZS4gSWYgYSBzcGVjaWZpYyBwcmludGVyIGRvZXMAAAAAEAgAABgAAAAYCAAAOHgoRcDQU0A=
0
true
true
false
false
false
false
<Aficio>
true
false
false
true
0
true
true
false
SETTINGSXML
;close XML;
open XML, ">$workdir/styles.xml";
print XML <<'STYLESXML';
STYLESXML
;close XML;
mkdir "$workdir/META-INF";
open XML, ">$workdir/META-INF/manifest.xml";
print XML <<'MANIFEST';
MANIFEST
;close XML;
}
# word-search-maker was written 2003 September for Galion Public
# Library and is primarily intended for use within the library; this
# code is not thoroughly tested and is only distributed with the
# expectation that anyone who wants to use it will test and evaluate
# it first to determine whether it will meet their needs, what bugs
# need to be fixed, what improvements that need to be made, et cetera
# and will make any necessary adjustments before distributing or using
# it. Galion Public Library can make no warrantee that it is complete
# (since it is not, in fact, complete) nor that it is suitable for any
# purpose other than our own use. Anyone who wishes to distribute,
# copy, modify, or use this code or any derivative works thereof may
# ONLY do so with the understanding and under the agreement that
# Galion Public Library is not and can not be responsible in any way
# for any resulting occurrances that may ensue; you the distributor or
# the end use must assume full responsibility for any distribution or
# use of this work; otherwise you are expressly forbidden to
# distribute, copy, modify, or use it, to the greatest extent that
# such actions can be forbidden under copyright laws applicable in the
# US and other countries.
####
$;=sub{$/};@;=map{my($a,$b)=($_,$;);$;=sub{$a.$b->()}}
split//,".rekcah lreP rehtona tsuJ";$\=$ ;->();print$/