diff --git a/Blaze/ByteString/Builder/ZoomCache/Internal.hs b/Blaze/ByteString/Builder/ZoomCache/Internal.hs --- a/Blaze/ByteString/Builder/ZoomCache/Internal.hs +++ b/Blaze/ByteString/Builder/ZoomCache/Internal.hs @@ -16,7 +16,7 @@ module Blaze.ByteString.Builder.ZoomCache.Internal ( -- * Builders - fromDataRateType + fromFlags , fromGlobal , fromSummary , fromTrackNo @@ -24,6 +24,7 @@ ) where import Blaze.ByteString.Builder +import Data.Bits import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C import Data.Monoid @@ -36,9 +37,15 @@ ---------------------------------------------------------------------- -- Creating builders for ZoomCache types. -fromDataRateType :: DataRateType -> Builder -fromDataRateType ConstantDR = fromInt16be 0 -fromDataRateType VariableDR = fromInt16be 1 +fromFlags :: Bool -> Bool -> DataRateType -> Builder +fromFlags delta zlib drType = fromInt16be (zl .|. dl .|. dr) + where + zl | zlib = 4 + | otherwise = 0 + dl | delta = 2 + | otherwise = 0 + dr | drType == VariableDR = 1 + | otherwise = 0 fromGlobal :: Global -> Builder fromGlobal Global{..} = mconcat diff --git a/Data/Iteratee/ZoomCache.hs b/Data/Iteratee/ZoomCache.hs --- a/Data/Iteratee/ZoomCache.hs +++ b/Data/Iteratee/ZoomCache.hs @@ -37,20 +37,22 @@ import Control.Applicative import Control.Monad (msum, replicateM) import Control.Monad.Trans (MonadIO) +import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as B +import Data.Functor.Identity import Data.Int import Data.IntMap (IntMap) import qualified Data.IntMap as IM import Data.Iteratee (Iteratee) import qualified Data.Iteratee as I -import qualified Data.ListLike as LL +import Data.Iteratee.ZLib import Data.Maybe -import Data.Word import Data.Iteratee.ZoomCache.Utils import Data.ZoomCache.Common import Data.ZoomCache.Format +import Data.ZoomCache.Numeric.Delta import Data.ZoomCache.Types ---------------------------------------------------------------------- @@ -80,23 +82,23 @@ -- | An enumeratee of a zoom-cache file, from the global header onwards. -- The global and track headers will be transparently read, and the -- 'CacheFile' visible in the 'Stream' elements. -enumCacheFile :: (I.Nullable s, LL.ListLike s Word8, Functor m, MonadIO m) +enumCacheFile :: (Functor m, MonadIO m) => [IdentifyCodec] - -> I.Enumeratee s Stream m a + -> I.Enumeratee ByteString Stream m a enumCacheFile mappings iter = do fi <- iterHeaders mappings enumStream fi iter -- | An enumeratee of zoom-cache data, after global and track headers -- have been read, or if the 'CacheFile' has been acquired elsewhere. -enumStream :: (I.Nullable s, LL.ListLike s Word8, Functor m, MonadIO m) +enumStream :: (Functor m, MonadIO m) => CacheFile - -> I.Enumeratee s Stream m a + -> I.Enumeratee ByteString Stream m a enumStream = I.unfoldConvStream go where - go :: (I.Nullable s, LL.ListLike s Word8, Functor m, MonadIO m) + go :: (Functor m, MonadIO m) => CacheFile - -> Iteratee s m (CacheFile, Stream) + -> Iteratee ByteString m (CacheFile, Stream) go cf = do header <- I.joinI $ I.takeUpTo 8 I.stream2list case parseHeader (B.pack header) of @@ -125,22 +127,22 @@ -- | Parse only the global and track headers of a zoom-cache file, returning -- a 'CacheFile' -iterHeaders :: (I.Nullable s, LL.ListLike s Word8, Functor m, Monad m) +iterHeaders :: (Functor m, Monad m) => [IdentifyCodec] - -> I.Iteratee s m CacheFile + -> I.Iteratee ByteString m CacheFile iterHeaders mappings = iterGlobal >>= go where - iterGlobal :: (I.Nullable s, LL.ListLike s Word8, Functor m, Monad m) - => Iteratee s m CacheFile + iterGlobal :: (Functor m, Monad m) + => Iteratee ByteString m CacheFile iterGlobal = do header <- I.joinI $ I.takeUpTo 8 I.stream2list case parseHeader (B.pack header) of Just GlobalHeader -> mkCacheFile <$> readGlobalHeader _ -> error "No global header" - go :: (I.Nullable s, LL.ListLike s Word8, Functor m, Monad m) + go :: (Functor m, Monad m) => CacheFile - -> Iteratee s m CacheFile + -> Iteratee ByteString m CacheFile go fi = do header <- I.joinI $ I.takeUpTo 8 I.stream2list case parseHeader (B.pack header) of @@ -152,8 +154,8 @@ else go fi' _ -> return fi -readGlobalHeader :: (I.Nullable s, LL.ListLike s Word8, Functor m, Monad m) - => Iteratee s m Global +readGlobalHeader :: (Functor m, Monad m) + => Iteratee ByteString m Global readGlobalHeader = do v <- readVersion n <- readInt32be @@ -162,25 +164,28 @@ _u <- B.pack <$> (I.joinI $ I.takeUpTo 20 I.stream2list) return $ Global v n p b Nothing -readTrackHeader :: (I.Nullable s, LL.ListLike s Word8, Functor m, Monad m) +readTrackHeader :: (Functor m, Monad m) => [IdentifyCodec] - -> Iteratee s m (TrackNo, TrackSpec) + -> Iteratee ByteString m (TrackNo, TrackSpec) readTrackHeader mappings = do trackNo <- readInt32be trackType <- readCodec mappings - drType <- readDataRateType + (drType, delta, zlib) <- readFlags rate <- readRational64be byteLength <- readInt32be name <- B.pack <$> (I.joinI $ I.takeUpTo byteLength I.stream2list) - return (trackNo, TrackSpec trackType drType rate name) + return (trackNo, TrackSpec trackType delta zlib drType rate name) ------------------------------------------------------------ -- Packet, Summary reading -readPacket :: (I.Nullable s, LL.ListLike s Word8, Functor m, Monad m) +enumInflateZlib :: (MonadIO m) => I.Enumeratee ByteString ByteString m a +enumInflateZlib = enumInflate Zlib defaultDecompressParams + +readPacket :: (Functor m, MonadIO m) => IntMap TrackSpec - -> Iteratee s m (TrackNo, Maybe Packet) + -> Iteratee ByteString m (TrackNo, Maybe Packet) readPacket specs = do trackNo <- readInt32be entryTime <- TS <$> readInt64be @@ -189,9 +194,14 @@ byteLength <- readInt32be packet <- case IM.lookup trackNo specs of Just TrackSpec{..} -> do - let readTS = readTimeStamps specDRType count entryTime - d <- readRawCodec specType count - ts <- readTS + let readDTS :: (Functor m, Monad m) + => Iteratee ByteString m (ZoomRaw, [TimeStamp]) + readDTS = readDataTimeStamps specType specDeltaEncode specDRType count entryTime + (d, ts) <- if specZlibCompress + then do + z <- I.joinI $ enumInflateZlib I.stream2stream + return $ runner1 $ I.enumPure1Chunk z readDTS + else readDTS return . Just $ (Packet trackNo entryTime exitTime count d ts) Nothing -> do @@ -199,28 +209,41 @@ return Nothing return (trackNo, packet) where - readRawCodec :: (I.Nullable s, LL.ListLike s Word8, - Functor m, Monad m) - => Codec -> Int -> Iteratee s m ZoomRaw - readRawCodec (Codec a) count = ZoomRaw <$> replicateM count (readRawAs a) + runner1 :: Identity (I.Iteratee s Identity c) -> c + runner1 = runIdentity . I.run . runIdentity - readRawAs :: (ZoomReadable a, I.Nullable s, LL.ListLike s Word8, - Functor m, Monad m) - => a -> Iteratee s m a + readRawCodec :: (Functor m, Monad m) + => Codec -> Bool -> Int + -> Iteratee ByteString m ZoomRaw + readRawCodec (Codec a) delta count = ZoomRaw . f <$> replicateM count (readRawAs a) + where + f | delta = deltaDecodeRaw + | otherwise = id + + readRawAs :: (ZoomReadable a, Functor m, Monad m) + => a -> Iteratee ByteString m a readRawAs = const readRaw - readTimeStamps :: (I.Nullable s, LL.ListLike s Word8, Functor m, Monad m) + readDataTimeStamps :: (Functor m, Monad m) + => Codec -> Bool -> DataRateType -> Int -> TimeStamp + -> Iteratee ByteString m (ZoomRaw, [TimeStamp]) + readDataTimeStamps codec delta drType count entry = do + d <- readRawCodec codec delta count + ts <- readTimeStamps drType count entry + return (d, ts) + + readTimeStamps :: (Functor m, Monad m) => DataRateType -> Int -> TimeStamp - -> Iteratee s m [TimeStamp] + -> Iteratee ByteString m [TimeStamp] readTimeStamps drType count entry = map TS <$> case drType of ConstantDR -> do return $ take count [unTS entry ..] VariableDR -> do - replicateM count readInt64be + deltaDecode <$> replicateM count readInt64be -readSummaryBlock :: (I.Nullable s, LL.ListLike s Word8, Functor m, Monad m) +readSummaryBlock :: (Functor m, Monad m) => IntMap TrackSpec - -> Iteratee s m (TrackNo, Maybe ZoomSummary) + -> Iteratee ByteString m (TrackNo, Maybe ZoomSummary) readSummaryBlock specs = do trackNo <- readInt32be lvl <- readInt32be @@ -237,16 +260,14 @@ return Nothing return (trackNo, summary) where - readSummaryCodec :: (I.Nullable s, LL.ListLike s Word8, - Functor m, Monad m) + readSummaryCodec :: (Functor m, Monad m) => Codec -> TrackNo -> Int -> TimeStamp -> TimeStamp - -> Iteratee s m ZoomSummary + -> Iteratee ByteString m ZoomSummary readSummaryCodec (Codec a) trackNo lvl entryTime exitTime = do ZoomSummary <$> (Summary trackNo lvl entryTime exitTime <$> readSummaryAs a) - readSummaryAs :: (ZoomReadable a, I.Nullable s, LL.ListLike s Word8, - Functor m, Monad m) - => a -> Iteratee s m (SummaryData a) + readSummaryAs :: (ZoomReadable a, Functor m, Monad m) + => a -> Iteratee ByteString m (SummaryData a) readSummaryAs = const readSummary @@ -254,18 +275,18 @@ -- Convenience functions -- | Map a monadic 'Stream' processing function over an entire zoom-cache file. -mapStream :: (I.Nullable s, LL.ListLike s Word8, Functor m, MonadIO m) +mapStream :: (Functor m, MonadIO m) => [IdentifyCodec] -> (Stream -> m ()) - -> Iteratee s m () + -> Iteratee ByteString m () mapStream mappings = I.joinI . enumCacheFile mappings . I.mapChunksM_ {-# INLINABLE mapStream #-} -- | Map a monadic 'Packet' processing function over an entire zoom-cache file. -mapPackets :: (I.Nullable s, LL.ListLike s Word8, Functor m, MonadIO m) +mapPackets :: (Functor m, MonadIO m) => [IdentifyCodec] -> (Packet -> m ()) - -> Iteratee s m () + -> Iteratee ByteString m () mapPackets mappings f = mapStream mappings process where process StreamPacket{..} = f strmPacket @@ -273,10 +294,10 @@ {-# INLINABLE mapPackets #-} -- | Map a monadic 'Summary' processing function over an entire zoom-cache file. -mapSummaries :: (I.Nullable s, LL.ListLike s Word8, Functor m, MonadIO m) +mapSummaries :: (Functor m, MonadIO m) => [IdentifyCodec] -> (ZoomSummary -> m ()) - -> Iteratee s m () + -> Iteratee ByteString m () mapSummaries mappings f = mapStream mappings process where process StreamSummary{..} = f strmSummary @@ -286,13 +307,13 @@ ---------------------------------------------------------------------- -- zoom-cache datatype parsers -readVersion :: (I.Nullable s, LL.ListLike s Word8, Functor m, Monad m) - => Iteratee s m Version +readVersion :: (Functor m, Monad m) + => Iteratee ByteString m Version readVersion = Version <$> readInt16be <*> readInt16be -readCodec :: (I.Nullable s, LL.ListLike s Word8, Functor m, Monad m) +readCodec :: (Functor m, Monad m) => [IdentifyCodec] - -> Iteratee s m Codec + -> Iteratee ByteString m Codec readCodec mappings = do tt <- B.pack <$> (I.joinI $ I.takeUpTo 8 I.stream2list) maybe (error "Unknown track type") return (parseCodec mappings tt) @@ -300,11 +321,17 @@ parseCodec :: [IdentifyCodec] -> IdentifyCodec parseCodec mappings h = msum . map ($ h) $ mappings -readDataRateType :: (I.Nullable s, LL.ListLike s Word8, Functor m, Monad m) - => Iteratee s m DataRateType -readDataRateType = do +readFlags :: (Functor m, Monad m) + => Iteratee ByteString m (DataRateType, Bool, Bool) +readFlags = do (n :: Int16) <- readInt16be - case n of - 0 -> return ConstantDR - 1 -> return VariableDR - _ -> error "Bad data rate type" + let drType = case n .&. 1 of + 0 -> ConstantDR + _ -> VariableDR + delta = case n .&. 2 of + 0 -> False + _ -> True + zlib = case n .&. 4 of + 0 -> False + _ -> True + return (drType, delta, zlib) diff --git a/Data/ZoomCache/Codec.hs b/Data/ZoomCache/Codec.hs --- a/Data/ZoomCache/Codec.hs +++ b/Data/ZoomCache/Codec.hs @@ -16,7 +16,7 @@ -- implement the methods of the ZoomReadable and ZoomWritable classes. -- -- For sample implementations, read the source of the provided instances --- "Data.ZoomCache.Int" and "Data.ZoomCache.Double". +-- "Data.ZoomCache.Numeric.Int" and "Data.ZoomCache.Numeric.Double". ---------------------------------------------------------------------- module Data.ZoomCache.Codec ( @@ -60,6 +60,8 @@ , TimeStampDiff(..) , timeStampDiff + -- * Delta encoding + , module Data.ZoomCache.Numeric.Delta -- * Minimum and maximum floating point , module Data.ZoomCache.Numeric.FloatMinMax ) where @@ -70,4 +72,5 @@ import Data.ZoomCache.Identify import Data.ZoomCache.Types import Data.ZoomCache.Write +import Data.ZoomCache.Numeric.Delta import Data.ZoomCache.Numeric.FloatMinMax diff --git a/Data/ZoomCache/Common.hs b/Data/ZoomCache/Common.hs --- a/Data/ZoomCache/Common.hs +++ b/Data/ZoomCache/Common.hs @@ -63,5 +63,5 @@ -- For variable datarate, explicit timestamps are attached to each datum, encoded -- as a separate block of timestamps in the Raw Data packet. data DataRateType = ConstantDR | VariableDR - deriving (Show) + deriving (Eq, Show) diff --git a/Data/ZoomCache/Format.hs b/Data/ZoomCache/Format.hs --- a/Data/ZoomCache/Format.hs +++ b/Data/ZoomCache/Format.hs @@ -95,7 +95,7 @@ -- | The minor version encoded by this library versionMinor :: Int -versionMinor = 0 +versionMinor = 1 {- | @@ -115,7 +115,7 @@ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ | ... | 16-19 +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ - | Flag: 0=CBR, 1=VBR | 20-23 + | Reserved |z|d|v| 20-23 +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ | Datarate numerator (int64) | 24-27 +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ @@ -131,6 +131,10 @@ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ @ + @v@ : Variable data rate flag. 0=CBR, 1=VBR + @d@ : Delta encode flag. 0=Raw values 1=delta encoded values + @z@ : Zlib encode flag. 0=uncompressed 1=zlib compressed + Datarate: numerator 0 indicates variable bitrate (all data values are timestamped) -} @@ -213,7 +217,7 @@ @ Some default encodings of Summary Data are provided in modules -"Data.ZoomCache.Double" and "Data.ZoomCache.Int". +"Data.ZoomCache.Numeric.Double" and "Data.ZoomCache.Numeric.Int". -} diff --git a/Data/ZoomCache/Numeric/Delta.hs b/Data/ZoomCache/Numeric/Delta.hs new file mode 100644 --- /dev/null +++ b/Data/ZoomCache/Numeric/Delta.hs @@ -0,0 +1,35 @@ +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Data.ZoomCache.Numeric.Delta +-- Copyright : Conrad Parker +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Conrad Parker +-- Stability : unstable +-- Portability : unknown +-- +-- Delta encoding and decoding of numeric values. +---------------------------------------------------------------------- + +module Data.ZoomCache.Numeric.Delta ( + -- * Delta encoding + deltaEncode + , deltaDecode +) where + +-- | Delta encode a list of numbers +-- +-- > > deltaEncode [1,2,3,2,4] +-- > [1,1,1,-1,2] +deltaEncode :: Num a => [a] -> [a] +deltaEncode xs = zipWith (-) xs (0:xs) +{-# INLINE deltaEncode #-} + +-- | Delta-decode a list of numbers +-- +-- > > deltaDecode [1,1,1,-1,2] +-- > [1,2,3,2,4] +deltaDecode :: Num a => [a] -> [a] +deltaDecode = scanl1 (+) +{-# INLINE deltaDecode #-} diff --git a/Data/ZoomCache/Numeric/IEEE754.hs b/Data/ZoomCache/Numeric/IEEE754.hs --- a/Data/ZoomCache/Numeric/IEEE754.hs +++ b/Data/ZoomCache/Numeric/IEEE754.hs @@ -85,7 +85,6 @@ import Blaze.ByteString.Builder import Data.ByteString (ByteString) import Data.Iteratee (Iteratee) -import Data.Word import Text.Printf import Data.ZoomCache.Codec @@ -113,7 +112,8 @@ prettyRaw = prettyPacketFloat prettySummaryData = prettySummaryFloat -{-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee [Word8] m (SummaryData Float) #-} + deltaDecodeRaw = deltaDecodeNum + {-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee ByteString m (SummaryData Float) #-} instance ZoomWrite Float where @@ -139,6 +139,7 @@ toSummaryData = mkSummaryNum updateSummaryData = updateSummaryNum appendSummaryData = appendSummaryNum + deltaEncodeRaw = deltaEncodeNum instance ZoomNum Float where numEntry = summaryFloatEntry @@ -185,7 +186,8 @@ prettyRaw = prettyPacketFloat prettySummaryData = prettySummaryFloat -{-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee [Word8] m (SummaryData Double) #-} + deltaDecodeRaw = deltaDecodeNum + {-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee ByteString m (SummaryData Double) #-} instance ZoomWrite Double where @@ -211,6 +213,7 @@ toSummaryData = mkSummaryNum updateSummaryData = updateSummaryNum appendSummaryData = appendSummaryNum + deltaEncodeRaw = deltaEncodeNum instance ZoomNum Double where numEntry = summaryDoubleEntry diff --git a/Data/ZoomCache/Numeric/Int.hs b/Data/ZoomCache/Numeric/Int.hs --- a/Data/ZoomCache/Numeric/Int.hs +++ b/Data/ZoomCache/Numeric/Int.hs @@ -178,7 +178,6 @@ import Data.Int import Data.Iteratee (Iteratee) import Data.Maybe (fromMaybe) -import Data.Word import Text.Printf import Data.ZoomCache.Codec @@ -206,7 +205,8 @@ prettyRaw = show prettySummaryData = prettySummaryInt -{-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee [Word8] m (SummaryData Int) #-} + deltaDecodeRaw = deltaDecodeNum + {-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee ByteString m (SummaryData Int) #-} instance ZoomWrite Int where @@ -233,6 +233,7 @@ toSummaryData = mkSummaryNum updateSummaryData = updateSummaryNum appendSummaryData = appendSummaryNum + deltaEncodeRaw = deltaEncodeNum instance ZoomNum Int where numEntry = summaryIntEntry @@ -280,7 +281,8 @@ prettyRaw = show prettySummaryData = prettySummaryInt -{-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee [Word8] m (SummaryData Int8) #-} + deltaDecodeRaw = deltaDecodeNum + {-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee ByteString m (SummaryData Int8) #-} instance ZoomWrite Int8 where @@ -307,6 +309,7 @@ toSummaryData = mkSummaryNum updateSummaryData = updateSummaryNum appendSummaryData = appendSummaryNum + deltaEncodeRaw = deltaEncodeNum instance ZoomNum Int8 where numEntry = summaryInt8Entry @@ -354,7 +357,8 @@ prettyRaw = show prettySummaryData = prettySummaryInt -{-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee [Word8] m (SummaryData Int16) #-} + deltaDecodeRaw = deltaDecodeNum + {-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee ByteString m (SummaryData Int16) #-} instance ZoomWrite Int16 where @@ -381,6 +385,7 @@ toSummaryData = mkSummaryNum updateSummaryData = updateSummaryNum appendSummaryData = appendSummaryNum + deltaEncodeRaw = deltaEncodeNum instance ZoomNum Int16 where numEntry = summaryInt16Entry @@ -428,7 +433,8 @@ prettyRaw = show prettySummaryData = prettySummaryInt -{-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee [Word8] m (SummaryData Int32) #-} + deltaDecodeRaw = deltaDecodeNum + {-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee ByteString m (SummaryData Int32) #-} instance ZoomWrite Int32 where @@ -455,6 +461,7 @@ toSummaryData = mkSummaryNum updateSummaryData = updateSummaryNum appendSummaryData = appendSummaryNum + deltaEncodeRaw = deltaEncodeNum instance ZoomNum Int32 where numEntry = summaryInt32Entry @@ -502,7 +509,8 @@ prettyRaw = show prettySummaryData = prettySummaryInt -{-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee [Word8] m (SummaryData Int64) #-} + deltaDecodeRaw = deltaDecodeNum + {-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee ByteString m (SummaryData Int64) #-} instance ZoomWrite Int64 where @@ -529,6 +537,7 @@ toSummaryData = mkSummaryNum updateSummaryData = updateSummaryNum appendSummaryData = appendSummaryNum + deltaEncodeRaw = deltaEncodeNum instance ZoomNum Int64 where numEntry = summaryInt64Entry @@ -576,7 +585,8 @@ prettyRaw = show prettySummaryData = prettySummaryInt -{-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee [Word8] m (SummaryData Integer) #-} + deltaDecodeRaw = deltaDecodeNum + {-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee ByteString m (SummaryData Integer) #-} instance ZoomWrite Integer where @@ -603,6 +613,7 @@ toSummaryData = toSummaryInteger updateSummaryData = updateSummaryInteger appendSummaryData = appendSummaryNum + deltaEncodeRaw = deltaEncodeNum instance ZoomNum Integer where numEntry = summaryIntegerEntry diff --git a/Data/ZoomCache/Numeric/Internal.hs b/Data/ZoomCache/Numeric/Internal.hs --- a/Data/ZoomCache/Numeric/Internal.hs +++ b/Data/ZoomCache/Numeric/Internal.hs @@ -10,26 +10,25 @@ , mkSummaryNum , appendSummaryNum , updateSummaryNum + , deltaDecodeNum + , deltaEncodeNum ) where import Blaze.ByteString.Builder import Control.Monad (replicateM) +import Data.ByteString (ByteString) import Data.Iteratee (Iteratee) -import qualified Data.Iteratee as I -import qualified Data.ListLike as LL import Data.Maybe (fromMaybe) import Data.Monoid -import Data.Word import Data.ZoomCache.Codec import Data.ZoomCache.Numeric.Types ---------------------------------------------------------------------- -readSummaryNum :: (I.Nullable s, LL.ListLike s Word8, - Functor m, Monad m, +readSummaryNum :: (Functor m, Monad m, ZoomNum a) - => Iteratee s m (SummaryData a) + => Iteratee ByteString m (SummaryData a) readSummaryNum = do [en,ex,mn,mx] <- replicateM 4 readRaw [avg,rms] <- replicateM 2 readDouble64be @@ -89,3 +88,11 @@ where !(TSDiff dur) = timeStampDiff t (numWorkTime sw) {-# INLINEABLE updateSummaryNum #-} + +deltaDecodeNum :: ZoomNum a => [a] -> [a] +deltaDecodeNum = deltaDecode +{-# INLINE deltaDecodeNum #-} + +deltaEncodeNum :: ZoomNum a => SummaryWork a -> a -> a +deltaEncodeNum sw d = d - numWorkExit sw +{-# INLINE deltaEncodeNum #-} diff --git a/Data/ZoomCache/Numeric/Word.hs b/Data/ZoomCache/Numeric/Word.hs --- a/Data/ZoomCache/Numeric/Word.hs +++ b/Data/ZoomCache/Numeric/Word.hs @@ -175,7 +175,6 @@ prettyRaw = show prettySummaryData = prettySummaryWord -{-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee [Word8] m (SummaryData Word) #-} {-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee ByteString m (SummaryData Word) #-} instance ZoomWrite Word where @@ -249,7 +248,6 @@ prettyRaw = show prettySummaryData = prettySummaryWord -{-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee [Word8] m (SummaryData Word8) #-} {-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee ByteString m (SummaryData Word8) #-} instance ZoomWrite Word8 where @@ -323,7 +321,6 @@ prettyRaw = show prettySummaryData = prettySummaryWord -{-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee [Word8] m (SummaryData Word16) #-} {-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee ByteString m (SummaryData Word16) #-} instance ZoomWrite Word16 where @@ -397,7 +394,6 @@ prettyRaw = show prettySummaryData = prettySummaryWord -{-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee [Word8] m (SummaryData Word32) #-} {-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee ByteString m (SummaryData Word32) #-} instance ZoomWrite Word32 where @@ -471,7 +467,6 @@ prettyRaw = show prettySummaryData = prettySummaryWord -{-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee [Word8] m (SummaryData Word64) #-} {-# SPECIALIZE readSummaryNum :: (Functor m, Monad m) => Iteratee ByteString m (SummaryData Word64) #-} instance ZoomWrite Word64 where diff --git a/Data/ZoomCache/Pretty.hs b/Data/ZoomCache/Pretty.hs --- a/Data/ZoomCache/Pretty.hs +++ b/Data/ZoomCache/Pretty.hs @@ -47,8 +47,14 @@ [ "Track " ++ show trackNo ++ ":" , "\tName:\t" ++ C.unpack specName , "\tType:\t" ++ show specType + , "\tEnc:\t" ++ unwords [encoding, compression] , "\tRate:\t" ++ show specDRType ++ " " ++ ratShow specRate ] + where + encoding | specDeltaEncode = "Delta" + | otherwise = "Raw" + compression | specZlibCompress = "Zlib" + | otherwise = "Uncompressed" -- | Pretty-print a 'TimeStamp', given a datarate prettyTimeStamp :: Rational -> TimeStamp -> String diff --git a/Data/ZoomCache/Types.hs b/Data/ZoomCache/Types.hs --- a/Data/ZoomCache/Types.hs +++ b/Data/ZoomCache/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -55,9 +56,6 @@ import Data.IntMap (IntMap) import qualified Data.IntMap as IM import Data.Iteratee (Iteratee) -import qualified Data.Iteratee as I -import qualified Data.ListLike as LL -import Data.Word import Data.ZoomCache.Common @@ -67,10 +65,12 @@ -- | A specification of the type and name of each track data TrackSpec = TrackSpec - { specType :: !Codec - , specDRType :: !DataRateType - , specRate :: {-# UNPACK #-}!Rational - , specName :: !ByteString + { specType :: !Codec + , specDeltaEncode :: !Bool + , specZlibCompress :: !Bool + , specDRType :: !DataRateType + , specRate :: {-# UNPACK #-}!Rational + , specName :: !ByteString } deriving (Show) @@ -129,6 +129,7 @@ , summaryExitTime :: {-# UNPACK #-}!TimeStamp , summaryData :: !(SummaryData a) } + deriving (Typeable) -- | The duration covered by a summary, in units of 1 / the track's datarate summaryDuration :: Summary a -> TimeStampDiff @@ -151,23 +152,25 @@ -- argument. trackIdentifier :: a -> ByteString - -- | An iteratee to read one value of type 'a' from a stream of something - -- like '[Word8]' or 'ByteString'. - readRaw :: (I.Nullable s, LL.ListLike s Word8, Functor m, Monad m) - => Iteratee s m a + -- | An iteratee to read one value of type 'a' from a stream of 'ByteString'. + readRaw :: (Functor m, Monad m) + => Iteratee ByteString m a -- | An iteratee to read one value of type 'SummaryData a' from a stream - -- of something like '[Word8]' or 'ByteString'. - readSummary :: (I.Nullable s, LL.ListLike s Word8, Functor m, Monad m) - => Iteratee s m (SummaryData a) + -- of 'ByteString'. + readSummary :: (Functor m, Monad m) + => Iteratee ByteString m (SummaryData a) -- | Pretty printing, used for dumping values of type 'a'. prettyRaw :: a -> String -- | Pretty printing for values of type 'SummaryData a'. prettySummaryData :: SummaryData a -> String - -- typeOfSummaryData :: SummaryData a -> TypeRep + -- | Delta-decode a list of values + deltaDecodeRaw :: [a] -> [a] + deltaDecodeRaw = id + data ZoomRaw = forall a . ZoomReadable a => ZoomRaw [a] data ZoomSummary = forall a . ZoomReadable a => ZoomSummary (Summary a) @@ -202,6 +205,10 @@ appendSummaryData :: TimeStampDiff -> SummaryData a -> TimeStampDiff -> SummaryData a -> SummaryData a + + -- | Delta-encode a value. + deltaEncodeRaw :: SummaryWork a -> a -> a + deltaEncodeRaw _ = id data ZoomWork = forall a . (Typeable a, ZoomWritable a) => ZoomWork { levels :: IntMap (Summary a -> Summary a) diff --git a/Data/ZoomCache/Write.hs b/Data/ZoomCache/Write.hs --- a/Data/ZoomCache/Write.hs +++ b/Data/ZoomCache/Write.hs @@ -46,11 +46,13 @@ ) where import Blaze.ByteString.Builder hiding (flush) +import Codec.Compression.Zlib import Control.Applicative ((<$>)) import Control.Monad.State import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L import Data.Dynamic import qualified Data.Foldable as Fold import Data.IntMap (IntMap) @@ -62,6 +64,7 @@ import Blaze.ByteString.Builder.ZoomCache.Internal import Data.ZoomCache.Common import Data.ZoomCache.Format +import Data.ZoomCache.Numeric.Delta import Data.ZoomCache.Types ------------------------------------------------------------ @@ -85,7 +88,7 @@ data TrackWork = TrackWork { twSpec :: TrackSpec , twBuilder :: Builder - , twTSBuilder :: Builder + , twReverseTS :: [TimeStamp] , twWriter :: Maybe ZoomWork , twCount :: {-# UNPACK #-}!Int , twWatermark :: {-# UNPACK #-}!Int @@ -121,7 +124,7 @@ tracks <- gets whTrackWork doRaw <- gets whWriteData when doRaw $ - liftIO $ Fold.mapM_ (B.hPut h) $ IM.mapWithKey bsFromTrack tracks + liftIO $ Fold.mapM_ (L.hPut h) $ IM.mapWithKey bsFromTrack tracks mapM_ (uncurry flushSummary) (IM.assocs tracks) pending <- mconcat . IM.elems <$> gets whDeferred liftIO . B.hPut h . toByteString $ pending @@ -160,11 +163,12 @@ closeWrite z = hClose (whHandle z) -- | Create a track map for a stream of a given type, as track no. 1 -oneTrack :: (ZoomReadable a) => a -> DataRateType -> Rational -> ByteString -> TrackMap -oneTrack a !drType !rate !name = IM.singleton 1 (mkTrackSpec a drType rate name) +oneTrack :: (ZoomReadable a) => a -> Bool -> Bool -> DataRateType -> Rational -> ByteString -> TrackMap +oneTrack a delta zlib !drType !rate !name = IM.singleton 1 (mkTrackSpec a delta zlib drType rate name) {-# INLINABLE oneTrack #-} -mkTrackSpec :: (ZoomReadable a) => a -> DataRateType -> Rational -> ByteString -> TrackSpec +mkTrackSpec :: (ZoomReadable a) + => a -> Bool -> Bool -> DataRateType -> Rational -> ByteString -> TrackSpec mkTrackSpec a = TrackSpec (Codec a) -- | Query the maximum number of data points to buffer for a given track before @@ -198,7 +202,7 @@ , toByteString $ mconcat [ fromTrackNo trackNo , fromCodec specType - , fromDataRateType specDRType + , fromFlags specDeltaEncode specZlibCompress specDRType , fromRational64 specRate , fromIntegral32be . C.length $ specName ] @@ -242,7 +246,10 @@ doRaw <- gets whWriteData when doRaw $ - modifyTrack trackNo $ \z -> z { twBuilder = twBuilder z <> fromRaw d } + modifyTrack trackNo $ \z -> z + { twBuilder = twBuilder z <> + (deltaEncodeWork (specDeltaEncode . twSpec $ z) (twWriter z) d) + } modifyTrack trackNo $ \z -> let c = (twCount z) in c `seq` z { twCount = c + 1 @@ -258,8 +265,9 @@ doRaw <- gets whWriteData when doRaw $ modifyTrack trackNo $ \z -> z - { twBuilder = twBuilder z <> fromRaw d - , twTSBuilder = twTSBuilder z <> fromTimeStamp t + { twBuilder = twBuilder z <> + (deltaEncodeWork (specDeltaEncode . twSpec $ z) (twWriter z) d) + , twReverseTS = t : twReverseTS z } modifyTrack trackNo $ \z -> let c = (twCount z) in c `seq` z @@ -268,6 +276,15 @@ } flushIfNeeded trackNo +deltaEncodeWork :: (Typeable a, ZoomWritable a) + => Bool -> Maybe ZoomWork -> a -> Builder +deltaEncodeWork False _ d = fromRaw d +deltaEncodeWork _ (Just (ZoomWork _ (Just cw))) d = + case (fromDynamic . toDyn $ d) of + Just d' -> fromRaw (deltaEncodeRaw cw d') + Nothing -> fromRaw d +deltaEncodeWork _ _ d = fromRaw d + ---------------------------------------------------------------------- -- Global @@ -289,25 +306,30 @@ modifyTrack :: TrackNo -> (TrackWork -> TrackWork) -> ZoomW () modifyTrack trackNo f = modifyTracks (IM.adjust f trackNo) -bsFromTrack :: TrackNo -> TrackWork -> ByteString -bsFromTrack trackNo TrackWork{..} = toByteString $ mconcat - [ fromByteString packetHeader - , fromIntegral32be trackNo - , fromTimeStamp twEntryTime - , fromTimeStamp twExitTime - , fromIntegral32be twCount - , fromIntegral32be (len twBuilder + len twTSBuilder) - , twBuilder - , twTSBuilder +bsFromTrack :: TrackNo -> TrackWork -> L.ByteString +bsFromTrack trackNo TrackWork{..} = mconcat + [ L.pack . B.unpack $ packetHeader + , toLazyByteString $ mconcat + [ fromIntegral32be trackNo + , fromTimeStamp twEntryTime + , fromTimeStamp twExitTime + , fromIntegral32be twCount + , fromIntegral32be (L.length rawBS) + ] + , rawBS ] where - len = B.length . toByteString + tsBuilder = mconcat . map fromInt64be . + deltaEncode . map unTS . reverse $ twReverseTS + rawBS = c $ toLazyByteString (twBuilder <> tsBuilder) + c | specZlibCompress twSpec = compress + | otherwise = id mkTrackWork :: TrackSpec -> TimeStamp -> Int -> TrackWork mkTrackWork !spec !entry !w = TrackWork { twSpec = spec , twBuilder = mempty - , twTSBuilder = mempty + , twReverseTS = [] , twCount = 0 , twWatermark = w , twEntryTime = entry diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -14,7 +14,7 @@ import Test.Framework.Providers.QuickCheck2 (testProperty) ---------------------------------------------------------------------- --- * Properties +-- * Read, Write roundtrips runner1 :: Identity (I.Iteratee s Identity c) -> c runner1 = runIdentity . I.run . runIdentity @@ -26,12 +26,14 @@ i = runner1 $ I.enumPure1Chunk bs readRaw bs = toByteString (fromRaw x) +roundTripUnit :: () -> Bool +roundTripUnit = roundTrip + roundTripBool :: Bool -> Bool roundTripBool = roundTrip roundTripInt :: Int -> Bool -roundTripInt 7 = False -roundTripInt x = roundTrip x +roundTripInt = roundTrip roundTripInt8 :: Int8 -> Bool roundTripInt8 = roundTrip @@ -70,6 +72,32 @@ roundTripDouble = roundTrip ---------------------------------------------------------------------- +-- * Delta encoding roundtrips + +deltaEncDec :: Num a => [a] -> Bool +deltaEncDec xs = xs == encDec + where + encDec = deltaDecode (deltaEncode xs) + +deltaEncDecInt :: [Int] -> Bool +deltaEncDecInt = deltaEncDec + +deltaEncDecInt8 :: [Int8] -> Bool +deltaEncDecInt8 = deltaEncDec + +deltaEncDecInt16 :: [Int16] -> Bool +deltaEncDecInt16 = deltaEncDec + +deltaEncDecInt32 :: [Int32] -> Bool +deltaEncDecInt32 = deltaEncDec + +deltaEncDecInt64 :: [Int64] -> Bool +deltaEncDecInt64 = deltaEncDec + +deltaEncDecInteger :: [Integer] -> Bool +deltaEncDecInteger = deltaEncDec + +---------------------------------------------------------------------- -- Test harness main :: IO () @@ -78,7 +106,8 @@ tests :: [Test] tests = [ testGroup "roundTrip" - [ testProperty "Bool" roundTripBool + [ testProperty "()" roundTripUnit + , testProperty "Bool" roundTripBool , testProperty "Int" roundTripInt , testProperty "Int8" roundTripInt8 , testProperty "Int16" roundTripInt16 @@ -92,5 +121,13 @@ , testProperty "Integer" roundTripInteger , testProperty "Float" roundTripFloat , testProperty "Double" roundTripDouble + ] + , testGroup "Delta Encoding" + [ testProperty "Int" deltaEncDecInt + , testProperty "Int8" deltaEncDecInt8 + , testProperty "Int16" deltaEncDecInt16 + , testProperty "Int32" deltaEncDecInt32 + , testProperty "Int64" deltaEncDecInt64 + , testProperty "Integer" deltaEncDecInteger ] ] diff --git a/tools/zoom-cache.hs b/tools/zoom-cache.hs --- a/tools/zoom-cache.hs +++ b/tools/zoom-cache.hs @@ -22,6 +22,8 @@ data Config = Config { noRaw :: Bool + , delta :: Bool + , zlib :: Bool , variable :: Bool , intData :: Bool , label :: ByteString @@ -36,6 +38,8 @@ defConfig :: Config defConfig = Config { noRaw = False + , delta = False + , zlib = False , variable = False , intData = False , label = "gen" @@ -45,6 +49,8 @@ } data Option = NoRaw + | Delta + | ZLib | Variable | IntData | Label String @@ -60,10 +66,14 @@ genOptions = [ Option ['z'] ["no-raw"] (NoArg NoRaw) "Do NOT include raw data in the output" + , Option ['d'] ["delta"] (NoArg Delta) + "Delta-encode data" + , Option ['Z'] ["zlib"] (NoArg ZLib) + "Zlib-compress data" , Option ['b'] ["variable"] (NoArg Variable) "Generate variable-rate data" , Option ['i'] ["integer"] (NoArg IntData) - "Generate ingeger data" + "Generate integer data" , Option ['l'] ["label"] (ReqArg Label "label") "Set track label" , Option ['r'] ["rate"] (ReqArg Rate "data-rate") @@ -87,6 +97,10 @@ where processOneOption config NoRaw = do return $ config {noRaw = True} + processOneOption config Delta = do + return $ config {delta = True} + processOneOption config ZLib = do + return $ config {zlib = True} processOneOption config Variable = do return $ config {variable = True} processOneOption config IntData = do @@ -125,10 +139,10 @@ w :: (ZoomReadable a, ZoomWrite a, ZoomWrite (TimeStamp, a)) => [a] -> FilePath -> IO () w d - | variable = withFileWrite (oneTrack (head d) VariableDR rate' label) + | variable = withFileWrite (oneTrack (head d) delta zlib VariableDR rate' label) (not noRaw) (sW >> mapM_ (write track) (zip (map TS [1,3..]) d)) - | otherwise = withFileWrite (oneTrack (head d) ConstantDR rate' label) + | otherwise = withFileWrite (oneTrack (head d) delta zlib ConstantDR rate' label) (not noRaw) (sW >> mapM_ (write track) d) rate' = fromInteger rate diff --git a/zoom-cache.cabal b/zoom-cache.cabal --- a/zoom-cache.cabal +++ b/zoom-cache.cabal @@ -3,7 +3,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.6.0.0 +Version: 0.7.0.0 Synopsis: A streamable, seekable, zoomable cache file format @@ -81,9 +81,12 @@ containers >= 0.2 && < 0.5, data-default, iteratee >= 0.8.6.0 && < 0.9, + iteratee-compress >= 0.3.0.0 && < 0.4, ListLike >= 1.0 && < 4, MonadCatchIO-transformers > 0.2 && < 0.3, - mtl >= 2.0.0.0 && < 3 + mtl >= 2.0.0.0 && < 3, + transformers >= 0.2 && < 0.3, + zlib Exposed-modules: Blaze.ByteString.Builder.ZoomCache @@ -96,6 +99,7 @@ Data.ZoomCache.Dump Data.ZoomCache.Format Data.ZoomCache.Identify + Data.ZoomCache.Numeric.Delta Data.ZoomCache.Numeric.FloatMinMax Data.ZoomCache.Numeric.IEEE754 Data.ZoomCache.Numeric.Int @@ -120,9 +124,12 @@ containers >= 0.2 && < 0.5, data-default, iteratee >= 0.8.6.0 && < 0.9, + iteratee-compress, ListLike >= 1.0 && < 4, mtl >= 2.0.0.0 && < 3, - ui-command + transformers >= 0.2 && < 0.3, + ui-command, + zlib Test-suite tests Type: exitcode-stdio-1.0