Solving Hangman in Haskell

hangman-no-types-w-arrow.hs

module HangmanGuesser (main) where

import Data.List (intersect, nub, sort)
import Data.Char (toLower)
import Data.Tuple (swap)
import Data.Map as M (Map, fromListWith, toList)


main = do
    corpus <- readFile "web2"

    putStrLn "Write down the current word so far (with unfilled letters as spaces)"
    currentState <- getLine --eg: "  a  an"

    putStrLn "Write down the incorrect letters so far"
    wrongGuesses <- getLine -- eg: "e"

    let candidates = getCandidates corpus (lowercase currentState) (lowercase wrongGuesses)
        letterFreq = frequency candidates

    putStrLn (show (length candidates) ++ " results found")
    putStrLn (unlines candidates)
    putStrLn ("Top letters:" ++ (show (topLetters wrongGuesses letterFreq)))

-- M.fromList [('a',118),('b',5),('c',12),('d',12),('f',6),('g',11),('h',15),
--             ('i',29),('k',2),('l',19),('m',26),('n',59),('o',12),('p',7),
--             ('q',3),('r',26),('s',16),('t',13),('u',7),('v',4),('w',3),
--             ('x',1),('y',6),('z',1)]

topLetters wrongGuesses letterFreq =
    letterFreq
        |> M.toList
        |> map swap
        |> sort
        |> reverse
        |> map snd
        |> filter (`notElem` wrongGuesses)

getCandidates corpus current guessed =
    corpus
        |> lines
        |> map lowercase
        |> filter (sameLength current)
        |> filter (alreadyGuessedLetters guessed)
        |> filter (lettersMatch current)

frequency strings =
    strings
        |> concat
        |> zip (repeat 1)
        |> map swap
        |> M.fromListWith (+)

alreadyGuessedLetters guessed word =
    guessed |> intersect word |> length |> (==0)

sameLength x y
    = length x == length y

lettersMatch actual word =
    and (zipWith isSpaceOrSameLetter word actual)
  where
    alreadyGuessedLetters = actual |> nub |> filter (/= ' ')
    isSpaceOrSameLetter a ' ' = notElem a alreadyGuessedLetters
    isSpaceOrSameLetter a b = a == b

lowercase word = word |> map toLower

-- |> is an infix function, so we need to tell the compiler its operator precedence.
infixl 0 |>
x |> f = f x

hangman-notypes.hs

module HangmanGuesser (main) where

import Data.List (intersect, nub, sort)
import Data.Char (toLower)
import Data.Tuple (swap)
import Data.Map as M (Map, fromListWith, toList)


main = do
    corpus <- readFile "web2"

    putStrLn "Write down the current word so far (with unfilled letters as spaces)"
    currentState <- getLine --eg: "  a  an"

    putStrLn "Write down the incorrect letters so far"
    wrongGuesses <- getLine -- eg: "e"

    let candidates = getCandidates corpus (lowercase currentState) (lowercase wrongGuesses)
        letterFreq = frequency candidates

    putStrLn $ show (length candidates) ++ " results found"
    putStrLn $ (unlines candidates)
    putStrLn $ "Top letters:" ++ (show $ topLetters wrongGuesses letterFreq)

-- M.fromList [('a',118),('b',5),('c',12),('d',12),('f',6),('g',11),('h',15),
--             ('i',29),('k',2),('l',19),('m',26),('n',59),('o',12),('p',7),
--             ('q',3),('r',26),('s',16),('t',13),('u',7),('v',4),('w',3),
--             ('x',1),('y',6),('z',1)]

topLetters wrongGuesses =
    filter (`notElem` wrongGuesses) . map snd . reverse . sort . map swap . M.toList

getCandidates corpus current guessed =
    filter (lettersMatch current)
    . filter (alreadyGuessedLetters guessed)
    . filter (sameLength current)
    . map lowercase
    . lines
    $ corpus

frequency =
    M.fromListWith (+) . map swap . zip (repeat 1) . concat

alreadyGuessedLetters guessed word =
    0 == (length $ intersect word guessed)

sameLength x y =
    length x == length y

lettersMatch actual word =
    and $ zipWith isSpaceOrSameLetter word actual
  where
    alreadyGuessedLetters = filter (/= ' ') $ nub actual
    isSpaceOrSameLetter a ' ' = notElem a alreadyGuessedLetters
    isSpaceOrSameLetter a b = a == b

lowercase =
    map toLower

hangman.hs

module HangmanGuesser (main) where

import Data.List (intersect, nub, sort)
import Data.Char (toLower)
import Data.Tuple (swap)
import Data.Map as M (Map, fromListWith, toList)

type Corpus = String
type CurrentState = String
type WrongGuesses = String

main = do
    corpus <- (readFile "web2") :: IO Corpus

    putStrLn "Write down the current word so far (with unfilled letters as spaces)"
    currentState <- getLine :: IO CurrentState --eg: "  a  an"

    putStrLn "Write down the incorrect letters so far"
    wrongGuesses <- getLine :: IO WrongGuesses -- eg: "e"

    let candidates = getCandidates (lowercase currentState) (lowercase wrongGuesses) corpus
        letterFreq = frequency candidates

    putStrLn $ show (length candidates) ++ " results found"
    putStrLn $ (unlines candidates)
    putStrLn $ "Top letters:" ++ (show $ topLetters (wrongGuesses ++ currentState) letterFreq)



-- M.fromList [('a',118),('b',5),('c',12),('d',12),('f',6),('g',11),('h',15),
--             ('i',29),('k',2),('l',19),('m',26),('n',59),('o',12),('p',7),
--             ('q',3),('r',26),('s',16),('t',13),('u',7),('v',4),('w',3),
--             ('x',1),('y',6),('z',1)]

topLetters :: WrongGuesses -> M.Map Char Int -> [Char]
topLetters wrongGuesses =
    filter (`notElem` wrongGuesses)
    . map snd
    . reverse
    . sort
    . map swap
    . M.toList

getCandidates :: CurrentState -> WrongGuesses -> Corpus -> [String]
getCandidates current guessed =
    filter (lettersMatch current)
    . filter (alreadyGuessedLetters guessed)
    . filter (sameLength current)
    . map lowercase
    . lines

frequency :: [String] -> M.Map Char Int
frequency = M.fromListWith (+) . flip zip (repeat 1) . concat

alreadyGuessedLetters :: String -> String -> Bool
alreadyGuessedLetters guessed word = 0 == (length $ intersect word guessed)

sameLength :: String -> String -> Bool
sameLength x y = length x == length y

lettersMatch :: String -> String -> Bool
lettersMatch actual word =
    and $ zipWith isSpaceOrSameLetter word actual
  where
    alreadyGuessedLetters = filter (/= ' ') $ nub actual
    isSpaceOrSameLetter a ' ' = notElem a alreadyGuessedLetters
    isSpaceOrSameLetter a b = a == b

lowercase :: String -> String
lowercase = map toLower