{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}

module Main where

import Control.Monad.Reader
import Control.Monad.State
import Data.Attoparsec.ByteString.Char8 as Atto
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BC8
import Data.Functor (void)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Debug.Trace
import GHC.Generics
import Network.Run.TCP
import Network.Socket
import Network.Socket.ByteString qualified as Socket
import Options.Generic
import Data.ByteString.UTF8 (fromString)
import Data.List.Extra
import Data.Maybe (mapMaybe)

main :: IO ()
main = gameLoop

data Server = Server
  { host :: HostName,
    port :: ServiceName,
    username :: String,
    password :: String
  }
  deriving (Show, Eq, Generic)

instance ParseRecord Server

data GameState = GameState
  { game :: Game,
    occupied :: Map (Int, Int) Int,
    lastPosition :: (Int, Int),
    otherPlayers :: Map Int String
  }

newtype ParserError = ParserError (Result Packet)
  deriving (Show)

gameLoop :: IO ()
gameLoop = do
  server <- getRecord "Tronly Typed"
  runTCPClient server.host server.port $ \sock -> do
    putStrLn "Connected"
    go sock server initState ""
  where
    go :: Socket -> Server -> GameState -> ByteString -> IO ()
    go sock server gs bs = do
      parsePacket sock bs >>= \case
        Left e -> error $ "ParserError: " <> show e
        Right (receivedPkt, remaining) -> do
          showGameUpdates gs receivedPkt
          let (action, newState) = runReader (runStateT (processPacket receivedPkt) gs) server
          case action of
            Chill -> go sock server newState remaining
            GameOver True score -> do
              putStrLn "Victory 🎉"
              putStrLn $ "wins: " <> show score.wins <> ", loses: " <> show score.loses
              go sock server initState remaining
            GameOver False score -> do
              putStrLn "Oh well, we lost!"
              putStrLn $ "wins: " <> show score.wins <> ", loses: " <> show score.loses
              go sock server initState remaining
            Error err ->
              putStrLn $ "Error :" <> err
            SendPacket pktToSend -> do
              sendPacket sock pktToSend
              go sock server newState remaining
            SayGoodBye deaths -> do
              case mapMaybe (\d -> Map.lookup d gs.otherPlayers) deaths of
                [] -> pure ()
                [dead] -> sendPacket sock $ ChatPacket $ "Snek ya later " <> dead
                (p:ps) -> sendPacket sock $ ChatPacket $ "Snek ya later " <> intercalate ", " ps <> " and " <> p
              go sock server newState remaining
            GiveUp -> do
              sendPacket sock $ ChatPacket "I don't know what to do! My whole brain is crying!"
              sendPacket sock $ MovePacket DirUp
              go sock server newState remaining

showGameUpdates :: GameState -> Packet -> IO ()
showGameUpdates gs = \case
  GamePacket game ->
    putStrLn $ "Game starts, we're player " <> show game.playerId
  TickPacket ->
    putStrLn $ showGame gs.game.height gs.game.width gs.occupied
  PlayerPacket player ->
    putStrLn $ "Player " <> show player.playerId <> " is " <> show player.name
  DiePacket players ->
    putStrLn $ "Player " <> show players <> " are dead"
  _ -> pure ()
sendPacket :: Socket -> Packet -> IO ()
sendPacket sock pkt = do
  let serialised = serialisePacket pkt
  BC8.putStrLn $ "Sending packet: " <> serialised
  void $ Socket.send sock serialised

initState :: GameState
initState =
  GameState
    { game = Game 0 0 (-1),
      lastPosition = (0, 0),
      occupied = mempty,
      otherPlayers = mempty
    }

parsePacket :: Socket -> ByteString -> IO (Either ParserError (Packet, ByteString))
parsePacket sock previous = go (parse packetParser previous)
  where
    go :: IResult ByteString Packet -> IO (Either ParserError (Packet, ByteString))
    go parseFn = do
      case parseFn of
        Done remaining packet -> do
          pure (Right (packet, remaining))
        Partial f -> do
          moreInput <- Socket.recv sock 1024
          go $ f moreInput
        res -> pure $ Left $ ParserError res

mkJoinPacket :: Server -> Packet
mkJoinPacket gs = JoinPacket $ Join gs.username gs.password

processPacket :: (MonadState GameState m, MonadReader Server m) => Packet -> m Action
processPacket incomingPacket = do
  case incomingPacket of
    MOTDPacket _ ->
      asks (SendPacket . mkJoinPacket)
    GamePacket game -> do
      modify (\gs -> gs {game = game})
      pure Chill
    PlayerPacket player -> do
      modify (\gs -> gs { otherPlayers = Map.insert player.playerId player.name gs.otherPlayers })
      pure Chill
    PosPacket pos -> do
      modify
        ( \gs ->
            gs
              { occupied = Map.insert (pos.x, pos.y) pos.playerId gs.occupied,
                lastPosition =
                  if pos.playerId == gs.game.playerId
                    then (pos.x, pos.y)
                    else gs.lastPosition
              }
        )
      pure Chill
    DiePacket deaths -> do
      modify (\gs -> gs {occupied = Map.filter (not . flip elem deaths) gs.occupied})
      pure $ SayGoodBye deaths
    WinPacket score -> do
      pure $ GameOver True score
    LosePacket score ->
      pure $ GameOver False score
    ErrorPacket err ->
      pure $ Error err
    TickPacket -> do
      gs <- get
      -- pure $ SendPacket $ MovePacket  $ nextMove gs.game.height gs.game.width (Map.keys gs.occupied) gs.lastPosition
      case nextMove gs.game.height gs.game.width (Map.keys gs.occupied) gs.lastPosition of
        Nothing -> pure GiveUp
        Just dir -> pure $ SendPacket $ MovePacket dir
    UnknownPacket unknown -> do
      traceM $ "Unknown packet: " <> BC8.unpack unknown
      pure Chill
    _ ->
      pure Chill

nextMove :: Int -> Int -> [(Int, Int)] -> (Int, Int) -> Maybe Direction
nextMove height width occupiedSpaces (x, y) =
  let isOccupied p = p `elem` occupiedSpaces

      closest :: Int -> ((Int, Int) -> (Int, Int)) -> (Int, Int) -> Int
      closest n next cur = if isOccupied cur then n else closest (1 + n) next (next cur)

      nextIn DirUp (x0, y0) = (x0, (y0 - 1) `mod` height)
      nextIn DirDown (x0, y0) = (x0, (y0 + 1) `mod` height)
      nextIn DirRight (x0, y0) = ((x0 + 1) `mod` width,  y0)
      nextIn DirLeft (x0, y0) = ((x0 - 1) `mod` width, y0)

      freeSquaresIn dir = closest 0 (nextIn dir) (nextIn dir (x,y))
      freeSquares = map (\dir -> (dir, freeSquaresIn dir)) [DirUp, DirRight, DirDown, DirLeft]
      maxFreeSquares = maximum $ map snd freeSquares

   in case maxFreeSquares of
    0 -> Nothing
    _ -> Just . fst $ maximumOn snd freeSquares

showGame :: Int -> Int -> Map (Int, Int) Int -> String
showGame height width occ =
  let row y =  unwords [maybe "." show $ Map.lookup (x, y) occ | x <- [0 .. width - 1]]
      grid = unlines [row x | x <- [0 .. height - 1]]
  in grid

data Action = SendPacket Packet | Chill | SayGoodBye [Int] | GameOver Bool Score | Error String | GiveUp

data Packet
  = MOTDPacket String
  | JoinPacket Join
  | ErrorPacket String
  | GamePacket Game
  | PosPacket Pos
  | PlayerPacket Player
  | TickPacket
  | DiePacket [Int]
  | MovePacket Direction
  | ChatPacket String
  | MessagePacket Message
  | WinPacket Score
  | LosePacket Score
  | UnknownPacket ByteString
  deriving (Show)

packetParser :: Parser Packet
packetParser = do
  packetName <- Atto.takeWhile (\c -> c /= '|' && c /= '\n')
  packet <- case packetName of
    "motd" -> MOTDPacket <$ char '|' <*> strParser '\n'
    "join" -> JoinPacket <$ char '|' <*> joinParser
    "error" -> ErrorPacket <$ char '|' <*> strParser '\n'
    "game" -> GamePacket <$ char '|' <*> gameParser
    "pos" -> PosPacket <$ char '|' <*> posParser
    "player" -> PlayerPacket <$ char '|' <*> playerParser
    "tick" -> pure TickPacket
    "die" -> DiePacket <$ char '|' <*> sepBy1 decimal (char '|')
    "move" -> MovePacket <$ char '|' <*> directionParser
    "chat" -> ChatPacket <$ char '|' <*> strParser '\n'
    "message" -> MessagePacket <$ char '|' <*> messageParser
    "win" -> WinPacket <$ char '|' <*> scoreParser
    "lose" -> LosePacket <$ char '|' <*> scoreParser
    unknown -> UnknownPacket . (unknown <>) <$> Atto.takeWhile (/= '\n')
  _ <- char '\n'
  pure packet

serialisePacket :: Packet -> ByteString
serialisePacket =
  (<> "\n") . BS.intercalate "|" . \case
    MOTDPacket motd -> ["motd", fromString motd]
    JoinPacket (Join username password) -> ["join", fromString username, fromString password]
    ErrorPacket e -> ["error", fromString e]
    GamePacket (Game w h p) -> ["game", fromString (show w), fromString (show h), fromString (show p)]
    PosPacket (Pos x y p) -> ["pos", fromString (show x), fromString (show y), fromString (show p)]
    PlayerPacket (Player p n) -> ["player", fromString (show p), fromString n]
    TickPacket -> ["tick"]
    DiePacket dead -> ["die", fromString (show dead)]
    MovePacket DirUp -> ["move", "up"]
    MovePacket DirDown -> ["move", "down"]
    MovePacket DirRight -> ["move", "right"]
    MovePacket DirLeft -> ["move", "left"]
    ChatPacket msg -> ["chat", fromString msg]
    MessagePacket (Message p msg) -> ["message", fromString (show p), fromString msg]
    WinPacket (Score w l) -> ["win", fromString (show w), fromString (show l)]
    LosePacket (Score w l) -> ["lose", fromString (show w), fromString (show l)]
    UnknownPacket str -> [str]

strParser :: Char -> Parser String
strParser stopper =
  BC8.unpack <$> Atto.takeWhile (/= stopper)

data Join = Join
  { username :: String,
    password :: String
  }
  deriving (Show)

joinParser :: Parser Join
joinParser =
  Join
    <$> (BC8.unpack <$> Atto.takeWhile (/= '|'))
    <* char '|'
    <*> (BC8.unpack <$> Atto.takeWhile (/= '\n'))

data Game = Game
  { width :: Int,
    height :: Int,
    playerId :: Int
  }
  deriving (Show)

gameParser :: Parser Game
gameParser =
  Game
    <$> decimal
    <* char '|'
    <*> decimal
    <* char '|'
    <*> decimal

data Pos = Pos
  { playerId :: Int,
    x :: Int,
    y :: Int
  }
  deriving (Show)

posParser :: Parser Pos
posParser =
  Pos
    <$> decimal
    <* char '|'
    <*> decimal
    <* char '|'
    <*> decimal

data Player = Player
  { playerId :: Int,
    name :: String
  }
  deriving (Show)

playerParser :: Parser Player
playerParser =
  Player
    <$> decimal
    <* char '|'
    <*> (BC8.unpack <$> Atto.takeWhile (/= '\n'))

data Direction = DirUp | DirDown | DirRight | DirLeft
  deriving (Show)

directionParser :: Parser Direction
directionParser =
  Atto.takeWhile (/= '\n') >>= \case
    "up" -> pure DirUp
    "down" -> pure DirDown
    "right" -> pure DirRight
    "left" -> pure DirLeft
    invalidDir -> fail $ "Invalid direction: " <> BC8.unpack invalidDir

data Message = Message
  { playerId :: Int,
    message :: String
  }
  deriving (Show)

messageParser :: Parser Message
messageParser =
  Message
    <$> decimal
    <* char '|'
    <*> (BC8.unpack <$> Atto.takeWhile (/= '\n'))

data Score = Score
  { wins :: Int,
    loses :: Int
  }
  deriving (Show)

scoreParser :: Parser Score
scoreParser =
  Score
    <$> decimal
    <* char '|'
    <*> decimal