module Parser ( Shape, ShapeUpdate, Command(..), Winner(..), command
              , Color(..), Format, PartylineMsg) where

import Partyline (Color(..), Format, PartylineMsg, partylinemsg)

import Char (ord, chr)
import Data.Bits (xor)
import Control.Monad (mplus)

import Text.ParserCombinators.Parsec

type Shape           = Char
type ShapeUpdate = (Shape, [(Int, Int)])

shapeRange = ['!' .. '/']
ordRange = take 30 [ '3' .. ]

data Command = AbsoluteField Int [Shape] 
             | IncrementalField Int [ShapeUpdate]
             | SpecialBlock Int Special Int
             | PlayerJoin Int String
             | PartyLine Int [PartylineMsg]
             | StartGame Bool Int
             | ChangeTeam Int String
             | Level Int Int
             | Nop
             | Init String
             | WinList [(Winner, Int)]
             | Other [Char]
               deriving (Show)

data Winner = Team String | Player String
            deriving (Show)

data Special = AddLines Int
             | AddLine
             | ClearLine
             | NukeField
             | ClearRandom
             | SwitchFields
             | ClearSpecials
             | BlockGravity
             | BlockQuake
             | BlockBomb
               deriving (Show)

-- command parsers

field, specialblock, partyline, playerjoin, startgame,
     changeteam, level, nop, initstring, other, winlist
    :: Parser Command

field = do
  char 'f'            ; spaces
  slot <- int         ; spaces
  do {    (many1 digit       >>= return . AbsoluteField    slot)
      <|> (many1 shapeUpdate >>= return . IncrementalField slot) }

specialblock = do
  try (string "sb")        ; spaces
  to           <- int      ; spaces
  specialblock <- special  ; spaces
  from         <- int
  return $ SpecialBlock to specialblock from

partyline  = do
  try (string "pline") ; spaces
  from <- int          ; spaces
  msg  <- partylinemsg
  return (PartyLine from msg)

playerjoin = slotString "playerjoin" PlayerJoin
startgame  = onOffActionBy "startgame" StartGame
changeteam = slotString "team" ChangeTeam
level      = slotNum "lvl" Level
nop        = eof >> return Nop
other      = many anyChar >>= return . Other

winlist = do
  try (string "winlist")    ; spaces
  win `sepBy` spaces >>= return . WinList
    where
      win =     (char 'p' >> winner Player)
            <|> (char 't' >> winner Team  )
      winner w = do
            name  <- manyTill anyChar (char ';')
            score <- int
            return $ (w name, score)

command = choice [field, specialblock, partyline, playerjoin, startgame,
                       changeteam, level, nop, initstring, winlist, other]

-- other parsers

shape :: Parser Shape
shape = oneOf shapeRange

shapeUpdate :: Parser ShapeUpdate
shapeUpdate = do
  shapeType <- shape
  coords <- many1 coord
  return (shapeType, coords)
  
coord :: Parser (Int, Int)
coord = do
  x <- oneOf ordRange
  y <- oneOf ordRange
  let x' = ord x - start
      y' = ord y - start
      start = (ord . head) ordRange
  return (x', y')

bool :: Parser Bool
bool = do
  c <- oneOf ['0', '1']
  return $ case c of
           '1' -> True
           _   -> False

int :: Parser Int
int =  many1 digit >>= return . read

special :: Parser Special
special =     do { try (string "cs") ; spaces
                 ; int >>= return . AddLines }
          <|> (oneOf "acnrsbgqo" >>= return . s)
    where
      s 'a' = AddLine
      s 'c' = ClearLine
      s 'n' = NukeField
      s 'r' = ClearRandom
      s 's' = SwitchFields
      s 'b' = ClearSpecials
      s 'g' = BlockGravity
      s 'q' = BlockQuake
      s 'o' = BlockBomb

-- Support methods

slot :: Parser a -> String -> (Int -> a -> Command) -> Parser Command
slot subparser token datatype = do
  try (string token)      ;  spaces
  slot   <- int           ;  spaces
  sub    <- subparser
  return $ datatype slot sub

slotString :: String -> (Int -> String -> Command) -> Parser Command
slotString = slot (many anyChar)

slotNum :: String -> (Int -> Int -> Command) -> Parser Command
slotNum = slot int

onOffActionBy :: String -> (Bool -> Int -> Command) -> Parser Command
onOffActionBy token datatype = do
  try (string token)         ; spaces
  status <- bool             ; spaces
  slot   <- int
  return $ datatype status slot

-- Init string parsing/decoding

initstring = do
  i <- try $ do { i' <-  many1 hexByte  ; eof
                ; return i' }
  let pattern = foldl1 mplus [findPattern s i |
                              s <- ["tetrifaste", "tetrisstar"] ]
  case pattern of
    Nothing -> fail "Invalid init string"
    Just p  -> return $ Init (decode p i)
  where
    hexByte = count 2 hexDigit >>= return . chr . read . ('0':) . ('x':)

decode :: String -> String -> String
decode pattern unknown =
  zipWith3 decodeStep (tail unknown) (cycle pattern) unknown
  where
    decodeStep x y z =
        chr $ ((ord x `xor` ord y) + 255 - (ord z)) `mod` 255

findPattern :: String -> String -> Maybe String
findPattern known unknown =
    repeatingSubstring 5 $ zipWith3
                       encodeStep known unknown (tail unknown)
    where
      encodeStep x y z =
        chr $ (mod (ord x + ord y) 255) `xor` (ord z)

-- repatingSubstring l xs
--
-- Finds the longest substring of length <= l that when cycled generates xs
-- eg l = 5, xs = [1,2,3,4,1,2,3,4,1,2], repeatingSubstring l xs = [1,2,3,4]
repeatingSubstring :: (Eq a) => Int -> [a] -> Maybe [a]
repeatingSubstring 0 _ = Nothing
repeatingSubstring n xs
    | all2 (==) xs (cycle (take n xs)) = Just (take n xs)
    | otherwise = repeatingSubstring (n-1) xs

all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
all2 _ [] _ = True
all2 _ _ [] = True
all2 f (x:xs) (y:ys)
    | f x y     = all2 f xs ys
    | otherwise = False