tateti-tateti-0.1.0.0: src/Util.hs

{-# LANGUAGE RankNTypes #-}
module Util where

import Control.Monad.Trans
import Data.Array
import Lens.Simple
import UI.NCurses

import Types


defaultBoard :: a -> BoardState a
defaultBoard a = BoardState
    { _bsCells=listArray (Position T L, Position B R) (repeat a)
    , _bsPosition=Position M C
    , _bsWinner=Nothing }


-- | Lens into an array
ax :: Ix i => i -> Lens (Array i a) (Array i a) a a
ax i = lens getter setter
  where
    getter = (! i)
    setter = (\arr v -> arr // [(i, v)])


bsAx :: Position -> Lens (BoardState t) (BoardState t) t t
bsAx p = bsCells . ax p


plusTuple :: (Num a, Num b) => (a, b) -> (a, b) -> (a, b)
plusTuple (a, b) (a', b') = (a + a', b + b')


isDiagonal :: Position -> Bool
isDiagonal (Position T L) = True
isDiagonal (Position T R) = True
isDiagonal (Position B L) = True
isDiagonal (Position B R) = True
isDiagonal (Position M C) = True
isDiagonal _ = False


positionToCoordinates :: Position -> Position -> (Integer, Integer)
positionToCoordinates outer_p inner_p =
    (getPos 8 outer_p) `plusTuple`
    (1, 1) `plusTuple`
    (getPos 2 inner_p)
  where
    getPos _ (Position T L) = (0, 0)
    getPos n (Position T C) = (0, n)
    getPos n (Position T R) = (0, n + n)
    getPos n (Position M L) = (n, 0)
    getPos n (Position M C) = (n, n)
    getPos n (Position M R) = (n, n + n)
    getPos n (Position B L) = (n + n, 0)
    getPos n (Position B C) = (n + n, n)
    getPos n (Position B R) = (n + n, n + n)


parseInput :: Window -> Game Input
parseInput w = do
    ev <- lift $ getEvent w Nothing
    case ev of
        Just (EventCharacter 'q') -> return Quit
        Just (EventCharacter 'Q') -> return Quit
        Just (EventCharacter ' ') -> return Select
        Just (EventSpecialKey k) ->
            case k of
                KeyUpArrow -> return $ Movement KUp
                KeyRightArrow -> return $ Movement KRight
                KeyDownArrow -> return $ Movement KDown
                KeyLeftArrow -> return $ Movement KLeft
                _ -> parseInput w
        _ -> parseInput w