BinaryInstances.hs

   1 -- This file is part of Intricacy
   2 -- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 module BinaryInstances where
  12 import           Control.Monad
  13 import           Data.Binary
  14 import           Data.Int       (Int8)
  15 import qualified Data.Vector    as Vector
  16
  17 import           Frame
  18 import           GameStateTypes
  19 import           Hex
  20 import           Physics
  21
  22 newtype SmallInt = SmallInt {fromSmallInt :: Int}
  23 newtype SmallNat = SmallNat {fromSmallNat :: Int}
  24 instance Binary SmallNat where
  25     put (SmallNat n) = if n < 255 then putWord8 (fromIntegral n) else putWord8 255 >> put n
  26     get = do
  27         n' <- get :: Get Word8
  28         if n' == 255 then SmallNat <$> get else return . SmallNat $ fromIntegral n'
  29
  30 instance Binary SmallInt where
  31     put (SmallInt n) = if abs n < 127 then put (fromIntegral n :: Int8) else put (127::Int8) >> put n
  32     get = do
  33         n' <- get :: Get Int8
  34         if n' == 127 then SmallInt <$> get else return . SmallInt $ fromIntegral n'
  35
  36 putPackedNat,putPackedInt :: Int -> Put
  37 putPackedNat n = put $ SmallNat n
  38 putPackedInt n = put $ SmallInt n
  39 getPackedNat,getPackedInt :: Get Int
  40 getPackedNat = fromSmallNat <$> get
  41 getPackedInt = fromSmallInt <$> get
  42
  43 newtype ShortList a = ShortList {fromShortList :: [a]}
  44 instance Binary a => Binary (ShortList a) where
  45     put (ShortList as) = putPackedNat (length as) >> mapM_ put as
  46     get = do
  47         n <- getPackedNat
  48         ShortList <$> getMany n
  49
  50  -- | 'getMany n' get 'n' elements in order, without blowing the stack.
  51  -- [ copied from source of package 'binary' by Lennart Kolmodin ]
  52 getMany :: Binary a => Int -> Get [a]
  53 getMany = go []
  54  where
  55     go xs 0 = return $! reverse xs
  56     go xs i = do x <- get
  57                  -- we must seq x to avoid stack overflows due to laziness in
  58                  -- (>>=)
  59                  x `seq` go (x:xs) (i-1)
  60 {-# INLINE getMany #-}
  61
  62 instance Binary HexVec where
  63     put (HexVec x y _) = putPackedInt x >> putPackedInt y
  64     get = do
  65         x <- getPackedInt
  66         y <- getPackedInt
  67         return $ tupxy2hv (x,y)
  68 instance Binary g => Binary (PHS g) where
  69     put (PHS v) = put v
  70     get = PHS <$> get
  71 instance Binary GameState where
  72     put (GameState pps conns) = put (ShortList $ Vector.toList pps) >> put (ShortList conns)
  73     get = liftM2 GameState (Vector.fromList . fromShortList <$> get) (fromShortList <$> get)
  74 instance Binary PlacedPiece where
  75     put (PlacedPiece ppos p) = put ppos >> put p
  76     get = liftM2 PlacedPiece get get
  77 instance Binary Piece where
  78     put (Block patt)         = put (0::Word8) >> put (ShortList patt)
  79     put (Pivot arms)         = put (1::Word8) >> put (ShortList arms)
  80     put (Hook arm stiffness) = put (2::Word8) >> put arm >> put stiffness
  81     put (Wrench mom)         = put (3::Word8) >> put mom
  82     put Ball                 = put (4::Word8)
  83     get = do
  84         tag <- get :: Get Word8
  85         case tag of
  86             0 -> Block . fromShortList <$> get
  87             1 -> Pivot . fromShortList <$> get
  88             2 -> liftM2 Hook get get
  89             3 -> Wrench <$> get
  90             4 -> return Ball
  91 instance Binary Connection where
  92     put (Connection (ri,rp) (ei,ep) l) = putPackedInt ri >> put rp >> putPackedInt ei >> put ep >> put l
  93     get = do
  94         ri <- getPackedInt
  95         rp <- get
  96         ei <- getPackedInt
  97         ep <- get
  98         Connection (ri,rp) (ei,ep) <$> get
  99 instance Binary Link where
 100     put (Free p)     = put (0::Word8) >> put p
 101     put (Spring d l) = put (1::Word8) >> put d >> putPackedInt l
 102     get = do
 103         tag <- get :: Get Word8
 104         case tag of
 105             0 -> Free <$> get
 106             1 -> liftM2 Spring get getPackedInt
 107 instance Binary HookForce where
 108     put NullHF         = put (0::Word8)
 109     put (TorqueHF dir) = put (1::Word8) >> putPackedInt dir
 110     put (PushHF v)     = put (2::Word8) >> put v
 111     get = do
 112         tag <- get :: Get Word8
 113         case tag of
 114             0 -> return NullHF
 115             1 -> TorqueHF <$> getPackedInt
 116             2 -> PushHF <$> get
 117 instance Binary Frame where
 118     put (BasicFrame s) = putPackedInt s
 119     get = BasicFrame <$> getPackedInt
 120
 121 instance Binary PlayerMove where
 122     put NullPM           = put (0::Word8)
 123     put (HookPush v)     = put (1::Word8) >> put v
 124     put (HookTorque dir) = put (2::Word8) >> putPackedInt dir
 125     put (WrenchPush v)   = put (3::Word8) >> put v
 126     get = do
 127         tag <- get :: Get Word8
 128         case tag of
 129             0 -> return NullPM
 130             1 -> HookPush <$> get
 131             2 -> HookTorque <$> getPackedInt
 132             3 -> WrenchPush <$> get