quoridor-hs (empty) → 0.1.0.0
raw patch · 18 files changed
+1570/−0 lines, 18 filesdep +HUnitdep +ansi-terminaldep +basesetup-changed
Dependencies added: HUnit, ansi-terminal, base, bytestring, containers, directory, dlist, exceptions, filepath, hex, mtl, network, network-simple, parsec, process, quoridor-hs, snap-core, snap-server, websockets, websockets-snap
Files
- LICENSE +28/−0
- Setup.hs +2/−0
- quoridor-exec/Main.hs +8/−0
- quoridor-hs.cabal +85/−0
- resources/console.html +21/−0
- resources/console.js +38/−0
- resources/style.css +49/−0
- src/Quoridor.hs +329/−0
- src/Quoridor/Cmdline.hs +87/−0
- src/Quoridor/Cmdline/Messages.hs +29/−0
- src/Quoridor/Cmdline/Network/Client.hs +76/−0
- src/Quoridor/Cmdline/Network/Common.hs +50/−0
- src/Quoridor/Cmdline/Network/Server.hs +171/−0
- src/Quoridor/Cmdline/Options.hs +139/−0
- src/Quoridor/Cmdline/Parse.hs +77/−0
- src/Quoridor/Cmdline/Render.hs +219/−0
- src/Quoridor/Helpers.hs +18/−0
- tests/Tests.hs +144/−0
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2015, Tal Walter <talw10@gmail.com>++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 <talw10@gmail.com> 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ quoridor-exec/Main.hs view
@@ -0,0 +1,8 @@+module Main+ ( main+ ) where++import Quoridor.Cmdline (cmdlineMain)++main :: IO ()+main = cmdlineMain
+ quoridor-hs.cabal view
@@ -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 <talw10@gmail.com>+maintainer: Tal Walter <talw10@gmail.com>+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:+ <https://github.com/talw/quoridor-hs>++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
+ resources/console.html view
@@ -0,0 +1,21 @@+<!DOCTYPE HTML>+<html>+ <head>+ <title>WebSockets Console</title>+ <link rel="stylesheet" type="text/css" href="style.css" />+ <script type="text/javascript"+ src="http://code.jquery.com/jquery-1.10.2.min.js"></script>+ <script type="text/javascript" src="console.js"></script>+ </head>+ <body>+ <div>+ <div id="console" style="display: block">+ <div id="console-output"></div>+ <form id="console-input">+ <code>$ </code><input type="text" size="64" id="line" />+ <input type="submit" style="display: none" />+ </form>+ </div>+ </div>+ </body>+</html>
+ resources/console.js view
@@ -0,0 +1,38 @@+function appendOutput(cls, text) {+ $('#console-output').append('<pre class="' + cls + '">' + text + '</pre>');+ $('#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;+ });+});
+ resources/style.css view
@@ -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; }
+ src/Quoridor.hs view
@@ -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
+ src/Quoridor/Cmdline.hs view
@@ -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
+ src/Quoridor/Cmdline/Messages.hs view
@@ -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."+ ]
+ src/Quoridor/Cmdline/Network/Client.hs view
@@ -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+
+ src/Quoridor/Cmdline/Network/Common.hs view
@@ -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
+ src/Quoridor/Cmdline/Network/Server.hs view
@@ -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+
+ src/Quoridor/Cmdline/Options.hs view
@@ -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
+ src/Quoridor/Cmdline/Parse.hs view
@@ -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
+ src/Quoridor/Cmdline/Render.hs view
@@ -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 "<font class=\"%s\">%c</font>" (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 ' '
+ src/Quoridor/Helpers.hs view
@@ -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
+ tests/Tests.hs view
@@ -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'+ ]