module Data.Approximate.Mass
( Mass(..)
, (|?), (&?), (^?)
) where
import Control.Applicative
import Control.Comonad
import Control.DeepSeq
import Control.Monad
import Data.Binary as Binary
import Data.Bytes.Serial as Bytes
import Data.Copointed
import Data.Data
import Data.Foldable
import Data.Functor.Bind
import Data.Functor.Extend
import Data.Hashable
import Data.Hashable.Extras
import Data.Pointed
import Data.SafeCopy
import Data.Semigroup
import Data.Serialize as Serialize
import Data.Traversable
import Data.Vector.Generic as G
import Data.Vector.Generic.Mutable as M
import Data.Vector.Unboxed as U
import Generics.Deriving
import Numeric.Log
data Mass a = Mass !(Log Double) a
deriving (Eq,Ord,Show,Read,Typeable,Data,Generic)
instance Binary a => Binary (Mass a) where
put (Mass p a) = Binary.put p >> Binary.put a
get = Mass <$> Binary.get <*> Binary.get
instance Serialize a => Serialize (Mass a) where
put (Mass p a) = Serialize.put p >> Serialize.put a
get = Mass <$> Serialize.get <*> Serialize.get
instance Serialize a => SafeCopy (Mass a)
instance Hashable a => Hashable (Mass a)
instance Hashable1 Mass
instance Serial1 Mass where
serializeWith f (Mass p a) = serialize p >> f a
deserializeWith m = Mass <$> deserialize <*> m
instance Serial a => Serial (Mass a) where
serialize (Mass p a) = serialize p >> serialize a
deserialize = Mass <$> deserialize <*> deserialize
instance Functor Mass where
fmap f (Mass p a) = Mass p (f a)
instance Foldable Mass where
foldMap f (Mass _ a) = f a
newtype instance U.MVector s (Mass a) = MV_Mass (U.MVector s (Log Double,a))
newtype instance U.Vector (Mass a) = V_Mass (U.Vector (Log Double,a))
instance Unbox a => M.MVector U.MVector (Mass a) where
basicLength (MV_Mass v) = M.basicLength v
basicUnsafeSlice i n (MV_Mass v) = MV_Mass $ M.basicUnsafeSlice i n v
basicOverlaps (MV_Mass v1) (MV_Mass v2) = M.basicOverlaps v1 v2
basicUnsafeNew n = MV_Mass `liftM` M.basicUnsafeNew n
basicUnsafeReplicate n (Mass p a) = MV_Mass `liftM` M.basicUnsafeReplicate n (p,a)
basicUnsafeRead (MV_Mass v) i = uncurry Mass `liftM` M.basicUnsafeRead v i
basicUnsafeWrite (MV_Mass v) i (Mass p a) = M.basicUnsafeWrite v i (p,a)
basicClear (MV_Mass v) = M.basicClear v
basicSet (MV_Mass v) (Mass p a) = M.basicSet v (p,a)
basicUnsafeCopy (MV_Mass v1) (MV_Mass v2) = M.basicUnsafeCopy v1 v2
basicUnsafeMove (MV_Mass v1) (MV_Mass v2) = M.basicUnsafeMove v1 v2
basicUnsafeGrow (MV_Mass v) n = MV_Mass `liftM` M.basicUnsafeGrow v n
instance Unbox a => G.Vector U.Vector (Mass a) where
basicUnsafeFreeze (MV_Mass v) = V_Mass `liftM` G.basicUnsafeFreeze v
basicUnsafeThaw (V_Mass v) = MV_Mass `liftM` G.basicUnsafeThaw v
basicLength (V_Mass v) = G.basicLength v
basicUnsafeSlice i n (V_Mass v) = V_Mass $ G.basicUnsafeSlice i n v
basicUnsafeIndexM (V_Mass v) i
= uncurry Mass `liftM` G.basicUnsafeIndexM v i
basicUnsafeCopy (MV_Mass mv) (V_Mass v) = G.basicUnsafeCopy mv v
elemseq _ (Mass p a) z
= G.elemseq (undefined :: U.Vector (Log Double)) p
$ G.elemseq (undefined :: U.Vector a) a z
instance NFData a => NFData (Mass a) where
rnf (Mass _ a) = rnf a `seq` ()
instance Traversable Mass where
traverse f (Mass p a) = Mass p <$> f a
instance Apply Mass where
(<.>) = (<*>)
instance Pointed Mass where
point = Mass 1
instance Copointed Mass where
copoint (Mass _ a) = a
instance Applicative Mass where
pure = Mass 1
Mass p f <*> Mass q a = Mass (p * q) (f a)
instance Monoid a => Monoid (Mass a) where
mempty = Mass 1 mempty
mappend (Mass p a) (Mass q b) = Mass (p * q) (mappend a b)
instance Semigroup a => Semigroup (Mass a) where
Mass p a <> Mass q b = Mass (p * q) (a <> b)
instance Bind Mass where
Mass p a >>- f = case f a of
Mass q b -> Mass (p * q) b
instance Monad Mass where
return = Mass 1
Mass p a >>= f = case f a of
Mass q b -> Mass (p * q) b
instance Extend Mass where
duplicated (Mass n a) = Mass n (Mass n a)
extended f w@(Mass n _) = Mass n (f w)
instance Comonad Mass where
extract (Mass _ a) = a
duplicate (Mass n a) = Mass n (Mass n a)
extend f w@(Mass n _) = Mass n (f w)
instance ComonadApply Mass where
(<@>) = (<*>)
infixl 6 ^?
infixr 3 &?
infixr 2 |?
(&?) :: Mass Bool -> Mass Bool -> Mass Bool
Mass p False &? Mass q False = Mass (max p q) False
Mass p False &? Mass _ True = Mass p False
Mass _ True &? Mass q False = Mass q False
Mass p True &? Mass q True = Mass (p * q) True
(|?) :: Mass Bool -> Mass Bool -> Mass Bool
Mass p False |? Mass q False = Mass (p * q) False
Mass _ False |? Mass q True = Mass q True
Mass p True |? Mass _ False = Mass p True
Mass p True |? Mass q True = Mass (max p q) True
(^?) :: Mass Bool -> Mass Bool -> Mass Bool
Mass p a ^? Mass q b = Mass (p * q) (xor a b) where
xor True True = False
xor False True = True
xor True False = True
xor False False = False