363 lines
11 KiB
Haskell
363 lines
11 KiB
Haskell
|
{-# 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
|