Asteroids vocab game in Haskell

Asteroids.hs

import System.IO
import System.Random
import System.Timeout
import System.Exit
import Control.Concurrent
import Control.Exception
import Data.Char
import Data.Maybe
import GHC.Float

data GameParams = GameParams {
  width :: Int,
  height :: Int,
  tiledict :: [(String, Char)]
}

defaultParams :: GameParams
defaultParams = GameParams {
  width = 80,
  height = 40,
  tiledict = [
    ("corner", '+'),
    ("hwall", '-'),
    ("vwall", '|'),
    ("empty", ' '),
    ("heart", '♥')
  ]
}

tileToChar :: [(String, Char)] -> String -> Char
tileToChar td tile = maybe ' ' id (lookup tile td)

data GameStats = GameStats {
  ticks :: Int,
  destroyed :: Int,
  emptied :: Int,
  nextRoid :: Float
}

data AsteroidsGame = AsteroidsGame {
  params :: GameParams,
  key :: String -> String -> Bool,
  roids :: [(String, Int, Int)],
  lives :: Int,
  strin :: String,
  rand :: StdGen,
  wordpool :: [String],
  wordlib :: [(String, [String])],
  stats :: GameStats
}

defaultGame :: AsteroidsGame
defaultGame = AsteroidsGame {
  params = defaultParams,
  key = (==),
  roids = [],
  lives = 3,
  strin = "",
  rand = mkStdGen 101,
  wordpool = [],
  wordlib = [],
  stats = GameStats {
    ticks = 0,
    destroyed = 0,
    emptied = 0,
    nextRoid = 1.0
  }
}

generateKey :: [(String, [String])] -> (String -> String -> Bool)
generateKey wds s1 s2
  = (maybe False (elem s2)) (lookup s1 wds)

gameFromWords :: [(String, [String])] -> AsteroidsGame
gameFromWords wds = defaultGame {
  key = generateKey wds,
  wordpool = map fst wds,
  wordlib = wds
}

incrementTicks :: AsteroidsGame -> AsteroidsGame
incrementTicks game = game {
  stats = (stats game) {
    ticks = (ticks $ stats game) + 1
  }
}

incrementDestroyed :: AsteroidsGame -> AsteroidsGame
incrementDestroyed game 
  = game {
    stats = st {
      destroyed = d + 1,
      emptied = if (length $ roids game) == 0 then (e + 1) else e
    }
  }
  where st = stats game
        d = destroyed st
        e = emptied st

scheduleNextAsteroid :: AsteroidsGame -> AsteroidsGame
scheduleNextAsteroid game
  = game {
    stats = st {
      nextRoid = nxt + 1.0 + 4.0/(1.0 + (int2Float e)/3.0)
    }
  }
  where st = stats game
        nxt = nextRoid st
        e = emptied st

newAsteroid :: AsteroidsGame -> AsteroidsGame
newAsteroid game
  = scheduleNextAsteroid game {rand = rdm3, roids = roids game ++ [(wd, xpos, 0)]}
  where rdm = rand game
        wds = wordpool game
        (idx, rdm2) = randomR (0, length wds - 1) rdm
        wd = wds !! idx
        w = width $ params game
        (xpos, rdm3) = randomR (0, w - length wd - 1) rdm2

asteroidsFall :: AsteroidsGame -> (AsteroidsGame, Maybe String)
asteroidsFall game 
  = if (int2Float t >= nxt) 
    then (newAsteroid game', fallenRoid) 
    else (game', fallenRoid)
  where h = height $ params game
        t = ticks $ stats game
        nxt = nextRoid $ stats game
        rds = roids game
        fallenRoids = filter (\(s,x,y) -> y == h-1) rds
        fallenRoid = if (length fallenRoids > 0) 
                     then Just ((\(s,x,y) -> s) (head fallenRoids))
                     else Nothing
        game' = incrementTicks game {
          roids = (filter (\(s,x,y) -> y < h)) $ map (\(s,x,y) -> (s,x,y+1)) rds,
          lives = lives game - (if (null fallenRoids) then 0 else 1)
        }

processGuess :: AsteroidsGame -> String -> AsteroidsGame
processGuess game s
  = if (null rds) then game
    else if (k (fst3 (rds !! 0)) s) then 
      incrementDestroyed game {roids = tail rds, strin = ""}
    else game {strin = ""}
  where rds = roids game
        fst3 = \(x,y,z) -> x
        k = key game

processCharIn :: AsteroidsGame -> Char -> AsteroidsGame
processCharIn game c
  = if c == '\DEL' then game' {strin = take (length s - 1) s}
    else if c == '\n' then processGuess game' s
    else if (isAlphaNum c) 
            || (isPunctuation c) 
            || (c == ' ') then game' {strin = s ++ [c]}
    else game
  where s = strin game
        game' = game {rand = snd $ randomR (0 :: Int, 1) (rand game)}
        -- We use keypress timing as a source of randomness

tileTranslator :: AsteroidsGame -> String -> Char
tileTranslator game = tileToChar $ tiledict $ params game

getCharAtPos :: AsteroidsGame -> (Int, Int) -> Char
getCharAtPos game (x, y)
  = if (null rds) 
    then (tr "empty") 
    else (\(s, xr, yr) -> s !! (x - xr)) $ (rds !! 0)
  where rds = filter 
                (\(s, xr, yr) -> y == yr && x >= xr && x < xr + length s) 
                (roids game)
        tr = tileTranslator game

boardString :: AsteroidsGame -> [String]
boardString game =
  [hbar] ++
  [(tr "vwall") 
   ++ [getCharAtPos game (x, y) | x <- [0..w-1]] 
   ++ (tr "vwall") | y <- [0..h-1]]  ++
  [hbar] ++
  [menubar] ++
  [hbar]  
  where conf = params game
        w = width conf
        h = height conf
        tr = (: "") . tileTranslator game
        hearts = lives game
        hbar = (tr "corner") ++
               (concat $ replicate w $ tr "hwall") ++ 
               (tr "corner")
        menubar = (tr "vwall") ++
                  (concat $ replicate hearts $ tr "heart") ++
                  (replicate (w - hearts) ' ') ++
                  (tr "vwall")
                  

printBoard :: AsteroidsGame -> IO ()
printBoard game = do
  putStr $ (foldr (\s s' -> s ++ "\n" ++ s') []) $ boardString game

initDisplay :: IO ()
initDisplay = do
  putStr "\ESC[2J"
  putStr "\ESC[0;0H"

updateDisplay :: AsteroidsGame -> IO ()
updateDisplay game = do
  putStr "\ESC[0;0H"

  putStr "\ESC[?25l"
  printBoard game
  putStr (strin game)
  putStr "\ESC[?25h"

  putStr "\ESC[0J"

newKeyThread :: IO (String, Char)
newKeyThread = getChar >>= (\c -> return ("key", c))

newTimerThread :: IO (String, Char)
newTimerThread = do
  threadDelay 1000000
  return ("timer", ' ')

data EventManager = EventManager {
  evtData :: MVar (String, Char),
  keyTid :: ThreadId,
  timerTid :: ThreadId
}

newEventManager :: IO EventManager
newEventManager = do
  mvar <- newEmptyMVar
  keyTid' <- forkIO $ newKeyThread >>= putMVar mvar
  timerTid' <- forkIO $ newTimerThread >>= putMVar mvar
  return EventManager {
    evtData = mvar,
    keyTid = keyTid',
    timerTid = timerTid'
  }

evtLoop :: EventManager -> AsteroidsGame -> IO ()
evtLoop evm game = do
  updateDisplay game

  result <- takeMVar (evtData evm)
  let evt = fst result

  if evt == "key"
    then do
      let c = snd result
      killThread (keyTid evm)
      keyTid' <- forkIO $ newKeyThread >>= putMVar (evtData evm)
      evtLoop (evm {keyTid = keyTid'}) (processCharIn game c)
    else do
      killThread (keyTid evm)
      killThread (timerTid evm)
      let (game', fallen) = asteroidsFall game
      let game'' = if (null fallen) then game' else game' {strin = ""}
      if (null fallen)
        then return () 
        else (doPenaltyScreen game' "" (fromJust fallen))
      if (lives game' == 0) then (doGameOverScreen game') else return ()
      keyTid' <- forkIO $ newKeyThread >>= putMVar (evtData evm)
      timerTid' <- forkIO $ newTimerThread >>= putMVar (evtData evm)
      evtLoop (evm {keyTid = keyTid', timerTid = timerTid'}) game''

doPenaltyScreen :: AsteroidsGame -> String -> String -> IO ()
doPenaltyScreen game str wd
  = do
      putStr "\ESC[?25l"
      putStr "\ESC[0;0H"
      putStr ("Question: " ++ wd ++ "\ESC[0K\n")
      putStr ("Correct answer: " ++ ans ++ "\ESC[0K\n")
      putStr "\ESC[0J"
      putStr str
      putStr "\ESC[?25h"

      c <- getChar
      if (isAlphaNum c || isPunctuation c || c == ' ')
      then doPenaltyScreen game (str ++ [c]) wd
      else if (c == '\DEL')
      then doPenaltyScreen game (reverse $ (drop 1) $ reverse str) wd
      else if (c == '\n')
      then (if k wd str 
              then return () 
              else doPenaltyScreen game "" wd)
      else doPenaltyScreen game str wd
  where k = key game
        ans = foldr (\s1 s2 -> s1 ++ "," ++ s2) "" 
                    (fromJust (lookup wd $ wordlib game))

doGameOverScreen :: AsteroidsGame -> IO ()
doGameOverScreen game = do
  putStr "\nGame over!\n"
  putStr ("Asteroids destroyed: " ++ (show $ destroyed $ stats $ game) ++ "\n")
  exitSuccess

getVocabFile :: IO Handle
getVocabFile = do
  putStr "Please enter name of vocab list file.\n"
  fname <- getLine
  catch (openFile fname ReadMode) handler
  where handler :: IOError -> IO Handle
        handler err = do
          putStr "File could not be opened. Try again.\n"
          getVocabFile

splitter :: (Eq a) => a -> [a] -> [[a]]
splitter delim ls = helper delim ls []
  where helper :: (Eq a) => a -> [a] -> [a] -> [[a]]
        helper delim [] acc = [acc]
        helper delim (x:xs) acc
          = if x == delim 
            then acc:(helper delim xs [])
            else helper delim xs (acc ++ [x])

readVocabWords :: Handle -> IO [(String, [String])]
readVocabWords fh = do
  contents <- hGetContents fh
  let lines = splitter '\n' contents
      wds = map (splitter ',') lines
      prs = map (\ls -> (head ls, tail ls)) wds
  return $ filter (not . null . snd) prs

main :: IO ()
main = do
  hSetEncoding stdin utf8

  game <- getVocabFile >>= readVocabWords >>= (return . gameFromWords)

  hSetEcho stdin False
  hSetBuffering stdin NoBuffering
  
  evm <- newEventManager
  evtLoop evm game