hfiar 0.1.1 → 0.1.2

raw patch · 4 files changed

+67/−68 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• hfiar.cabal +1/−1
• src/HFiaR.hs +55/−54
• src/HFiaR/GUI.hs +9/−11
• src/HFiaR/Server.hs +2/−2

@@ -1,5 +1,5 @@ name: hfiar-version: 0.1.1+version: 0.1.2 cabal-version: >=1.6 build-type: Custom license: BSD3

@@ -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

@@ -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} ->

@@ -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