diff --git a/hfiar.cabal b/hfiar.cabal --- a/hfiar.cabal +++ b/hfiar.cabal @@ -1,5 +1,5 @@ name: hfiar -version: 1.0.1 +version: 1.2.0 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -14,7 +14,7 @@ description: The classical game, implemented with wxHaskell category: Game author: Fernando "Brujo" Benavides -tested-with: GHC ==6.10.4 +tested-with: GHC ==6.12.1 data-files: LICENSE README data-dir: "" extra-source-files: Setup.hs @@ -27,17 +27,17 @@ Library build-depends: base >= 4, base < 5, mtl >=1.1.0, mtl < 1.2, - eprocess >= 1.1.0, eprocess < 2 + eprocess >= 1.1.2, 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 + build-depends: wxcore >=0.12.1.4, wxcore < 0.13, + wx >=0.12.1.4, wx < 0.13 extensions: MultiParamTypeClasses, GeneralizedNewtypeDeriving main-is: Main.hs buildable: True hs-source-dirs: src - other-modules: HFiaR.GUI, HFiaR.Server + other-modules: HFiaR.AI, HFiaR.GUI, HFiaR.Server ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns diff --git a/src/HFiaR/AI.hs b/src/HFiaR/AI.hs new file mode 100644 --- /dev/null +++ b/src/HFiaR/AI.hs @@ -0,0 +1,71 @@ +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,6 +2,7 @@ module HFiaR.GUI ( gui ) where import HFiaR +import HFiaR.AI import qualified HFiaR.Server as HFS import Data.List (transpose) import Control.Monad @@ -12,7 +13,8 @@ colCells :: [Panel ()], colButton :: Button () } -data GUIContext = GUICtx { guiWin :: Frame (), +data GUIContext = GUICtx { guiPlayers :: Var Int, + guiWin :: Frame (), guiPlayer :: StaticText (), guiColumns :: [GUIColumn], guiModel :: Var HFS.ServerHandle } @@ -41,8 +43,10 @@ status <- statusField [text := ""] --NOTE: Just decorative set win [statusBar := [status]] - let guiCtx = GUICtx win playerText columns modelVar + playersVar <- varCreate 2 + let guiCtx = GUICtx playersVar win playerText columns modelVar + forM_ columns $ \GUICol{colButton = b, colNumber = c} -> set b [on command := do selectColumn c guiCtx @@ -50,8 +54,10 @@ -- Menu bar... mnuGame <- menuPane [text := "Game"] - menuAppend mnuGame 5002 "&New\tCtrl-n" "New Game" False - evtHandlerOnMenuCommand win 5002 $ restartGame guiCtx >> refreshGUI guiCtx + 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] mnuHelp <- menuHelp [] menuAppend mnuHelp 5009 "&Instructions\tCtrl-h" "Open the Instructions Page" False @@ -67,18 +73,27 @@ ------------------------------------------------------------------------------------------------------------------------- selectColumn :: Int -> GUIContext -> IO () -selectColumn c GUICtx{guiWin = win, guiModel = modelVar} = +selectColumn c GUICtx{guiPlayers = playersVar, 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 () -> - return () + 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 () restartGame :: GUIContext -> IO () -restartGame GUICtx{guiModel = modelVar} = +restartGame GUICtx{guiPlayers = players, guiModel = modelVar} = --TODO: Verify if the player wants to restart the game even if it hasn't ended yet do model <- varGet modelVar