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 Data.Binary
  13 import qualified Data.Vector as Vector
  14 import Control.Monad
  15 import Data.Int (Int8)
  16
  17 import GameStateTypes
  18 import Physics
  19 import Hex
  20 import Frame
  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 liftM 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 liftM 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 = liftM fromSmallNat get
  41 getPackedInt = liftM 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 `liftM` 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 = liftM PHS get
  71 instance Binary GameState where
  72     put (GameState pps conns) = put (ShortList $ Vector.toList pps) >> put (ShortList conns)
  73     get = liftM2 GameState (liftM (Vector.fromList . fromShortList) get) (liftM 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 -> liftM (Block . fromShortList) get
  87             1 -> liftM (Pivot . fromShortList) get
  88             2 -> liftM2 Hook get get
  89             3 -> liftM 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         l <- get
  99         return $ Connection (ri,rp) (ei,ep) l
 100 instance Binary Link where
 101     put (Free p) = put (0::Word8) >> put p
 102     put (Spring d l) = put (1::Word8) >> put d >> putPackedInt l
 103     get = do
 104         tag <- get :: Get Word8
 105         case tag of
 106             0 -> liftM Free get
 107             1 -> liftM2 Spring get getPackedInt
 108 instance Binary HookForce where
 109     put NullHF = put (0::Word8)
 110     put (TorqueHF dir) = put (1::Word8) >> putPackedInt dir
 111     put (PushHF v) = put (2::Word8) >> put v
 112     get = do
 113         tag <- get :: Get Word8
 114         case tag of
 115             0 -> return NullHF
 116             1 -> liftM TorqueHF getPackedInt
 117             2 -> liftM PushHF get
 118 instance Binary Frame where
 119     put (BasicFrame s) = putPackedInt s
 120     get = liftM BasicFrame getPackedInt
 121
 122 instance Binary PlayerMove where
 123     put NullPM = put (0::Word8)
 124     put (HookPush v) = put (1::Word8) >> put v
 125     put (HookTorque dir) = put (2::Word8) >> putPackedInt dir
 126     put (WrenchPush v) = put (3::Word8) >> put v
 127     get = do
 128         tag <- get :: Get Word8
 129         case tag of
 130             0 -> return NullPM
 131             1 -> liftM HookPush get
 132             2 -> liftM HookTorque getPackedInt
 133             3 -> liftM WrenchPush get