module Minecraft
( ClientToServerPacket
, ServerToClientPacket
, MCInventoryItem
, MCInventory
) where

import Data.Int
import Data.Binary.IEEE754
import Data.Binary
import Control.Monad

{- Client to Server packets -}

data ClientToServerPacket
    = CTSKeepAlive
    | CTSLoginRequest Int32 String String Int64 Int8
    | CTSHandshake String
    | CTSChatMessage String
    | CTSPlayerInventory MCInventory
    | CTSUseEntity Int32 Int32 Bool
    | CTSRespawn
    | CTSPlayerState Bool
    | CTSPlayerPosition Double Double Double Double Bool
    | CTSPlayerLook Float Float Bool
    | CTSPlayerPositionAndLook Double Double Double Double Float Float Bool
    | CTSPlayerDigging Int8 Int32 Int8 Int32 Int8
    | CTSPlayerBlockPlacement Int16 Int32 Int8 Int32 Int8
    | CTSHoldingChange Int32 Int16
    | CTSArmAnimation Int32 Int8
    | CTSPickupSpawn Int32 Int16 Int8 Int32 Int32 Int32 Int8 Int8 Int8
    | CTSDisconnect String
    deriving Show

instance Binary ClientToServerPacket where
    put pkt = case pkt of
        CTSKeepAlive -> putInt8 0x00
        CTSLoginRequest a b c d e -> putInt8 0x01 >> put a >> putMCStr b >> putMCStr c >> put d >> put e
        CTSHandshake a -> putInt8 0x02 >> put a
        CTSChatMessage a -> putInt8 0x03 >> put a
        CTSPlayerInventory a -> put a
        CTSUseEntity a b c -> put a >> put b >> put c
        CTSRespawn -> putInt8 0x09
        CTSPlayerState a -> putInt8 0x0A >> put a
        CTSPlayerPosition a b c d e -> putInt8 0x0B >> putFloat64be a >> putFloat64be b >> putFloat64be c >> putFloat64be d >> put e
        CTSPlayerLook a b c -> putInt8 0x0C >> putFloat32be a >> putFloat32be b >> put c
        CTSPlayerPositionAndLook a b c d e f g -> putInt8 0x0D >> putFloat64be a >> putFloat64be b >> putFloat64be c >> putFloat64be d >> putFloat32be e >> putFloat32be f >> put g
        CTSPlayerDigging a b c d e -> putInt8 0x0E >> put a >> put b >> put c >> put d >> put e
        CTSPlayerBlockPlacement a b c d e -> putInt8 0x0F >> put a >> put b >> put c >> put d >> put e
        CTSHoldingChange a b -> putInt8 0x10 >> put a >> put b
        CTSArmAnimation a b -> putInt8 0x12 >> put a >> put b
        CTSPickupSpawn a b c d e f g h i -> putInt8 0x15 >> put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h >> put i
        CTSDisconnect a -> putInt8 0xFF >> put a
    get = do
        tag <- getInt8
        case tag of
            0x00 -> return CTSKeepAlive
            0x01 -> liftM5 CTSLoginRequest get getMCStr getMCStr get get
            0x02 -> liftM CTSHandshake getMCStr
            0x03 -> liftM CTSChatMessage getMCStr
            0x05 -> liftM CTSPlayerInventory get
            0x07 -> liftM3 CTSUseEntity get get get
            0x09 -> return CTSRespawn
            0x0A -> liftM CTSPlayerState get
            0x0B -> liftM5 CTSPlayerPosition getFloat64be getFloat64be getFloat64be getFloat64be get
            0x0C -> liftM3 CTSPlayerLook getFloat32be getFloat32be get
            0x0D -> liftM7 CTSPlayerPositionAndLook getFloat64be getFloat64be getFloat64be getFloat64be getFloat32be getFloat32be get
            0x0E -> liftM5 CTSPlayerDigging get get get get get
            0x0F -> liftM5 CTSPlayerBlockPlacement get get get get get
            0x10 -> liftM2 CTSHoldingChange get get
            0x12 -> liftM2 CTSArmAnimation get get
            0x15 -> liftM9 CTSPickupSpawn get get get get get get get get get
            0xFF -> liftM CTSDisconnect getMCStr
            otherwise -> error $ "Invalid packet tag: " ++ show tag

{- Server to Client packets -}

data ServerToClientPacket
    = STCKeepAlive
    | STCLoginResponse Int32 String String Int64 Int8
    | STCHandshake String
    | STCChatMessage String
    | STCTimeUpdate Int64
    | STCPlayerInventory MCInventory
    | STCSpawnPosition Int32 Int32 Int32
    deriving Show

instance Binary ServerToClientPacket where
    put pkt = case pkt of
        STCKeepAlive -> putInt8 0x00
        STCLoginResponse a b c d e -> putInt8 0x01 >> put a >> putMCStr b >> putMCStr c >> put d >> put e
        STCHandshake a -> putInt8 0x02 >> put a
        STCChatMessage a -> putInt8 0x03 >> put a
        STCTimeUpdate a -> putInt8 0x04 >> put a
        STCPlayerInventory a -> put a
        STCSpawnPosition a b c -> put a >> put b >> put c
    get = do
        tag <- getInt8
        case tag of
            0x00 -> return STCKeepAlive
            0x01 -> liftM5 STCLoginResponse get getMCStr getMCStr get get
            0x02 -> liftM STCHandshake getMCStr
            0x03 -> liftM STCChatMessage getMCStr
            0x04 -> liftM STCTimeUpdate get
            0x05 -> liftM STCPlayerInventory get
            0x06 -> liftM3 STCSpawnPosition get get get
            otherwise -> error $ "Invalid packet tag: " ++ show tag

{- Data Types -}

type MCInventoryItem = (Int16, Int8, Int16)
data MCInventory = MCInventory Int32 Int16 [MCInventoryItem] deriving Show

instance Binary MCInventory where
    put (MCInventory sec cnt inv) = do
        put sec
        put cnt
        forM_ inv $ \itm@(iid, cnt, hlh) -> case iid of
            -1 -> put (-1 :: Int16)
            otherwise -> put itm
    get = do
        t <- get
        c <- get
        items <- replicateM (fromIntegral c) $ do
            iid <- get :: Get Int16
            case iid of
                -1 -> return (-1, 0, 0)
                otherwise -> do
                    cnt <- get
                    hlh <- get
                    return (iid, cnt, hlh)
        return (MCInventory t c items)


{- Utility stuff -}

putInt8 :: Int -> Put
putInt8 i = put (fromIntegral i :: Int8)

getInt8 :: Get Int8
getInt8 = get :: Get Int8

putMCStr :: String -> Put
putMCStr s = do
    put (fromIntegral (length s) :: Int16)
    mapM_ put s

getMCStr :: Get String
getMCStr = do
    len <- get :: Get Int16
    replicateM (fromIntegral len :: Int) (get :: Get Char)

liftM6  :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m a6 -> m r
liftM6 f m1 m2 m3 m4 m5 m6 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; return (f x1 x2 x3 x4 x5 x6) }

liftM7  :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m a6 -> m a7 -> m r
liftM7 f m1 m2 m3 m4 m5 m6 m7 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; x7 <- m7; return (f x1 x2 x3 x4 x5 x6 x7) }

liftM8  :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m a6 -> m a7 -> m a8 -> m r
liftM8 f m1 m2 m3 m4 m5 m6 m7 m8 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; x7 <- m7; x8 <- m8; return (f x1 x2 x3 x4 x5 x6 x7 x8) }

liftM9  :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m a6 -> m a7 -> m a8 -> m a9 -> m r
liftM9 f m1 m2 m3 m4 m5 m6 m7 m8 m9 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; x7 <- m7; x8 <- m8; x9 <- m9; return (f x1 x2 x3 x4 x5 x6 x7 x8 x9) }