home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / ipl / progs / makepuzz.icn < prev    next >
Text File  |  2001-05-02  |  11KB  |  331 lines
  1. ############################################################################
  2. #
  3. #    File:     makepuzz.icn
  4. #
  5. #    Subject:  Program to make find-the-word puzzle
  6. #
  7. #    Author:   Richard L. Goerwitz
  8. #
  9. #    Date:     May 2, 2001
  10. #
  11. ###########################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #    Version:  1.19
  18. #
  19. ###########################################################################
  20. #
  21. #     This program doesn't do anything fancy.  It simply takes a list
  22. #  of words, and constructs out of them one of those square
  23. #  find-the-word puzzles that some people like to bend their minds
  24. #  over.  Usage is:
  25. #
  26. #      makepuzz [-f input-file] [-o output-file] [-h puzzle-height]
  27. #         -w puzzle-width] [-t how-many-seconds-to-keep-trying]
  28. #         [-r maximum-number-of-rejects] [-s] [-d]
  29. #
  30. #  where input-file is a file containing words, one to a line
  31. #  (defaults to &input), and output-file is the file you would like the
  32. #  puzzle written to (defaults to &output).  Puzzle-height and width
  33. #  are the basic dimensions you want to try to fit your word game into
  34. #  (default 20x20).  If the -s argument is present, makepuzz will
  35. #  scramble its output, by putting random letters in all the blank
  36. #  spaces.  The -t tells the computer when to give up, and construct
  37. #  the puzzle (letting you know if any words didn't make it in).
  38. #  Defaults to 60 (i.e. one minute).  The -r argument tells makepuzz to
  39. #  run until it arrives at a solution with number-of-rejects or less
  40. #  un-inserted words.  -d turns on certain diagnostic messages.
  41. #
  42. #      Most of these options can safely be ignored.  Just type
  43. #  something like "makepuzz -f wordlist," where wordlist is a file
  44. #  containing about sixty words, one word to a line.  Out will pop a
  45. #  "word-find" puzzle.  Once you get the hang of what is going on,
  46. #  try out the various options.
  47. #
  48. #      The algorithm used here is a combination of random insertions
  49. #  and mindless, brute-force iterations through possible insertion
  50. #  points and insertion directions.  If you don't like makepuzz's per-
  51. #  formance on one run, run it again.  If your puzzle is large, try
  52. #  increasing the timeout value (see -t above).
  53. #
  54. ############################################################################
  55. #
  56. #  Links: options, random, colmize
  57. #
  58. ############################################################################
  59.  
  60. link options
  61. link random
  62. link colmize
  63.  
  64. global height, width, _debug_
  65.  
  66. procedure main(a)
  67.  
  68.     local usage, opttbl, inputfile, outputfile, maxrejects, puzzle,
  69.     wordlist, rejects, master_list, word, timeout, x, y, l_puzzle,
  70.     l_wordlist, l_rejects, no_ltrs, l_no_ltrs, try, first_time
  71.  
  72.     # Filename is the only mandatory argument; they can come in any order.
  73.     usage := "makepuzz [-f infile] [-o outfile] [-h height] [-w width] _
  74.     [-t secs] [-r rejects] [-s]"
  75.  
  76.     # Set up puzzle height and width (default 20x20); set up defaults
  77.     # such as the input & output files, time to spend, target reject
  78.     # count, etc.
  79.     opttbl := options(a, "w+h+f:o:t+sr+d") # stop(usage)
  80.     width  := \opttbl["w"] | 20
  81.     height := \opttbl["h"] | 20
  82.     timeout := &time + (1000 * (\opttbl["t"] | 60))
  83.     inputfile := open(\opttbl["f"], "r") | &input
  84.     outputfile := open(\opttbl["o"], "w") | &output
  85.     maxrejects := \opttbl["r"] | 0
  86.     _debug_ := \opttbl["d"] & try := 0
  87.     first_time := 1
  88.  
  89.     # Set random number seed.
  90.     randomize()
  91.  
  92.     # Read, check, and sort word list hardest to easiest.
  93.     master_list := list()
  94.     every word := "" ~== trim(map(!inputfile)) do {
  95.     upto(~(&lcase++&ucase), word) &
  96.         stop("makepuzz:  non-letter found in ", word)
  97.     write(&errout, "makepuzz:  warning, ",3 > *word,
  98.           "-letter word (", word, ")")
  99.     put(master_list, word)
  100.     }
  101.     master_list := sort_words(master_list)
  102.     if \_debug_ then write(&errout, "makepuzz:  thinking...")
  103.  
  104.     # Now, try to insert the words in the master list into a puzzle.
  105.     # Stop when the timeout limit is reached (see -t above).
  106.     until &time > timeout & /first_time do {
  107.  
  108.     first_time := &null
  109.     wordlist := copy(master_list); rejects := list()
  110.     puzzle := list(height); every !puzzle := list(width)
  111.     blind_luck_insert(puzzle, wordlist, rejects)
  112.     brute_force_insert(puzzle, wordlist, rejects, timeout)
  113.  
  114.     # Count the number of letters left over.
  115.     no_ltrs := 0; every no_ltrs +:= *(!wordlist | !rejects)
  116.     l_no_ltrs := 0; every l_no_ltrs +:= *(!\l_wordlist | !\l_rejects)
  117.     # If our last best try at making a puzzle was worse...
  118.     if /l_puzzle |
  119.         (*\l_wordlist + *l_rejects) > (*wordlist + *rejects) |
  120.         ((*\l_wordlist + *l_rejects) = (*wordlist + *rejects) &
  121.          l_no_ltrs > no_ltrs)
  122.     then {
  123.         # ...then save the current (better) one.
  124.         l_puzzle   := puzzle
  125.         l_wordlist := wordlist
  126.         l_rejects  := rejects
  127.     }
  128.  
  129.     # Tell the user how we're doing.
  130.     if \_debug_ then
  131.         write(&errout, "makepuzz:  try number ", try +:= 1, "; ",
  132.           *wordlist + *rejects, " rejects")
  133.  
  134.     # See the -r argument above.  Stop if we get to a number of
  135.     # rejects deemed acceptable to the user.
  136.     if (*\l_wordlist + *l_rejects) <= maxrejects then break
  137.     }
  138.  
  139.     # Signal to user that we're done, and set puzzle, wordlist, and
  140.     # rejects to their best values in this run of makepuzz.
  141.     write(&errout, "makepuzz:  done")
  142.     puzzle   := \l_puzzle
  143.     wordlist := \l_wordlist
  144.     rejects  := \l_rejects
  145.  
  146.     # Print out original word list, and list of words that didn't make
  147.     # it into the puzzle.
  148.     write(outputfile, "Original word list (sorted hardest-to-easiest): \n")
  149.     every write(outputfile, colmize(master_list))
  150.     write(outputfile, "")
  151.     if *rejects + *wordlist > 0 then {
  152.     write(outputfile, "Couldn't insert the following words: \n")
  153.     every write(outputfile, colmize(wordlist ||| rejects))
  154.     write(outputfile, "")
  155.     }
  156.  
  157.     # Scramble (i.e. put in letters for remaining spaces) if the user
  158.     # put -s on the command line.
  159.     if \opttbl["s"] then {
  160.     every y := !puzzle do
  161.         every x := 1 to *y do
  162.             /y[x] := ?&ucase
  163.  
  164.         # Print out puzzle structure (answers in lowercase).
  165.     every y := !puzzle do {
  166.         every x := !y do
  167.         writes(outputfile, \x | " ", " ")
  168.         write(outputfile, "")
  169.     }
  170.     write(outputfile, "")
  171.     }
  172.  
  173.     # Print out puzzle structure, all lowercase.
  174.     every y := !puzzle do {
  175.     every x := !y do
  176.         writes(outputfile, map(\x) | " ", " ")
  177.         write(outputfile, "")
  178.     }
  179.  
  180.     # Exit with default OK status for this system.
  181.     every close(inputfile | outputfile)
  182.     exit()
  183.  
  184. end
  185.  
  186.  
  187. procedure sort_words(wordlist)
  188.  
  189.     local t, t2, word, sum, l
  190.  
  191.     # Obtain a rough character count.
  192.     t := table(0)
  193.     every t[!!wordlist] +:= 1
  194.     t2 := table()
  195.  
  196.     # Obtain weighted values for each word, essentially giving longer
  197.     # words and words with uncommon letters the highest values.  Later
  198.     # we'll reverse the order (-> hardest-to-easiest), and return a list.
  199.     every word := !wordlist do {
  200.     "" == word & next
  201.     sum := 0
  202.     every sum +:= t[!word]
  203.     insert(t2, word, (sum / *word) - (2 * *word))
  204.     }
  205.     t2 := sort(t2, 4)
  206.     l := list()
  207.  
  208.     # Put the hardest words first.  These will get laid down when the
  209.     # puzzle is relatively empty.  Save the small, easy words for last.
  210.     every put(l, t2[1 to *t2-1 by 2])
  211.     return l
  212.  
  213. end
  214.  
  215.  
  216. procedure blind_luck_insert(puzzle, wordlist, rejects)
  217.  
  218.     local s, s2, s3, begy, begx, y, x, diry, dirx, diry2, dirx2, i
  219.     # global height, width
  220.  
  221.     # Try using blind luck to make as many insertions as possible.
  222.     while s := get(wordlist) do {
  223.  
  224.     # First try squares with letters already on them, but don't
  225.     # try every direction yet (we're relying on luck just now).
  226.     # Start at a random spot in the puzzle, and wrap around.
  227.     begy := ?height; begx := ?width
  228.     every y := (begy to height) | (1 to begy - 1) do {
  229.         every x := (begx to width) | (1 to begx - 1) do  {
  230.         every i := find(\puzzle[y][x], s) do {
  231.             diry := ?3; dirx := ?3
  232.             s2 := s[i:0]
  233.             diry2 := 4 > (diry + 2) | 0 < (diry - 2) | 2
  234.             dirx2 := 4 > (dirx + 2) | 0 < (dirx - 2) | 2
  235.             s3 := reverse(s[1:i+1])
  236.             if insert_word(puzzle, s2, diry, dirx, y, x) &
  237.             insert_word(puzzle, s3, diry2, dirx2, y, x)
  238.             then break { break break next }
  239.         }
  240.         }
  241.     }
  242.  
  243.     # If the above didn't work, give up on spaces with characters
  244.     # in them; use blank squares as well.
  245.     every 1 to 512 do
  246.         if insert_word(puzzle, s, ?3, ?3, ?height, ?width) then
  247.            break next
  248.     # If this word doesn't submit to easy insertion, save it for
  249.     # later.
  250.     put(rejects, s)
  251.     }
  252.  
  253.     # Nothing useful to return (puzzle, wordlist, and rejects objects
  254.     # are themselves modified; not copies of them).
  255.     return
  256.  
  257. end
  258.  
  259.  
  260. procedure brute_force_insert(puzzle, wordlist, rejects, timeout)
  261.  
  262.     local s, start, dirs, begy, begx, y, x
  263.     
  264.     # Use brute force on the remaining forms.
  265.     if *rejects > 0 then {
  266.     wordlist |||:= rejects; rejects := []
  267.     while s := pop(wordlist) do {
  268.         start := ?3; dirs := ""
  269.         every dirs ||:= ((start to 3) | (1 to start-1))
  270.         begy := ?height; begx := ?width
  271.         every y := (begy to height) | (1 to begy - 1) do {
  272.         if &time > timeout then fail
  273.         every x := (begx to width) | (1 to begx - 1) do  {
  274.             if insert_word(puzzle, s, !dirs, !dirs, y, x) then
  275.             break { break next }
  276.         }
  277.         }
  278.         # If we can't find a place for s, put it in the rejects list.
  279.         put(rejects, s)
  280.     }
  281.     }
  282.  
  283.     # Nothing useful to return (puzzle, wordlist, and rejects objects
  284.     # are themselves modified; not copies of them).
  285.     return
  286.  
  287. end
  288.  
  289.  
  290. procedure insert_word(puzzle, s, ydir, xdir, y, x)
  291.  
  292.     local incry, incrx, firstchar
  293.  
  294.     # If s is zero length, we've matched it in it's entirety!
  295.     if *s = 0 then {
  296.     return
  297.  
  298.     } else {
  299.  
  300.     # Make sure there's enough space in the puzzle in the direction
  301.     # we're headed.
  302.     case ydir of {
  303.         "3":  if (height - y) < (*s - 1) then fail
  304.         "1":  if y < (*s - 1) then fail
  305.     }
  306.     case xdir of {
  307.         "3":  if (width - x) < (*s - 1) then fail
  308.         "1":  if x < (*s - 1) then fail
  309.     }
  310.  
  311.     # Check to be sure everything's in range, and that both the x and
  312.     # y increments aren't zero (in which case, we aren't headed in any
  313.     # direction at all...).
  314.     incry := (ydir - 2); incrx := (xdir - 2)
  315.     if incry = 0 & incrx = 0 then fail
  316.     height >= y >= 1 | fail
  317.     width >= x >= 1 | fail
  318.  
  319.     # Try laying the first char in s down at puzzle[y][x].  If it
  320.     # works, head off in some direction, and try laying down the rest
  321.     # of s along that vector.  If at any point we fail, we must
  322.     # reverse the assignment (<- below).
  323.     firstchar := !s
  324.     ((/puzzle[y][x] <- firstchar) | (\puzzle[y][x] == firstchar)) &
  325.         insert_word(puzzle, s[2:0], ydir, xdir, y + incry, x + incrx) &
  326.         suspend
  327.     fail
  328.     }
  329.  
  330. end
  331.