TCODTest.hs

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 ()