diff --git a/arith-encode.cabal b/arith-encode.cabal --- a/arith-encode.cabal +++ b/arith-encode.cabal @@ -1,11 +1,11 @@ Name: arith-encode -Category: Testing, Test, Serialization, Data -Version: 0.6.0 +Category: Data, Serialization, Test, Testing +Version: 0.7.0 License: BSD3 License-File: LICENSE Author: Eric McCorkle Maintainer: Eric McCorkle -Stability: Pre-alpha +Stability: Beta Synopsis: A practical arithmetic encoding (aka Godel numbering) library. Homepage: https://github.com/emc2/arith-encode Bug-Reports: https://github.com/emc2/arith-encode/issues @@ -20,7 +20,7 @@ This has various uses, among them binary serialization/deserialization and enumeration testing. . - This is the first release candidate for 1.0 (the initial release). + This is the second release candidate for 1.0 (initial release). Build-type: Simple Cabal-version: >= 1.16 @@ -34,14 +34,15 @@ Main-Is: UnitTest.hs hs-source-dirs: src test build-depends: base >= 4.4.0 && < 5, Cabal >= 1.16.0, HUnit-Plus, containers, - unordered-containers, array, hashable, fgl, arithmoi + unordered-containers, array, hashable, fgl, arithmoi, binary ghc-options: -fhpc Library default-language: Haskell2010 hs-source-dirs: src build-depends: base >= 4.4.0 && < 5, Cabal >= 1.16.0, containers, - unordered-containers, array, hashable, fgl, arithmoi + unordered-containers, array, hashable, fgl, arithmoi, binary exposed-modules: Data.ArithEncode Data.ArithEncode.Basic + Data.ArithEncode.Binary Data.ArithEncode.Util diff --git a/src/Data/ArithEncode/Binary.hs b/src/Data/ArithEncode/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Data/ArithEncode/Binary.hs @@ -0,0 +1,204 @@ +-- Copyright (c) 2014 Eric McCorkle. All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions +-- are met: +-- +-- 1. Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- 2. Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- 3. Neither the name of the author nor the names of any contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF +-- USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +-- OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +-- SUCH DAMAGE. +{-# OPTIONS_GHC -Wall -Werror #-} + +-- | Facilities for using @Encoding@s as binary serializers. The +-- resulting binary format is, for the most part, determined by the +-- @Encoding@, and therefore is within a constant factor of +-- succintness. +-- +-- In all cases, little-endian byte ordering is used in order to allow +-- for very large data to be read in an decoded lazily. (Note: +-- Haskell's libraries do not provide support for this functionality +-- at this time). +-- +-- For finite @Encoding@s, the binary format is just the little-endian +-- encoding of the encoded value, using as few bytes as necessary to +-- represent the largest encoded value. +-- +-- For infinite @Encoding@s, the binary format includes a length field +-- for most values. The current encoding uses length fields of +-- different sizes, depending on the size of the encoded value. +module Data.ArithEncode.Binary( + getWithEncoding, + putWithEncoding + ) where + +import Data.ArithEncode.Basic +import Data.Binary.Put +import Data.Binary.Get hiding (remaining) +import Data.Bits +import Math.NumberTheory.Logarithms + +-- Read in a natural number as a sequence of some number of bytes +getNatural :: Int -> Get Integer +getNatural bytes = + let + getNatural' :: Integer -> Int -> Get Integer + getNatural' accum count + | count + 8 < bytes = + do + input <- getWord64le + getNatural' ((toInteger input `shiftL` (count * 8)) .|. accum) (count + 8) + | count + 4 < bytes = + do + input <- getWord32le + getNatural' ((toInteger input `shiftL` (count * 8)) .|. accum) (count + 4) + | count + 2 < bytes = + do + input <- getWord16le + getNatural' ((toInteger input `shiftL` (count * 8)) .|. accum) (count + 2) + | count < bytes = + do + input <- getWord8 + getNatural' ((toInteger input `shiftL` (count * 8)) .|. accum) (count + 1) + | otherwise = return accum + in + getNatural' 0 0 + +-- | Use an @Encoding@ to extract a @ty@ from binary data. +getWithEncoding :: Encoding ty + -- ^ The encoding to use. + -> Get ty +getWithEncoding enc = + case size enc of + Just 0 -> error "Cannot decode with empty encoding" + -- For the degenerate case of a singleton, no need to encode anything at all + Just 1 -> return (decode enc 0) + -- Otherwise store the natural as a sequence of bytes. We store + -- this in little-endian order to allow lazy handling of very large + -- numbers. + Just finitesize -> + let + bytes = ((integerLog2 (finitesize - 1)) `quot` 3) + 1 + in do + encoded <- getNatural bytes + return (decode enc encoded) + -- Arbitrary-length naturals are encoded with a more complex + -- scheme. The first two bits are a tag, which tells how to + -- interpret the rest. + Nothing -> + do + firstbyte <- lookAhead getWord8 + encoded <- + case firstbyte .&. 0x03 of + -- Naturals less than 64 get packed into the same byte as the tag + 0x0 -> + do + datafield <- getWord8 + return (toInteger (datafield `shiftR` 2)) + -- One-byte length field, and then up to 64 bytes of data + 0x1 -> + do + lenfield <- getWord8 + getNatural (fromIntegral (lenfield `shiftR` 2) + 1) + -- Two-byte length field, and then up to 16384 bytes of data + 0x2 -> + do + lenfield <- getWord16le + getNatural (fromIntegral (lenfield `shiftR` 2) + 1) + -- Eight-byte length field, and then data + 0x3 -> + do + lenfield <- getWord64le + getNatural (fromIntegral (lenfield `shiftR` 2) + 1) + _ -> error "Impossible case" + return (decode enc encoded) + +-- Emit a natural number as a sequence of some number of bytes +putNatural :: Int -> Integer -> Put +putNatural 0 0 = return () +putNatural 0 _ = error "Data remaining at end of encoding" +putNatural remaining natural + | remaining > 8 = + let + output = fromInteger (natural .&. 0xffffffffffffffff) + rest = natural `shiftR` 64 + in do + putWord64le output + putNatural (remaining - 8) rest + | remaining > 4 = + let + output = fromInteger (natural .&. 0xffffffff) + rest = natural `shiftR` 32 + in do + putWord32le output + putNatural (remaining - 4) rest + | remaining > 2 = + let + output = fromInteger (natural .&. 0xffff) + rest = natural `shiftR` 16 + in do + putWord16le output + putNatural (remaining - 2) rest + | otherwise = + let + output = fromInteger (natural .&. 0xff) + rest = natural `shiftR` 8 + in do + putWord8 output + putNatural (remaining - 1) rest + +-- | Use an @Encoding@ to write a @ty@ out as binary data. +putWithEncoding :: Encoding ty + -- ^ The encoding to use. + -> ty + -- ^ The value to encode. + -> Put +putWithEncoding enc val = + case size enc of + Just 0 -> error "Cannot encode with empty encoding" + -- For the degenerate case of a singleton, no need to encode anything at all + Just 1 -> return () + -- Otherwise store the natural as a sequence of bytes. We store + -- this in little-endian order to allow lazy handling of very large + -- numbers. + Just finitesize -> + let + bytes = ((integerLog2 (finitesize - 1)) `quot` 3) + 1 + encoded = encode enc val + in + putNatural bytes encoded + Nothing -> + let + encoded = encode enc val + in + if encoded < 64 + then putWord8 (fromInteger encoded `shiftL` 2) + else + let + bytes = ((integerLog2 (encoded - 1)) `quot` 3) + 1 + in do + if bytes <= 64 + then putWord8 (fromIntegral (((bytes - 1) `shiftL` 2) .|. 0x1)) + else if bytes <= 16384 + then putWord16le (fromIntegral (((bytes - 1) `shiftL` 2) .|. 0x2)) + else putWord64le (fromIntegral (((bytes - 1) `shiftL` 2) .|. 0x3)) + putNatural bytes encoded