path: root/ipl/progs/makepuzz.icn

############################################################################
#
#	File:     makepuzz.icn
#
#	Subject:  Program to make find-the-word puzzle
#
#	Author:   Richard L. Goerwitz
#
#	Date:     May 2, 2001
#
###########################################################################
#
#   This file is in the public domain.
#
############################################################################
#
#	Version:  1.19
#
###########################################################################
#
#     This program doesn't do anything fancy.  It simply takes a list
#  of words, and constructs out of them one of those square
#  find-the-word puzzles that some people like to bend their minds
#  over.  Usage is:
#
#      makepuzz [-f input-file] [-o output-file] [-h puzzle-height]
#         -w puzzle-width] [-t how-many-seconds-to-keep-trying]
#         [-r maximum-number-of-rejects] [-s] [-d]
#
#  where input-file is a file containing words, one to a line
#  (defaults to &input), and output-file is the file you would like the
#  puzzle written to (defaults to &output).  Puzzle-height and width
#  are the basic dimensions you want to try to fit your word game into
#  (default 20x20).  If the -s argument is present, makepuzz will
#  scramble its output, by putting random letters in all the blank
#  spaces.  The -t tells the computer when to give up, and construct
#  the puzzle (letting you know if any words didn't make it in).
#  Defaults to 60 (i.e. one minute).  The -r argument tells makepuzz to
#  run until it arrives at a solution with number-of-rejects or less
#  un-inserted words.  -d turns on certain diagnostic messages.
#
#      Most of these options can safely be ignored.  Just type
#  something like "makepuzz -f wordlist," where wordlist is a file
#  containing about sixty words, one word to a line.  Out will pop a
#  "word-find" puzzle.  Once you get the hang of what is going on,
#  try out the various options.
#
#      The algorithm used here is a combination of random insertions
#  and mindless, brute-force iterations through possible insertion
#  points and insertion directions.  If you don't like makepuzz's per-
#  formance on one run, run it again.  If your puzzle is large, try
#  increasing the timeout value (see -t above).
#
############################################################################
#
#  Links: options, random, colmize
#
############################################################################

link options
link random
link colmize

global height, width, _debug_

procedure main(a)

    local usage, opttbl, inputfile, outputfile, maxrejects, puzzle,
	wordlist, rejects, master_list, word, timeout, x, y, l_puzzle,
	l_wordlist, l_rejects, no_ltrs, l_no_ltrs, try, first_time

    # Filename is the only mandatory argument; they can come in any order.
    usage := "makepuzz [-f infile] [-o outfile] [-h height] [-w width] _
	[-t secs] [-r rejects] [-s]"

    # Set up puzzle height and width (default 20x20); set up defaults
    # such as the input & output files, time to spend, target reject
    # count, etc.
    opttbl := options(a, "w+h+f:o:t+sr+d") # stop(usage)
    width  := \opttbl["w"] | 20
    height := \opttbl["h"] | 20
    timeout := &time + (1000 * (\opttbl["t"] | 60))
    inputfile := open(\opttbl["f"], "r") | &input
    outputfile := open(\opttbl["o"], "w") | &output
    maxrejects := \opttbl["r"] | 0
    _debug_ := \opttbl["d"] & try := 0
    first_time := 1

    # Set random number seed.
    randomize()

    # Read, check, and sort word list hardest to easiest.
    master_list := list()
    every word := "" ~== trim(map(!inputfile)) do {
	upto(~(&lcase++&ucase), word) &
	    stop("makepuzz:  non-letter found in ", word)
	write(&errout, "makepuzz:  warning, ",3 > *word,
	      "-letter word (", word, ")")
	put(master_list, word)
    }
    master_list := sort_words(master_list)
    if \_debug_ then write(&errout, "makepuzz:  thinking...")

    # Now, try to insert the words in the master list into a puzzle.
    # Stop when the timeout limit is reached (see -t above).
    until &time > timeout & /first_time do {

	first_time := &null
	wordlist := copy(master_list); rejects := list()
	puzzle := list(height); every !puzzle := list(width)
	blind_luck_insert(puzzle, wordlist, rejects)
	brute_force_insert(puzzle, wordlist, rejects, timeout)

	# Count the number of letters left over.
	no_ltrs := 0; every no_ltrs +:= *(!wordlist | !rejects)
	l_no_ltrs := 0; every l_no_ltrs +:= *(!\l_wordlist | !\l_rejects)
	# If our last best try at making a puzzle was worse...
	if /l_puzzle |
	    (*\l_wordlist + *l_rejects) > (*wordlist + *rejects) |
	    ((*\l_wordlist + *l_rejects) = (*wordlist + *rejects) &
	     l_no_ltrs > no_ltrs)
	then {
	    # ...then save the current (better) one.
	    l_puzzle   := puzzle
	    l_wordlist := wordlist
	    l_rejects  := rejects
	}

	# Tell the user how we're doing.
	if \_debug_ then
	    write(&errout, "makepuzz:  try number ", try +:= 1, "; ",
		  *wordlist + *rejects, " rejects")

	# See the -r argument above.  Stop if we get to a number of
	# rejects deemed acceptable to the user.
	if (*\l_wordlist + *l_rejects) <= maxrejects then break
    }

    # Signal to user that we're done, and set puzzle, wordlist, and
    # rejects to their best values in this run of makepuzz.
    write(&errout, "makepuzz:  done")
    puzzle   := \l_puzzle
    wordlist := \l_wordlist
    rejects  := \l_rejects

    # Print out original word list, and list of words that didn't make
    # it into the puzzle.
    write(outputfile, "Original word list (sorted hardest-to-easiest): \n")
    every write(outputfile, colmize(master_list))
    write(outputfile, "")
    if *rejects + *wordlist > 0 then {
	write(outputfile, "Couldn't insert the following words: \n")
	every write(outputfile, colmize(wordlist ||| rejects))
	write(outputfile, "")
    }

    # Scramble (i.e. put in letters for remaining spaces) if the user
    # put -s on the command line.
    if \opttbl["s"] then {
	every y := !puzzle do
	    every x := 1 to *y do
	        /y[x] := ?&ucase

        # Print out puzzle structure (answers in lowercase).
	every y := !puzzle do {
	    every x := !y do
		writes(outputfile, \x | " ", " ")
	    write(outputfile, "")
	}
	write(outputfile, "")
    }

    # Print out puzzle structure, all lowercase.
    every y := !puzzle do {
	every x := !y do
	    writes(outputfile, map(\x) | " ", " ")
        write(outputfile, "")
    }

    # Exit with default OK status for this system.
    every close(inputfile | outputfile)
    exit()

end


procedure sort_words(wordlist)

    local t, t2, word, sum, l

    # Obtain a rough character count.
    t := table(0)
    every t[!!wordlist] +:= 1
    t2 := table()

    # Obtain weighted values for each word, essentially giving longer
    # words and words with uncommon letters the highest values.  Later
    # we'll reverse the order (-> hardest-to-easiest), and return a list.
    every word := !wordlist do {
	"" == word & next
	sum := 0
	every sum +:= t[!word]
	insert(t2, word, (sum / *word) - (2 * *word))
    }
    t2 := sort(t2, 4)
    l := list()

    # Put the hardest words first.  These will get laid down when the
    # puzzle is relatively empty.  Save the small, easy words for last.
    every put(l, t2[1 to *t2-1 by 2])
    return l

end


procedure blind_luck_insert(puzzle, wordlist, rejects)

    local s, s2, s3, begy, begx, y, x, diry, dirx, diry2, dirx2, i
    # global height, width

    # Try using blind luck to make as many insertions as possible.
    while s := get(wordlist) do {

	# First try squares with letters already on them, but don't
	# try every direction yet (we're relying on luck just now).
	# Start at a random spot in the puzzle, and wrap around.
	begy := ?height; begx := ?width
	every y := (begy to height) | (1 to begy - 1) do {
	    every x := (begx to width) | (1 to begx - 1) do  {
		every i := find(\puzzle[y][x], s) do {
		    diry := ?3; dirx := ?3
		    s2 := s[i:0]
		    diry2 := 4 > (diry + 2) | 0 < (diry - 2) | 2
		    dirx2 := 4 > (dirx + 2) | 0 < (dirx - 2) | 2
		    s3 := reverse(s[1:i+1])
		    if insert_word(puzzle, s2, diry, dirx, y, x) &
			insert_word(puzzle, s3, diry2, dirx2, y, x)
		    then break { break break next }
		}
	    }
	}

	# If the above didn't work, give up on spaces with characters
	# in them; use blank squares as well.
	every 1 to 512 do
	    if insert_word(puzzle, s, ?3, ?3, ?height, ?width) then
	       break next
	# If this word doesn't submit to easy insertion, save it for
	# later.
	put(rejects, s)
    }

    # Nothing useful to return (puzzle, wordlist, and rejects objects
    # are themselves modified; not copies of them).
    return

end


procedure brute_force_insert(puzzle, wordlist, rejects, timeout)

    local s, start, dirs, begy, begx, y, x
    
    # Use brute force on the remaining forms.
    if *rejects > 0 then {
	wordlist |||:= rejects; rejects := []
	while s := pop(wordlist) do {
	    start := ?3; dirs := ""
	    every dirs ||:= ((start to 3) | (1 to start-1))
	    begy := ?height; begx := ?width
	    every y := (begy to height) | (1 to begy - 1) do {
		if &time > timeout then fail
		every x := (begx to width) | (1 to begx - 1) do  {
		    if insert_word(puzzle, s, !dirs, !dirs, y, x) then
			break { break next }
		}
	    }
	    # If we can't find a place for s, put it in the rejects list.
	    put(rejects, s)
	}
    }

    # Nothing useful to return (puzzle, wordlist, and rejects objects
    # are themselves modified; not copies of them).
    return

end


procedure insert_word(puzzle, s, ydir, xdir, y, x)

    local incry, incrx, firstchar

    # If s is zero length, we've matched it in it's entirety!
    if *s = 0 then {
	return

    } else {

	# Make sure there's enough space in the puzzle in the direction
	# we're headed.
	case ydir of {
	    "3":  if (height - y) < (*s - 1) then fail
	    "1":  if y < (*s - 1) then fail
	}
	case xdir of {
	    "3":  if (width - x) < (*s - 1) then fail
	    "1":  if x < (*s - 1) then fail
	}

	# Check to be sure everything's in range, and that both the x and
	# y increments aren't zero (in which case, we aren't headed in any
	# direction at all...).
	incry := (ydir - 2); incrx := (xdir - 2)
	if incry = 0 & incrx = 0 then fail
	height >= y >= 1 | fail
	width >= x >= 1 | fail

	# Try laying the first char in s down at puzzle[y][x].  If it
	# works, head off in some direction, and try laying down the rest
	# of s along that vector.  If at any point we fail, we must
	# reverse the assignment (<- below).
	firstchar := !s
	((/puzzle[y][x] <- firstchar) | (\puzzle[y][x] == firstchar)) &
	    insert_word(puzzle, s[2:0], ydir, xdir, y + incry, x + incrx) &
		suspend
	fail
    }

end