diff --git a/hfiar.cabal b/hfiar.cabal --- a/hfiar.cabal +++ b/hfiar.cabal @@ -1,5 +1,5 @@ name: hfiar -version: 0.0.1 +version: 0.1.0 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -24,15 +24,20 @@ type: git location: git://github.com/elbrujohalcon/hfiar.git -Executable hfiar +Library build-depends: base >= 4, base < 5, mtl >=1.1.0, mtl < 1.2, - eprocess >= 1.1.0, eprocess < 2, - wxcore >=0.11.1, wxcore < 0.13, + eprocess >= 1.1.0, eprocess < 2 + extensions: MultiParamTypeClasses, GeneralizedNewtypeDeriving + exposed-modules: HFiaR + hs-source-dirs: src + +Executable hfiar + build-depends: wxcore >=0.11.1, wxcore < 0.13, wx >=0.11.1, wx < 0.13 extensions: MultiParamTypeClasses, GeneralizedNewtypeDeriving main-is: Main.hs buildable: True hs-source-dirs: src - other-modules: HFiaR, HFiaR.GUI, HFiaR.Server + other-modules: HFiaR.GUI, HFiaR.Server ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns diff --git a/src/HFiaR.hs b/src/HFiaR.hs --- a/src/HFiaR.hs +++ b/src/HFiaR.hs @@ -1,15 +1,16 @@ -- | This module defines the HFiaR monad and all the actions you can perform in it module HFiaR ( - -- MONAD CONTROLS -- - HFiaR, play, - -- TYPES -- +-- * Monad controls + HFiaRT, HFiaR, play, +-- * Types Player(..), HFiaRError(..), HFiaRResult(..), - -- ACTIONS -- - restart, dropIn, currentPlayer, board, result +-- * Actions + dropIn, currentPlayer, board, result ) where import Control.Monad.State +-- | Posible errors in the HFiaR Monad data HFiaRError = GameEnded | GameNotEnded | InvalidColumn | FullColumn deriving (Eq) @@ -19,9 +20,11 @@ show InvalidColumn = "That column doesn't exist" show FullColumn = "That column is full" +-- | Posible tile / player colours data Player = Red | Green deriving (Eq, Show) - + +-- | Posible results for the game data HFiaRResult = Tie | WonBy Player deriving (Eq, Show) @@ -32,23 +35,28 @@ } deriving (Eq, Show) +-- | Generic HFiaRT type newtype HFiaRT m a = HFT {state :: StateT Game m a} deriving (Monad, MonadIO, MonadTrans) instance Monad m => MonadState Game (HFiaRT m) where get = HFT $ get put = HFT . put - + +-- | Specialized HFiaR IO monadic type type HFiaR = HFiaRT IO +-- | Run the monad actions and return the result of them play :: Monad m => HFiaRT m a -> m a -play actions = (state actions) `evalStateT` emptyGame +play actions = (state actions) `evalStateT` Game{gamePlayer = Green, + gameBoard = replicate 7 [], + gameEnded = False, + gameResult = Tie} -------------------------------------------------------------------------------- -restart :: HFiaR () -restart = put emptyGame - -dropIn :: Int -> HFiaR (Either HFiaRError ()) +-- | Drop a tile in a column +dropIn :: Int -- ^ Column number + -> HFiaR (Either HFiaRError ()) dropIn c | c < 0 = return $ Left InvalidColumn | 6 < c = return $ Left InvalidColumn | otherwise = @@ -105,26 +113,21 @@ 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 - +-- | Current board distribution board :: HFiaR [[Player]] 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 - --------------------------------------------------------------------------------- -emptyGame :: Game -emptyGame = Game{gamePlayer = Green, - gameBoard = replicate 7 [], - gameEnded = False, - gameResult = Tie} diff --git a/src/HFiaR/GUI.hs b/src/HFiaR/GUI.hs --- a/src/HFiaR/GUI.hs +++ b/src/HFiaR/GUI.hs @@ -14,11 +14,13 @@ data GUIContext = GUICtx { guiWin :: Frame (), guiPlayer :: StaticText (), - guiColumns :: [GUIColumn] } + guiColumns :: [GUIColumn], + guiModel :: Var HFS.ServerHandle } gui :: IO () gui = do model <- HFS.start + modelVar <- varCreate model win <- frame [text := "Four in a Row"] @@ -37,17 +39,17 @@ status <- statusField [text := ""] --NOTE: Just decorative set win [statusBar := [status]] - let guiCtx = GUICtx win player columns + let guiCtx = GUICtx win player columns modelVar forM_ columns $ \GUICol{colButton = b, colNumber = c} -> set b [on command := do - selectColumn c guiCtx model - refreshGUI guiCtx model] + selectColumn c guiCtx + refreshGUI guiCtx] -- Menu bar... mnuGame <- menuPane [text := "Game"] menuAppend mnuGame 5002 "&New\tCtrl-n" "New Game" False - evtHandlerOnMenuCommand win 5002 $ restartGame guiCtx model >> refreshGUI guiCtx model + evtHandlerOnMenuCommand win 5002 $ restartGame guiCtx >> refreshGUI guiCtx menuQuit mnuGame [on command := wxcAppExit] mnuHelp <- menuHelp [] menuAppend mnuHelp 5009 "&Instructions\tCtrl-h" "Open the Instructions Page" False @@ -62,9 +64,10 @@ ------------------------------------------------------------------------------------------------------------------------- -selectColumn :: Int -> GUIContext -> HFS.ServerHandle -> IO () -selectColumn c GUICtx{guiWin = win} model = +selectColumn :: Int -> GUIContext -> IO () +selectColumn c GUICtx{guiWin = win, guiModel = modelVar} = do + model <- varGet modelVar res <- HFS.runIn model $ dropIn c case res of Left err -> @@ -72,12 +75,19 @@ Right () -> return () -restartGame :: GUIContext -> HFS.ServerHandle -> IO () -restartGame _guiCtx model = HFS.runIn model $ restart --TODO: Verify if the player wants to restart the game even if it hasn't ended yet +restartGame :: GUIContext -> IO () +restartGame GUICtx{guiModel = modelVar} = + --TODO: Verify if the player wants to restart the game even if it hasn't ended yet + do + model <- varGet modelVar + HFS.stop model + newModel <- HFS.start + varSet modelVar newModel -refreshGUI :: GUIContext -> HFS.ServerHandle -> IO () -refreshGUI GUICtx{guiPlayer = player, guiColumns = columns, guiWin = win} model = +refreshGUI :: GUIContext -> IO () +refreshGUI GUICtx{guiPlayer = player, guiColumns = columns, guiWin = win, guiModel = modelVar} = do + model <- varGet modelVar res1 <- HFS.runIn model currentPlayer case res1 of Left GameEnded ->