module Game.H2048.UI.Simple
( drawBoard
, playGame
, mainSimple
)
where
import Game.H2048.Core
import Data.List
import Text.Printf
import Control.Monad.IO.Class
import Control.Monad.Random
import Control.Arrow
import System.IO
helpString :: String
helpString = "'i'/'k'/'j'/'l' to move, 'q' to quit."
drawBoard :: Board -> IO ()
drawBoard board = do
putStrLn horizSeparator
mapM_ drawRow board
where
cellWidth = length " 2048 "
horizSeparator' =
intercalate "+" (replicate 4 (replicate cellWidth '-'))
horizSeparator = "+" ++ horizSeparator' ++ "+"
prettyCell c = if c == 0
then replicate cellWidth ' '
else printf " %4d " c
drawRow :: [Int] -> IO ()
drawRow row = do
putChar '|'
mapM_ (prettyCell >>> putStr >>> (>> putChar '|') ) row
putChar '\n'
putStrLn horizSeparator
playGame :: (RandomGen g) => (Board, Int) -> RandT g IO ()
playGame (b,score) = do
let endGame (b',score') win = do
drawBoard b'
putStrLn $ if win
then "You win"
else "Game over"
_ <- printf "Final score: %d\n" score'
hFlush stdout
handleUserMove win = do
let scoreFormat =
if win
then "You win, current score: %d\n"
else "Current score: %d\n"
drawBoard b
_ <- printf scoreFormat score
hFlush stdout
c <- getChar
putStrLn ""
hFlush stdout
maybeKey <- case c of
'q' -> return Nothing
'i' -> putStrLn "Up" >> return (Just DUp)
'k' -> putStrLn "Down" >> return (Just DDown)
'j' -> putStrLn "Left" >> return (Just DLeft)
'l' -> putStrLn "Right" >> return (Just DRight)
_ -> do
putStrLn helpString
return $ error "Unreachable code: unhandled invalid user input"
if c `elem` "qijkl"
then return maybeKey
else handleUserMove win
handleGame =
maybe
(return ())
((`updateBoard` b) >>>
maybe
(liftIO (putStrLn "Invalid move") >> playGame (b,score))
(\ result -> do
(Just newB) <- insertNewCell (brBoard result)
playGame (newB, score + brScore result)))
case gameState b of
Win ->
liftIO $ endGame (b,score) True
Lose ->
liftIO $ endGame (b,score) False
WinAlive ->
liftIO (handleUserMove True ) >>= handleGame
Alive ->
liftIO (handleUserMove False) >>= handleGame
mainSimple :: IO ()
mainSimple = do
bfMod <- hGetBuffering stdin
hSetBuffering stdin NoBuffering
g <- newStdGen
putStrLn helpString
_ <- evalRandT (initGameBoard >>= playGame) g
hSetBuffering stdin bfMod