Skip to content

Instantly share code, notes, and snippets.

@aisamanra
Created October 18, 2013 04:37
Show Gist options
  • Save aisamanra/7036558 to your computer and use it in GitHub Desktop.
Save aisamanra/7036558 to your computer and use it in GitHub Desktop.
module Main where
import Data.List (nub)
import MonadLib
import UI.TCOD.Console
import UI.TCOD.Console.Types
import UI.TCOD.Color
type Pt = (Int, Int)
type St = (Pt, [Pt])
type Game a = ReaderT Console (StateT (Pt, [Pt]) (ExceptionT () IO)) a
initialState :: (Pt, [Pt])
initialState = ((40, 40), [(40, 40)])
runGame :: Console -> Game a -> IO ()
runGame c game = do
_ <- runExceptionT (runStateT initialState (runReaderT c game))
return ()
io :: IO a -> Game a
io = inBase
width, height :: Int
width = 80
height = 80
bgcol, fgcol :: Color
bgcol = getColor Red Darkest
fgcol = getColor Red Lightest
main :: IO ()
main = do
con <- initConsole width height "Color test" defaultConsoleConfig
setDefaultBackground con bgcol
setDefaultForeground con fgcol
runGame con drawLoop
drawLoop :: Game ()
drawLoop = do
con <- ask
(coord, history) <- get
set (coord, take 40 $ coord : nub history)
io $ clear con
io $ setDefaultBackground con bgcol
io $ setChar con coord '@'
let go p = io $ setCharBackground con p (getColor Blue Darkest) backSet
mapM_ go history
io flushConsole
event <- io (waitForKeypress False)
handleInput (eventCharacter event)
drawLoop
move :: Char -> Pt -> Pt
move 'a' (r, c) = (r - 1, c)
move 'd' (r, c) = (r + 1, c)
move 'w' (r, c) = (r, c - 1)
move 's' (r, c) = (r, c + 1)
move _ (r, c) = (r, c)
handleInput :: Maybe Char -> Game ()
handleInput (Just 'q') = raise ()
handleInput (Just c) = do
(coord, history) <- get
let coord' = move c coord
if coord' `elem` history
then return ()
else set (coord', history)
handleInput _ = return ()
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment