diff --git a/hfiar.cabal b/hfiar.cabal --- a/hfiar.cabal +++ b/hfiar.cabal @@ -1,5 +1,5 @@ name: hfiar -version: 1.2.0 +version: 2.0.0 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -39,5 +39,5 @@ main-is: Main.hs buildable: True hs-source-dirs: src - other-modules: HFiaR.AI, 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 @@ -53,15 +53,15 @@ put = HFT . put -- | Basic HFiaR type - ready to /just/ play HFiaR actions -type HFiaR = HFiaRT Maybe +type HFiaR = HFiaRT IO -- | Starts a game, run the /HFiaRT/ actions and returns the game -justPlay :: HFiaR a -> Game -justPlay actions = let Just r = play actions in r +justPlay :: HFiaR a -> IO Game +justPlay actions = play actions -- | Starts a game, run the /HFiaRT/ actions and returns the result of the last one -justEval :: HFiaR a -> a -justEval actions = let Just r = eval actions in r +justEval :: HFiaR a -> IO a +justEval actions = eval actions -- | Starts a game, run the /HFiaRT/ actions and returns the game wrapped up in the /m/ monad play :: Monad m => HFiaRT m a -> m Game @@ -82,18 +82,18 @@ game <- get case game of Ended{} -> return $ Left GameEnded - OnCourse{gameBoard = board, - gamePlayer= player} -> - if length (board !! c) == 7 + OnCourse{gameBoard = theBoard, + gamePlayer= thePlayer} -> + if length (theBoard !! c) == 7 then return $ Left FullColumn else - let newBoard = insertAt c (tiles player) board - newResult= if (isWinner c player newBoard) then WonBy player else Tie - newGame = if (full newBoard || (newResult == WonBy player)) + let newBoard = insertAt c (tiles thePlayer) theBoard + newResult= if (isWinner c thePlayer newBoard) then WonBy thePlayer else Tie + newGame = if (full newBoard || (newResult == WonBy thePlayer)) then Ended{gameResult = newResult, gameBoard = newBoard} else OnCourse{gameBoard = newBoard, - gamePlayer= otherPlayer player} + gamePlayer= otherPlayer thePlayer} 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) @@ -106,25 +106,25 @@ full = all (\x -> 7 == length x) isWinner :: Int -> Player -> [[Tile]] -> Bool - isWinner c Pl{tiles=p} b = - let col = b !! c + isWinner cc Pl{tiles=p} b = + let col = b !! cc 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) + fourIn (getDiagUpRight cc (length col - 1) b) || + fourIn (getDiagUpLeft cc (length col - 1) b) getRow :: Int -> [[Tile]] -> [Maybe Tile] getRow r = map (cell r) getDiagUpRight :: Int -> Int -> [[Tile]] -> [Maybe Tile] - getDiagUpRight c r xss = map (\i -> cell (i+r-c) (xss !! i)) [0..6] + getDiagUpRight cc r xss = map (\i -> cell (i+r-cc) (xss !! i)) [0..6] getDiagUpLeft :: Int -> Int -> [[Tile]] -> [Maybe Tile] - getDiagUpLeft c r xss = map (\i -> cell (r+c-i) (xss !! i)) [0..6] + getDiagUpLeft cc r xss = map (\i -> cell (r+cc-i) (xss !! i)) [0..6] cell :: Int -> [Tile] -> Maybe Tile - cell c xs = if (c >= 0 && c < length xs) - then Just $ (reverse xs) !! c + cell cc xs = if (cc >= 0 && cc < length xs) + then Just $ (reverse xs) !! cc else Nothing fourIn :: [Maybe Tile] -> Bool diff --git a/src/HFiaR/AI.hs b/src/HFiaR/AI.hs deleted file mode 100644 --- a/src/HFiaR/AI.hs +++ /dev/null @@ -1,71 +0,0 @@ -module HFiaR.AI (aiDropIn) where - -import HFiaR - --- | Drop a tile in a column choosen by the Artificial Inteligence -aiDropIn :: Monad m => HFiaRT m (Either HFiaRError ()) -aiDropIn = - do { - r <- result; - case r of { - Left GameNotEnded -> - do { - Right p <- player; - b <- board; - dropIn $ bestColumnFor p b - }; - Left err -> - return $ Left err; - Right _ -> - return $ Left GameEnded - } - } - -bestColumnFor :: Player -> [[Tile]] -> Int -bestColumnFor p b = - case columnWhereWins p b of - Nothing -> - case columnWhereLoses p b of - Nothing -> - case length (b !! 3) of - 7 -> length $ takeWhile (\c -> length c == 7) b - _ -> 3 - Just cwl -> cwl - Just cww -> cww - -columnWhereWins :: Player -> [[Tile]] -> Maybe Int -columnWhereWins Pl{tiles=tile} b = - case (length $ takeWhile (not . wins tile b) [0..6]) of - 7 -> Nothing - x -> Just x - -columnWhereLoses :: Player -> [[Tile]] -> Maybe Int -columnWhereLoses Pl{tiles=tile} b = - let otherTile = case tile of {Green -> Red; Red -> Green} - in case (length $ takeWhile (not . wins otherTile b) [0..6]) of - 7 -> Nothing - x -> Just x - -wins :: Tile -> [[Tile]] -> Int -> Bool -wins t b c = - let newBoard = (take c b) ++ ((t : (b !! c)) : drop (c+1) b) - col = newBoard !! c - getRow r = map (cell r) - getDiagUpRight c r xss = map (\i -> cell (i+r-c) (xss !! i)) [0..6] - getDiagUpLeft c r xss = map (\i -> cell (r+c-i) (xss !! i)) [0..6] - cell c xs = if (c >= 0 && c < length xs) - then Just $ (reverse xs) !! c - else Nothing - fourIn [] = False - fourIn (Nothing:xs) = fourIn xs - fourIn (Just p :xs) = ([Just p, Just p, Just p] == take 3 xs) || fourIn xs - in ([t,t,t,t] == take 4 col) || - fourIn (getRow (length col - 1) newBoard) || - fourIn (getDiagUpRight c (length col - 1) newBoard) || - fourIn (getDiagUpLeft c (length col - 1) newBoard) - -testGame :: [[Tile]] -testGame = justEval $ aiDropIn >> aiDropIn >> - aiDropIn >> aiDropIn >> - aiDropIn >> aiDropIn >> - aiDropIn >> aiDropIn >> board diff --git a/src/HFiaR/GUI.hs b/src/HFiaR/GUI.hs --- a/src/HFiaR/GUI.hs +++ b/src/HFiaR/GUI.hs @@ -2,7 +2,6 @@ module HFiaR.GUI ( gui ) where import HFiaR -import HFiaR.AI import qualified HFiaR.Server as HFS import Data.List (transpose) import Control.Monad @@ -13,8 +12,7 @@ colCells :: [Panel ()], colButton :: Button () } -data GUIContext = GUICtx { guiPlayers :: Var Int, - guiWin :: Frame (), +data GUIContext = GUICtx { guiWin :: Frame (), guiPlayer :: StaticText (), guiColumns :: [GUIColumn], guiModel :: Var HFS.ServerHandle } @@ -30,70 +28,56 @@ playerText <- staticText win [text := "Green Player Turn"] - columns <- forM [0..6] (\c -> - do - cells <- forM [0.. 6] (\r -> panelCreate win (cellId c r) rectNull 0) - forM_ cells $ \cell -> set cell [bgcolor := grey] - btn <- button win [identity := buttonId c, - bgcolor := grey, - text := "Select"] - return $ GUICol c cells btn - ) + theBoard <- forM [0..6] $ \c -> + do + cells <- forM [0.. 6] (\r -> panelCreate win (cellId c r) rectNull 0) + forM_ cells $ \cell -> set cell [bgcolor := grey] + btn <- button win [identity := buttonId c, + bgcolor := grey, + text := "Select"] + return $ GUICol c cells btn status <- statusField [text := ""] --NOTE: Just decorative set win [statusBar := [status]] - playersVar <- varCreate 2 - - let guiCtx = GUICtx playersVar win playerText columns modelVar + let guiCtx = GUICtx win playerText theBoard modelVar - forM_ columns $ \GUICol{colButton = b, colNumber = c} -> + forM_ theBoard $ \GUICol{colButton = b, colNumber = c} -> set b [on command := do selectColumn c guiCtx refreshGUI guiCtx] -- Menu bar... mnuGame <- menuPane [text := "Game"] - menuAppend mnuGame 5002 "&New (2 Players)\tCtrl-n" "New Game (2 Players)" False - menuAppend mnuGame 5003 "&New (1 Player)\tCtrl-Shift-n" "New Game (1 Player)" False - evtHandlerOnMenuCommand win 5002 $ varSet playersVar 2 >> restartGame guiCtx >> refreshGUI guiCtx - evtHandlerOnMenuCommand win 5003 $ varSet playersVar 1 >> restartGame guiCtx >> refreshGUI guiCtx - menuQuit mnuGame [on command := wxcAppExit] + menuAppend mnuGame 5002 "&New\tCtrl-n" "New Game" False + evtHandlerOnMenuCommand win 5002 $ restartGame guiCtx >> refreshGUI guiCtx + _quit <- menuQuit mnuGame [on command := wxcAppExit] mnuHelp <- menuHelp [] menuAppend mnuHelp 5009 "&Instructions\tCtrl-h" "Open the Instructions Page" False - menuAbout mnuHelp [on command := infoDialog win "About HFiaR" "Author: Fernando Brujo Benavides"] + _about <- menuAbout mnuHelp [on command := infoDialog win "About HFiaR" "Author: Fernando Brujo Benavides"] set win [menuBar := [mnuGame, mnuHelp]] let columnLayout GUICol{colCells = cs, colButton = b} = (hfill $ widget b) : (map (fill . widget) $ reverse cs) set win [layout := column 5 [hfill . boxed "" . floatCenter $ widget playerText, - grid 1 1 . transpose $ map columnLayout columns], + grid 1 1 . transpose $ map columnLayout theBoard], clientSize := sz 500 500] ------------------------------------------------------------------------------------------------------------------------- selectColumn :: Int -> GUIContext -> IO () -selectColumn c GUICtx{guiPlayers = playersVar, guiWin = win, guiModel = modelVar} = +selectColumn c GUICtx{guiWin = win, guiModel = modelVar} = do model <- varGet modelVar - players <- varGet playersVar res <- HFS.runIn model $ dropIn c case res of Left err -> errorDialog win "Four in a Row" $ show err Right () -> - case players of - 1 -> do - res2 <- HFS.runIn model $ aiDropIn - case res2 of - Left err -> - errorDialog win "Four in a Row" $ show err - Right () -> - return () - _ -> return () + return () restartGame :: GUIContext -> IO () -restartGame GUICtx{guiPlayers = players, guiModel = modelVar} = +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 @@ -102,14 +86,14 @@ varSet modelVar newModel refreshGUI :: GUIContext -> IO () -refreshGUI GUICtx{guiPlayer = playerText, guiColumns = columns, guiWin = win, guiModel = modelVar} = +refreshGUI GUICtx{guiPlayer = playerText, guiColumns = theBoard, guiWin = win, guiModel = modelVar} = do model <- varGet modelVar res1 <- HFS.runIn model player case res1 of Left GameEnded -> do - forM_ columns $ \GUICol{colButton = b} -> set b [enabled := False] + forM_ theBoard $ \GUICol{colButton = b} -> set b [enabled := False] res2 <- HFS.runIn model result case res2 of Left err -> @@ -122,11 +106,11 @@ errorDialog win "Four in a Row" $ show err Right p -> do - forM_ columns $ \GUICol{colButton = b} -> set b [enabled := True] + forM_ theBoard $ \GUICol{colButton = b} -> set b [enabled := True] set playerText [text := (show p) ++ " Player turn"] cols <- HFS.runIn model board - forM_ columns $ \GUICol{colCells = cells, - colNumber= coln} -> + forM_ theBoard $ \GUICol{colCells = cells, + colNumber= coln} -> do forM_ cells $ \cell -> set cell [bgcolor := grey] zipWithM_ (\cell val -> set cell [bgcolor := case val of