hfiar (empty) → 0.0.1
raw patch · 8 files changed
+437/−0 lines, 8 filesdep +basedep +eprocessdep +mtlbuild-type:Customsetup-changed
Dependencies added: base, eprocess, mtl, wx, wxcore
Files
- LICENSE +31/−0
- README +2/−0
- Setup.hs +70/−0
- hfiar.cabal +38/−0
- src/HFiaR.hs +130/−0
- src/HFiaR/GUI.hs +115/−0
- src/HFiaR/Server.hs +43/−0
- src/Main.hs +8/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright Fernando Brujo Benavides 2009++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Fernando Brujo Benavides nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ README view
@@ -0,0 +1,2 @@+Four in a Row in Haskell!!+See http://hackage.haskell.org/package/hfiar
+ Setup.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE CPP #-}++import Control.Monad (foldM_, forM_)+import System.Cmd+import System.Exit+import System.Info (os)+import System.FilePath+import System.Directory ( doesFileExist, copyFile, removeFile, createDirectoryIfMissing )++import Distribution.PackageDescription+import Distribution.Simple.Setup+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo++main :: IO ()+main = defaultMainWithHooks $ addMacHook simpleUserHooks+ where+ addMacHook h =+ case os of+ "darwin" -> h { postInst = appBundleHook }+ _ -> h++appBundleHook :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO ()+appBundleHook _ _ pkg localb =+ forM_ exes $ \app ->+ do createAppBundle theBindir (buildDir localb </> app </> app)+ removeFile (theBindir </> app)+ createAppBundleWrapper theBindir app+ return ()+ where+ theBindir = bindir $ absoluteInstallDirs pkg localb NoCopyDest+ exes = map exeName $ executables pkg++-- ----------------------------------------------------------------------+-- helper code for application bundles+-- ----------------------------------------------------------------------++-- | 'createAppBundle' @d p@ - creates an application bundle in @d@+-- for program @p@, assuming that @d@ already exists and is a directory.+-- Note that only the filename part of @p@ is used.+createAppBundle :: FilePath -> FilePath -> IO ()+createAppBundle dir p =+ do createDirectoryIfMissing False $ bundle+ createDirectoryIfMissing True $ bundleBin+ createDirectoryIfMissing True $ bundleRsrc+ copyFile p (bundleBin </> takeFileName p)+ where+ bundle = appBundlePath dir p+ bundleBin = bundle </> "Contents/MacOS"+ bundleRsrc = bundle </> "Contents/Resources"++-- | 'createAppBundleWrapper' @d p@ - creates a script in @d@ that calls+-- @p@ from the application bundle @d </> takeFileName p <.> "app"@+createAppBundleWrapper :: FilePath -> FilePath -> IO ExitCode+createAppBundleWrapper bindir p =+ do writeFile scriptFile scriptTxt+ makeExecutable scriptFile+ where+ scriptFile = bindir </> takeFileName p+ scriptTxt = "`dirname $0`" </> appBundlePath "." p </> "Contents/MacOS" </> takeFileName p ++ " \"$@\""++appBundlePath :: FilePath -> FilePath -> FilePath+appBundlePath dir p = dir </> takeFileName p <.> "app"++-- ----------------------------------------------------------------------+-- utilities+-- ----------------------------------------------------------------------++makeExecutable :: FilePath -> IO ExitCode+makeExecutable f = system $ "chmod a+x " ++ f
+ hfiar.cabal view
@@ -0,0 +1,38 @@+name: hfiar+version: 0.0.1+cabal-version: >=1.6+build-type: Custom+license: BSD3+license-file: LICENSE+copyright: 2010 Fernando "Brujo" Benavides+maintainer: greenmellon@gmail.com+stability: provisional+homepage: http://github.com/elbrujohalcon/hfiar+package-url: http://code.haskell.org/hfiar+bug-reports: http://github.com/elbrujohalcon/hfiar/issues+synopsis: Four in a Row in Haskell!!+description: The classical game, implemented with wxHaskell+category: Game+author: Fernando "Brujo" Benavides+tested-with: GHC ==6.10.4+data-files: LICENSE README+data-dir: ""+extra-source-files: Setup.hs+extra-tmp-files:++source-repository head+ type: git+ location: git://github.com/elbrujohalcon/hfiar.git++Executable hfiar+ build-depends: base >= 4, base < 5,+ mtl >=1.1.0, mtl < 1.2,+ eprocess >= 1.1.0, eprocess < 2,+ wxcore >=0.11.1, wxcore < 0.13,+ wx >=0.11.1, wx < 0.13+ extensions: MultiParamTypeClasses, GeneralizedNewtypeDeriving+ main-is: Main.hs+ buildable: True+ hs-source-dirs: src+ other-modules: HFiaR, HFiaR.GUI, HFiaR.Server+ ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns
+ src/HFiaR.hs view
@@ -0,0 +1,130 @@+-- | This module defines the HFiaR monad and all the actions you can perform in it+module HFiaR (+ -- MONAD CONTROLS --+ HFiaR, play,+ -- TYPES --+ Player(..), HFiaRError(..), HFiaRResult(..),+ -- ACTIONS --+ restart, dropIn, currentPlayer, board, result+ ) where++import Control.Monad.State++data HFiaRError = GameEnded | GameNotEnded | InvalidColumn | FullColumn+ deriving (Eq)+ +instance Show HFiaRError where+ show GameEnded = "Game ended"+ show GameNotEnded = "Game is on curse yet"+ show InvalidColumn = "That column doesn't exist"+ show FullColumn = "That column is full"++data Player = Red | Green+ deriving (Eq, Show)+ +data HFiaRResult = Tie | WonBy Player+ deriving (Eq, Show)++data Game = Game {gameEnded :: Bool,+ gameResult :: HFiaRResult,+ gamePlayer :: Player,+ gameBoard :: [[Player]]+ }+ deriving (Eq, Show)+ +newtype HFiaRT m a = HFT {state :: StateT Game m a}+ deriving (Monad, MonadIO, MonadTrans)+ +instance Monad m => MonadState Game (HFiaRT m) where+ get = HFT $ get+ put = HFT . put+ +type HFiaR = HFiaRT IO++play :: Monad m => HFiaRT m a -> m a+play actions = (state actions) `evalStateT` emptyGame++--------------------------------------------------------------------------------+restart :: HFiaR ()+restart = put emptyGame++dropIn :: Int -> HFiaR (Either HFiaRError ())+dropIn c | c < 0 = return $ Left InvalidColumn+ | 6 < c = return $ Left InvalidColumn+ | otherwise =+ do+ game <- get+ if (gameEnded game)+ then return $ Left GameEnded+ else if (length $ (gameBoard game) !! c) == 7+ then return $ Left FullColumn+ else+ let player = gamePlayer game+ newBoard = insertAt c player $ gameBoard game+ newResult= if (isWinner c player newBoard) then WonBy player else Tie+ newEnded = (newResult == WonBy player) || full newBoard+ in put game{gameBoard = newBoard,+ gamePlayer= otherPlayer $ gamePlayer game,+ gameEnded = newEnded,+ gameResult= newResult+ } >>= return . Right+ where insertAt :: Int -> a -> [[a]] -> [[a]]+ insertAt i x xss = (take i xss) ++ ( (x : (xss !! i)) : drop (i+1) xss)+ + otherPlayer :: Player -> Player+ otherPlayer Green = Red+ otherPlayer Red = Green+ + full :: [[a]] -> Bool+ full = all (\x -> 7 == length x)+ + isWinner :: Int -> Player -> [[Player]] -> Bool+ isWinner c p b =+ let col = b !! c+ 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)++ getRow :: Int -> [[Player]] -> [Maybe Player]+ getRow r = map (cell r)+ + getDiagUpRight :: Int -> Int -> [[Player]] -> [Maybe Player]+ getDiagUpRight c r xss = map (\i -> cell (i+r-c) (xss !! i)) [0..6]+ + getDiagUpLeft :: Int -> Int -> [[Player]] -> [Maybe Player]+ getDiagUpLeft c r xss = map (\i -> cell (r+c-i) (xss !! i)) [0..6]+ + cell :: Int -> [Player] -> Maybe Player+ cell c xs = if (c >= 0 && c < length xs)+ then Just $ (reverse xs) !! c+ else Nothing++ fourIn :: [Maybe Player] -> Bool+ fourIn [] = False+ fourIn (Nothing:xs) = fourIn xs+ fourIn (Just p :xs) = ([Just p, Just p, Just p] == take 3 xs) || fourIn xs++currentPlayer :: HFiaR (Either HFiaRError Player)+currentPlayer = get >>= \Game{gameEnded = e,+ gamePlayer= p} ->+ return $ if e+ then Left GameEnded+ else Right p++board :: HFiaR [[Player]]+board = get >>= return . gameBoard++result :: HFiaR (Either HFiaRError HFiaRResult)+result = get >>= \Game{gameEnded = e,+ gameResult= r} ->+ return $ if (not e)+ then Left GameNotEnded+ else Right r++--------------------------------------------------------------------------------+emptyGame :: Game+emptyGame = Game{gamePlayer = Green,+ gameBoard = replicate 7 [],+ gameEnded = False,+ gameResult = Tie}
+ src/HFiaR/GUI.hs view
@@ -0,0 +1,115 @@+-- | This module provides the HFiaR GUI+module HFiaR.GUI ( gui ) where++import HFiaR+import qualified HFiaR.Server as HFS+import Data.List (transpose)+import Control.Monad+import Graphics.UI.WXCore+import Graphics.UI.WX++data GUIColumn = GUICol { colNumber :: Int,+ colCells :: [StaticText ()], --TODO: Use images+ colButton :: Button () }++data GUIContext = GUICtx { guiWin :: Frame (),+ guiPlayer :: StaticText (),+ guiColumns :: [GUIColumn] }++gui :: IO ()+gui = do+ model <- HFS.start+ + win <- frame [text := "Four in a Row"]+ + set win [on closing := HFS.stop model >> propagateEvent]+ + player <- staticText win [text := "Green Player Turn"]+ + columns <- forM [0..6] (\c ->+ do+ cells <- forM [0.. 6] (\r -> staticTextCreate win (cellId c r) "" rectNull 0)+ btn <- button win [identity := buttonId c,+ text := "Select"]+ return $ GUICol c cells btn+ )+ + status <- statusField [text := ""] --NOTE: Just decorative+ set win [statusBar := [status]]+ + let guiCtx = GUICtx win player columns + + forM_ columns $ \GUICol{colButton = b, colNumber = c} ->+ set b [on command := do+ selectColumn c guiCtx model+ refreshGUI guiCtx model]+ + -- Menu bar...+ mnuGame <- menuPane [text := "Game"]+ menuAppend mnuGame 5002 "&New\tCtrl-n" "New Game" False+ evtHandlerOnMenuCommand win 5002 $ restartGame guiCtx model >> refreshGUI guiCtx model+ 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"]+ set win [menuBar := [mnuGame, mnuHelp]]+ + let columnLayout GUICol{colCells = cs, colButton = b} =+ (hfill $ widget b) : (map (fill . boxed "" . floatCenter . widget) $ reverse cs)+ set win [layout := column 5 [hfill . boxed "" . floatCenter $ widget player,+ grid 1 1 . transpose $ map columnLayout columns],+ clientSize := sz 500 500]+++-------------------------------------------------------------------------------------------------------------------------+selectColumn :: Int -> GUIContext -> HFS.ServerHandle -> IO ()+selectColumn c GUICtx{guiWin = win} model =+ do+ res <- HFS.runIn model $ dropIn c+ case res of+ Left err ->+ errorDialog win "Four in a Row" $ show err+ Right () ->+ return ()++restartGame :: GUIContext -> HFS.ServerHandle -> IO ()+restartGame _guiCtx model = HFS.runIn model $ restart --TODO: Verify if the player wants to restart the game even if it hasn't ended yet++refreshGUI :: GUIContext -> HFS.ServerHandle -> IO ()+refreshGUI GUICtx{guiPlayer = player, guiColumns = columns, guiWin = win} model =+ do+ res1 <- HFS.runIn model currentPlayer+ case res1 of+ Left GameEnded ->+ do+ forM_ columns $ \GUICol{colButton = b} -> set b [enabled := False]+ res2 <- HFS.runIn model result+ case res2 of+ Left err ->+ errorDialog win "Four in a Row" $ show err+ Right Tie ->+ set player [text := "It was a tie"]+ Right (WonBy Green) ->+ set player [text := "Green Player won"]+ Right (WonBy Red) ->+ set player [text := "Red Player won"]+ Left err ->+ errorDialog win "Four in a Row" $ show err+ Right p ->+ do+ forM_ columns $ \GUICol{colButton = b} -> set b [enabled := True]+ set player [text := (show p) ++ " Player turn"]+ cols <- HFS.runIn model board+ forM_ columns $ \GUICol{colCells = cells,+ colNumber= coln} ->+ do+ forM_ cells $ \cell -> set cell [text := ""]+ zipWithM_ (\cell val -> set cell [text := show val])+ cells (reverse $ cols !! coln)++-------------------------------------------------------------------------------------------------------------------------+cellId :: Int -> Int -> Id+cellId c r = 5300 + c * 10 + r++buttonId :: Int -> Id+buttonId c = 5300 + c * 10
+ src/HFiaR/Server.hs view
@@ -0,0 +1,43 @@+-- | This module provides a Server to run HFiaR actions in a separate eprocess+module HFiaR.Server (+-- * Types+ ServerHandle,+-- * Functions+ start, stop, runIn+ ) where++import Control.Monad+import Control.Monad.Trans+import Control.Concurrent.Process+import HFiaR++-- | The server handle. It's returned on process creation and should be used+-- afterwards to send messages to it+newtype ServerHandle = SH {handle :: Handle (HFiaR ())}++-- | Starts the server. Usage:+-- @+-- handle <- start+-- @+start :: IO ServerHandle+start = (spawn $ makeProcess play game) >>= return . SH+ where game = forever $ recv >>= lift++-- | Runs the action. Usage:+-- @+-- result <- runIn serverhandle action+-- @+runIn :: ServerHandle -- ^ The handle of the server that will run the action+ -> HFiaR a -- ^ The action to be run+ -> IO a+runIn server action = runHere $ do+ me <- self+ sendTo (handle server) $ action >>= sendTo me+ recv++-- | Stops the server. Usage:+-- @+-- stop serverhandle+-- @+stop :: ServerHandle -> IO ()+stop = kill . handle
+ src/Main.hs view
@@ -0,0 +1,8 @@+-- | This is the main module of the application +module Main where++import Graphics.UI.WX+import HFiaR.GUI++main::IO()+main = start gui