hfiar 1.2.0 → 2.0.0
raw patch · 4 files changed
+46/−133 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- HFiaR: justEval :: HFiaR a -> a
+ HFiaR: justEval :: HFiaR a -> IO a
- HFiaR: justPlay :: HFiaR a -> Game
+ HFiaR: justPlay :: HFiaR a -> IO Game
- HFiaR: type HFiaR = HFiaRT Maybe
+ HFiaR: type HFiaR = HFiaRT IO
Files
- hfiar.cabal +2/−2
- src/HFiaR.hs +20/−20
- src/HFiaR/AI.hs +0/−71
- src/HFiaR/GUI.hs +24/−40
hfiar.cabal view
@@ -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
src/HFiaR.hs view
@@ -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
− src/HFiaR/AI.hs
@@ -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
src/HFiaR/GUI.hs view
@@ -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