h-reversi (empty) → 0.1.0.0
raw patch · 9 files changed
+543/−0 lines, 9 filesdep +QuickCheckdep +basedep +blank-canvassetup-changed
Dependencies added: QuickCheck, base, blank-canvas, containers, h-reversi, hspec, split, stm, text
Files
- ChangeLog.md +5/−0
- LICENSE +20/−0
- Setup.hs +2/−0
- h-reversi.cabal +72/−0
- src/Game/Disc.hs +48/−0
- src/Game/Grid.hs +190/−0
- src/Game/Util.hs +29/−0
- src/Main.hs +139/−0
- test/MovePropSpec.hs +38/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for h-reversi++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2016 Apoorv Ingle++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ h-reversi.cabal view
@@ -0,0 +1,72 @@+-- Initial h-reversi.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: h-reversi+version: 0.1.0.0+synopsis: Reversi game in haskell/blank-canvas+description: Reversi game build in haskell using blank-canvas+homepage: https://github.com/apoorvingle/h-reversi+license: MIT+license-file: LICENSE+author: Apoorv Ingle+maintainer: apoorv.ingle@gmail.com+copyright: Apoorv Ingle+category: Game+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10+tested-with: GHC == 8.0.1++executable h-reversi+ main-is: Main.hs+ ghc-options: + -O3+ -threaded+ -rtsopts+ -- other-modules: + -- other-extensions: + build-depends: base >=4.9 && < 4.10+ , blank-canvas == 0.6+ , containers >= 0.5.7.1+ , hspec >= 2.3.2+ , split >= 0.2.3+ , stm >= 2.4.4.1+ , text >= 1.2.2.1+ hs-source-dirs: src+ default-language: Haskell2010++library+ Exposed-modules: Main+ , Game.Util+ , Game.Grid+ , Game.Disc+ default-language: Haskell2010+ hs-source-dirs: src+ build-depends: QuickCheck >= 2.9.2+ , base >=4.9 && < 4.10+ , blank-canvas == 0.6+ , containers >= 0.5.7.1+ , hspec >= 2.3.2+ , split >= 0.2.3+ , stm >= 2.4.4.1+ , text >= 1.2.2.1+ hs-source-dirs: src+ default-language: Haskell2010++test-suite h-reversi-properties+ type: exitcode-stdio-1.0+ main-is: MovePropSpec.hs+ build-depends: QuickCheck >= 2.9+ , base >= 4.8 && < 4.10+ , containers >= 0.5.7.1+ , h-reversi == 0.1.0.0+ , hspec >= 2.3.2+ , split >= 0.2.3+ , text >= 1.2.2.1+ hs-source-dirs: test+ default-language: Haskell2010+ ghc-options: -threaded -Wall++source-repository head+ type: git+ location: https://github.com/apoorvingle/h-reversi.git
+ src/Game/Disc.hs view
@@ -0,0 +1,48 @@+module Game.Disc where++import Data.Map+import qualified Data.Map as Map+import Data.Text+import Game.Util+import Graphics.Blank+data Disc = White | Black deriving (Show, Eq, Ord)++-- | Swaps the turn+swap :: Disc -> Disc+swap White = Black+swap Black = White++isBlack = (== Black)+isWhite = not . isBlack++-- | Draws the disc in the appropriate position+drawDisc :: Double -> Disc -> Canvas ()+drawDisc radius disc = do+ beginPath()+ arc(0, 0, radius, 0, 2 * pi, False)+ fillStyle $ pack $ clr disc+ fill()+ lineWidth 5+ strokeStyle $ pack $ clr disc+ stroke()++-- | Returns the color of the disk+clr :: Disc -> String+clr Black = "#000000"+clr White = "#ffffff"++drawDiscs sz board =+ sequence_ [ do save()+ translate (sz / 2+ + (1.8 * sz / 9)+ + fromIntegral x * (sz / 9)+ , sz / 2+ -- + (0.5 * sz/9)+ + fromIntegral y * (sz / 9))+ case Map.lookup (x,y) board of+ Just d -> drawDisc (sz / 32) d+ Nothing -> return ()+ restore()+ | x <- [minX..maxX::Int]+ , y <- [minY..maxY::Int]+ ]
+ src/Game/Grid.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE OverloadedStrings #-}++module Game.Grid where++import Control.Applicative+import Control.Arrow+import Data.List.Split+import Data.Map (Map, fromList)+import qualified Data.Map as Map+import Data.Maybe+import qualified Data.Set as Set+import qualified Data.Text as T+import Debug.Trace+import Game.Disc+import Game.Util+import Graphics.Blank++-- | Coordinate system goes from -4 to 3+type Cord = (Int, Int)++type Board = Map Cord Disc++-- | Orientation of the line+-- whether it is North, south east, west, south-east, etc+-- The order is important as it matches with the adjacent square list+data Direction = NW | N | NE | E | SE | S | SW | W+ deriving (Show, Eq, Enum)++grid w h = do+ let sz = min w h+ let sqSize = sz / 9+ clearRect (0,0,w,h)+ beginPath()+ save()+ translate (w / 2, h / 2)+ lineWidth 3+ beginPath()+ strokeStyle "black"+ sequence_ $ computeSquare (-sz/2, -sz/2) sqSize <$> gridCord 8+ fillStyle "green"+ fill()+ stroke()+ restore()++gridCord n = (,) <$> [0..n-1] <*> [0..n-1]++computeSquare (x0, y0) sz (x, y) = sqr (x0 + x*sz, y0 + y * sz, sz)+sqr (x, y, s) = rect (x, y, s, s)++-- | Returns the square co-ordiantes of the click+pointToSq :: (Double, Double) -> Double -> Double -> Maybe Cord+pointToSq (x,y) w h = validate $+ do x' <- Just $ round $ ((x - w / 2) / sz) * 10+ y' <- Just $ round $ ((y - h / 2) / sz) * 10+ return (x', y')+ where sz = min w h++-- | validate if the coordinate is inside the board+validate :: Maybe Cord -> Maybe Cord+validate c@(Just (x , y)) = if (x > maxX || x < minX) || (y > maxY || y < minY)+ then Nothing else c+validate Nothing = Nothing++-- | return the adjacent co-ordinates starting from NE clockwise+adjacent :: Cord -> [Cord]+adjacent (x, y) = Prelude.filter (\(a,b) -> a >= minX && a <= maxX+ && b >= minY && b <= maxY && (a,b) /= (x,y))+ $ (,) <$> [ x-1..x+1 ] <*> [ y-1..y+1 ]++direction :: Cord -> Cord -> Direction+direction (nc_x, nc_y) (oc_x, oc_y)+ | (nc_x > oc_x) && (nc_y > oc_y) = NW+ | (nc_x == oc_x) && (nc_y > oc_y) = N+ | (nc_x < oc_x) && (nc_y > oc_y) = NE+ | (nc_x < oc_x) && (nc_y == oc_y) = E+ | (nc_x < oc_x) && (nc_y < oc_y) = SE+ | (nc_x == oc_x) && (nc_y < oc_y) = S+ | (nc_x > oc_x) && (nc_y < oc_y) = SW+ | (nc_x > oc_x) && (nc_y == oc_y) = W++-- | Gives the next co-ordinate in the given direction+move :: Direction -> Cord -> Maybe Cord+move N (x,y) = validate $ return (x, y-1)+move NE (x,y) = validate $ return (x+1,y-1)+move E (x,y) = validate $ return (x+1,y)+move SE (x,y) = validate $ return (x+1,y+1)+move S (x,y) = validate $ return (x,y+1)+move SW (x,y) = validate $ return (x-1,y+1)+move W (x,y) = validate $ return (x-1,y)+move NW (x,y) = validate $ return (x-1,y-1)++-- | It is a valid move if+-- 1) The current pos is empty+-- 2) There is an adjacent square with opposite colored disc+-- 3) placing the disc creates a sandwich+isValidMove :: Cord -> Map Cord Disc -> Disc -> Bool+isValidMove pos board turn = isEmptySquare pos board+ && areAdjacentSquareOpposite pos board turn+ && sandwiches pos board turn++-- | Condition 1) in @isValidMove@+isEmptySquare :: Cord -> Map Cord Disc -> Bool+isEmptySquare pos board = isNothing $ Map.lookup pos board++-- | Condition 2) in @isValidMove@+areAdjacentSquareOpposite :: Cord -> Map Cord Disc -> Disc -> Bool+areAdjacentSquareOpposite pos board turn = not . null+ $ adjacentOppositeSquares pos board turn++-- | All the squares that are adjacent to the current square and have opposite+-- colored disc+adjacentOppositeSquares :: Cord -> Map Cord Disc -> Disc -> [Maybe Disc]+adjacentOppositeSquares pos board turn =+ filter (== (Just $ swap turn))+ $ flip Map.lookup board <$> adjacent pos++-- | condition 3) in @isValidMove@+-- Select all adjacent squares that have opposite disc+-- For each of those discs get first disk of same color in appropriate direction+-- if any of such discs exist return True+-- else return False+sandwiches :: Cord -> Map Cord Disc -> Disc -> Bool+sandwiches pos board turn = not . null $ filter isJust+ $ allFirstSameDiscs pos board turn++allFirstSameDiscs pos board turn = sds <$> vps+ where+ l d = move d pos+ ps = zip allDirections (l <$> allDirections)+ vps = filter (\(a, Just b) -> isJust (Map.lookup b board)+ && (Map.lookup b board /= Just turn))+ $ filter (isJust . snd)+ $ second validate <$> ps+ sds (d, Just p) = getFirstSameDisc p d board turn+ -- z = zip3 allDirections+ -- $ (l <$> allDirections)+ -- $ ((flip Map.lookup board =<<) <$> (l <$> allDirections))++-- | returns the co-ordinate of the first disc of the same color+-- that appears after 1 or more opposite colored discs+getFirstSameDisc :: Cord -> Direction -> Map Cord Disc -> Disc -> Maybe (Cord, Disc)+getFirstSameDisc pos dir board turn = collapse $ head z+ where+ -- get the series of all the coordinates in the given direction+ l = line pos dir+ md = (flip Map.lookup board =<<) <$> l+ z = dropWhile (\(a,b) -> (b == (Just $ swap turn)))+ $ safeTail+ $ zip l md++updateBoard :: Cord -> Disc -> Board -> Board+updateBoard pos turn board = Map.union (fromList nv) board+ where+ z :: [(Direction, Maybe (Cord, Disc))]+ z = zip allDirections $ allFirstSameDiscs pos board turn+ bs = sequence $ concat $ between pos <$> z+ nv = case bs of+ Just l -> zip l $ repeat turn+ Nothing -> []++-- | returns the sequence of squares from fist position to second position+-- including the start and end+between :: Cord -> (Direction, Maybe (Cord, Disc)) -> [Maybe Cord]+between _ (_, Nothing) = []+between pos1 (_, Just (pos2, disc)) =+ takeWhile (/= Just pos2) $ line pos1 $ direction pos1 pos2++-- | returns a sequence of squares from cord in direction+line :: Cord -> Direction -> [Maybe Cord]+line pos d = l+ where+ l = Just pos : scanl (\c _ -> c >>= move d)+ (Just pos >>= move d) l++allDirections :: [Direction]+allDirections = (toEnum <$> [0..7::Int])::[Direction]++-- | get all valid moves+allValidMoves :: Board -> Disc -> [Cord]+allValidMoves board turn = filter iv cs+ where+ cs = emptyCords board+ iv c = isValidMove c board turn+++emptyCords :: Board -> [Cord]+emptyCords board = Set.toList $ Set.difference bs es+ where+ bs = Set.fromList ((,) <$> [minX..maxX] <*> [minY..maxY])+ es = Set.fromList (fst <$> Map.toList board)
+ src/Game/Util.hs view
@@ -0,0 +1,29 @@+module Game.Util where++minX :: Int+minX = -4++maxX :: Int+maxX = 3++minY :: Int+minY = -4++maxY :: Int+maxY = 3++collapse :: (Maybe a, Maybe b) -> Maybe (a,b)+collapse (Just x, Just y) = Just (x, y)+collapse _ = Nothing++safeLast :: [a] -> Maybe a+safeLast [] = Nothing+safeLast (x:xs) = safeLast xs++safeTail :: [a] -> [a]+safeTail [] = []+safeTail (x:xs) = xs++safeHead :: [a] -> Maybe a+safeHead [] = Nothing+safeHead (x:xs) = Just x
+ src/Main.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Arrow (second)+import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TVar+import Control.Monad (when)+import Data.Map (Map, fromList, toList)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Text (pack)+import Debug.Trace+import Game.Disc+import Game.Grid+import Game.Util+import Graphics.Blank+main :: IO ()+main = do+ boardV <- newTVarIO []+ -- generate some static data for rendering+ startData boardV+ print "starting canvas"+ blankCanvas 3000 {events = ["mousedown"] }+ $ \context -> forever boardV context++startData :: TVar [(Disc, Board)] -> IO ()+startData boardV = atomically $ do+ board <- readTVar boardV+ writeTVar boardV [(White, fromList [((-1,-1), Black),+ ((-1,0), White),+ ((0,0), Black),+ ((0,-1), White)])]+++viewer :: TVar [(Disc, Board)] -> DeviceContext ->IO ()+viewer boardV context = do+ let (cw, ch, sz) = (width context, height context, min cw ch)+ boardStates <- atomically $ readTVar boardV+ let (turn, board) = head boardStates++ --print boardStates+ let blacks = length $ filter (isBlack . snd) $ Map.toList board+ let whites = length $ filter (isWhite . snd) $ Map.toList board+ print (length $ Map.toList board, blacks, whites)++ -- check if valid move exist+ let vs = allValidMoves board turn+ let vs' = allValidMoves board $ swap turn+ send context $ do clearRect (0,0, cw, ch)+ beginPath()+ grid (width context) (height context)+ drawDiscs sz board+ -- print $ (width context, height context)+ printTurn context cw ch turn whites blacks+ save ()++ if not $ null vs+ then do atomically $ do boardStates' <- readTVar boardV+ let board' = snd $ head boardStates'+ when (board == board') retry+ viewer boardV context+ else endGame context cw ch whites blacks++printTurn :: DeviceContext -> Double -> Double -> Disc -> Int -> Int -> Canvas ()+printTurn context cw ch turn whites blacks =+ do clearRect (cw/8, ch*0.95, cw, ch)+ font "italic 15pt Calibri"+ fillText(pack $ "Turn: " ++ show turn ++ " || Score || White: "+ ++ show whites ++ " Black: " ++ show blacks+ , cw/8, ch*0.95)+ save ()++endGame :: DeviceContext -> Double -> Double -> Int -> Int -> IO ()+endGame context cw ch whites blacks = do+ send context+ $ do clearRect (cw/9, ch*0.90, cw, ch)+ font "italic 15pt Calibri"+ fillText(pack $ "Game Over! || Final Score || White: "+ ++ show whites ++ " Black: " ++ show blacks+ ++ " || Winner: "+ ++ (if whites > blacks+ then show White+ else if whites == blacks+ then "Draw"+ else show Black)+ , cw/8, ch*0.95)+ save ()+ print "Game Over!"++play :: TVar [(Disc, Board)] -> DeviceContext -> IO ()+play boardV context = do+ let (cw, ch, sz) = (width context, height context, min cw ch)+ boardStates <- atomically $ readTVar boardV+ let (turn, board) = head boardStates++ let blacks = length $ filter (isBlack . snd) $ Map.toList board+ let whites = length $ filter (isWhite . snd) $ Map.toList board+ -- check if valid move exist+ let vs = allValidMoves board turn+ let vs' = allValidMoves board $ swap turn++ if null vs+ then if null vs'+ then viewer boardV context+ else do print $ show turn ++ " cannot play. swapping.."+ atomically $ do writeTVar boardV+ $ (swap turn, board) : boardStates+ return ()+ play boardV context+ else do print board+ print $ "waiting for turn: " ++ show turn+ event <- wait context+ --print $ ePageXY event+ let sq = ePageXY event >>= \ (x, y) -> pointToSq (x, y) cw ch+ print sq+ turn' <- atomically $ do+ boardStates <- readTVar boardV+ let board = snd $ head boardStates++ case sq of+ Just pos -> case Map.lookup pos board of+ Nothing ->+ if isValidMove pos board turn+ then do writeTVar boardV+ $ (swap turn, updateBoard pos turn board)+ : boardStates+ return $ swap turn+ else return turn+ -- already something here+ Just _ -> return turn+ Nothing -> return turn+ play boardV context++forever :: TVar [(Disc, Board)] -> DeviceContext -> IO ()+forever boardV context= do+ forkIO $ viewer boardV context+ play boardV context+
+ test/MovePropSpec.hs view
@@ -0,0 +1,38 @@+module Main (main) where++import qualified Data.Map as Map+import Data.Set ()+import Game.Grid+import Generators+import Test.Hspec+import Test.QuickCheck++main :: IO ()+main = hspec $+ do playerProgressSpec+ discIncSpec++-- | Property --> after every move the total number of discs increase by one+prop_disc_inc :: GameState -> Bool+prop_disc_inc (GS (disc, board, pos)) =+ 1 + (length $ Map.toList board)+ == length (Map.toList $ updateBoard pos disc board)++discIncSpec :: Spec+discIncSpec = describe "Disc Increment Property"+ $ it "Total increase in no. of discs should be equal to one"+ $ property $ forAll (arbitrary :: Gen GameState)+ $ \gs -> prop_disc_inc gs++-- | Property --> after every move # of discs of the player who played+-- is greater than previous board state+prop_player_progress :: GameState -> Bool+prop_player_progress (GS (turn, board, pos)) =+ (length $ filter (\(_,b) -> b == turn) (Map.toList board))+ < (length $ filter (\(_,b) -> b == turn) (Map.toList $ updateBoard pos turn board))++playerProgressSpec :: Spec+playerProgressSpec = describe "Player progress spec"+ $ it "The player who plays always increments his discs "+ $ property $ forAll (arbitrary:: Gen GameState)+ $ \gs -> prop_player_progress gs