duelcode.hs

{-# LANGUAGE RecordWildCards, OverloadedStrings #-}

import Prelude hiding (Either(..))
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import System.IO (Handle)
import Network (withSocketsDo, listenOn, accept, PortID(..))
import qualified Data.ByteString.Lazy as B
import Data.Aeson
import Control.Applicative
import Control.Monad

main = withSocketsDo $ do
    hs <- listen $ PortNumber $ fromIntegral 1337
    return ()

listen :: PortID -> IO (Handle, Handle)
listen p = do
    s <- listenOn p
    (red, _, _)  <- accept s
    (blue, _, _) <- accept s
    return (red, blue)

gameLoop :: (Handle, Handle) -> GameState -> IO ()
gameLoop hs@(hRed, hBlue) s0@Game{..} = do
    redMove <- runRound hRed s0
    let s1 = step $ s0 { red = red { action = Just redMove } }
    blueMove <- runRound hBlue s1
    gameLoop hs $ step $ s1 { blue = blue { action = Just blueMove } }

runRound :: Handle -> GameState -> IO Move
runRound h s = do
    B.hPutStr h $ encode s
    m <- B.hGetContents h
    case decode m of
        Just x -> return x
        _      -> error "failed to parse received move"

data GameState = Game {
    red   :: Player,
    blue  :: Player,
    board :: Board }

type Board = IntMap (IntMap Cell)

data Cell = Block | Empty deriving Eq

data Player = Player {
    position :: (Int, Int),
    action   :: Maybe Move }

data Move = Up | Down | Left | Right

instance ToJSON GameState where
    toJSON Game{..} = object [
        "red"   .= red,
        "blue"  .= blue,
        "board" .= board ]

instance ToJSON Player where
    toJSON Player{..} = object [
        "position" .= position,
        "action"   .= action ]

instance ToJSON Cell where
    toJSON Block = String "block"
    toJSON Empty = String "empty"

instance ToJSON Move where
    toJSON Up    = String "up"
    toJSON Down  = String "down"
    toJSON Left  = String "left"
    toJSON Right = String "right"

instance FromJSON GameState where
    parseJSON (Object v) = Game
        <$> v .: "red"
        <*> v .: "blue"
        <*> v .: "board"
    parseJSON _ = mzero

instance FromJSON Player where
    parseJSON (Object v) = Player
        <$> v .: "position"
        <*> v .: "action"
    parseJSON _ = mzero

instance FromJSON Cell where
    parseJSON (String "block") = return Block
    parseJSON (String "empty") = return Empty
    parseJSON _ = mzero

instance FromJSON Move where
    parseJSON (String "up")    = return Up
    parseJSON (String "down")  = return Down
    parseJSON (String "left")  = return Left
    parseJSON (String "right") = return Right

step :: GameState -> GameState
step s@Game{..}
    | hasMove red  = case move board red of
        Just b  -> s { board = b, red  = update red }
        Nothing -> s
    | hasMove blue = case move board blue of
        Just b  -> s { board = b, blue = update blue }
        Nothing -> s

hasMove :: Player -> Bool
hasMove (Player _ (Just _)) = True
hasMove _ = False

move :: Board -> Player -> Maybe Board
move b (Player (x, y) (Just m)) = case m of
    Up    -> block x $ y + 1
    Down  -> block x $ y - 1
    Left  -> block (x - 1) y
    Right -> block (x + 1) y
    where
        block x0 y0 = case check $ IM.lookup x b of
            Just b0 -> Just $ IM.insert x0 (IM.insert y0 Block b0) b
            _       -> Nothing
        check (Just b1) = if IM.lookup y b1 == (Just Empty) then
            Just b1
            else Nothing
        check _ = Nothing
move b _ = Just b

update :: Player -> Player
update (Player (x, y) m0@(Just m1)) = case m1 of
    Up    -> Player (x, y + 1) m0
    Down  -> Player (x, y - 1) m0
    Left  -> Player (x - 1, y) m0
    Right -> Player (x + 1, y) m0
update p = p