hfiar 2.0.4 → 2.1.1
raw patch · 3 files changed
+77/−7 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- HFiaR: instance (Monad m) => Monad (HFiaRT m)
- HFiaR: instance (Monad m) => MonadState Game (HFiaRT m)
- HFiaR: instance (MonadIO m) => MonadIO (HFiaRT m)
+ HFiaR: instance Monad m => Monad (HFiaRT m)
+ HFiaR: instance Monad m => MonadState Game (HFiaRT m)
+ HFiaR: instance MonadIO m => MonadIO (HFiaRT m)
- HFiaR: board :: (Monad m) => HFiaRT m [[Tile]]
+ HFiaR: board :: Monad m => HFiaRT m [[Tile]]
- HFiaR: dropIn :: (Monad m) => Int -> HFiaRT m (Either HFiaRError ())
+ HFiaR: dropIn :: Monad m => Int -> HFiaRT m (Either HFiaRError ())
- HFiaR: eval :: (Monad m) => HFiaRT m a -> m a
+ HFiaR: eval :: Monad m => HFiaRT m a -> m a
- HFiaR: play :: (Monad m) => HFiaRT m a -> m Game
+ HFiaR: play :: Monad m => HFiaRT m a -> m Game
- HFiaR: player :: (Monad m) => HFiaRT m (Either HFiaRError Player)
+ HFiaR: player :: Monad m => HFiaRT m (Either HFiaRError Player)
- HFiaR: result :: (Monad m) => HFiaRT m (Either HFiaRError HFiaRResult)
+ HFiaR: result :: Monad m => HFiaRT m (Either HFiaRError HFiaRResult)
- HFiaR: tryDropIn :: (Monad m) => [Int] -> HFiaRT m (Either HFiaRError Game)
+ HFiaR: tryDropIn :: Monad m => [Int] -> HFiaRT m (Either HFiaRError Game)
Files
- hfiar.cabal +2/−1
- src/HFiaR/AI.hs +54/−0
- src/HFiaR/GUI.hs +21/−6
hfiar.cabal view
@@ -1,5 +1,5 @@ name: hfiar-version: 2.0.4+version: 2.1.1 cabal-version: >=1.6 build-type: Custom license: BSD3@@ -30,6 +30,7 @@ eprocess >= 1.1.2, eprocess < 2 extensions: MultiParamTypeClasses, GeneralizedNewtypeDeriving exposed-modules: HFiaR+ other-modules: HFiaR.AI hs-source-dirs: src Executable hfiar
+ src/HFiaR/AI.hs view
@@ -0,0 +1,54 @@+module HFiaR.AI (aiDropIn) where++import HFiaR+import Data.Maybe++-- | 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 ->+ bestColumn >>= dropIn + Left err ->+ return $ Left err+ Right _ ->+ return $ Left GameEnded++bestColumn :: Monad m => HFiaRT m Int+bestColumn =+ do+ j1 <- columnWhereWins+ j2 <- columnWhereLoses+ j3 <- column3IfAvailable+ j4 <- firstAvailableColumn+ return . head $ catMaybes [j1, j2, j3, j4]++columnWhereWins, columnWhereLoses,+ column3IfAvailable, firstAvailableColumn :: Monad m => HFiaRT m (Maybe Int)++columnWhereWins = mapM (tryDropIn . (:[])) [0..6] >>= return . firstEnded++columnWhereLoses = mapM moves [0..6] >>= return . firstEnded+ where moves :: Monad m => Int -> HFiaRT m (Either HFiaRError Game)+ moves col = do+ b <- board+ let avail c = c == col || length (b!!c) == 7+ let other = length $ takeWhile avail [0..6]+ tryDropIn [other, col]++column3IfAvailable = board >>= \b -> return $ case length (b !! 3) of+ 7 -> Nothing+ _ -> Just 3++firstAvailableColumn = board >>=+ return . Just . length . takeWhile (\c -> length c == 7)++firstEnded :: [Either HFiaRError Game] -> Maybe Int+firstEnded games = case (length $ takeWhile onCourse games) of+ 7 -> Nothing+ g -> Just g+ where onCourse (Left _) = False+ onCourse (Right OnCourse{}) = True+ onCourse (Right Ended{}) = False
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 }@@ -40,8 +42,10 @@ status <- statusField [text := ""] --NOTE: Just decorative set win [statusBar := [status]] - let guiCtx = GUICtx win playerText theBoard modelVar+ playersVar <- varCreate 2 + let guiCtx = GUICtx playersVar win playerText theBoard modelVar+ forM_ theBoard $ \GUICol{colButton = b, colNumber = c} -> set b [on command := do selectColumn c guiCtx@@ -49,8 +53,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 _quit <- menuQuit mnuGame [on command := wxcAppExit] mnuHelp <- menuHelp [] menuAppend mnuHelp 5009 "&Instructions\tCtrl-h" "Open the Instructions Page" False@@ -66,15 +72,24 @@ ------------------------------------------------------------------------------------------------------------------------- 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} =