Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/BIPL.ZIP/PROGS.ZIP/MAKEPUZZ.ICN

Text File | 1992-09-28 | 10.7 KB | 325 lines

############################################################################
#
#    File:     makepuzz.icn
#
#    Subject:  Program to make find-the-word puzzle
#
#    Author:   Richard L. Goerwitz
#
#    Date:     July 8, 1992
#
###########################################################################
#
#    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 ouput-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, irandom, colmize
#  Requires:  An up-to-date IPL (2/10/92)
#
############################################################################

link options, irandom, 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.
    irandom()

    # 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