diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2015, Tal Walter + +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 Tal Walter 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/quoridor-exec/Main.hs b/quoridor-exec/Main.hs new file mode 100644 --- /dev/null +++ b/quoridor-exec/Main.hs @@ -0,0 +1,8 @@ +module Main + ( main + ) where + +import Quoridor.Cmdline (cmdlineMain) + +main :: IO () +main = cmdlineMain diff --git a/quoridor-hs.cabal b/quoridor-hs.cabal new file mode 100644 --- /dev/null +++ b/quoridor-hs.cabal @@ -0,0 +1,85 @@ +name: quoridor-hs +version: 0.1.0.0 +synopsis: A Quoridor implementation in Haskell +homepage: https://github.com/talw/quoridor-hs +license: BSD3 +license-file: LICENSE +author: Tal Walter +maintainer: Tal Walter +category: Game +build-type: Simple +cabal-version: >=1.19 + +description: + An implementation in Haskell of the 2-to-4-player strategy game. + For more information, see: + + +data-dir: resources +data-files: console.html + console.js + style.css + +library + hs-source-dirs: src + exposed-modules: Quoridor + Quoridor.Cmdline + other-modules: Quoridor.Cmdline.Parse + Quoridor.Cmdline.Render + Quoridor.Cmdline.Options + Quoridor.Cmdline.Messages + Quoridor.Cmdline.Network.Server + Quoridor.Cmdline.Network.Client + Quoridor.Cmdline.Network.Common + Quoridor.Helpers + Paths_quoridor_hs + -- other-extensions: + build-depends: base >=4.7 && <4.8, + containers >=0.5 && <0.6, + mtl >=2.1 && <2.2, + parsec ==3.1.*, + dlist ==0.7.1.*, + network-simple ==0.4.*, + hex ==0.1.*, + bytestring ==0.10.*, + exceptions ==0.6.*, + ansi-terminal ==0.6.*, + process ==1.2.*, + websockets-snap ==0.9.*, + websockets ==0.9.*, + snap-core ==0.9.*, + snap-server ==0.9.*, + filepath ==1.3.*, + directory ==1.2.*, + network ==2.5.* + + -- hs-source-dirs: + default-language: Haskell2010 + GHC-Options: -Wall + --Werror + -fno-warn-unused-do-bind + -fno-warn-type-defaults + +executable quoridor-exec + hs-source-dirs: quoridor-exec + main-is: Main.hs + build-depends: base >=4.7 && <4.8, + quoridor-hs + default-language: Haskell2010 + GHC-Options: -Wall + -threaded + +test-suite quoridor-tests + hs-source-dirs: tests + main-is: Tests.hs + build-depends: base >=4.7 && <4.8, + HUnit, + quoridor-hs, + mtl >=2.1 && <2.2 + default-language: Haskell2010 + type: exitcode-stdio-1.0 + GHC-Options: -Wall + +Source-repository head + Type: git + Location: https://github.com/talw/quoridor-hs diff --git a/resources/console.html b/resources/console.html new file mode 100644 --- /dev/null +++ b/resources/console.html @@ -0,0 +1,21 @@ + + + + WebSockets Console + + + + + +
+
+
+
+ $ + +
+
+
+ + diff --git a/resources/console.js b/resources/console.js new file mode 100644 --- /dev/null +++ b/resources/console.js @@ -0,0 +1,38 @@ +function appendOutput(cls, text) { + $('#console-output').append('
' + text + '
'); + $('#line').focus(); + $('#line')[0].scrollIntoView({block: "end", behavior: "instant"}); +} + +$(document).ready(function () { + var port = window.location.port + var hostName = window.location.hostname; + var uri = "ws://"+hostName+":"+port+"/play" + var ws = new WebSocket(uri); + + appendOutput('stderr', 'Opening WebSockets connection...\n'); + + ws.onerror = function(event) { + appendOutput('stderr', 'WebSockets error: ' + event.data + '\n'); + }; + + ws.onopen = function() { + appendOutput('stderr', 'WebSockets connection successful!\n'); + }; + + ws.onclose = function() { + appendOutput('stderr', 'WebSockets connection closed.\n'); + }; + + ws.onmessage = function(event) { + appendOutput('stdout', event.data); + }; + + $('#console-input').submit(function () { + var line = $('#line').val(); + ws.send(line + '\n'); + appendOutput('stdin', line + '\n'); + $('#line').val(''); + return false; + }); +}); diff --git a/resources/style.css b/resources/style.css new file mode 100644 --- /dev/null +++ b/resources/style.css @@ -0,0 +1,49 @@ +body { + margin: 18px; + font-family: 'Inconsolata', monospace; + font-size: 16px; + background-color: #444; +} + +form { + color: #cfc; + font-family: 'Inconsolata', monospace; + font-size: 16px; + margin-top: 6px; +} + +form input { + background-color: #444; + border: 1px solid #777; + color: #cfc; + font-family: 'Inconsolata', monospace; + font-size: 16px; + margin: 0px; + padding: 0px; +} + +pre { + margin: 0px; + padding: 0px; + display: inline; +} + +pre.stderr { + color: #fcc; +} + +pre.stdout { + color: white; +} + +pre.stdin { + color: #cfc; +} + +font.Yellow { color: LemonChiffon; } +font.Magenta { color: HotPink; } +font.Cyan { color: LightSteelBlue; } +font.White { color: white; } +font.Blue { color: LightSkyBlue; } +font.Red { color: IndianRed; } +font.Green { color: GreenYellow; } diff --git a/src/Quoridor.hs b/src/Quoridor.hs new file mode 100644 --- /dev/null +++ b/src/Quoridor.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Quoridor +where + +import Control.Applicative (Applicative, (<$>)) +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) +import Control.Monad.Reader (MonadReader, ReaderT, reader, + runReaderT) +import Control.Monad.State (MonadIO, MonadState, MonadTrans, StateT, + evalState, get, gets, lift, modify, put, + runStateT, void, when) +import Data.List (find, sort) +import qualified Data.Map as M +import qualified Data.Set as S + +import Quoridor.Helpers (andP, rotateList, unsafeLookup) + +-- | A tile on the board. +-- Direction of X and Y axis are right and down respectively. +type Cell = (Int, Int) -- y, x + +-- \ A half gate, is a game gate broken into two. +-- So that it blocks one path between two 'Cell's in the game, +-- and not two paths. +type HalfGate = (Cell, Cell) +type Gate = (HalfGate, HalfGate) +type HalfGates = S.Set HalfGate + +-- | Size of the board in one dimension. +-- The board is a square +type BoardSize = Int + +-- | The monad used for running the game. +-- Basically adds layers of ReaderT for configuration, +-- StateT for state, and some monad for the rest +-- (currently just IO monad). +newtype Game m a = Game (ReaderT GameConfig (StateT GameState m) a) + deriving ( Monad, MonadState GameState, MonadIO + , Applicative, Functor, MonadReader GameConfig + , MonadThrow, MonadCatch, MonadMask ) + +instance MonadTrans Game where + lift = Game . lift . lift + +-- | To 'run' the Game monad +runGame :: Functor m => Game m a -> GameConfig -> m () +runGame g gc = void $ runGameWithGameState g (initialGameState gc) gc + +-- | Same as runGame, but allows to start from a given GameState, instead of +-- from the beginning +runGameWithGameState :: Game m a -> GameState -> GameConfig -> m (a, GameState) +runGameWithGameState (Game g) gs gc = runStateT (runReaderT g gc) gs + +data Player = Player + { color :: Color + , pos :: Cell + , gatesLeft :: Int + } deriving (Show, Eq, Read) + +-- | Represents a turn, +-- can be either a 'Gate' put, +-- a 'Player' move +-- or a 'ShortCutMove' which is specified by an index +-- from the given valid moves for a player at +-- the current turn +data Turn = PutGate Gate + | Move Cell + | ShortCutMove Int + deriving (Read, Show) + +-- | Colors to distinguish between 'Player's +data Color = Blue | White | Red | Green + deriving (Eq, Show, Ord, Enum, Read) + +-- | The orientation (perhaps a better name?) +-- of the 'Gate', it can be either vertical or horizontal +data Direction = H | V + deriving (Show, Read) + +-- | Represents the game state. +-- With a list of 'Player's (the head is the current player), +-- maybe a winner, and a map of the 'Gate's, which actually +-- breaks them into 'Halfgate's. +data GameState = GameState + { playerList :: [Player] + , halfGates :: HalfGates + , winner :: Maybe Color + } deriving (Show, Read) + +data GameConfig = GameConfig + { gatesPerPlayer :: Int + , boardSize :: Int + , numOfPlayers :: Int + } deriving (Show, Read) + +--- static data + +-- | An initial state. +-- All players begin at the first/last row/column +initialGameState :: GameConfig -> GameState +initialGameState gc = + GameState + { playerList = take (numOfPlayers gc) $ map (initP . toEnum) [0..] + , halfGates = S.empty + , winner = Nothing + } + where initP c = Player + { color = c + , pos = unsafeLookup c $ startPos $ boardSize gc + , gatesLeft = gatesPerPlayer gc + } + +defaultGameConfig :: GameConfig +defaultGameConfig = GameConfig + { gatesPerPlayer = 10 + , boardSize = 9 + , numOfPlayers = 2 + } + +-- | Initial positions for the different 'Color's +startPos :: Int -> M.Map Color Cell +startPos bs = M.fromList [ (Blue, (bs - 1,bs `div` 2)) + , (White, (0, bs `div` 2)) + , (Red, (bs `div` 2, 0)) + , (Green, (bs `div` 2, bs - 1)) + ] + + + +--- helper functions + +-- | Applies f on the current player +modifyCurrP :: (Player -> Player) -> GameState -> GameState +modifyCurrP f gs = gs {playerList = playerList'} + where playerList' = f (currP gs) : tail (playerList gs) + +-- | Returns the current player +currP :: GameState -> Player +currP = head . playerList + +distance :: Cell -> Cell -> Int +distance (y,x) (y',x') = abs (y' - y) + abs (x' - x) + +isAdj :: Cell -> Cell -> Bool +isAdj = ((1 ==) .) . distance + +-- | Returns adjacent cells that are within the ranger of the board +getAdj :: Int -> Cell -> [Cell] +getAdj bs (y,x) = filter (isWithinRange bs) adjs + where adjs = [(y-1,x),(y+1,x),(y,x-1),(y,x+1)] + +-- | Is cell within board range +isWithinRange :: Int -> Cell -> Bool +isWithinRange bs = all ((>= 0) `andP` (< bs)) . tupToList + where tupToList (a,b) = [a,b] + +-- | Coerces 'HalfGate's so that left item is +-- less than or equal to the right item. +align :: HalfGate -> HalfGate +align (c1,c2) = (min c1 c2, max c1 c2) + +-- | Equivalent to, given cells a and b (a,b) +-- is the space between them open for movement? +isHalfGateSpaceClear :: HalfGate -> HalfGates -> Bool +isHalfGateSpaceClear = (not .) . S.member . align + +isGateSpaceClear :: Gate -> HalfGates -> Bool +isGateSpaceClear (h1, h2) = + isHalfGateSpaceClear h1 `andP` isHalfGateSpaceClear h2 + +-- | Breaks a gate into it's cell components. +-- Used, for example, to make sure a gate is placed +-- within bounds of the board. +gateToCells :: Gate -> [Cell] +gateToCells ((a,b),(c,d)) = [a,b,c,d] + +-- | Given a cell, returns a gate. +-- That gate, the upper left corner of +-- it's encompassing 2x2 square is at the given cell. +gateUpperLeft :: Cell -> Direction -> Gate +gateUpperLeft (y,x) H = (((y,x),(y+1,x)),((y,x+1),(y+1,x+1))) +gateUpperLeft (y,x) V = (((y,x),(y,x+1)),((y+1,x),(y+1,x+1))) + +insertGate :: Gate -> HalfGates -> HalfGates +insertGate (h1, h2) = S.insert (align h2) . S.insert (align h1) + +-- | Is the cell empty (i.e. no player is standing there) +isVacant :: Cell -> GameState -> Bool +isVacant c = all ((c /=) . pos) . playerList + +-- | Given a cell and a player, is that a cell that +-- if the player reaches it, the game ends. +-- Used with dfs, to make sure placing a gate still leaves +-- at least one cell which is a winning cell, for every player. +isWinningCell :: Int -> Player -> Cell -> Bool +isWinningCell bs p (cy,cx) + | startX == bs `div` 2 = cy + startY == bs - 1 + | startY == bs `div` 2 = cx + startX == bs - 1 + | otherwise = error "startPos is not properly defined." + where (startY,startX) = unsafeLookup (color p) (startPos bs) + +-- | Basically, translates a 'ShortCutMove' into the 'Move' +-- that it is a shortcut of, using the integral index that +-- is the index of the shortcut character in the list of +-- 'validMovesChars' +coerceTurn :: (Monad m, Functor m) => Turn -> Game m Turn +coerceTurn (ShortCutMove i) = do + vmSorted <- sort <$> getCurrentValidMoves + return $ Move $ vmSorted !! i +coerceTurn t = return t + +-- | Gets a list of possible cells which +-- the current player can move to. +getValidMoves :: Cell -> Int -> GameState -> [Cell] +getValidMoves c@(y,x) bs gs = validatedResult + where adjs = getAdj bs c + hgs = halfGates gs + noHgs src = filter (\c' -> isHalfGateSpaceClear (src,c') hgs) + result = concatMap + (\c' -> if isVacant c' gs then [c'] else plTr c') $ noHgs c adjs + validatedResult = filter + (flip isVacant gs `andP` isWithinRange bs) result + + plTr c'@(y',x') = if null $ noHgs c' [c''] + then noHgs c' sideCells + else [c''] + where c'' = (y' + (y'-y), x' + (x'-x)) + sideCells + | y' == y = [(y'-1,x'),(y'+1,x')] + | x' == x = [(y',x'-1),(y',x'+1)] + | otherwise = error "A bug in getAdj" + +-- | Checks if from a given cell, another cell, which satisfies +-- the given predicate, can be reached. +-- Used in gate placement, to make sure a cell which is a winning cell +-- for a player can still be reached. +dfs :: Cell -> (Cell -> Bool) -> Int -> GameState -> Bool +dfs from predicate bs gs = evalState (go from) $ S.insert from S.empty + where + go from' + | predicate from' = return True + | otherwise = or <$> mapM throughThis reachableCells + where + reachableCells = getValidMoves from' bs gs + throughThis c = do + visited <- get + if S.member c visited + then return False + else put (S.insert c visited) >> go c + + + +--- Game functions + +-- | Rotates the 'Player' list to change the current player. +-- The player at the had of the player list is the current player. +changeCurrPlayer :: Monad m => Game m () +changeCurrPlayer = modify $ \s -> s {playerList = rotateList $ playerList s} + +-- | Checks if a given 'Turn' is valid, rule-wise. +-- It does it by perusing 'getCurrentValidMoves's returned +-- list of all possible valid moves. +isValidTurn :: (Monad m, Functor m) => Turn -> Game m Bool +isValidTurn (Move c) = (c `elem`) <$> getCurrentValidMoves + +isValidTurn (PutGate g) = do + gs <- get + bs <- reader boardSize + let validGate = all (isWithinRange bs) $ gateToCells g + hgs = halfGates gs + cp = currP gs + noOtherGate = isGateSpaceClear g hgs + haveGates = gatesLeft cp > 0 + wontBlockPlayer p = dfs (pos p) (isWinningCell bs p) bs $ + gs { halfGates = insertGate g hgs } + wontBlock = all wontBlockPlayer $ playerList gs + return $ validGate && noOtherGate && haveGates && wontBlock + +isValidTurn _ = error "bug with coerceTurn" + +-- | Acts upon a single 'Turn'. +-- The difference with 'MakeTurn', is that MakeTurn calls this +-- function and does more, like changing currentPlayer and +-- checking for a winner. +actTurn :: Monad m => Turn -> Game m () +actTurn (Move c) = modify $ modifyCurrP $ \p -> p { pos = c } +actTurn (PutGate g) = do + modify $ \s -> s { halfGates = insertGate g (halfGates s) } + modify $ modifyCurrP $ \p -> p { gatesLeft = gatesLeft p - 1 } +actTurn _ = error "Bug with coerceTurn" + +-- | Checks if there's a winner, returning it if there is +-- and sets the winner in the 'GameState'. +checkAndSetWinner :: Monad m => Game m (Maybe Color) +checkAndSetWinner = do + pl <- gets playerList + bs <- reader boardSize + let mWinner = color <$> find (\p -> isWinningCell bs p (pos p)) pl + modify $ \s -> s { winner = mWinner } + return mWinner + + + +--- exported functions (for modules other than Tests) + +-- | Makes a single 'Turn' in a game. +-- Changes the state ('GameState') accordingly and returns +-- whether or not a valid turn was requested. +-- If an invalid turn was requested, it can be safely assumed +-- that the GameState did not change. +makeTurn :: (Monad m, Functor m) => Turn -> Game m (Maybe Turn) +makeTurn t = do + t' <- coerceTurn t + wasValid <- isValidTurn t' + if wasValid + then do actTurn t' + checkAndSetWinner + changeCurrPlayer + return $ Just t' + else return Nothing + +-- | A Game monad wrapper for the unmonadic 'getValidMoves' +getCurrentValidMoves :: Monad m => Game m [Cell] +getCurrentValidMoves = do + bs <- reader boardSize + gs <- get + let cell = pos $ currP gs + return $ getValidMoves cell bs gs diff --git a/src/Quoridor/Cmdline.hs b/src/Quoridor/Cmdline.hs new file mode 100644 --- /dev/null +++ b/src/Quoridor/Cmdline.hs @@ -0,0 +1,87 @@ +module Quoridor.Cmdline + ( cmdlineMain + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (when) +import Control.Monad.Reader (ask) +import Control.Monad.State (MonadIO, get, gets, liftIO) +import Data.List (sort) +import System.Environment (getArgs) +import System.Exit (exitSuccess) + +import Network.Simple.TCP (withSocketsDo) + +import Quoridor +import Quoridor.Cmdline.Messages (msgGameEnd, msgInitialTurn, + msgInvalidTurn, msgValidTurn) +import Quoridor.Cmdline.Network.Client (connectClient) +import Quoridor.Cmdline.Network.Server (hostServer) +import Quoridor.Cmdline.Options (ExecMode (..), Options (..), + getOptions) +import Quoridor.Cmdline.Parse (parseTurn) +import Quoridor.Cmdline.Render (putColoredStrTerm, + runRenderColor) + +-- | The main entry point to quoridor-exec +cmdlineMain :: IO () +cmdlineMain = do + args <- getArgs + opts <- getOptions args + let gc = GameConfig + { gatesPerPlayer = opGatesPerPlayer opts + , boardSize = opBoardSize opts + , numOfPlayers = opNumOfPlayers opts + } + case opExecMode opts of + ExLocal -> runGame playLocal gc + ExHost -> withSocketsDo $ runGame + (hostServer (opHostListenPort opts) (opHttpListenPort opts)) gc + joinOrProxy -> withSocketsDo $ + connectClient (joinOrProxy == ExProxy) $ opHostListenPort opts + exitSuccess + +-- playLocal used to be structured similarly to +-- playClient and playServer, but those functions +-- seemed a bit monolithc to me, so I tried an alternative +-- approach that, admittedly, I'm not sure is more readable. +playLocal :: Game IO () +playLocal = go True msgInitialTurn + where go showBoard msg = do + gs <- get + let parseFailAct = go False + parseSuccAct turn = do + mTurn <- makeTurn turn + go True $ maybe msgInvalidTurn + (msgValidTurn (color $ currP gs)) + mTurn + when showBoard renderCurrentBoard + liftIO $ putStrLn msg + handleWinOrTurn + wonAction $ + handleParse (liftIO getLine) parseFailAct parseSuccAct + +renderCurrentBoard :: (Functor m, MonadIO m) => Game m () +renderCurrentBoard = do + gc <- ask + gs <- get + vm <- sort <$> getCurrentValidMoves + liftIO $ renderBoard gs gc vm + +-- Function that could be common to playLocal, +-- playClient(handleWinOrTurn, wonAction, renderBoard) and playServer(handleParse) +-- if I change playClient and playServer to be in the same vein as playLocal +renderBoard :: GameState -> GameConfig -> [Cell] -> IO () +renderBoard gs gc vms = putColoredStrTerm $ runRenderColor gs gc vms + +handleParse :: MonadIO m => + m String -> (String -> m ()) -> (Turn -> m ()) -> m () +handleParse getStrAct failAct succAct = + (either failAct succAct . parseTurn) =<< getStrAct + +handleWinOrTurn :: MonadIO m => (Color -> Game m ()) -> Game m () -> Game m () +handleWinOrTurn wonAct contAct = + maybe contAct wonAct =<< gets winner + +wonAction :: MonadIO m => Color -> m () +wonAction = liftIO . putStrLn . msgGameEnd diff --git a/src/Quoridor/Cmdline/Messages.hs b/src/Quoridor/Cmdline/Messages.hs new file mode 100644 --- /dev/null +++ b/src/Quoridor/Cmdline/Messages.hs @@ -0,0 +1,29 @@ +-- | Messages to be printed to the player +module Quoridor.Cmdline.Messages +where + +import Quoridor (Color, Turn) + +msgAwaitingTurn :: Color -> String +msgAwaitingTurn c = "Waiting for " ++ show c ++ " to make a move." + +msgGameEnd :: Color -> String +msgGameEnd c = show c ++ " won!" + +msgValidTurn :: Color -> Turn -> String +msgValidTurn c t = "Previous turn was: " ++ show c ++ " - " ++ show t + +msgInvalidTurn, msgInitialTurn :: String +msgInvalidTurn = "Attempted Turn was invalid" +msgInitialTurn = "Good luck!" + +validMovesChars :: String +validMovesChars = "!@#$%^&*" + +msgInputInstr :: String +msgInputInstr = unlines + [ "type: g y x [h/v] to place horizontal/vertical gate," + , " across a 2x2 square, whose top left is at y,x" + , "type: m y x to move." + , "type one of: " ++ validMovesChars ++ " to move to where that character is on the board." + ] diff --git a/src/Quoridor/Cmdline/Network/Client.hs b/src/Quoridor/Cmdline/Network/Client.hs new file mode 100644 --- /dev/null +++ b/src/Quoridor/Cmdline/Network/Client.hs @@ -0,0 +1,76 @@ +module Quoridor.Cmdline.Network.Client + ( connectClient + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (when) +import Control.Monad.State (liftIO) +import Control.Monad.State (MonadIO) +import Data.Maybe (fromMaybe) +import System.IO (hFlush, hReady, stdin, + stdout) + +import Network.Simple.TCP (Socket, connect) + +import Quoridor +import Quoridor.Cmdline.Messages +import Quoridor.Cmdline.Network.Common +import Quoridor.Cmdline.Render (putColoredStrHtml, + putColoredStrTerm, + runRenderColor) + + +-- | Given a port, joins a game server that listens +-- on the given port. +connectClient :: Bool -> Int -> IO () +connectClient isProxy port = connect "127.0.0.1" (show port) $ + \(connSock, _) -> do + msg <- recvFromServer connSock + flushStrLn msg + (gc, c) <- recvFromServer connSock + playClient connSock isProxy gc c + +playClient :: Socket -> Bool -> GameConfig -> Color -> IO () +playClient connSock isProxy gc myColor = play + where + play = do + (gs, vm, msg) <- recvFromServer connSock + emptyInput + (if isProxy then putColoredStrHtml else putColoredStrTerm) $ + runRenderColor gs gc vm + flushStrLn msg + hFlush stdout + case winner gs of + Just c -> + flushStrLn $ msgGameEnd c + Nothing -> do + let currPC = color $ currP gs + if currPC /= myColor + then do + flushStrLn $ msgAwaitingTurn currPC + play + else do + strTurn <- liftIO getLine + sendToSock strTurn connSock + play + +recvFromServer :: (Functor m, MonadIO m, Read r) => Socket -> m r +recvFromServer sock = fromMaybe throwErr <$> recvFromSock sock + where throwErr = error "Lost connection with the server" + +-- | Like putStrLn, but flushes right afterwards. +flushStrLn :: String -> IO () +flushStrLn = (hFlush stdout <<) . putStrLn + where (<<) = flip (>>) + +-- | This empties command line input that was buffered +-- while it wasn't the player's turn. +-- Otherwise, garbage that was being fed to input +-- while it wasn't the player's turn, will +-- be fed to the server and generate an error message per line, +-- or even play a turn, which may or may not be intentional. +emptyInput :: IO () +emptyInput = do + inputExists <- hReady stdin + when inputExists $ getLine >> emptyInput + diff --git a/src/Quoridor/Cmdline/Network/Common.hs b/src/Quoridor/Cmdline/Network/Common.hs new file mode 100644 --- /dev/null +++ b/src/Quoridor/Cmdline/Network/Common.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Quoridor.Cmdline.Network.Common + ( ConnPlayer (..) + , sendToSock + , recvFromSock + , isAliveSock + ) where + +import Control.Applicative ((<$>)) +import Control.Exception (ErrorCall (..), SomeException, catch, + handle) +import Control.Monad.State (MonadIO, liftIO, replicateM_) +import qualified Data.ByteString.Char8 as BC +import Data.Maybe (fromJust) +import Text.Printf (printf) + +import Network.Simple.TCP (Socket, recv, send) +import Numeric (readHex, showHex) + +import Quoridor + +data ConnPlayer = ConnPlayer + { coplSock :: Socket + , coplColor :: Color + } deriving Show + +sendToSock :: (Show s, MonadIO m) => s -> Socket -> m () +sendToSock s sock = do + send sock $ BC.pack $ + printf "%04s" $ showHex (BC.length serialized) "" + send sock serialized + where serialized = BC.pack $ show s + +isAliveSock :: (MonadIO m) => Socket -> m Bool +isAliveSock sock = liftIO $ + do replicateM_ 2 $ (send sock . BC.pack) "0000" + return True + `catch` + \(_ :: SomeException) -> return False + +recvFromSock :: (Read r, Functor m, MonadIO m) => Socket -> m (Maybe r) +recvFromSock sock = liftIO $ handle (\(ErrorCall _) -> return Nothing) $ do + mHexSize <- recv sock 4 + let ((size,_):_) = readHex $ BC.unpack $ fromJust mHexSize + if size == 0 + then recvFromSock sock -- To handle size 0 messages which are just isAlive check + else do + mValue <- recv sock size + return $ (read . BC.unpack) <$> mValue diff --git a/src/Quoridor/Cmdline/Network/Server.hs b/src/Quoridor/Cmdline/Network/Server.hs new file mode 100644 --- /dev/null +++ b/src/Quoridor/Cmdline/Network/Server.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Quoridor.Cmdline.Network.Server + ( hostServer + ) where + +import Control.Applicative ((<$>)) +import Control.Concurrent (ThreadId, forkIO, killThread, + myThreadId, threadDelay, + throwTo) +import Control.Exception (bracket, handle) +import Control.Monad (filterM, forever, unless, + (>=>)) +import Control.Monad.Reader (ask) +import Control.Monad.State (MonadIO, get, liftIO) +import qualified Data.ByteString as B +import Data.List (find) +import Data.Maybe (fromJust, fromMaybe) +import System.Directory (getCurrentDirectory) +import System.IO (Handle, hClose, hFlush) +import System.Process (runInteractiveCommand, + terminateProcess, + waitForProcess) + +import Network.Simple.TCP (HostPreference (Host), + accept, listen) +import qualified Network.WebSockets as WS +import qualified Network.WebSockets.Snap as WS +import qualified Snap.Core as Snap +import qualified Snap.Http.Server as Snap +import qualified Snap.Util.FileServe as Snap +import System.FilePath (()) + +import Paths_quoridor_hs (getDataDir) +import Quoridor +import Quoridor.Cmdline.Messages +import Quoridor.Cmdline.Network.Common +import Quoridor.Cmdline.Parse (parseTurn) + +-- | Given a port, hosts a game server that listens +-- on the given port. +-- This returns a Game monad which should be used with runGame. +hostServer :: Int -> Int -> Game IO () +hostServer quoriHostPort httpPort = do + liftIO $ forkIO $ httpListen quoriHostPort httpPort + listen (Host "127.0.0.1") (show quoriHostPort) $ + \(lstnSock, _) -> do + gc <- ask + + let getPlayers 0 socks = do + coSocks <- liftIO $ filterM isAliveSock socks + if length coSocks /= length socks + then getPlayers (length socks - length coSocks) coSocks + else do + let colors = map toEnum [0..] + connPs = zipWith ConnPlayer socks colors + {-getConnPlayers socks' = zipWith ConnPlayer socks' colors-} + {-connPs = getConnPlayers socks-} + mapM_ (\p -> sendToPlayer (gc, coplColor p) p) connPs + playServer connPs + + getPlayers n socks = accept lstnSock $ \(connSock, _) -> do + let msg = "Connected. " ++ if n > 1 + then "Waiting for other players." else "" + liftIO $ putStrLn msg + sendToSock msg connSock + getPlayers (n-1) $ connSock : socks + + getPlayers (numOfPlayers gc) [] + +playServer :: [ConnPlayer] -> Game IO () +playServer connPs = play msgInitialTurn + where + play msg = do + gs <- get + vm <- getCurrentValidMoves + mapM_ (sendToPlayer (gs,vm,msg)) connPs + case winner gs of + Just _ -> liftIO $ threadDelay $ 10 * 1000 * 1000 + Nothing -> do + let currColor = color $ currP gs + currConnP = fromJust $ find ((currColor ==) . coplColor) connPs + sendToCurrPlayer x = sendToPlayer x currConnP + + execValidTurn = do + strTurn <- recvFromPlayer currConnP + let reAskForInput msg' = do sendToCurrPlayer (gs,vm,msg') + execValidTurn + either reAskForInput + (makeTurn >=> maybe (reAskForInput msgInvalidTurn) + return) + $ parseTurn strTurn + + turn <- execValidTurn + play $ msgValidTurn currColor turn + +sendToPlayer :: (Show s, MonadIO m) => s -> ConnPlayer -> m () +sendToPlayer s cnp = sendToSock s $ coplSock cnp + +-- | The error message will appear only if the current player exits. +-- To handle the case where other players will exit I'll have to rewrite the whole +-- mechanism to be asynchronous between players. +recvFromPlayer :: (Functor m, MonadIO m) => ConnPlayer -> m String +recvFromPlayer cnp = fromMaybe throwErr <$> recvFromSock (coplSock cnp) + where throwErr = error $ "Lost connection with " ++ show (coplColor cnp) + +httpListen :: Int -> Int -> IO () +httpListen quoriHostPort httpPort = Snap.httpServe config $ app quoriHostPort + where + config = Snap.setPort httpPort $ + Snap.setErrorLog Snap.ConfigNoLog $ + Snap.setAccessLog Snap.ConfigNoLog + Snap.defaultConfig + app :: Int -> Snap.Snap () + app port = do + dataDir <- liftIO getDataDir + Snap.route + [ ("", Snap.ifTop $ Snap.serveFile $ dataDir "console.html") + , ("console.js", Snap.serveFile $ dataDir "console.js") + , ("style.css", Snap.serveFile $ dataDir "style.css") + , ("play", acceptWSPlayer port) + ] + +acceptWSPlayer :: Int -> Snap.Snap () +acceptWSPlayer port = WS.runWebSocketsSnap $ \pending -> + do + dir <- getCurrentDirectory + let cmd = dir "quoridor-exec -p " ++ show port + putStrLn cmd + + let acqRsrc = do + (hIn, hOut, _, ph) <- runInteractiveCommand cmd + conn <- WS.acceptRequest pending + outT <- forkIO $ copyHandleToConn hOut conn + tId <- myThreadId + inT <- forkIO $ copyConnToHandle conn hIn tId + return (hIn, hOut, ph, inT, outT) + freeRsrc (hIn, hOut, ph, inT, outT) = do + killThread inT + killThread outT + hClose hIn + hClose hOut + terminateProcess ph + bracket acqRsrc freeRsrc $ + \(_,_,ph,_,_) -> waitForProcess ph + + return () + +copyHandleToConn :: Handle -> WS.Connection -> IO () +copyHandleToConn h c = do + bs <- B.hGetSome h 4096 + unless (B.null bs) $ do + putStrLn $ previewStr $ "WS > " ++ show bs + WS.sendTextData c bs + copyHandleToConn h c + where + +copyConnToHandle :: WS.Connection -> Handle -> ThreadId -> IO () +copyConnToHandle c h t = handle thrower $ forever $ do + bs <- WS.receiveData c + putStrLn $ previewStr $ "WS < " ++ show bs + B.hPutStr h bs + hFlush h + where + thrower e = throwTo t (e :: WS.ConnectionException) + +previewStr :: String -> String +previewStr str = prvw ++ if not $ null rst then "....." + else "" + where (prvw, rst) = splitAt 80 str + diff --git a/src/Quoridor/Cmdline/Options.hs b/src/Quoridor/Cmdline/Options.hs new file mode 100644 --- /dev/null +++ b/src/Quoridor/Cmdline/Options.hs @@ -0,0 +1,139 @@ +module Quoridor.Cmdline.Options + ( Options(..) + , ExecMode(..) + , getOptions + ) where + +import Control.Monad (unless) +import System.Environment (getProgName) +import System.Exit (exitFailure, exitSuccess) + +import System.Console.GetOpt (ArgDescr (NoArg, OptArg), + ArgDescr (ReqArg), + ArgOrder (RequireOrder), OptDescr, + OptDescr (Option), getOpt, usageInfo) + +import Quoridor.Helpers (andP) + +-- | Represents possible options from the cmdline +data Options = Options + { opBoardSize :: Int + , opNumOfPlayers :: Int + , opGatesPerPlayer :: Int + , opHostListenPort :: Int + , opHttpListenPort :: Int + , opExecMode :: ExecMode + } + +-- | Represents an execution mode for the program. +-- One can run quoridor at local play, server host or client join modes +data ExecMode = ExLocal | ExHost | ExJoin | ExProxy + deriving Eq + +defaultOptions :: Options +defaultOptions = Options + { opBoardSize = 9 + , opNumOfPlayers = 2 + , opGatesPerPlayer = 10 + , opHostListenPort = 33996 + , opHttpListenPort = 33997 + , opExecMode = ExLocal + } + +-- exported functions + +-- | Given the args from the cmdline, +-- returns them parsed into an Options data value. +-- It runs in the IO monad to allow the ability to exit the program +-- if something fails in the parsing (upon which, a usageInfo will be displayed) +getOptions :: [String] -> IO Options +getOptions args = do + let (actions, _, _) = getOpt RequireOrder options args + foldl (>>=) (return defaultOptions) actions + + + +--helpers + +isInRange :: Ord a => a -> a -> a -> Bool +isInRange a b c = ((>= b) `andP` (<= c)) a + +putUsageInfoLn :: IO () +putUsageInfoLn = do + prg <- getProgName + putStrLn (usageInfo prg options) + +options :: [ OptDescr (Options -> IO Options) ] +options = + [ Option "b" ["board-size"] + (ReqArg + (\arg opts -> do + argNum <- rangedOption 2 9 arg + return opts { opBoardSize = argNum }) + "INTEGER") + "Board size (2-9 rows/columns). default 9" + + , Option "n" ["number-of-players"] + (ReqArg + (\arg opts -> do + argNum <- rangedOption 2 4 arg + return opts { opNumOfPlayers = argNum }) + "INTEGER") + "Number of players (2-4 players). default 2" + + , Option "g" ["gates-per-player"] + (ReqArg + (\arg opts -> do + argNum <- rangedOption 0 100 arg + return opts { opGatesPerPlayer = argNum }) + "INTEGER") + "Gates per player (1-100 gates per player). default 10" + + , Option "l" ["local"] + (NoArg $ + \opts -> return opts { opExecMode = ExLocal }) + "Start a local game" + + , Option "h" ["host"] + (portOptionArg ExHost) + "Host a game server. default port 33997" + + , Option "j" ["join"] + (portOptionArg ExJoin) + "Join a game server" + + , Option "p" ["client-proxy"] + (portOptionArg ExProxy) + "Client acts as proxy for a browser (used by the http server)" + + , Option "t" ["http-port"] + (ReqArg + (\arg opts -> do + argNum <- rangedOption 1025 65535 arg + return opts { opHttpListenPort = argNum }) + "PORT") + "A port for the http-server (port 1025-65535), relevant only if --host flag is used. default 33997" + + , Option "?" ["help"] + (NoArg $ + \_ -> do + putUsageInfoLn + exitSuccess) + "Show help" + ] + where portOptionArg execMode = + OptArg + (\arg opts -> do + argNum <- maybe (return $ opHostListenPort opts) + (rangedOption 1025 65535) arg + return opts + { opExecMode = execMode + , opHostListenPort = argNum + }) + "PORT" + rangedOption x y arg = do + let argNum = read arg + unless (isInRange argNum x y) $ do + putUsageInfoLn + exitFailure + return argNum diff --git a/src/Quoridor/Cmdline/Parse.hs b/src/Quoridor/Cmdline/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Quoridor/Cmdline/Parse.hs @@ -0,0 +1,77 @@ +module Quoridor.Cmdline.Parse + ( parseTurn + ) where + +import Control.Applicative (pure) +import Data.Char (toUpper) +import Data.Functor ((<$>)) +import Data.List (elemIndex) +import Data.Maybe (fromJust) + +import Text.Parsec (Parsec, char, digit, eof, many1, + oneOf, parse, spaces, (<|>)) + +import Quoridor +import Quoridor.Cmdline.Messages (validMovesChars) + +type Parse = Parsec String () + +-- helper functions + +pTurn :: Parse Turn +pTurn = do + res <- pMove <|> pShortCutMove <|> pPutGate + eof + return res + +-- m y x +pMove :: Parse Turn +pMove = do + char 'm' + Move <$> pCell + +-- one of 'validMovesChars', translated +-- into their index. +pShortCutMove :: Parse Turn +pShortCutMove = do + c <- oneOf validMovesChars + return $ ShortCutMove $ translate c + where translate c = fromJust $ elemIndex c validMovesChars + +-- g y x h|v +pPutGate :: Parse Turn +pPutGate = do + char 'g' + c <- pCell + PutGate . gateUpperLeft c <$> pDirection + +pCell :: Parse Cell +pCell = do + y <- pInt + x <- pInt + return (y,x) + +pDirection :: Parse Direction +pDirection = cToDirection <$> asToken (oneOf "hv") + where cToDirection = (read :: String -> Direction) . pure . toUpper + +pInt :: Parse Int +pInt = (read :: String -> Int) <$> asToken (many1 digit) + +asToken :: Parse a -> Parse a +asToken p = spaces >> p + + + +-- exported functions + +-- | Given a string representing a turn, +-- Parses it and returns the Turn +-- +-- Note: This is not the same string as show turn, it is +-- a more concise, for example: "m y x" to move +-- to (y,x) +parseTurn :: String -> Either String Turn +parseTurn s = func $ parse pTurn "" s + where func (Left errMsgs) = Left $ show errMsgs + func (Right x) = Right x diff --git a/src/Quoridor/Cmdline/Render.hs b/src/Quoridor/Cmdline/Render.hs new file mode 100644 --- /dev/null +++ b/src/Quoridor/Cmdline/Render.hs @@ -0,0 +1,219 @@ +module Quoridor.Cmdline.Render + ( runRender + , runRenderColor + , putColoredStrTerm + , putColoredStrHtml + ) where + +import Control.Monad.Reader (ReaderT, reader, runReaderT) +import Control.Monad.State (StateT, get, gets, modify, + runStateT) +import Control.Monad.Writer (Writer, runWriter, tell, void) +import Data.List (partition, sort, sortBy) +import qualified Data.Set as S (toAscList) +import Text.Printf (printf) + +import qualified Data.DList as D +import qualified System.Console.ANSI as CA + +import Quoridor +import Quoridor.Cmdline.Messages (msgInputInstr, validMovesChars) + + + +-- | Monad stack used for rendering the board. +-- ReaderT with game configuration +-- Writer for accumulating the String which represents the board +-- StateT for a state of sorted lists o what is left to +-- render on the board (e.g. players, gates). +type Render = ReaderT GameConfig + (StateT RenderState + (Writer (D.DList Char))) + +-- | Sorted lists of what is left to render on the board. +-- The rendering of the board is linear, and at every tile +-- or in between tiles, whether something should be rendered there +-- or not is checked. To avoid going over all the lists every turn, +-- only the head is checked (but for that to be correct the lists +-- must be sorted). +data RenderState = RenderState + { players :: [Player] + , vertHalfGates :: [HalfGate] + , horizHalfGates :: [HalfGate] + , validMoves :: [Cell] + , leftValidMovesChars :: String + } + + +--- exported functions + +-- | Returns a String of the game board along with some basic info +runRender :: GameState -> GameConfig -> [Cell] -> String +runRender gs gc vms = D.toList w + where (_,w) = + runWriter (runStateT (runReaderT (render cp) gc) initialRenderState) + initialRenderState = RenderState + psSorted vhgs hhgs vmSorted validMovesChars + psSorted = sortPlayers $ playerList gs + vmSorted = sort vms + (hhgs, vhgs) = partitionHalfGates $ S.toAscList $ halfGates gs + cp = currP gs + +-- | Returns a String of the game board along with some basic info, +-- and a series of IO () actions, one per character, which describe how +-- to set the terminal color. putColoredStr can be used to apply +-- those actions automatically +runRenderColor :: GameState -> GameConfig -> [Cell] -> (String, [CA.Color]) +runRenderColor = ((addColor .) .) . runRender + +-- | Given an input such as the output of runRenderColor, writes the +-- game board along with some basic info, to the screen, applying +-- the IO actions to colorize the output. +putColoredStrTerm :: (String, [CA.Color]) -> IO () +putColoredStrTerm (str, colors) = mapM_ putColoredChar $ zip str colors + where putColoredChar (ch, col) = colorToAction col >> putChar ch + colorToAction col = + CA.setSGR [CA.SetColor CA.Foreground CA.Vivid col] + +-- | This is wasteful compared to having this logic in the browser's javascript. +-- However this is still amounts to very little data being transferred, and that way +-- I can avoid duplicating the coloring logic" +putColoredStrHtml :: (String, [CA.Color]) -> IO () +putColoredStrHtml (str, colors) = putStr $ concatMap addColorProp $ zip str colors + where addColorProp (ch, CA.White) = [ch] + addColorProp (ch, col) = printf "%c" (show col) ch + + + +--- helper functions + +render :: Player -> Render () +render cp = do + renderBoard + tellLine msgInputInstr + tellLine $ "It's " ++ show (color cp) ++ "'s Turn." + ++ " " ++ show (gatesLeft cp) ++ " gates left." + tellNewLine + +tellStr :: String -> Render () +tellStr str = tell $ D.fromList str + +tellLine :: String -> Render () +tellLine str = tellStr str >> tellNewLine + +tellNewLine :: Render () +tellNewLine = tellStr "\n" + +-- | Actually specifies how to render the board. +-- Using 'renderTileRow' and 'renderBetweenRow' +renderBoard :: Render () +renderBoard = do + bs <- reader boardSize + let go y + | y == bs = return () + | otherwise = do + let lineRuler = show y ++ tail linePadding + tellStr lineRuler >> renderTileRow y + tellStr linePadding >> renderBetweenRow y + go $ y+1 + tellRulerLine = tellLine $ + linePadding ++ unwords (map show [0..bs-1]) + tellRulerLine + tellNewLine + go 0 + tellRulerLine + tellNewLine + +-- | Rendering of a tile row +-- (i.e. a row with players and/or vertical gates potentially on it) +renderTileRow :: Int -> Render () +renderTileRow row = do + bs <- reader boardSize + let go y x + | x == bs = void $ tellStr "\n" + | otherwise = do + RenderState ps vhgs _ vms vmcs <- get + let (cp, ps') = getCharAndList + ps ((==) (y,x) . pos) noP (colorLetter $ color $ head ps) + (cg, vhgs') = getCharAndList vhgs (== ((y,x),(y,x+1))) noG vgc + (cvm, vms') = getCharAndList vms (== (y,x)) noP (head vmcs) + vmcs' = if cvm /= noP then tail vmcs else vmcs + cTile | cp /= noP = cp + | cvm /= noP = cvm + | otherwise = noP + modify $ \s -> s { players = ps' + , vertHalfGates = vhgs' + , validMoves = vms' + , leftValidMovesChars = vmcs' + } + tellStr [cTile,cg] + go y (x+1) + go row 0 + +-- | Rendering of a between row +-- (i.e. a row with horizontal gates potentially on it) +renderBetweenRow :: Int -> Render () +renderBetweenRow row = do + bs <- reader boardSize + let go y x + | x == bs = void $ tellStr "\n" + | otherwise = do + hhgs <- gets horizHalfGates + let (c, hhgs') = getCharAndList hhgs (== ((y,x),(y+1,x))) noG hgc + modify $ \s -> s { horizHalfGates = hhgs' } + tellStr (c:" ") + go y $ x+1 + go row 0 + +-- | This function, checks if the first item in the sorted list +-- (of players/gates/valid moves) satisfies a predicate. +-- The predicate is basically, whether or not that item should be printed +-- in the current position of the board render. +-- It returns the according character that should be printed in that +-- potential tile, and returns the tail of the list if there's a match. +getCharAndList :: [a] -> (a -> Bool) -> Char -> Char -> (Char, [a]) +getCharAndList [] _ cFalse _ = (cFalse, []) +getCharAndList (x:xs) predicate cFalse cTrue + | predicate x = (cTrue, xs) + | otherwise = (cFalse, x:xs) + +-- | Partition 'HalfGate's into horizontal and vertical. +partitionHalfGates :: [HalfGate] -> ([HalfGate],[HalfGate]) +partitionHalfGates = partition $ \((_,x),(_,x')) -> x == x' + +sortPlayers :: [Player] -> [Player] +sortPlayers = sortBy func + where func p1 p2 + | pos p1 < pos p2 = LT + | pos p1 > pos p2 = GT + | otherwise = EQ + +colorLetter :: Color -> Char +colorLetter = head . show + +-- | Given a board render, attaches an IO action per character +-- that changes terminal color accordingly. +addColor :: String -> (String, [CA.Color]) +addColor str = (str, map addColorChar str) + where + addColorChar ch | ch == noP = CA.Yellow + | ch == hgc || ch == vgc = CA.Magenta + | ch `elem` validMovesChars = CA.Cyan + | ch == 'W' = CA.White + | ch == 'B' = CA.Blue + | ch == 'R' = CA.Red + | ch == 'G' = CA.Green + | otherwise = CA.White + + + +-- constants + +noP, noG, hgc, vgc :: Char +noP = 'E' +noG = ' ' +hgc = '-' +vgc = '|' + +linePadding :: String +linePadding = replicate 2 ' ' diff --git a/src/Quoridor/Helpers.hs b/src/Quoridor/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Quoridor/Helpers.hs @@ -0,0 +1,18 @@ +module Quoridor.Helpers +where + +import Control.Monad (liftM2) +import qualified Data.Map as M +import Data.Maybe (fromJust) + + + +andP :: (a -> Bool) -> (a -> Bool) -> a -> Bool +andP = liftM2 (&&) + +rotateList :: [a] -> [a] +rotateList [] = [] +rotateList (x:xs) = xs ++ [x] + +unsafeLookup :: Ord k => k -> M.Map k a -> a +unsafeLookup = (fromJust .) . M.lookup diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,144 @@ +module Main + ( main + ) where + +import Data.List (find, sort) +import Data.Maybe (fromJust, isJust, isNothing) + +import Test.HUnit + +import Quoridor + +-- helper functions + +testCase :: String -> Assertion -> Test +testCase label assertion = TestLabel label (TestCase assertion) + +main :: IO Counts +main = runTestTT $ TestList accumulateTests +{-main = runTestTT $ accumulateTests !! 7-} + + + +-- A gamestate to test +-- Blue's turn +-- 2 3 4 5 +-- 2 E E E|E +-- - - +-- 3 E B W|E +-- +-- 4 E E E E +-- E = empty tile, B = Blue, W = White, |,- = Gates +someGameState :: GameState +someGameState = initgs + { halfGates = halfGates' + , playerList = playerList' + } + where initgs = initialGameState defaultGameConfig + halfGates' = foldr insertGate (halfGates initgs) + [ gateUpperLeft (2,3) H + , gateUpperLeft (2,4) V + ] + playerList' = + [ Player { color = Blue + , pos = (3,3) + , gatesLeft = 1 + } + , Player { color = White + , pos = (3,4) + , gatesLeft = 0 + } + ] + +runGameTest :: Game m a -> GameState -> m (a, GameState) +runGameTest g gs = runGameWithGameState g gs defaultGameConfig + +execGame :: Functor m => Game m a -> GameState -> m GameState +execGame = (fmap snd .) . runGameTest + +evalGame :: Functor m => Game m a -> GameState -> m a +evalGame = (fmap fst .) . runGameTest + +accumulateTests :: [Test] +accumulateTests = + [ + testCase "changeCurrPlayer" $ do + let gs = someGameState + gs' <- execGame changeCurrPlayer gs + True @=? currP gs' /= currP gs + head (tail $ playerList gs) @=? currP gs' + currP gs @=? last (playerList gs') + + , testCase "getValidMoves" $ do + let + getPlayer thisColor = fromJust $ + find ((==) thisColor . color) (playerList someGameState) + validForColor c = + getValidMoves (pos $ getPlayer c) + (boardSize defaultGameConfig) someGameState + [(3,2),(4,3),(4,4)] @=? sort (validForColor Blue) + [(3,2),(4,4)] @=? sort (validForColor White) + + , testCase "isValidTurn-1-move-valid" $ do + (True @=?) =<< evalGame (isValidTurn $ Move (3,2)) someGameState + (True @=?) =<< evalGame (isValidTurn $ Move (4,3)) someGameState + + , testCase "isValidTurn-1-move-invalid" $ do + (False @=?) =<< evalGame (isValidTurn $ Move (2,3)) someGameState + (False @=?) =<< evalGame (isValidTurn $ Move (3,4)) someGameState + + , testCase "isValidTurn-2-move-valid" $ + (True @=?) =<< evalGame (isValidTurn $ Move (4,4)) someGameState + + , testCase "isValidTurn-2-move-invalid" $ do + let gs = someGameState + halfGates' = insertGate (gateUpperLeft (3,4) H) $ halfGates gs + gs' = gs { halfGates = halfGates' } + (False @=?) =<< evalGame (isValidTurn $ Move (4,4)) gs' + + , testCase "isValidTurn-putGate-valid" $ + (True @=?) =<< evalGame (isValidTurn $ PutGate $ gateUpperLeft (2,3) V) + someGameState + + , testCase "isValidTurn-putGate-invalid-overlap" $ + (False @=?) =<< evalGame (isValidTurn $ PutGate $ gateUpperLeft (2,2) H) + someGameState + + , testCase "isValidTurn-putGate-invalid-willBlock" $ do + let gs = someGameState + halfGates' = insertGate (gateUpperLeft (3,3) V) $ halfGates gs + gs' = gs { halfGates = halfGates' } + (False @=?) =<< evalGame + (isValidTurn $ PutGate $ gateUpperLeft (3,3) H) gs' + + , testCase "makeTurn-move-valid" $ do + let gs = someGameState + (mTurn, gs') <- runGameTest (makeTurn $ Move (4,4)) gs + True @=? isJust mTurn + let p' = last $ playerList gs' + color (currP gs) @=? color p' + (4,4) @=? pos p' + + , testCase "makeTurn-move-invalid" $ do + let gs = someGameState + (mTurn, gs') <- runGameTest (makeTurn $ Move (3,5)) gs + True @=? isNothing mTurn + color (currP gs) @=? color (currP gs') + (3,3) @=? pos (currP gs') + + , testCase "makeTurn-putGate-valid" $ do + let gs = someGameState + ggs = halfGates gs + gateToInsert = gateUpperLeft (3,3) V + (mTurn, gs') <- runGameTest (makeTurn $ PutGate gateToInsert) gs + True @=? isJust mTurn + insertGate gateToInsert ggs @=? halfGates gs' + + , testCase "checkAndSetWinner-nothing" $ + (Nothing @=?) =<< evalGame checkAndSetWinner someGameState + + , testCase "checkAndSetWinner-black-won" $ do + let gs = someGameState + gs' = modifyCurrP (\p -> p { pos = (0,3) }) gs + (Just (color $ currP gs) @=?) =<< evalGame checkAndSetWinner gs' + ]