Boggling with Haskell : how to achieve victory over word puzzles

1
2
3
4
5
6
-- A trie node may contain a character (but usually only the root node should be missing one), can contain next characters and an indication if the word is complete
data Node = Node {
    nodeChar :: Maybe Char,
    nextCharacters :: [Node],
    isCompleteWord :: Bool
} deriving (Eq, Show)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
loadWordTree :: Text.Text -> Node
loadWordTree str = runST $ do
    -- Create a new reference for the string
    data_str <- newSTRef str
    -- Create an empty node
    root_node <- newSTRef (Node Nothing [] False)
    -- Read the subnode in
    readSubnode data_str root_node
    -- And return the now-altered root node
    readSTRef root_node
  where
    readSubnode :: STRef s Text.Text -> STRef s Node -> ST s ()
    readSubnode strRef nodeRef = do
      exitRef <- newSTRef False
      whileM_ (do
                str <- readSTRef strRef
                mustExit <- readSTRef exitRef
                return ((not . Text.null $ str) && not mustExit)
              ) (do
                -- Extract the head
                h <- readSTRef strRef <&> Text.head
                -- Strictly discard the head from the buffer
                modifySTRef' strRef Text.tail

                -- Read current head character
                case h of
                  '#' -> modifySTRef' exitRef (const True) -- We want to exit now
                  '!' -> modifySTRef' nodeRef (\node -> node {isCompleteWord = True}) -- This node now denotes a complete word
                  _   -> do
                   -- Initialize a new node with the character we just read
                   newNode <- newSTRef (Node (Just (Char.toUpper h)) [] False)
                   -- Read the subnode
                   readSubnode strRef newNode
                   -- Alter the current reference
                   readSTRef newNode >>= (\extractedNode -> modifySTRef' nodeRef (\node -> node {nextCharacters = extractedNode:nextCharacters node}))
              )
       -- Now that new changes are not expected, flip the list to its proper order         
      modifySTRef' nodeRef (\node -> node {nextCharacters = reverse (nextCharacters node)})
      return ()

1
2
3
4
5
6
7
8
9
10
11
type Solution = (SolutionMeta, Array.Array BGCoord Flag) -- A definition of a solution

data Flag = None | D | U | L | R | UL | UR | DL | DR | Stop deriving (Eq,Show) -- For each point on a grid, in which direction we should step? None indicates a letter should be shown, Stop indicates that the solution ends there

data SolutionMeta = Meta {
  foundWord :: Text.Text, -- What was the word found?
  initialPoint :: BGCoord -- The starting point?
}

type BGCoord = (Int, Int) -- Coordinates used for a grid
type BoggleGrid = Array.Array BGCoord Char -- The datatype of a grid

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
-- Define a flag for each direction; a zero move means a stop and end of word
directionToFlag :: (Int, Int) -> Flag
directionToFlag (0,0) = Stop
directionToFlag (-1,0) = L
directionToFlag (1, 0) = R
directionToFlag (0,1) = D
directionToFlag (0,-1) = U
directionToFlag (-1,1) = DL
directionToFlag (1,1) = DR
directionToFlag (-1,-1) = UL
directionToFlag (1,-1) = UR
directionToFlag _ = undefined

-- Checks if some coordinate is in valid bounds
inBounds :: Array.Array BGCoord z -> BGCoord -> Bool
inBounds grid (x,y)
 | x < 0 || y < 0 = False
 | x > w || y > h = False
 | otherwise = True
 where
  (w,h) = (snd . Array.bounds) grid

-- Apply a direction to the grid
applyDirection :: (BGCoord, Array.Array BGCoord Flag) -> BGCoord -> (BGCoord, Array.Array BGCoord Flag)
applyDirection (pos@(posX, posY), baseGrid) direction@(dirX,dirY) = ((posX+dirX, posY+dirY), baseGrid Array.// [(pos, directionToFlag direction)]) 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
-- Returns a lazy list of possible solutions; select only those subnodes where we also have letters in the dictionary.           
generatePathList :: Node -> BoggleGrid -> [Solution]
generatePathList rootNode grid = concat $ List.transpose $ map (\(pos,node) -> findWordsOnPos node grid pos) validStarts
  where validStarts = [ (p,n) | p <- Array.indices grid, n <- nextCharacters rootNode, nodeChar n == Just (grid Array.! p)]

-- Finds the solutions from a single point. It is assumed the first letter is already root node 
findWordsOnPos :: Node -> BoggleGrid -> BGCoord -> [Solution]
findWordsOnPos rootNode grid initialPos = iterateNode rootNode Nothing (Text.singleton (Maybe.fromJust $ nodeChar rootNode)) (initialPos, zeroArray)
 where
  zeroArray = fmap (const None) grid -- A default-by-zero array of proper size

  -- Iteration function; the current node being explored,  the last direction taken if available, the current text, and the path
  iterateNode :: Node -> Maybe BGCoord -> Text.Text -> (BGCoord, Array.Array BGCoord Flag) -> [Solution]
  iterateNode currentNode maybeLastDir currentText point@(pos@(posX,posY), currentPath)
      | maybeLastDir == Just (0,0) = [(Meta currentText initialPos, currentPath)] -- End of path, return a result
      | otherwise = concat pathSelector -- Otherwise return the contents of the path selector
      where
        pathSelector = [ iterateNode nextNode (Just (dX,dY)) (if dX /= 0 || dY /= 0 then currentText `Text.snoc` nodeLetter else currentText) (applyDirection point (dX,dY))  | -- Apply a path for each combination where..
                        nextNode <- currentNode:nextCharacters currentNode,  -- we can select either our current node or any other node
                        dX <- [-1,0,1], dY <- [-1,0,1], -- there's a direction... 
                        gridLetter <- [grid Array.! (posX+dX, posY+dY)], -- must have a valid letter on the grid..
                        (Just nodeLetter) <- [nodeChar nextNode], -- we've now established that we can possibly take the next node. Let's analyze it
                        (dX /= 0 || dY /= 0) && nextNode /= currentNode || dX == 0 && dY == 0 && nextNode == currentNode && isCompleteWord currentNode, -- But either require a nonzero direction and a new node OR stay in place, choose current node and this word being a complete one  
                        inBounds currentPath (posX+dX, posY+dY), -- ensure that we can actually walk there
                        currentPath Array.! (posX+dX, posY+dY) == None, -- our next step must be empty
                        nodeLetter == gridLetter -- and which must naturally match to the chosen node 
                        ]

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

module Main where

import BoggleUtils
    ( BoggleGrid,
      BGCoord,
      SolutionMeta(Meta),
      Flag(..),
      Node,
      loadWordTree,
      generatePathList )
import Data.Array
    ( Ix(range), (!), bounds, ixmap, listArray, Array )
import Data.Ord ()
import Data.List ( nubBy, sortBy )
import Data.IORef ( modifyIORef', newIORef, readIORef )
import Data.Maybe ()
import Data.STRef ()
import Data.Char ( toUpper )
import qualified Data.Text as T
import qualified Data.Text.IO as T.IO
import Text.Read ( readMaybe )
import System.IO ()
import System.Console.Readline ( readline )
import Control.Monad.ST ()
import Control.Monad.Loops ( untilJust, untilM_ )
import Data.Functor ((<&>))

-- Define a character to show for each flag; first one is normal, 2nd one is a highlighted one
char :: Flag -> (Char, Char)
char None = (' ', ' ')
char D = ('↓', '🢃')
char U = ('↑', '🢁')
char L = ('←', '🢀')
char R = ('→', '🢂')
char UL = ('↖', '🢄')
char UR = ('↗', '🢅')
char DR = ('↘', '🢆')
char DL = ('↙', '🢇')
char Stop = ('◊', '◊')

-- Prompt to exit when exit is typed (returns false), otherwise returns true
promptExit :: String -> IO Bool
promptExit str = untilJust $ do
   res <- promptStr (str ++ " (type 'exit' to exit)")
   return (Just (res /= "exit"))

-- Prompt yes/no on something
promptYN :: String -> IO Bool
promptYN str = untilJust $ do
  res <- promptStr (str ++ " (Y/N)")
  case res of
    "Y" -> return (Just True)
    "y" -> return (Just True)
    "N" -> return (Just False)
    "n" -> return (Just False)
    _   -> return Nothing

-- Prompt something and require it to be a valid result
promptX :: Read a => String -> IO a
promptX str = untilJust $ do {rdln <- untilJust $ readline (str ++ "\n>"); return (readMaybe rdln)}

-- Prompt a string, or possibly hang if unable to provide one
promptStr :: String -> IO String
promptStr str = untilJust $ readline (str ++ "\n>")

-- Generates a rendering of a given grid, using a specialized function for that purpose
printGrid:: Array BGCoord z -> ((BGCoord, z) -> Char) -> IO ()
printGrid grid func = mapM_ (\y -> do {row_func y;putStrLn " "}) (range (0,h))
 where
  -- Params
  (w,h) = snd $ bounds grid
  --
  row_func :: Int -> IO ()
  row_func y = putStrLn $ concatMap ((\coord -> ' ':[func (coord,grid ! coord)]) . (,y)) (range (0,w))

-- Do an IO operation to inquire from the user and generate a grid with that
generateWordGrid :: IO BoggleGrid
generateWordGrid = untilJust $ do
    x :: Int <- promptX "Enter the width of the grid"
    y :: Int <- promptX "Enter the height of the grid"

    if x < 1 || y < 1
      then do {putStrLn "Both sizes must be nonzero!"; return Nothing}
      else do
        str :: T.Text <- promptStr ("Enter the word to parse, reading left-to-right, up-to-down (must be exactly " ++ show (x*y) ++ " characters)") <&> T.pack
        if T.length str /= x*y then do {putStrLn "Word not of correct length!"; return Nothing}
        else
           return (Just (ixmap ((0,0),(x-1,y-1)) (\(x,y) -> (y,x)) $ listArray ((0,0), (y-1,x-1)) $ map toUpper (T.unpack str)))

pathReader :: BoggleGrid -> Node -> IO ()
pathReader grid rootNode = do
    --solutionRef <- newIORef $ generatePathList rootNode grid -- This takes all
    solutionRef <- newIORef $ sortBy (\(Meta word1 _, _) (Meta word2 _, _) -> compare (T.length word2) (T.length word1)) $ nubBy (\(Meta word1 _, _) (Meta word2 _, _) -> word1 == word2) $ generatePathList rootNode grid -- This removes duplicates and sorts by length, but also pulls in everything before displaying anything
    emptyAtStart <- readIORef solutionRef Data.Functor.<&> null
    if emptyAtStart then do {putStrLn "Oops! No solutions were found at all!"; return ()} else
      untilM_ (do
        putStrLn "Found solution!"
        (Meta word initialPos@(posX,posY), solutionGrid) <- readIORef solutionRef Data.Functor.<&> head
        putStrLn $ "Starting from " ++ show posX ++ " steps from left, " ++ show posY ++ " steps down, word '" ++ T.unpack word ++ "'\n"
        printGrid solutionGrid (\(pos, dir) -> if dir == None then grid ! pos else (if pos == initialPos then snd else fst) $ char dir)
       ) (do
        modifyIORef' solutionRef tail
        isEmpty <- readIORef solutionRef Data.Functor.<&> null
        promptExit "Press ENTER to get next word" >>= (\x -> return (not x || isEmpty))
       )

main = do
 putStrLn "Loading the wordlist.."

 wordtext <- T.IO.readFile "./wordlist.dat"
 let worddata = loadWordTree wordtext
 (do
   grid <- generateWordGrid
   putStrLn "Loaded grid!"
   printGrid grid snd
   putStrLn "Finding words"
   pathReader grid worddata
   return ()
  ) `untilM_` (do {bl <- promptYN "Try again?"; return (not bl);})

 return ()