packages feed

haskell-go-checkers 0.1.0.0 → 0.1.1.0

raw patch · 8 files changed

+726/−11 lines, 8 files

Files

+ ChangeLog.md view
@@ -0,0 +1,9 @@+# Revision history for haskell-go-checkers++## 0.1.0.0  -- 2017-04-14++* First version.++## 0.1.1.0  -- 2017-05-07++* A working game
+ Makefile view
@@ -0,0 +1,9 @@+install:+	cabal update+	cabal install++clean:+	cabal clean++run:+	@./dist/build/haskell-go-checkers/haskell-go-checkers
README.md view
@@ -1,8 +1,18 @@ # haskell-go-checkers Go and checkers game in Haskell -1. Install haskell most recent.(>7.10)-2. Clone the repo-3. cabal update-4. cabal install-5. cabal run+## Instructions+* Requirements : **ghc, cabal**+* Install+	```bash+	make+	```+* Run+	```bash+	make run+	```+* Clean+	```bsh+	make clean+	```+
haskell-go-checkers.cabal view
@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.1.0.0+version:             0.1.1.0  -- A short (one-line) description of the package. synopsis:            Go and Checkers game in Haskell@@ -30,7 +30,7 @@ license-file:        LICENSE  -- The package author(s).-author:              Prateek Kumar, Vaibhav Sinha, Anurag Singh+author:              Prateek Kumar, Vaibhav Sinha  -- An email address to which users can send suggestions, bug reports, and -- patches.@@ -45,7 +45,7 @@  -- Extra files to be distributed with the package, such as examples or a -- README.-extra-source-files:  README.md+extra-source-files:  README.md ChangeLog.md Makefile  -- Constraint on the version of Cabal needed to build this package. cabal-version:       >=1.10@@ -56,7 +56,7 @@   main-is:             Main.hs    -- Modules included in this executable, other than Main.-  -- other-modules:+  other-modules:       Go Checkers BoardGo BoardCheckers    -- LANGUAGE extensions used by modules in this package.   -- other-extensions:@@ -70,7 +70,6 @@   -- Base language which the package is written in.   default-language:    Haskell2010 -source-repository this+source-repository head   type:                git   location:            https://github.com/prateekkumarweb/haskell-go-checkers-  tag:                 v0.1.0.0
+ src/BoardCheckers.hs view
@@ -0,0 +1,239 @@+{-|+    This module exports all the functions required by 'playCheckers'+    function in 'Checkers' game.+-}+module BoardCheckers(+    Square(Square),+    Player(Red, Black),+    PieceType(Pawn, King),+    Piece(Empty, Piece),+    Move(March, Jump),+    isJump,+    getDestination,+    getSource,+    BoardMap(BoardMap),+    Board(seekBoard, validMoves, playMove),+    Game(Game),+    mValidJumps,+    startGame+) where++import Data.Map as Map+import Data.List as List++-- | This data type represents a 'Player'+data Player = Red -- ^ To represent 'Red' 'Player'+            | Black -- ^ To represent 'Black' 'Player'+              deriving (Eq) -- Equable++-- | This data type represents a 'Move'+-- Can be either a 'Jump' or a 'March'+data Move = Jump Square Square -- ^ To represent 'Jump' from 'Square' to 'Square'+          | March Square Square -- ^ To represent 'March' from 'Square' to 'Square'+           deriving (Eq) -- Equable++-- | Take a 'Move' and decide if it is a 'Jump' or not+isJump :: Move -> Bool+isJump (Jump _ _ ) = True+isJump (March _ _) = False++-- | Take a 'Move' and return its destination 'Square'+getDestination :: Move -> Square+getDestination (March _ s) = s+getDestination (Jump _ s) = s++-- | Take a 'Move' and return its source 'Square'+getSource :: Move -> Square+getSource (March s _) = s+getSource (Jump s _) = s++-- | This data type represents a 'Square'+-- A 'Square' consists of two ints+data Square = Square Int Int++-- | Makes the 'Square' orderable+instance Ord Square where+    (Square a b) <= (Square c d) = a < c || (a == c && b <= d)++-- | Makes the 'Square' equable+instance Eq Square where+    (Square a b) == (Square c d) = a == c && b == d++-- | This data type represents a 'PieceType'+-- 'PieceType' can be either Pawn or King+data PieceType = Pawn -- ^ To represent Pawn+               | King -- ^ To represent King+                 deriving (Eq) -- Equable++-- | This data type represents 'Piece'+-- 'Piece' can either be empty or fully qualified by its 'PieceType' and 'Player'+data Piece = Empty -- ^ To represent Empty 'Piece', Empty pieces are not shown on board+           | Piece Player PieceType -- ^ To represent a 'Piece' denoted by its 'PieceType' and 'Player'+             deriving (Eq) -- Equable++-- | Test if the given 'Piece' is 'Red'+isRed :: Piece -> Bool+isRed Empty = False+isRed (Piece pl _) = pl == Red++-- | Test if the given 'Piece' is 'Black'+isBlack :: Piece -> Bool+isBlack Empty = False+isBlack (Piece pl _) = pl == Black++-- | This data type represents 'BoardMap'+data BoardMap = BoardMap (Map Square Piece) -- ^ 'BoardMap' is a Map from 'Square' to 'Piece'++-- | This data type represents 'Game'+data Game = Game BoardMap [Move] Player Square -- ^ A 'Game' consists of the 'BoardMap', possible moves of the current 'Player', the current 'Player' and the 'Square' which was clicked++-- | Class Board+class Board board where+    -- | Return the 'Piece' that is at the 'Square' in the board+    seekBoard :: board -> Square -> Piece+    -- | Remove the 'Piece' that is at the 'Square' in the board and return the new board+    removePiece :: board -> Square -> board+    -- | Add the 'Piece' at the 'Square' in the board and return the new board+    addPiece :: board -> Square -> Piece -> board+    -- | Replace the current 'Piece' by the new 'Piece' at the 'Square' in the board and return the new board+    replacePiece :: board -> Square -> Piece -> board+    -- | Return the valid moves of the specified 'Player'+    validMoves :: board -> Player -> [Move]+    -- | Play the 'Move' on the board and return the new board+    playMove :: board -> Move -> board++-- | Set corresponding member functions for the functions of the class+instance Board BoardMap where+    seekBoard = mSeekBoard+    removePiece = mRemovePiece+    addPiece = mAddPiece+    replacePiece = mReplacePiece+    validMoves = mValidMoves+    playMove = mPlayMove++-- Implementation of the Class's functions ------++-- | Return the 'Piece' that is at the 'Square' in the board+mSeekBoard :: BoardMap -> Square -> Piece+mSeekBoard (BoardMap b) sq = case Map.lookup sq b of+    Just piece -> piece+    Nothing -> Empty++-- | Remove the 'Piece' that is at the 'Square' in the board and return the new 'BoardMap'+mRemovePiece :: BoardMap -> Square -> BoardMap+mRemovePiece (BoardMap b) sq = BoardMap $ Map.delete sq b++-- | Add the 'Piece' at the 'Square' in the board and return the new 'BoardMap'+mAddPiece :: BoardMap -> Square -> Piece -> BoardMap+mAddPiece (BoardMap b) sq piece = BoardMap $ Map.insert sq piece b++-- | Replace the current 'Piece' by the new 'Piece' at the 'Square' in the 'BoardMap' and return the new 'BoardMap'+mReplacePiece :: BoardMap -> Square -> Piece -> BoardMap+mReplacePiece b sq piece = addPiece ( removePiece b sq) sq piece+++--- Functions that start the game --------++-- | Return the initial 'BoardMap'+startGame :: BoardMap+-- Add appropriate 'Piece' at all 'Square' of the Board+startGame = addPieces (BoardMap (Map.empty)) squares+    where squares = [(Square x y) | x <- [1..8], y <- [1..8], (mod x 2 == 0 && mod y 2 == 1) || (mod x 2 == 1 && mod y 2 == 0)]++-- | Takes an empty 'BoardMap' and a list of 'Square', adds appropeiate 'Piece' at the squares and returns the new 'BoardMap'+addPieces :: BoardMap -> [Square] -> BoardMap+addPieces (BoardMap m) [] = (BoardMap m)+addPieces (BoardMap m) (x:xs) = addPieces (addPiece (BoardMap m) x $ initialPieceAtSquare x) xs++-- | Takes a 'Square' and returns the 'Piece' that the board has at that 'Square' in the beginning of game+initialPieceAtSquare :: Square -> Piece+initialPieceAtSquare (Square x y) | y <= 3 = (Piece Red Pawn)+                                  | y >= 6 = (Piece Black Pawn)+                                  | otherwise = Empty++--- Member Functions for actual moves ------------++-- | Play the 'Move' on the board and return the new board+mPlayMove :: BoardMap -> Move -> BoardMap+-- During Jump remove the current piece at the current positon, add it at the final position and remove the piece jumped over. Check for promotion to King+mPlayMove board (Jump s1@(Square x1 y1) s2@(Square x2 y2)) | y2 /= 8 && y2 /= 1 = replacePiece (replacePiece (replacePiece board s2 (seekBoard board s1)) s1 Empty) (Square (quot (x1+x2) 2) (quot (y1+y2) 2)) Empty+                                                         | otherwise = replacePiece (replacePiece (replacePiece board s2 (promote $ seekBoard board s1)) s1 Empty) (Square (quot (x1+x2) 2) (quot (y1+y2) 2)) Empty+-- During Move remove the current piece at the current positon, add it at the final position. Check for promotion to King+mPlayMove board (March s1@(Square x1 y1) s2@(Square x2 y2)) | y2 /= 8 && y2 /= 1 = replacePiece (replacePiece board s2 (seekBoard board s1)) s1 Empty+                                                          | otherwise = replacePiece (replacePiece board s2 (promote (seekBoard board s1))) s1 Empty++-- | Promote the Piece pass as argument to a King Piece+promote :: Piece -> Piece+promote (Piece pl ty) = Piece pl King+promote Empty = Empty++-- | Return the valid moves for the 'Player' passed as argument+mValidMoves :: BoardMap -> Player -> [Move]+mValidMoves b pl | length jumpsList > 0 = jumpsList -- If jump is possible then only jumps are allowed+               | otherwise = marchList -- Else return the march list+               where jumpsList = List.foldr (++) [] (List.map (mValidJumps b) (mPlayableSquares b pl)) -- Get the valid jumps for all the Pieces of the current 'Player'+                     marchList = List.foldr (++) [] (List.map (mValidMarches b) (mPlayableSquares b pl)) -- Get the valid jumps for all the Pieces of the current 'Player'++-- | Return a list of all the 'Square' that have the Piece of the currrent 'Player'+mPlayableSquares :: BoardMap -> Player -> [(Square, Piece)]+mPlayableSquares (BoardMap b) pl = List.filter (isSamePlayer pl) (toList b)++-- | Is the 'Player' same the 'Player' of the Piece ?+isSamePlayer :: Player -> (Square, Piece) -> Bool+isSamePlayer p (_, Piece p2 _) = p == p2+isSamePlayer p (_,Empty) = False++-- Functions to calculate the possible jumps -----++-- | Return the valid jumps from the passed 'Square' of the passed 'Player'+mValidJumps :: BoardMap -> (Square, Piece) -> [Move]+mValidJumps b (s@(Square x y), piece@(Piece player ptype)) | player == Black && ptype == Pawn && y >= 3 = validJumpsBlackPawn b s -- Get valid jumps for Black Pawn+                                                         | player == Black && ptype == King = validJumpsBlackKing b s -- Get valid jumps for Black King+                                                         | player == Red && ptype == Pawn && y <= 6 = validJumpsRedPawn b s -- Get valid jumps for Red Pawn+                                                         | player == Red && ptype == King = validJumpsRedKing b s -- Get valid jumps for Red King+                                                         | otherwise = []+mValidJumps _ (_, Empty) = []++-- | Get valid jumps for the passed Black Pawn+validJumpsBlackPawn :: BoardMap -> Square -> [Move]+-- Check if it is possible to Jump in the two directions, if so add to the List+validJumpsBlackPawn board s@(Square x y) = [Jump (Square x y) (Square a b) | (a, b) <- [(x-2, y-2), (x+2, y-2)], a >= 1 && a <= 8 && b >= 1 && b <= 8, seekBoard board (Square a b) == Empty, isRed $ seekBoard board (Square (quot (a+x) 2) (quot (b+y) 2))]++-- | Get valid jumps for the passed Red Pawn+validJumpsRedPawn :: BoardMap -> Square -> [Move]+-- Check if it is possible to Jump in the two directions, if so add to the List+validJumpsRedPawn board s@(Square x y) = [Jump (Square x y) (Square a b) | (a, b) <- [(x-2, y+2), (x+2, y+2)], a >= 1 && a <= 8 && b >= 1 && b <= 8, seekBoard board (Square a b) == Empty, isBlack $ seekBoard board (Square (quot (a+x) 2) (quot (b+y) 2))]++-- | Get valid jumps for the passed Black King+validJumpsBlackKing :: BoardMap -> Square -> [Move]+-- Check if it is possible to Jump in the four directions, if so add to the List+validJumpsBlackKing board s@(Square x y) = [Jump (Square x y) (Square a b) | a <- [x-2, x+2], b <- [y-2, y+2], a >= 1 && a <= 8 && b >= 1 && b <= 8, seekBoard board (Square a b) == Empty, isRed $ seekBoard board (Square (quot (a+x) 2) (quot (b+y) 2))]++-- | Get valid jumps for the passed Red King+validJumpsRedKing :: BoardMap -> Square -> [Move]+-- Check if it is possible to Jump in the four directions, if so add to the List+validJumpsRedKing board s@(Square x y) = [Jump (Square x y) (Square a b) | a <- [x-2, x+2], b <- [y-2, y+2], a >= 1 && a <= 8 && b >= 1 && b <= 8, seekBoard board (Square a b) == Empty, isBlack $ seekBoard board (Square (quot (a+x) 2) (quot (b+y) 2))]++-- Functions to calculate the possible marches -----++-- | Return the valid marches from the passed Square of the passed 'Player'+mValidMarches :: BoardMap -> (Square, Piece) -> [Move]+mValidMarches b (s@(Square x y), piece@(Piece player ptype)) | player == Black && ptype == Pawn && y >= 2 = validMarchesBlackPawn b s -- Get valid marches for Black Pawn+                                                           | ptype == King = validMarchesKing b s -- Get valid marches for King+                                                           | player == Red && ptype == Pawn && y <= 7 = validMarchesRedPawn b s -- Get valid marches for Red Pawn+                                                           | otherwise = []++-- | Get valid marches for the passed King+validMarchesKing :: BoardMap -> Square -> [Move]+-- Check if it is possible to March in the four directions, if so add to the List+validMarchesKing board s@(Square x y) = [March (Square x y) (Square a b) | a <- [x-1, x+1], b <- [y-1, y+1], a >= 1 && a <= 8 && b >= 1 && b <= 8, seekBoard board (Square a b) == Empty]++-- | Get valid marches for the passed Black Pawn+validMarchesBlackPawn :: BoardMap -> Square -> [Move]+-- Check if it is possible to March in the two directions, if so add to the List+validMarchesBlackPawn board s@(Square x y) = [March (Square x y) (Square a b) | (a, b) <- [(x-1, y-1), (x+1, y-1)], a >= 1 && a <= 8 && b >= 1 && b <= 8, seekBoard board (Square a b) == Empty]++-- | Get valid marches for the passed Red Pawn+validMarchesRedPawn :: BoardMap -> Square -> [Move]+-- Check if it is possible to March in the two directions, if so add to the List+validMarchesRedPawn board s@(Square x y) = [March (Square x y) (Square a b) | (a, b) <- [(x-1, y+1), (x+1, y+1)], a >= 1 && a <= 8 && b >= 1 && b <= 8, seekBoard board (Square a b) == Empty]
+ src/BoardGo.hs view
@@ -0,0 +1,308 @@+{-|+    This module exports all the functions required by 'playGo'+    function in 'Go' game.+-}+module BoardGo(+    Point(Point),+    Stone(Black, White, Ko, Empty),+    getOppositeStone,+    Move(Pass, Move),+    getPiece,+    GameStatus(Alive, Dead, Over),+    Game(Game),+    createGame,+    killGame,+    seekBoard,+    removeKo,+    removePiece,+    playPass,+    validMove,+    playMove,+    finishGame,+    getWinner+) where++import Data.Map as Map+import Data.List as List++-- | This data type represents a 'Point' in Board of Go (i.e. intersection of two lines)+data Point = Point Int Int -- ^ Point constructor takes two coordinates x and y+           deriving (Ord, Eq)++-- | This data type represents 'Stone' placed on the board+data Stone = Black -- ^ To represent 'Black' stone+           | White -- ^ To represent 'White' stone+           | Ko -- ^ 'Ko' is not shown on the board. Placed when Ko situation occurs+           | Empty -- ^ To represent that nothing is placed on the point+           deriving (Eq, Show)++-- | 'getOppositeStone' returns opposite stone of given 'Stone'+getOppositeStone :: Stone -> Stone+getOppositeStone stone | stone == Black = White+                      | stone == White = Black+                      | otherwise = Empty++-- | This data type represents a 'Move' that can be performed on the board by a player+data Move = Pass Stone -- ^ Player with this 'Stone' plays pass+          | Move Point Stone -- ^ Player with this 'Stone' plays on a 'Point'+          deriving (Eq)++-- | 'getPiece' returns the 'Stone' from a given 'Move'+getPiece :: Move -> Stone+getPiece (Pass st) = st+getPiece (Move  _ st) = st++-- | This data type reprsents 'Game'+data Game = Game {+    board :: Map Point Stone, -- ^ Map from point to stone+    lastMove :: Move, -- ^ Last move that was played in the game+    boardSize :: Int, -- ^ Board size 9 or 13 or 19+    scoreBlack :: Int, -- ^ Score of Black stone+    scoreWhite :: Int, -- ^ Score of White stone+    status :: GameStatus -- ^ Status of the game whether game is running or over+}++-- | 'GameStatus' represents state of the game if game is alive or dead or over+data GameStatus = Alive -- ^ game is running+                | Dead -- ^ game is over and hopeless string is counted+                | Over -- ^ Game over and results are shown on the screen+                deriving (Eq)++-- | 'createGame' takes a size and returns a 'Game' object+createGame :: Int -> Game+createGame size = Game{+    board = addPieces (Map.empty) points,+    lastMove = Move (Point (-1) (-1)) White,+    boardSize = size,+    scoreBlack = 0,+    scoreWhite = 0,+    status = Alive+} where points = [(Point x y) | x <- [1..size], y <- [1..size]]++-- | 'addPieces' adds Empty to set of points in a map+addPieces :: (Map Point Stone) -> [Point] -> (Map Point Stone)+addPieces m [] = m+addPieces m (x:xs) = addPieces (Map.insert x Empty m) xs++-- | 'killGame' changes game status from 'Alive' to 'Dead' and increases the score of 'Black'+-- as 'White' plays the last 'Pass'.+killGame :: Game -> Game+killGame game@(Game m lm s sb sw Alive) = Game m lm s (sb+1) sw Dead+killGame game = game++-- | 'removeKo' removes 'Ko' from the 'Game'+removeKo :: Game -> Game+removeKo game@(Game m lm s b w status) = (Game newBoard lm s b w status)+    where pointsWithKo = List.filter (\(p, s) -> s == Ko) (assocs m)+          newBoard = if pointsWithKo == [] then m else addPiece m (fst (pointsWithKo !! 0)) Empty++-- | 'addPiece' adds a element of type t to map+addPiece :: (Map Point t) -> Point -> t -> (Map Point t)+addPiece m point stone = Map.insert point stone (Map.delete point m)++-- | 'removePiece' removes the stone from given point in the map+removePiece :: (Map Point Stone) -> Point -> (Map Point Stone)+removePiece m point = addPiece m point Empty++-- | 'playPass' adds 'Pass' move by the 'Stone' on the 'Game'+playPass :: Game -> Stone -> Game+playPass game@(Game board lm s sb sw status) stone = Game {+    board = board,+    lastMove = Pass stone,+    boardSize = s,+    scoreBlack = newsb,+    scoreWhite = newsw,+    status = status+} where+    -- | Increase score of opposite stone+    newsb = if stone == Black then sb else (sb+1)+    newsw = if stone == White then sw else (sw+1)++-- | 'playMove' adds 'Move' to 'Point' by 'Stone' on the 'Game'.+-- After playing the move, also removes the captured points of the opposite stone if present+playMove :: Game -> Point -> Stone -> Game+playMove game@(Game board lm s sb sw status) point stone = removeGroups Game {+    board = addPiece board point stone,+    lastMove = Move point stone,+    boardSize = s,+    scoreBlack = sb,+    scoreWhite = sw,+    status = status+} point ostone where ostone = getOppositeStone stone++-- | 'removeGroups' removes captured stones of 'Stone' from the 'Game' starting from+-- 'Point' and moving in all four directions+removeGroups :: Game -> Point -> Stone -> Game+removeGroups game@(Game board lm s sb sw status) point@(Point x y) stone+    -- If number of points captured is one then check if Ko is formed and add Ko to the board if neccesary+    | length pointsToBeRemoved == 1 && isKo = updateScore (addKo (removeStones game pointsToBeRemoved) (pointsToBeRemoved !! 0)) 1 stone'+    | otherwise = updateScore (removeStones game pointsToBeRemoved) (length pointsToBeRemoved) stone'+    where (up, down, left, right) = getAdj point+          removeUp = removeDead up stone game+          removeDown = removeDead down stone game+          removeLeft = removeDead left stone game+          removeRight = removeDead right stone game+          pointsToBeRemoved = removeUp ++ removeDown ++ removeLeft ++ removeRight+          point' = if length removeUp == 1 then up else if length removeDown == 1 then down else if length removeLeft == 1 then left else right+          (up', down', left', right') = getAdj point'+          stone' = getOppositeStone stone+          isKo = length ((removeDead up' stone' game) ++ (removeDead down' stone' game) ++ (removeDead left' stone' game) ++ (removeDead right' stone' game)) == 1++-- | 'getAdj' returns adjacent points of a given 'Point'+getAdj :: Point -> (Point, Point, Point, Point)+getAdj (Point x y) = (Point x (y+1), Point x (y-1), Point (x-1) y, Point (x+1) y)++-- | 'removeDead' returns dead groups of 'Stone' in 'Game' starting from 'Point'+removeDead :: Point -> Stone -> Game -> [Maybe Point]+removeDead point stone game | checkIfTrapped game point stone = removablePoints+                            | otherwise = []+                            where removablePoints = (findTrappedGroup game point stone [])++-- | 'updateScore' updates the score of 'Stone' by given 'Int'+updateScore :: Game -> Int -> Stone -> Game+updateScore game@(Game m lm s b w status) p st+    | st == Black = (Game m lm s (b+p) w status)+    | otherwise = (Game m lm s b (w+p) status)++-- | 'addKo' adds 'Ko' to the game at given point+addKo :: Game -> (Maybe Point) -> Game+addKo game@(Game m lm s b w status) (Just p) = (Game (addPiece m p Ko) lm s b w status)++-- | 'removeStones' given a list of points removes stones from all those pieces in the game+removeStones :: Game -> [Maybe Point] -> Game+removeStones game@(Game m lm _ _ _ status) [] = game+removeStones game@(Game m lm s b w status) (Nothing:xs) = game+removeStones game@(Game m lm s b w status) ((Just p):xs) = removeStones (Game (removePiece m p) lm s b w status) xs++-- | 'seekBoard' returns the 'Stone' at given 'Point' in the 'Game'+seekBoard :: Game -> Point -> Stone+seekBoard (Game m _ _ _ _ _) p = case Map.lookup p m of+    Just stone -> stone+    Nothing -> Empty++-- | This data type represents whether corresponding stone belongs to Black or White or None+data Status = Seen | Unseen | SeenW | SeenB | None deriving (Eq)++-- | 'seekMap' returns the 'Status' of 'Point' from a given map+seekMap :: (Map Point Status) -> Point -> Status+seekMap m p = case Map.lookup p m of+    Just s -> s+    Nothing -> Unseen++-- | 'findTrappedGroup' finds trapped group of stones in the game+-- starting from point and going in all directions+findTrappedGroup :: Game -> Point -> Stone -> [Maybe Point] -> [Maybe Point]+findTrappedGroup game@(Game m move@(Move pt st) boardSize _ _ _) point@(Point x y) stone seenPoints+    | x < 1 || x > boardSize || y < 1 || y > boardSize  = seenPoints+    | elem (pure point) seenPoints = seenPoints+    | seekBoard game point == Empty = Nothing:seenPoints+    | seekBoard game point == Ko = Nothing:seenPoints+    | seekBoard game point /= stone = seenPoints+    | otherwise = findTrappedGroup game left stone+        $ findTrappedGroup game right stone+        $ findTrappedGroup game up stone+        $ findTrappedGroup game down stone ((pure point):seenPoints)+    where up = Point x (y+1)+          down = Point x (y-1)+          right = Point (x+1) y+          left = Point (x-1) y++-- | 'findTerritory' finds territory of a given point in the game+-- starting from point and going in all directions+findTerritory :: Game -> Point -> Stone -> ((Map Point Status), [Maybe Point]) -> ((Map Point Status), [Maybe Point])+findTerritory game@(Game _ _ boardSize _ _ _) point@(Point x y) stone (m, points)+    | x < 1 || x > boardSize || y < 1 || y > boardSize = (m, points) -- If point is out of board+    | elem (pure point) points = (m, points) -- If we have already visited this point+    | seekBoard game point == getOppositeStone stone = (m, Nothing:points) -- If this point has opposite stone+    | seekBoard game point == stone = (m, points) -- If this point has current stone+    | otherwise = findTerritory game left stone+        $ findTerritory game right stone+        $ findTerritory game up stone+        $ findTerritory game down stone ((Map.insert point Seen m), ((pure point):points)) -- Otherwise recure on all adjacent points of the stone+    where (up, down, left, right) = getAdj point++-- | 'findTerritories' finds terrirtories of either Black or White stone from given Point+findTerritories :: Game -> Point -> (Map Point Status) -> (Map Point Status)+findTerritories game point m+    | seekBoard game point /= Empty && seekBoard game point /= Ko = addPiece m point None -- If point has Ko or Empty+    | seekMap m point == SeenW = m -- If point belongs to White's territory+    | seekMap m point == SeenB = m -- If point belongs to Black's territory+    | seekMap m point == None = m -- If point has been seen and belongs to none+    | otherwise = if elem Nothing (snd tw) then+                      if elem Nothing (snd tb) then setInMap m (snd tb) None+                      else setInMap m (snd tb) SeenB+                  else setInMap m (snd tw) SeenW+    where tb = findTerritory game point Black (m, [])+          tw = findTerritory game point White (m, [])++-- | 'setInMap' sets staus of points in the map+setInMap :: (Map Point Status) -> [Maybe Point] -> Status -> (Map Point Status)+setInMap m [] st = m+setInMap m (point:points) st | point /= Nothing = setInMap (addPiece m (purify point) st) points st+                             | otherwise = setInMap m points st++-- | 'findAllTerritoriesOfPoints' calulates all the territories of given list of points in Game+findAllTerritoriesOfPoints :: Game -> [Point] -> (Map Point Status) -> (Map Point Status)+findAllTerritoriesOfPoints game [] m = m+findAllTerritoriesOfPoints game (point:points) m = findAllTerritoriesOfPoints game points (findTerritories game point m)++-- | 'findTerritories' creates list of points and finds territories for all the points in the game+findAllTerritories :: Game -> (Map Point Status)+findAllTerritories game@(Game _ _ boardSize _ _ _) = findAllTerritoriesOfPoints game points Map.empty+    where points = [(Point x y) | x <- [1..boardSize], y <- [1..boardSize]]++-- | 'finishGame' finds all the captured territories in the 'Game' and updates the correspoing scores of the 'Stone'+finishGame :: Game -> Game+finishGame game@(Game m lm s sb sw status) = Game m lm s sb' sw' Over+    where sb' = sb + countSeenB t s+          sw' = sw + countSeenW t s+          t = findAllTerritories game++-- | 'countSeenB' counts the points that belong to territory of Black+countSeenB :: (Map Point Status) -> Int -> Int+countSeenB m size | l == size*size = 0 -- If board is empty then it cannot be territory+                  | otherwise = l+                  where l = length $ List.filter (\(p,s) -> s == SeenB) (assocs m)++-- | 'countSeenW' counts the points that belong to territory of White+countSeenW :: (Map Point Status) -> Int -> Int+countSeenW m size | l == size*size = 0 -- If board is empty then it cannot be territory+                  | otherwise = l+                  where l = length $ List.filter (\(p,s) -> s == SeenW) (assocs m)+-- | 'purify' changes Maybe Type to Type+purify :: Maybe a -> a+purify (Just a) = a++-- | 'validMove' checks if the move of given 'Point' to given 'Stone' is valid or not+validMove :: Game -> Point -> Stone -> Bool+validMove game@(Game m lm s _ _ _) p@(Point x y) st | x < 1 || x > s || y < 1 || y > s = False+    | seekBoard game p /= Empty = False -- If point is not empty+    | not $ checkIfTrapped game1 p st = True -- If point is not trapped then validmove+    -- If point is trapped then check if on placing the stone whether opposites stone sare captured or not+    | (seekBoard game up == ostone) && (checkIfTrapped game1 up ostone) = True+    | (seekBoard game down == ostone) && (checkIfTrapped game1 down ostone) = True+    | (seekBoard game left == ostone) && (checkIfTrapped game1 left ostone) = True+    | (seekBoard game right == ostone) && (checkIfTrapped game1 right ostone) = True+    | otherwise = False+    where game1 = playMove game p st+          ostone = getOppositeStone st+          up = Point x (y+1)+          down = Point x (y-1)+          right = Point (x+1) y+          left = Point (x-1) y++-- | 'checkIfTrapped' checks whether a stone is trapped or not+checkIfTrapped :: Game -> Point -> Stone -> Bool+checkIfTrapped game p st = not $ elem Nothing (findTrappedGroup game p st [])++-- | 'checkIfNothing' checks whether 'Maybe Point' is 'Nothing'+checkIfNothing :: (Maybe Point) -> Bool+checkIfNothing Nothing = True+checkIfNothing (Just point) = False++-- | 'getWinner' declares the winner depending on the scores of the stones+getWinner :: Game -> String+getWinner game@(Game _ _ _ sb sw _)+    | sb > sw = "Black wins." -- If 'Black' score is more than 'White' score+    | sw > sb = "White wins." -- If 'White' score is more than 'Black' score+    | otherwise = "Game Draws" -- If both the scores are equal
+ src/Checkers.hs view
@@ -0,0 +1,74 @@+{-|+    This module has only one function 'playCheckers' that asks+    creates a game and starts the game window.+-}+module Checkers(playCheckers) where++import Data.Map+import BoardCheckers+import Graphics.Gloss+import Graphics.Gloss.Interface.IO.Game++-- | Main function that plays Checkers+playCheckers :: IO()+-- | Play the Game+playCheckers = play window (dark yellow) 0 game render handleEvent (\_ y -> y)+    where -- | The window for 'Game'+          window = InWindow "Checkers Window" (600, 600) (10, 10)+          -- | Get the initial 'BoardMap'+          s = startGame+          -- | Get the starting moves for 'Black'+          moves = validMoves s Black+          -- | Initialize 'Game'+          game = Game s moves Black $ Square (-1) (-1)++-- | Take the 'Game' and return the picture for the "Game"+render :: BoardCheckers.Game -> Picture+-- The final Picture is a collection of blackBoxes, boardBox, greenSquares, blueSquare, pieces, kings+render game@(Game (BoardMap board) moves player (Square x y) ) = pictures [boardBox, (pictures blackboxes), blueSquare, pictures greenSquares, (pictures pieces), (pictures kings), playerBox]+    where -- | Blackboxes of board+          blackboxes = [translate (fromIntegral (2*x -9)*30) (fromIntegral (9-2*y)*30) $ color (greyN 0.25) $ rectangleSolid 60 60 | (Square x y,b) <- assocs board ]+          -- | Pieces on board+          pieces = [translate (fromIntegral (2*x -9)*30) (fromIntegral (9-2*y)*30) $ color c $ circleSolid 24 | (Square x y, Piece pl pt) <- assocs board, c <- [black,red], pl == Black && c == black || pl == Red && c == red]+          -- | Kings on board+          kings = [translate (fromIntegral (2*x -9)*30) (fromIntegral (9-2*y)*30) $ scale 0.17 0.17 $ color white $ text "K" | (Square x y, Piece pl pt) <- assocs board, pt == King]+          -- | Surrounding boardBox+          boardBox = color white $ rectangleSolid 480 480+          -- | Clicked Blue Square+          blueSquare = if x /= (-1) then translate (fromIntegral (2*x -9)*30) (fromIntegral (9-2*y)*30) $ color (light blue) $ rectangleSolid 60 60+                       else translate (fromIntegral (2*x -9)*30) (fromIntegral (9-2*y)*30) $ color (dark yellow) $ rectangleSolid 60 60+          -- | Dest greenSquares+          greenSquares = if x /= (-1) then [ translate (fromIntegral (2*a -9)*30) (fromIntegral (9-2*b)*30) $ color (light green) $ rectangleSolid 60 60 | move <- moves, a <- [1..8], b <- [1..8], getSource move == Square x y, getDestination move == Square a b] else []+          -- | Display turn and log+          playerBox = if length moves == 0 then translate (-100) 270 $ scale 0.2 0.2 $ text $ "Game Over " ++ (if player == Red then "Black wins" else "Red wins")+                      else translate (-100) 270 $ scale 0.2 0.2 $ text $ (if player == Red then "Red's turn" else "Black's turn")++-- | Takes an event and 'Game' and returns the board after the result of this event+handleEvent :: Event -> BoardCheckers.Game -> BoardCheckers.Game+-- | When the left mouse button is pressed ..+handleEvent (EventKey (MouseButton LeftButton) Down _ (x, y)) game@(Game board moves player _)+    | x' < 1 || x' > 8 || y' < 1 || y' > 8 = game -- If pressed outside board do nothing+    | otherwise = Game board moves player $ Square x' y' -- Otherwise update the clicked 'Square'+    where x' = round $ (x+270)/60 -- Get the x coordinate of the clicked square+          y' = round $ (270-y)/60 -- Get the y coordinate of the clicked square+-- | When the left mouse button is unclicked ..+handleEvent (EventKey (MouseButton LeftButton) Up _ (x, y)) game@(Game board moves player (Square x' y'))+    | not isValid = game -- If the move to be done is not a valid move do nothing+    | isJump move && length moreJumps > 0 = Game newBoard moreJumps player $ Square (-1) (-1) -- If the player can continue jumping+    | otherwise = Game newBoard nextMoves nextPlayer $ Square (-1) (-1) -- Else the turn goes to the opposite player+    where (move, isValid) = getMoveFromMoves (Square x' y') (Square x'' y'') moves+          x'' = round $ (x+270)/60 -- Get the x coordinate of the clicked square+          y'' = round $ (270-y)/60 -- Get the y coordinate of the clicked square+          newBoard = playMove board move -- Obtain the new Board by playing the move+          moreJumps = mValidJumps newBoard (Square x'' y'', seekBoard newBoard $ Square x'' y'')  -- Get the jumps possible form the dest 'Sqaure'+          nextPlayer = if player == Red then Black else Red -- Get the next Player+          nextMoves = validMoves newBoard nextPlayer -- Get the moves op the next player+handleEvent _ game = game -- Rest of the events - no response++-- | Takes a src and a dest 'Square' and moves and returns if there is a 'Jump' or a 'March' from src to dest+getMoveFromMoves :: Square -> Square -> [Move] -> (Move, Bool)+getMoveFromMoves src dest moves | not foundMove && not foundJump = (Jump src dest, False) -- If not found set False+                                | not foundMove = (Jump src dest, True) -- If 'Jump' found return the 'Jump' and True+                                | otherwise = (March src dest, True) -- If 'March' found return the 'March' and True+                                where foundMove = elem (March src dest) moves+                                      foundJump = elem (Jump src dest) moves
+ src/Go.hs view
@@ -0,0 +1,67 @@+{-|+    This module has only one function 'playGo' that asks+    user for size as input, creates a game and starts the game window.+-}+module Go(playGo) where++import Data.Map+import BoardGo+import Graphics.Gloss+import Graphics.Gloss.Interface.IO.Game++-- | 'PlayGo' functions asks for size of board, creates a 'Game' object and starts the game display+playGo :: IO ()+playGo = do+    putStrLn "Please enter the size of the board - 9 13 or 19"+    sizeString <- getLine+    let size = read sizeString+    -- If invalid size is given then ask again+    if size /= 9 && size /= 13 && size /= 19 then playGo else do+        let game = createGame size+        let window = InWindow "Go Window" (20 * size + 180, 20 * size +240) (10, 10)+        play window (dark yellow) 0 game render handleEvent (\_ y -> y)++-- | 'handleEvent' handles mouse click and keyboard events+handleEvent :: Event -> Game -> Game+-- ^ If clicked on point on alive game, then check if valid move and play the move+handleEvent (EventKey (MouseButton LeftButton) Down _ (x, y)) game@(Game _ lm s _ _ Alive)+    | validMove game p st = playMove (removeKo game) p st+    where p = BoardGo.Point (round ((x + 10*(fromIntegral s+1))/20)) (round ((-1*y + 10*(fromIntegral s+1))/20))+          st = getOppositeStoneFromLastMove lm+-- ^ If p is pressed on keyboard on alive game then play pass by current stone+handleEvent (EventKey (Char 'p') Down _ _) game@(Game _ lm s _ _ Alive)+    | lm == Pass Black = killGame game+    | otherwise = playPass (removeKo game) st+    where st = getOppositeStoneFromLastMove lm+-- ^ If clicked on point on dead game then take the point as part of hopeless string+handleEvent (EventKey (MouseButton LeftButton) Down _ (x, y)) game@(Game m lm s sb sw Dead) = Game (removePiece m (BoardGo.Point x' y')) lm s sb' sw' Dead+    where x' = round ((x + 10*(fromIntegral s+1))/20)+          y' = round ((-1*y + 10*(fromIntegral s+1))/20)+          sb' = if seekBoard game (BoardGo.Point x' y') == White then sb+1 else sb+          sw' = if seekBoard game (BoardGo.Point x' y') == Black then sw+1 else sw+-- ^ If e is pressed on keyboard on dead group then end the game+handleEvent (EventKey (Char 'e') Down _ _) game@(Game _ lm s _ _ Dead) = finishGame game+-- ^ Ignore all other events+handleEvent _ game = game++-- | This function returns opposite stone from given 'Move'+getOppositeStoneFromLastMove :: Move -> Stone+getOppositeStoneFromLastMove (Move _ st) = getOppositeStone st+getOppositeStoneFromLastMove (Pass st) = getOppositeStone st++-- | 'render' functions gives picture of the Game that will be displayed on the window+render :: Game -> Picture+render game@(Game m lm s sb sw status) = pictures [ (pictures gameHorizontalLines), (pictures gameVerticalLines), (pictures stones),  scoreBlack, scoreWhite, statusText]+    where -- Horizontal and vertical lines of the board+          gameHorizontalLines = [line [(fromIntegral (10 - 10*s),fromIntegral (10*s - 10 - 20*x)), (fromIntegral (20*s - 10 - 10*s),fromIntegral (10*s - 10 - 20*x))] | x <- [0..(s-1)]]+          gameVerticalLines = [line [(fromIntegral (10*s - 10 - 20*x),fromIntegral (10 - 10*s)), (fromIntegral (10*s - 10 - 20*x),fromIntegral (-10*s + 20*s - 10))] | x <- [0..(s-1)]]+          -- All stones present on the game+          stones = [translate (fromIntegral (x*20 - 10*s-10)) (fromIntegral (10*s - y*20 + 10)) $ color c $ circleSolid 8 | (BoardGo.Point x y, st) <- (assocs m) , c <- [black,white], ((st == Black && c == black) ||  (st == White && c == white))]+          -- Score of black stone+          scoreBlack = translate 0 (fromIntegral (10*s + 40)) $ scale 0.1 0.1 $ text $ "Black's Score : " ++ (show sb)+          -- Score of White stone+          scoreWhite = translate 0 (fromIntegral (10*s + 60)) $ scale 0.1 0.1 $ text $ "White's Score : " ++ (show sw)+          -- Display tirn if game is alive or instruction for capturing hopeless strings if game is dead oe winner if game is over+          statusText = if status == Alive then translate (fromIntegral (-10*s)) (fromIntegral (-10*s - 60)) $ scale 0.2 0.2 $ text $ (show $ getOppositeStone (getPiece lm)) ++ "'s turn"+                       else if status == Dead then translate (fromIntegral (-10*s)) (fromIntegral (-10*s - 60)) $ scale 0.1 0.1 $ text "Click on hopeless stones and enter e"+                       else translate (fromIntegral (-10*s)) (fromIntegral (-10*s - 60)) $ scale 0.2 0.2 $ text $ getWinner game