-- implements the Logical Rules of Go (http://tromp.github.io/go.html) {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Go where import Data.List import Control.Monad.State -- article 1a: Go is played on a 19x19 square grid of points size = 19 coords = [1..size] type Point = (Int,Int) points = [(x,y) | x<-coords, y<-coords] -- article 1b: by two players called Black and White data Player = Black | White deriving (Eq, Show) -- article 2: Each point on the grid may be colored black, white or empty. data Color = Empty | Stone Player deriving (Eq, Show) type Position = Point -> Color -- article 3b: if there is a path of (vertically or horizontally) adjacent points of P's color from P neighbours (x,y) = [(x,y1) | y1<-neighbours1 y] ++ [(x1,y) | x1<-neighbours1 x] where neighbours1 z = [pred z | z/=1] ++ [succ z | z/=size] string pos point = join (expand [[point],[]]) where expand l@(curr:prev:_) = if (null next) then l else expand (next:l) where next = nub [nbr | nbr <- curr>>=neighbours, pos nbr==pos point] \\ prev -- article 4: Clearing a color is the process of emptying all points of that color clear pos points = \pt -> if pt `elem` captured then Empty else pos pt where captured = join [str | pt<-points, let str=string pos pt, null (liberties pos str)] -- article 4b: that don't reach empty. liberties pos group = nub [nbr | nbr<-group>>=neighbours, pos nbr==Empty] -- article 5a: Starting with an empty grid emptypos = const Empty -- article 5b: the players alternate turns, starting with Black. results turns = evalState (sequence $ zipWith play (cycle [Black,White]) turns) [emptypos] -- article 6a: A turn is either a pass; or a move data Turn = Pass | Move Point deriving (Show) -- article 6b: that doesn't repeat an earlier grid coloring. data GoError = Occupied | Superko Int deriving (Eq, Show) -- cycle length testko pos past noko = case elemIndex (map pos points) (map (`map` points) past) of Just i -> return $ Left $ Superko (1+i) Nothing -> noko -- article 7: A move consists of coloring an empty point one's own color; then clearing the opponent color, and then clearing one's own color. move player point pos = pos3 where pos1 = \pt -> if pt==point then (Stone player) else pos pt opponent = [nbr|nbr<-neighbours point, (Stone p)<-[pos1 nbr], p/=player] pos2 = clear pos1 opponent pos3 = clear pos2 [point] play player Pass = do past@(pos:_) <- get put (pos:past) return $ Right $ show (length past) ++ ". " ++ show player ++ " pass\n" ++ gameover past play player (Move point) = do past@(pos:_) <- get let pos' = move player point pos if pos point /= Empty then return (Left Occupied) else let pos' = move player point pos in testko pos' past $ do put (pos':past) return $ Right $ show (length past) ++ ". " ++ show player++" "++show point++"\n\n"++showpos pos' -- article 8: The game ends after two consecutive passes. gameover (pos:pos':_) | map pos points == map pos' points = "\nGame Over. Black: " ++ show bscore ++ " White: " ++ show wscore ++ ". " ++ winner bscore wscore ++ "\n" where (bscore, wscore) = (score pos Black, score pos White) gameover _ = "" -- article 9: A player's score is the number of points of her color, plus the number of empty points that reach only her color. score pos player = sum $ map scorepoint points where scorepoint pt = case pos pt of Stone p | p == player -> 1 | otherwise -> 0 Empty | owners == [player] -> 1 | otherwise ->0 where owners = nub [p|(Stone p)<-string pos pt>>=neighbours>>=return.pos] -- article 10: The player with the higher score at the end of the game is the winner. Equal scores result in a tie. winner bscore wscore = case compare bscore wscore of LT -> "White wins." EQ -> "It's a tie." GT -> "Black wins." -- show stuff showpos pos = unlines (map showrow (reverse coords)) where showrow y = ' ':intersperse ' ' [tochar (pos(x,y))|x<-coords] tochar (Stone Black) = '@' tochar (Stone White) = 'O' tochar Empty = '.' showgame game = do putStrLn $ showpos emptypos mapM_ (putStrLn . either (error.show) id) (results game) -- example game game = [Move (2,1), Move (2,3), Move (2,2), Move (3,2), Move (1,2), Pass, Pass] main = showgame game