Re: Puzzle Challenge
- To: mathgroup at smc.vnet.net
- Subject: [mg63619] Re: Puzzle Challenge
- From: Maxim <m.r at inbox.ru>
- Date: Sat, 7 Jan 2006 03:13:52 -0500 (EST)
- References: <dojf6m$fqo$1@smc.vnet.net>
- Sender: owner-wri-mathgroup at wolfram.com
On Sat, 24 Dec 2005 12:33:26 +0000 (UTC), <gleam at flashmail.com> wrote: > > A Merry Christmas to all! > > > I offer the following word puzzle as a friendly challenge to list > participants. > > Please consider the game board: > > http://www.mathematica-users.org/mediawiki/images/0/03/hexagonpuzzle.gif > __ > __/C \__ > __/O \__/E \__ > __/L \__/I \__/R \__ > /D \__/P \__/N \__/U \ > \__/E \__/R \__/A \__/ > \__/A \__/T \__/ > \__/S \__/ > \__/ > > The goal is to find as many words as possible of length five or > greater that each can be spelled by starting on a hexagonal token and > hopping from one token to the next. > > You may use a token multiple times while spelling a word, but not > twice in a row. For example, you may spell APART but not COOLED. > > Your program should work on a puzzle with arbitrarily chosen letters. > > Your solution will not be judged, but please put effort into your > algorithm, and tell us what makes it excel. For example, was your > goal to write the most concise function? The most > elegant? Fastest? Unusual? A a robust function that will solve a > larger set of puzzles? > > You will need word lists (dictionary files) and I recommend ENABLE2k > or the even larger YAWL, both available from: > > http://personal.riverusers.com/~thegrendel/software.html > > I hope you will really enjoy working this puzzle, as well as seeing > each other's results! > > Paul > > Here's a brute force search approach; we simply create another dictionary of all possible prefixes and at each step perform a binary search in the two dictionaries: dict = ReadList[$InstallationDirectory <> "/SystemFiles/Dictionaries/English/dictionary.txt", String] // ToLowerCase; dict2 = Rest@ FoldList[StringJoin, "", #]& /@ Characters@ dict // Flatten // Union; Module[{step, wordQ, Lltr, LLadj, ans = {}}, Lltr = {"D", "L", "O", "C", "E", "P", "I", "E", "A", "R", "N", "R", "S", "T", "A", "U"} // ToLowerCase; LLadj = {{2, 5}, {1, 3, 5, 6}, {2, 4, 6, 8}, {3, 7, 8}, {1, 2, 6, 9}, {2, 3, 5, 7, 9, 10}, {3, 4, 6, 8, 10, 11}, {4, 7, 11, 12}, {5, 6, 10, 13}, {6, 7, 9, 11, 13, 14}, {7, 8, 10, 12, 14, 15}, {8, 11, 15, 16}, {9, 10, 14}, {10, 11, 13, 15}, {11, 12, 14, 16}, {12, 15}}; step[str_, pos_] := If[wordQ[dict2, str], If[wordQ[dict, str], AppendTo[ans, str] ]; step[str <> Lltr[[#]], #]& /@ LLadj[[pos]] ]; wordQ[dict_, str_ ] := Module[{a, b, c}, {a, b} = {1, Length@ dict}; While[a <= b, c = Quotient[a + b, 2]; Switch[Order[dict[[c]], str], 0, Return[True], 1, a = c + 1, -1, b = c - 1 ]]; False ]; step[Lltr[[#]], #]& /@ Range@ Length@ Lltr; Select[Union@ ans, StringLength@ # >= 5&] ] {"anent", "apart", "apiece", "ararat", "arena", "astana", "centaur", "centric", "cents", "coled", "coped", "copier", "copra", "dears", "depart", "departs", "earner", "earpiece", "easts", "elope", "eloped", "enrico", "entrap", "ernie", "icier", "inane", "inaner", "leaped", "learn", "learner", "least", "loped", "nauru", "nicene", "nicer", "nicole", "niece", "opine", "papas", "paras", "partner", "parts", "pasta", "pasts", "pears", "pepin", "piece", "pinata", "pinier", "pints", "piped", "pleas", "poled", "price", "pricier", "prier", "print", "prints", "rants", "raped", "rapier", "rapine", "rarer", "recent", "recipe", "recipient", "recipients", "rents", "reran", "ricer", "riped", "sapient", "sarnie", "stare", "starer", "stats", "strap", "strip", "stripe", "striped", "stripier", "tantra", "tatar", "trice", "trier", "trina", "tripe", "triple", "tripled"} Maxim Rytin m.r at inbox.ru
