hfiar 0.0.1 → 0.1.0
raw patch · 3 files changed
+54/−36 lines, 3 files
Files
- hfiar.cabal +10/−5
- src/HFiaR.hs +23/−20
- src/HFiaR/GUI.hs +21/−11
hfiar.cabal view
@@ -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
src/HFiaR.hs view
@@ -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}
src/HFiaR/GUI.hs view
@@ -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 ->