6 -- | Lazy bitstrings based on 'L.ByteString' which treats a byte
7 -- stream as a bit sequence in the same way as WavPack's manner.
8 module Codec.Audio.WavPack.BitString
9 ( -- * The BitString Type
26 -- * Conversion from/to 'L.ByteString'
36 import qualified Data.ByteString.Lazy as L
39 import qualified Data.Strict as S
41 import Prelude hiding (drop, head, length, null, splitAt, tail, take)
42 import Prelude.Unicode
44 -- | The BitString Type.
48 , leftBytes ∷ !L.ByteString
50 , rightBytes ∷ !L.ByteString
55 -- | /O(n)/ The bitstrings must have finite lengths to test the
57 instance Eq BitString where
58 a == b = leftRem a' ≡ leftRem b' ∧
59 leftBytes a' ≡ leftBytes b' ∧
60 rightRem a' ≡ rightRem b'
65 normalise ∷ BitString → BitString
67 | remLen (leftRem bs) ≡ 8
70 , leftBytes = L.cons (remByte $ leftRem bs) $ leftBytes bs
72 | remLen (rightRem bs) ≡ 8
74 rightBytes = L.cons (remByte $ rightRem bs) $ rightBytes bs
79 leftBytes = leftBytes bs `L.append` (L.reverse $ rightBytes bs)
80 , rightBytes = L.empty
85 -- | bit length from 0 to 8
87 -- | current byte @(0 <= remByte <= (1 `'shiftL'` 'remLen') - 1)@
93 remEmpty = Remnant 0 0
95 remNull ∷ Remnant → Bool
96 remNull = (0 ≡) ∘ remLen
98 remSingleton ∷ Bool -> Remnant
99 remSingleton b = Remnant {
101 , remByte = if b then 1 else 0
104 byteToRem ∷ Word8 → Remnant
105 byteToRem w = Remnant {
110 remToStr ∷ Remnant → L.ByteString
112 | remNull r = L.empty
113 | otherwise = L.singleton $ remByte r
115 consRem ∷ Bool → Remnant → (# Remnant, S.Maybe Word8 #)
117 | remLen r ≡ 8 = (# remSingleton b, S.Just $ remByte r #)
118 | remLen r ≡ 7 = (# remEmpty, S.Just w' #)
119 | otherwise = let !r' = r {
120 remLen = remLen r + 1
126 w' = (remByte r `shiftL` 1)
130 snocRem ∷ Remnant → Bool → (# S.Maybe Word8, Remnant #)
132 | remLen r ≡ 8 = (# S.Just $ remByte r, remSingleton b #)
133 | remLen r ≡ 7 = (# S.Just w', remEmpty #)
134 | otherwise = let !r' = r {
135 remLen = remLen r + 1
141 w' | b = bit (remLen r) .|. remByte r
142 | otherwise = remByte r
144 unconsRem ∷ Remnant → (# S.Maybe Bool, Remnant #)
146 | remNull r = (# S.Nothing, remEmpty #)
147 | otherwise = let !b = remByte r `testBit` 0
149 remLen = remLen r - 1
150 , remByte = remByte r `shiftR` 1
155 unconsBytes ∷ L.ByteString → (# S.Maybe Remnant, L.ByteString #)
157 = case L.uncons bs of
159 → (# S.Just (byteToRem w), bs' #)
161 → (# S.Nothing, L.empty #)
163 appendRem ∷ Remnant → Remnant → Remnant
164 appendRem a b = Remnant {
165 remLen = remLen a + remLen b
166 , remByte = (remByte a `shiftL` remLen b) .|. remByte b
169 splitRemAt ∷ Integral n ⇒ n → Remnant → (# S.Maybe Remnant, Remnant #)
171 | remLen r ≥ fromIntegral n
173 remLen = fromIntegral n
174 , remByte = remByte r .&. ((1 `shiftL` fromIntegral n) - 1)
177 remLen = remLen r - fromIntegral n
178 , remByte = remByte r `shiftR` fromIntegral n
183 = (# S.Nothing, remEmpty #)
185 -- | /O(1)/ The same as 'empty'.
189 -- | /O(1)/ The empty 'BitString'.
193 , leftBytes = L.empty
194 , rightBytes = L.empty
195 , rightRem = remEmpty
198 -- | /O(1)/ Convert a 'Bool' into a 'BitString'.
199 singleton ∷ Bool → BitString
200 singleton b = BitString {
201 leftRem = remSingleton b
202 , leftBytes = L.empty
203 , rightBytes = L.empty
204 , rightRem = remEmpty
207 -- | /O(1)/ Prepend a bit to the beginning of a 'BitString'.
208 cons ∷ Bool → BitString → BitString
210 = case consRem b $ leftRem bs of
214 , leftBytes = L.cons' w $ leftBytes bs
218 → bs { leftRem = lr' }
220 -- | /O(1)/ Append a bit to the end of a 'BitString'.
221 snoc ∷ BitString → Bool → BitString
223 = case snocRem (rightRem bs) b of
226 rightBytes = L.cons' w $ rightBytes bs
231 → bs { rightRem = rr' }
233 -- | /amortized O(1)/ Extract the first bit of a 'BitString', which
234 -- must be non-empty.
235 head ∷ BitString → Bool
236 head bs = case uncons bs of
240 → error "head: empty BitString"
242 -- | /amortized O(1)/ Extract the bits after the head of a
243 -- 'BitString', which must be non-empty.
244 tail ∷ BitString → BitString
245 tail bs = case uncons bs of
249 → error "tail: empty BitString"
251 -- | /amortized O(1)/ Extract the the head and tail of a 'BitString',
252 -- returning 'Nothing' if it's empty.
253 uncons ∷ BitString → Maybe (Bool, BitString)
255 = case unconsRem $ leftRem bs of
257 → Just (b, bs { leftRem = lr' })
260 → case unconsBytes $ leftBytes bs of
262 → let !bs' = bs { leftRem = lr
269 → if L.null $ rightBytes bs then
270 case unconsRem $ rightRem bs of
272 → Just (b, bs { rightRem = rr' })
277 let !bs' = bs { leftBytes = L.reverse
283 -- | /O(1)/ Test whether a 'BitString' is empty.
284 null ∷ BitString → Bool
286 = remNull (leftRem bs)
288 L.null (leftBytes bs)
290 L.null (rightBytes bs)
292 remNull (rightRem bs)
294 -- | /O(n)/ @'length' bs@ returns the number of bits in @bs@. @bs@
295 -- must have a finite length.
296 length ∷ Integral n ⇒ BitString → n
298 = fromIntegral $ ( fromIntegral (remLen $ leftRem bs)
300 L.length (leftBytes bs) ⋅ 8
302 L.length (rightBytes bs) ⋅ 8
304 fromIntegral (remLen $ rightRem bs)
306 {-# SPECIALISE length ∷ BitString → Int64 #-}
308 -- | /O(1)/ Convert a 'L.ByteString' into a 'BitString'.
309 fromByteString ∷ L.ByteString → BitString
310 fromByteString bs = BitString {
313 , rightBytes = L.empty
314 , rightRem = remEmpty
317 -- | /O(n)/ @'toByteString' bs@ converts @bs@ into 'L.ByteString',
318 -- padding incomplete bytes to single bytes with necessary 0's at
319 -- their MSB. Thus the following equation does not hold when the
320 -- length of @bs@ isn't multiple of 8.
322 -- > fromByteString . toByteString = id
324 -- But the following always holds true.
326 -- > toByteString . fromByteString = id
328 -- Note that @bs@ must have a finite length.
329 toByteString ∷ BitString → L.ByteString
331 = L.concat [ remToStr $ leftRem bs
333 , L.reverse $ rightBytes bs
334 , remToStr $ rightRem bs
337 -- | /O(n)/ @'take' n bs@ returns the prefix of @bs@ of length
338 -- @n@. @bs@ must have at least @n@ bits.
339 take ∷ Integral n ⇒ n → BitString → BitString
340 take n xs = case splitAt n xs of
343 -- | /O(n)/ @'drop' n bs@ returns the suffix of @bs@ after the first
344 -- @n@ bits. @bs@ must have at least @n@ bits.
345 drop ∷ Integral n ⇒ n → BitString → BitString
346 drop n xs = case splitAt n xs of
347 (_, dropped) → dropped
349 -- | /O(n)/ @'splitAt' n bs@ is equivalent to @('take' n bs, 'drop' n
351 splitAt ∷ Integral n ⇒ n → BitString → (BitString, BitString)
353 = case splitRemAt n $ leftRem bs of
355 -- The leftRem has enough bits.
356 → let !h' = BitString {
358 , leftBytes = L.empty
359 , rightBytes = L.empty
360 , rightRem = remEmpty
363 (h', bs { leftRem = lr' })
366 → let !bytesToTake = (n - fromIntegral (remLen $ leftRem bs)) `div` 8
367 !amortised = leftBytes bs `L.append` (L.reverse $ rightBytes bs)
368 -- 0 ≤ bitsToTake < 8 - remLen (leftRem bs)
369 -- ∴ remLen (leftRem bs) + bitsToTake < 8
370 !bitsToTake = n - bytesToTake ⋅ 8 - fromIntegral (remLen $ leftRem bs)
372 case (# bytesToTake, L.uncons amortised #) of
373 (#_, Just (!w, amor') #)
374 -- There is at least one byte in the byte pool
376 → let !h1 = leftRem bs
378 = case splitRemAt bitsToTake $ byteToRem w of
379 (# S.Just h2', lr'' #) → (# h2', lr'' #)
380 (# S.Nothing , _ #) → error "internal error"
381 !h = h1 `appendRem` h2
383 = L.splitAt (fromIntegral bytesToTake) amor'
385 if L.length bytes ≡ fromIntegral bytesToTake then
386 -- The byte pool actuall has at least
387 -- bytesToTake bytes.
388 let !h' = BitString {
391 , rightBytes = L.empty
392 , rightRem = remEmpty
397 , rightBytes = L.empty
398 , rightRem = rightRem bs
403 error "splitAt: not enough bits"
406 -- No bytes are in the byte pool but the
407 -- rightRem may have enough bits.
408 → case splitRemAt bitsToTake $ rightRem bs of
410 → let !h' = BitString {
412 , leftBytes = L.empty
413 , rightBytes = L.empty
418 , leftBytes = L.empty
419 , rightBytes = L.empty
426 → error "splitAt: not enough bits"
429 -- No bytes are in the byte pool but more than 8
430 -- bits are requested. The rightRem can't have
432 → error "splitAt: not enough bits"