module PlayTak.Parser (parsePlayTak, PlayTakMsg(..)) where
import qualified Data.ByteString as BS
import Data.List
import Data.Maybe
import Text.Parsec hiding (char, string, space)
import qualified Text.Parsec as Parsec
import Tak
import PlayTak.Types
type Parser a = Parsec BS.ByteString () a
parsePlayTak :: BS.ByteString -> Either ParseError PlayTakMsg
parsePlayTak str = parse playtak "" str
playtak :: Parser PlayTakMsg
playtak = welcome
<|> loginOrRegister
<|> loggedIn
<|> seek
<|> online
<|> shout
<|> gameStart
<|> game
<|> gamelist
<|> message
<|> errorMsg
<|> nok
<|> ok
welcome :: Parser PlayTakMsg
welcome = try (string "Welcome!") >> return Welcome
loginOrRegister :: Parser PlayTakMsg
loginOrRegister = string "Login or Register" >> return PleaseLogin
loggedIn :: Parser PlayTakMsg
loggedIn = do
try $ string "Welcome"
space
name <- username
char '!'
return $ LoggedIn name
seek :: Parser PlayTakMsg
seek = do
try $ string "Seek"
space
s <- (string "new" >> return SeekNew)
<|> (string "remove" >> return SeekRemove)
space
no <- int
space
name <- username
space
boardsize <- int
space
gameTime <- int
return $ s no name boardsize gameTime
online :: Parser PlayTakMsg
online = do
try $ string "Online"
space
name <- username
return $ Online name
shout :: Parser PlayTakMsg
shout = do
try $ string "Shout"
space
char '<'
name <- username
char '>'
space
msg <- many1 anyChar
return $ Shout name msg
gameStart :: Parser PlayTakMsg
gameStart = do
try $ string "Game Start"
space
gameno <- int
space
size <- int
space
p1 <- username
space
string "vs"
space
p2 <- username
space
c <- colour
return $ GameStart gameno size p1 p2 c
game :: Parser PlayTakMsg
game = do
try $ string "Game#"
n <- int
space
place n <|> move n <|> time n <|> over n <|> offerDraw n <|> removeDraw n
<|> resign n <|> requestUndo n <|> removeUndo n <|> undo n <|> abandon n
place :: Int -> Parser PlayTakMsg
place gameno = do
char 'P'
space
sq <- square
stone <- option Flat $ space >> (cap <|> wall)
return $ PlayMsg gameno $ Place stone sq
where
cap = char 'C' >> return Cap
wall = char 'W' >> return Standing
move :: Int -> Parser PlayTakMsg
move gameno = do
char 'M'
space
sq1 <- square
space
sq2 <- square
space
drops <- int `sepBy1` space
return $ PlayMsg gameno $ Move sq1 (dir sq2 sq1) drops
where
dir (i1, j1) (i2, j2) = dir' (signum $ i1 i2) (signum $ j1 j2)
dir' 1 0 = PosX
dir' (1) 0 = NegX
dir' 0 1 = PosY
dir' 0 (1) = NegY
dir' _ _ = error "Not a legal direction"
time :: Int -> Parser PlayTakMsg
time gameno = do
try $ string "Time"
space
whitetime <- int
space
blacktime <- int
return $ Time gameno whitetime blacktime
over :: Int -> Parser PlayTakMsg
over gameno = do
try $ string "Over"
space
p1 <- score
char '-'
p2 <- score
return $ Over gameno p1 p2
where
score = roadScore <|> flatScore <|> drawScore <|> zeroScore <|> abandonScore
zeroScore = char '0' >> return ZeroScore
roadScore = char 'R' >> return RoadScore
flatScore = char 'F' >> return FlatScore
drawScore = try (string "1/2") >> return DrawScore
abandonScore = char '1' >> return AbandonScore
offerDraw :: Int -> Parser PlayTakMsg
offerDraw gameno = string "OfferDraw" >> return (OfferDraw gameno)
removeDraw :: Int -> Parser PlayTakMsg
removeDraw gameno = try (string "RemoveDraw") >> return (RemoveDraw gameno)
resign :: Int -> Parser PlayTakMsg
resign gameno = try (string "Resign") >> return (Resign gameno)
requestUndo :: Int -> Parser PlayTakMsg
requestUndo gameno = try (string "RequestUndo") >> return (RequestUndo gameno)
removeUndo :: Int -> Parser PlayTakMsg
removeUndo gameno = try (string "RemoveUndo") >> return (RemoveUndo gameno)
undo :: Int -> Parser PlayTakMsg
undo gameno = string "Undo" >> return (Undo gameno)
abandon :: Int -> Parser PlayTakMsg
abandon gameno = string "Abandoned" >> return (Abandon gameno)
message :: Parser PlayTakMsg
message = do
string "Message"
space
text <- many anyChar
return $ Message text
errorMsg :: Parser PlayTakMsg
errorMsg = do
string "Error"
space
text <- many anyChar
return $ ErrorMsg text
nok :: Parser PlayTakMsg
nok = string "NOK" >> return NOK
ok :: Parser PlayTakMsg
ok = try (string "OK") >> return OK
gamelist :: Parser PlayTakMsg
gamelist = do
try $ string "GameList"
space
proc <- (string "Add" >> return GameListAdd) <|>
(string "Remove" >> return GameListRemove)
space
string "Game#"
gameno <- int
space
p1 <- username
space
string "vs"
space
p2 <- username
comma
space
size1 <- int
char 'x'
size2 <- int
if size1 /= size2
then error "Board is not square!"
else return ()
comma
space
gameTime <- int
comma
space
seconds <- int
comma
space
moves <- int
space
string "half-moves played"
comma
space
nextPlayer <- username
space
string "to move"
return $ proc gameno p1 p2 size1 gameTime seconds moves nextPlayer
username :: Parser String
username = many1 $ noneOf " <>!,"
comma :: Parser ()
comma = char ','
int :: Parser Int
int = do
n <- many1 digit
return $ read n
colour :: Parser Colour
colour = white <|> black where
white = string "white" >> return White
black = string "black" >> return Black
square :: Parser (Int, Int)
square = do
rank <- oneOf letters
file <- int
return ((fromJust $ elemIndex rank letters) + 1, file)
letters :: String
letters = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
char :: Char -> Parser ()
char c = Parsec.char c >> return ()
space :: Parser ()
space = Parsec.space >> return ()
string :: String -> Parser ()
string str = Parsec.string str >> return ()