hfiar 1.0.1 → 1.2.0
raw patch · 3 files changed
+99/−13 lines, 3 filesdep ~eprocessdep ~wxdep ~wxcorePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: eprocess, wx, wxcore
API changes (from Hackage documentation)
Files
- hfiar.cabal +6/−6
- src/HFiaR/AI.hs +71/−0
- src/HFiaR/GUI.hs +22/−7
hfiar.cabal view
@@ -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
+ src/HFiaR/AI.hs view
@@ -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
src/HFiaR/GUI.hs view
@@ -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