Word Chains http://www.4clojure.com/problem/82

4closure.82.hs

module Main where


import Test.HUnit
import System.Environment
 

main :: IO ()
main = do
  words <- getArgs
  print $ makeWordChain [] [] words


-- Takes a word chain, a list of candidate words and a list of words to be
-- added to the chain.
makeWordChain :: [String] -> [String] -> [String] -> Maybe [String]

-- If the list of unused words is empty, we're done
makeWordChain chain [] [] = Just chain

-- If the chain and candidate list are both empty, kick things off by adding
-- all words to the list of candidates
makeWordChain [] [] words = makeWordChain [] words words

-- If the list of candidate links becomes empty, we've failed
makeWordChain _ [] _ = Nothing

-- If there's only one candidate link, add it to the chain, generate the new
-- candidates and carry on
makeWordChain chain [link] words = makeWordChain newChain newCandidates newWords
    where newChain = chain ++ [link]
          newCandidates = possibleLinks link newWords
          newWords = filter (/=link) words

-- Catch-all: add the first candidate to the chain.  If somewhere down the line
-- we get a Nothing, discard the first candidate and try again.
makeWordChain chain (link:candidates) words = switch $ makeWordChain newChain newCandidates newWords
    where switch Nothing = makeWordChain chain candidates words -- discard the first candidate
          switch (Just chain) = Just chain -- Hooray!
          newChain = chain ++ [link]
          newWords = filter (/=link) words
          newCandidates = possibleLinks link newWords


-- Find all possible links for a given word
possibleLinks :: String -> [String] -> [String]
possibleLinks word words = filter (isLink word) words
 

-- two words form a link if they differ by one letter
-- i.e. there is exactly one false value in the diffs list
isLink :: String -> String -> Bool
isLink word1 word2 = (length (filter (==False) (diffs word1 word2)) == 1)


-- Returns a list of Bools representing the differences between the input words
diffs :: String -> String -> [Bool]
diffs [] [] = []

-- Handle insertion/deletion at end of word by adding False until both lists
-- are empty
diffs [] (l2:w2)  = False : (diffs [] w2)
diffs (l1:w1)  [] = False : (diffs w1 [])

-- Handle insertion/deletion/substitution mid-word
diffs (l1:w1) (l2:w2)
  | l1 == l2              = True  : (diffs w1 w2)      -- no diff
  | length w1 > length w2 = False : (diffs w1 (l2:w2)) -- deletion
  | length w1 < length w2 = False : (diffs (l1:w1) w2) -- insertion
  | otherwise             = False : (diffs w1 w2)      -- substitution


-- Turn the Maybe [String] returned by makeWordChain into a Bool for the tests
canMakeWordChain :: [String] -> Bool
canMakeWordChain words = switch $ makeWordChain [] [] words
  where switch Nothing  = False
        switch (Just _) = True


challenges = TestList
  [ TestLabel "1" $ TestCase $ assertEqual "1" True  (canMakeWordChain ["hat", "coat", "dog", "cat", "oat", "cot", "hot", "hog"])
  , TestLabel "2" $ TestCase $ assertEqual "2" False (canMakeWordChain ["cot", "hot", "bat", "fat"])
  , TestLabel "3" $ TestCase $ assertEqual "3" False (canMakeWordChain ["to", "top", "stop", "tops", "toss"])
  , TestLabel "4" $ TestCase $ assertEqual "4" True  (canMakeWordChain ["spout", "do", "pot", "pout", "spot", "dot"])
  , TestLabel "5" $ TestCase $ assertEqual "5" True  (canMakeWordChain ["share", "hares", "shares", "hare", "are"])
  , TestLabel "6" $ TestCase $ assertEqual "6" False (canMakeWordChain ["share", "hares", "hare", "are"])
  ]