diff --git a/hfiar.cabal b/hfiar.cabal --- a/hfiar.cabal +++ b/hfiar.cabal @@ -1,5 +1,5 @@ name: hfiar -version: 0.1.1 +version: 0.1.2 cabal-version: >=1.6 build-type: Custom license: BSD3 diff --git a/src/HFiaR.hs b/src/HFiaR.hs --- a/src/HFiaR.hs +++ b/src/HFiaR.hs @@ -1,11 +1,11 @@ -- | This module defines the HFiaR monad and all the actions you can perform in it module HFiaR ( -- * Monad controls - HFiaRT, HFiaR, play, + HFiaRT, play, eval, -- * Types - Player(..), HFiaRError(..), HFiaRResult(..), + Game, Player, Tile(..), HFiaRError(..), HFiaRResult(..), -- * Actions - dropIn, currentPlayer, board, result + dropIn, player, board, result ) where import Control.Monad.State @@ -16,23 +16,30 @@ instance Show HFiaRError where show GameEnded = "Game ended" - show GameNotEnded = "Game is on curse yet" + show GameNotEnded = "Game is on course yet" show InvalidColumn = "That column doesn't exist" show FullColumn = "That column is full" --- | Posible tile / player colours -data Player = Red | Green +-- | Posible tiles (just green or red ones) +data Tile = Red | Green deriving (Eq, Show) +-- | Posible players (each one with his tile colour) +data Player = Pl {tiles :: Tile} + deriving (Eq) + +instance Show Player where + show (Pl t) = show t + -- | Posible results for the game data HFiaRResult = Tie | WonBy Player deriving (Eq, Show) -data Game = Game {gameEnded :: Bool, - gameResult :: HFiaRResult, - gamePlayer :: Player, - gameBoard :: [[Player]] - } +-- | Game description +data Game = OnCourse {gamePlayer :: Player, + gameBoard :: [[Tile]]} | + Ended {gameResult :: HFiaRResult, + gameBoard :: [[Tile]]} deriving (Eq, Show) -- | Generic HFiaRT type @@ -43,91 +50,85 @@ get = HFT $ get put = HFT . put --- | Specialized HFiaR IO monadic type -type HFiaR = HFiaRT IO +play :: Monad m => HFiaRT m a -> m Game +play actions = (state actions) `execStateT` (OnCourse (Pl Green) (replicate 7 [])) --- | Run the monad actions and return the result of them -play :: Monad m => HFiaRT m a -> m a -play actions = (state actions) `evalStateT` Game{gamePlayer = Green, - gameBoard = replicate 7 [], - gameEnded = False, - gameResult = Tie} +eval :: Monad m => HFiaRT m a -> m a +eval actions = (state actions) `evalStateT` (OnCourse (Pl Green) (replicate 7 [])) -------------------------------------------------------------------------------- -- | Drop a tile in a column -dropIn :: Int -- ^ Column number - -> HFiaR (Either HFiaRError ()) +dropIn :: Monad m => Int -- ^ Column number + -> HFiaRT m (Either HFiaRError ()) dropIn c | c < 0 = return $ Left InvalidColumn | 6 < c = return $ Left InvalidColumn | otherwise = do game <- get - if (gameEnded game) - then return $ Left GameEnded - else if (length $ (gameBoard game) !! c) == 7 + case game of + Ended{} -> return $ Left GameEnded + OnCourse{gameBoard = board, + gamePlayer= player} -> + if length (board !! c) == 7 then return $ Left FullColumn else - let player = gamePlayer game - newBoard = insertAt c player $ gameBoard game + let newBoard = insertAt c (tiles player) board newResult= if (isWinner c player newBoard) then WonBy player else Tie - newEnded = (newResult == WonBy player) || full newBoard - in put game{gameBoard = newBoard, - gamePlayer= otherPlayer $ gamePlayer game, - gameEnded = newEnded, - gameResult= newResult - } >>= return . Right + newGame = if (full newBoard || (newResult == WonBy player)) + then Ended{gameResult = newResult, + gameBoard = newBoard} + else OnCourse{gameBoard = newBoard, + gamePlayer= otherPlayer player} + in put newGame >>= return . Right where insertAt :: Int -> a -> [[a]] -> [[a]] insertAt i x xss = (take i xss) ++ ( (x : (xss !! i)) : drop (i+1) xss) otherPlayer :: Player -> Player - otherPlayer Green = Red - otherPlayer Red = Green + otherPlayer Pl{tiles=Green} = Pl Red + otherPlayer Pl{tiles=Red} = Pl Green full :: [[a]] -> Bool full = all (\x -> 7 == length x) - isWinner :: Int -> Player -> [[Player]] -> Bool - isWinner c p b = + isWinner :: Int -> Player -> [[Tile]] -> Bool + isWinner c Pl{tiles=p} b = let col = b !! c in ([p,p,p,p] == take 4 col) || fourIn (getRow (length col - 1) b) || fourIn (getDiagUpRight c (length col - 1) b) || fourIn (getDiagUpLeft c (length col - 1) b) - getRow :: Int -> [[Player]] -> [Maybe Player] + getRow :: Int -> [[Tile]] -> [Maybe Tile] getRow r = map (cell r) - getDiagUpRight :: Int -> Int -> [[Player]] -> [Maybe Player] + getDiagUpRight :: Int -> Int -> [[Tile]] -> [Maybe Tile] getDiagUpRight c r xss = map (\i -> cell (i+r-c) (xss !! i)) [0..6] - getDiagUpLeft :: Int -> Int -> [[Player]] -> [Maybe Player] + getDiagUpLeft :: Int -> Int -> [[Tile]] -> [Maybe Tile] getDiagUpLeft c r xss = map (\i -> cell (r+c-i) (xss !! i)) [0..6] - cell :: Int -> [Player] -> Maybe Player + cell :: Int -> [Tile] -> Maybe Tile cell c xs = if (c >= 0 && c < length xs) then Just $ (reverse xs) !! c else Nothing - fourIn :: [Maybe Player] -> Bool + fourIn :: [Maybe Tile] -> Bool fourIn [] = False fourIn (Nothing:xs) = fourIn xs fourIn (Just p :xs) = ([Just p, Just p, Just p] == take 3 xs) || fourIn xs -- | Player who's supposed to play the next tile -currentPlayer :: HFiaR (Either HFiaRError Player) -currentPlayer = get >>= \Game{gameEnded = e, - gamePlayer= p} -> - return $ if e - then Left GameEnded - else Right p +player :: Monad m => HFiaRT m (Either HFiaRError Player) +player = get >>= \game -> return $ case game of + Ended{} -> Left GameEnded + OnCourse{gamePlayer = p} -> Right p + -- | Current board distribution -board :: HFiaR [[Player]] +board :: Monad m => HFiaRT m [[Tile]] board = get >>= return . gameBoard -- | If the game ended, returns the result of it -result :: HFiaR (Either HFiaRError HFiaRResult) -result = get >>= \Game{gameEnded = e, - gameResult= r} -> - return $ if (not e) - then Left GameNotEnded - else Right r +result :: Monad m => HFiaRT m (Either HFiaRError HFiaRResult) +result = get >>= \game -> return $ case game of + OnCourse{} -> Left GameNotEnded + Ended{gameResult = r} -> Right r diff --git a/src/HFiaR/GUI.hs b/src/HFiaR/GUI.hs --- a/src/HFiaR/GUI.hs +++ b/src/HFiaR/GUI.hs @@ -26,7 +26,7 @@ set win [on closing := HFS.stop model >> propagateEvent] - player <- staticText win [text := "Green Player Turn"] + playerText <- staticText win [text := "Green Player Turn"] columns <- forM [0..6] (\c -> do @@ -41,7 +41,7 @@ status <- statusField [text := ""] --NOTE: Just decorative set win [statusBar := [status]] - let guiCtx = GUICtx win player columns modelVar + let guiCtx = GUICtx win playerText columns modelVar forM_ columns $ \GUICol{colButton = b, colNumber = c} -> set b [on command := do @@ -60,7 +60,7 @@ let columnLayout GUICol{colCells = cs, colButton = b} = (hfill $ widget b) : (map (fill . widget) $ reverse cs) - set win [layout := column 5 [hfill . boxed "" . floatCenter $ widget player, + set win [layout := column 5 [hfill . boxed "" . floatCenter $ widget playerText, grid 1 1 . transpose $ map columnLayout columns], clientSize := sz 500 500] @@ -87,10 +87,10 @@ varSet modelVar newModel refreshGUI :: GUIContext -> IO () -refreshGUI GUICtx{guiPlayer = player, guiColumns = columns, guiWin = win, guiModel = modelVar} = +refreshGUI GUICtx{guiPlayer = playerText, guiColumns = columns, guiWin = win, guiModel = modelVar} = do model <- varGet modelVar - res1 <- HFS.runIn model currentPlayer + res1 <- HFS.runIn model player case res1 of Left GameEnded -> do @@ -100,17 +100,15 @@ Left err -> errorDialog win "Four in a Row" $ show err Right Tie -> - set player [text := "It was a tie"] - Right (WonBy Green) -> - set player [text := "Green Player won"] - Right (WonBy Red) -> - set player [text := "Red Player won"] + set playerText [text := "It was a tie"] + Right (WonBy p) -> + set playerText [text := show p ++ " Player won!!"] Left err -> errorDialog win "Four in a Row" $ show err Right p -> do forM_ columns $ \GUICol{colButton = b} -> set b [enabled := True] - set player [text := (show p) ++ " Player turn"] + set playerText [text := (show p) ++ " Player turn"] cols <- HFS.runIn model board forM_ columns $ \GUICol{colCells = cells, colNumber= coln} -> diff --git a/src/HFiaR/Server.hs b/src/HFiaR/Server.hs --- a/src/HFiaR/Server.hs +++ b/src/HFiaR/Server.hs @@ -13,7 +13,7 @@ -- | The server handle. It's returned on process creation and should be used -- afterwards to send messages to it -newtype ServerHandle = SH {handle :: Handle (HFiaR ())} +newtype ServerHandle = SH {handle :: Handle (HFiaRT IO ())} -- | Starts the server. Usage: -- @ @@ -28,7 +28,7 @@ -- result <- runIn serverhandle action -- @ runIn :: ServerHandle -- ^ The handle of the server that will run the action - -> HFiaR a -- ^ The action to be run + -> HFiaRT IO a -- ^ The action to be run -> IO a runIn server action = runHere $ do me <- self