deulcode.hs

{-# LANGUAGE RecordWildCards #-}

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 as B
import Data.Aeson

main = withSocketsDo $ 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.hPutStrLn h $ encode s
    m <- B.hGetLine 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

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

duelcode.hs:29:21:
    Couldn't match expected type `B.ByteString'
                with actual type `bytestring-0.10.0.2:Data.ByteString.Lazy.Internal.ByteString'
    In the return type of a call of `encode'
    In the second argument of `($)', namely `encode s'
    In a stmt of a 'do' block: B.hPutStrLn h $ encode s

duelcode.hs:31:17:
    Couldn't match expected type `bytestring-0.10.0.2:Data.ByteString.Lazy.Internal.ByteString'
                with actual type `B.ByteString'
    In the first argument of `decode', namely `m'
    In the expression: decode m
    In a stmt of a 'do' block:
      case decode m of {
        Just x -> return x
        _ -> error "failed to parse received move" }

duelcode.hs:29:21:
    Couldn't match expected type `B.ByteString'
                with actual type `Data.ByteString.Lazy.Internal.ByteString'
    In the return type of a call of `encode'
    In the second argument of `($)', namely `encode s'
    In a stmt of a 'do' block: B.hPutStrLn h $ encode s

duelcode.hs:31:17:
    Couldn't match expected type `Data.ByteString.Lazy.Internal.ByteString'
                with actual type `B.ByteString'
    In the first argument of `decode', namely `m'
    In the expression: decode m
    In a stmt of a 'do' block:
      case decode m of {
        Just x -> return x
        _ -> error "failed to parse received move" }