Ticket #2284: boggle.hs

File boggle.hs, 3.1 KB (added by guest, 3 years ago)

an example without GUI dependencies

Line 
1{-
2
3usage: ./boggle /usr/share/dict/words random
4
5benchmarks:
6  compiled with            runtime  "dictionary" traced to stderr (line 62)
7  ghc -O2                   29.5s   100x
8  ghc -O2 -fno-state-hack    0.5s     1x
9
10-}
11import Control.Monad (forever, replicateM, replicateM_)
12import Data.Array
13import Data.Char (isLower, toLower, toUpper)
14import Data.List (foldl')
15import qualified Data.Map.Strict as M
16import Data.Maybe (mapMaybe, catMaybes)
17import Data.Map.Strict (Map)
18import qualified Data.Set as S
19import System.Environment (getArgs)
20import System.Random (randomRIO)
21
22import Debug.Trace (trace)
23
24main = do
25  dictFile:args <- getArgs
26  dict <- parseDict `fmap` readFile dictFile
27  case args of
28    [] -> interact (main' dict)
29    _ -> replicateM_ 100 $ putStr . main' dict =<< randomBoard
30
31randomBoard = do
32  b <- replicateM 16 (randomRIO ('A', 'Z'))
33  putStr . unlines . map expandQu' . chunk 4 $ b
34  return (expandQu b)
35
36chunk n [] = []
37chunk n xs = let (ys, zs) = splitAt n xs in ys : chunk n zs
38
39main' dict = unlines . mapMaybe (fmap (unwords . longestFirst . boggle dict) . parseBoard) . lines
40
41boggle dict0 board = concatMap (go dict0 emptyUsed "") . indices $ board
42  where
43    go dict used word ix
44      | used ! ix = []
45      | otherwise = case lookupTrie (board ! ix) dict of
46          Nothing -> []
47          Just dict' ->
48            let word' = (board ! ix) : word
49                used' = used // [(ix, True)]
50            in  (if isWord dict' then (reverse word' :) else id)
51                  (concatMap (go dict' used' word') (neighbours ! ix))
52
53bogBounds = ((0,0),(3,3))
54emptyUsed = array bogBounds [(ix,False) | ix <- range bogBounds ]
55neighbours = array bogBounds
56  [ ((i, j), [ (i',j') | di <- [-1,0,1], let i' = i + di, dj <- [-1,0,1], let j' = j + dj
57    , inRange bogBounds (i', j')
58    ])
59  | (i, j) <- range bogBounds
60  ]
61
62parseDict = trace "dictionary" . buildTrie . mapMaybe canonical . filter (all isLower) . lines
63parseBoard = fmap (listArray bogBounds) . (checkLength =<<) . canonical
64  where checkLength l | length l == 16 = Just l
65                      | otherwise = Nothing
66
67canonical = compressQu . filter isLetter . map toUpper
68isLetter c = 'A' <= c && c <= 'Z'
69
70expandQu = concatMap qu
71  where qu 'Q' = "QU"
72        qu c = [c]
73expandQu' = concatMap qu
74  where qu 'Q' = "Qu"
75        qu c = [c, ' ']
76compressQu ('Q':'U':xs) = ('Q' :) `fmap` compressQu xs
77compressQu ('Q':_) = Nothing
78compressQu (x:xs) = (x :) `fmap` compressQu xs
79compressQu [] = Just []
80
81data Trie = Trie{ isWord :: !Bool, nextLetters :: !(Map Char Trie) }
82emptyTrie = Trie{ isWord = False, nextLetters = M.empty }
83buildTrie = foldl' (flip insertTrie) emptyTrie
84insertTrie [] t = t{ isWord = True }
85insertTrie (c:cs) t = case lookupTrie c t of
86  Nothing -> t{ nextLetters = M.insert c (insertTrie cs emptyTrie) (nextLetters t) }
87  Just t' -> t{ nextLetters = M.insert c (insertTrie cs t'       ) (nextLetters t) }
88lookupTrie c t = M.lookup c (nextLetters t)
89
90longestFirst = map snd . S.toAscList . S.fromList . mapMaybe (short . expandQu)
91short l = case length l of
92  m | m < 3 -> Nothing
93    | otherwise -> Just (-m, map toLower l)