diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +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: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* 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. + +* Neither the name of the {organization} nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/arith-encode.cabal b/arith-encode.cabal new file mode 100644 --- /dev/null +++ b/arith-encode.cabal @@ -0,0 +1,47 @@ +Name: arith-encode +Category: Testing, Test, Serialization, Data +Version: 0.6.0 +License: BSD3 +License-File: LICENSE +Author: Eric McCorkle +Maintainer: Eric McCorkle +Stability: Pre-alpha +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 +Copyright: Copyright (c) 2014 Eric McCorkle. All rights reserved. +Description: + A library providing tools and various schemes for encoding arbitrary datatypes + as natural numbers. The underlying theory is that of isomorphisms with the natural + numbers (known as Godel numbering). The library provides functionality for defining + multiple such encodings for a given datatype, as well as a collection of stock + encodings and combinators which can be used to build more complex encodings. + . + This has various uses, among them binary serialization/deserialization and + enumeration testing. + . + This is the first release candidate for 1.0 (the initial release). +Build-type: Simple +Cabal-version: >= 1.16 + +Source-Repository head + Type: git + Location: git@github.com:emc2/arith-encode.git + +Test-Suite UnitTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + 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 + 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 + exposed-modules: Data.ArithEncode + Data.ArithEncode.Basic + Data.ArithEncode.Util diff --git a/src/Data/ArithEncode.hs b/src/Data/ArithEncode.hs new file mode 100644 --- /dev/null +++ b/src/Data/ArithEncode.hs @@ -0,0 +1,109 @@ +-- 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 #-} +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} + +-- | ArithEncode is a library that provides tools for defining +-- arithmetic encodings for arbitrary datatypes. The library is +-- designed so that multiple encoding schemes can be defined for a +-- given datatype, and a given encoding need not encode all possible +-- instances of the datatype. +-- +-- An 'Encoding' is an object which is passed as the first argument +-- to seven different functions. The primary function of an +-- 'Encoding' is manifest in the 'encode' and 'decode' functions, +-- which define an isomorphism between the datatype and the natural +-- numbers (or a bounded set thereof), represented using @Integer@s. +-- The 'encode' and 'decode' functions have the following properties: +-- +-- * @decode enc (encode enc v) == v@ for all values @v@ in the domain +-- +-- * @encode enc v == encode enc w@ only if @w == v@ +-- +-- * @decode enc n == decode enc m@ only if @n == m@ +-- +-- The 'inDomain' function indicates whether or not a given value is +-- in the domain of the encoding. Passing a value @v@ where @inDomain +-- enc v == False@ into any other function /may/ result in an +-- @IllegalArgument@ exception. (For performance reasons, encodings +-- are not /strictly/ required to throw @IllegalArgument@, but the +-- result should not be considered valid if they do not throw the +-- exception). +-- +-- This library provides a large collection of combinators for +-- constructing more complex 'Encoding's out of simpler ones. The +-- provided combinators should be appropriate for constructing +-- 'Encoding's for most datatypes. +-- +-- As an example, the following definition creates an 'Encoding' for +-- the @Tree Integer@ type: +-- +-- > tree :: Encoding (Tree Integer) +-- > tree = +-- > let +-- > ... +-- > nodeEncoding nodeenc = +-- > wrap unmakeNode makeNode (pair interval (seq nodeenc)) +-- > in +-- > recursive nodeEncoding +-- +-- In this example, the @makeNode@ and @unmakeNode@ functios are +-- simply \"glue\"; their definitions are +-- +-- > makeNode (label, children) = +-- > Node { rootLabel = label, subForest = children } +-- > +-- > unmakeNode Node { rootLabel = label, subForest = children } = +-- > Just (label, children) +-- +-- The resulting 'Encoding' maps any @Tree Integer@ to a unique +-- @Integer@ value. +-- +-- 'Encoding's have a number of practical uses. First, all +-- 'Encoding's in this library satisfy a /completeness/ property, +-- which guarantees that they map each value to a finite natural +-- number (or in the case of constructions on 'Encoding's, they +-- preserve completeness). Hence, they can be used as an enumeration +-- procedure for their underlying datatype. +-- +-- Second, as 'Encoding's define an isomorphism to the natural +-- numbers, they provide an efficient binary encode/decode procedure +-- in theory. In practice, the techniques used to guarantee the +-- completeness property may result in long encodings of some types +-- (particularly sequences). Also, knowledge of the distribution of +-- the domain is necessary in order to achieve the most succinct +-- possible encoding. +module Data.ArithEncode( + module Data.ArithEncode.Basic, + module Data.ArithEncode.Util + ) where + +import Data.ArithEncode.Basic +import Data.ArithEncode.Util diff --git a/src/Data/ArithEncode/Basic.hs b/src/Data/ArithEncode/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Data/ArithEncode/Basic.hs @@ -0,0 +1,1881 @@ +-- 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 -funbox-strict-fields #-} +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} + +-- | Definition of 'Encoding', and a set of fundamental 'Encoding's +-- and constructions. +-- +-- This module contains the basic definitions for 'Encoding's. It +-- defines the 'Encoding' type, the functions for creating an +-- 'Encoding', and a set of stock constructions. +-- +-- The 'Encoding' type is encapsulated; the functions 'mkEncoding' +-- (and the variants thereof) are used to synthetically construct an +-- encoding from the fundamental operations. +-- +-- The 'IllegalArgument' exception datatype, as well as the +-- fundamental operations are also defined here. +-- +-- In addition to this, a set of basic definitions and constructions +-- are provided. These definitions should be suitable for defining +-- 'Encoding's for most algebraic datatypes without having to manually +-- write encode/decode implementations. +module Data.ArithEncode.Basic( + -- * Basic Definitions + + -- ** Constructors + Encoding, + mkEncoding, + mkInfEncoding, + + -- ** Using Encodings + IllegalArgument(..), + encode, + decode, + size, + inDomain, + + -- * Building Encodings + + -- ** Basic Encodings + identity, + singleton, + integral, + interval, + fromHashableList, + fromOrdList, + + -- ** Constructions + + -- *** Wrapping + wrap, + + -- *** Optional + optional, + mandatory, + + -- *** Exclusion + nonzero, + exclude, + + -- *** Unions + either, + union, + + -- *** Products and Powers + pair, + triple, + quad, + quint, + sextet, + septet, + octet, + nonet, + dectet, + power, + + -- *** Sets + set, + hashSet, +-- exactSet, +-- boundedSet, + + -- *** Sequences + seq, + boundedSeq, + + -- *** Recursive + recursive, + recursive2, + recursive3, + recursive4, + recursive5, + recursive6, + recursive7, + recursive8, + recursive9, + recursive10 + ) where + +import Control.Exception +import Control.Monad +import Data.Array.IArray(Array) +import Data.Bits +import Data.Hashable +import Data.List hiding (elem, union) +import Data.Maybe +import Data.Set(Set) +import Data.HashSet(HashSet) +import Data.Typeable +import Prelude hiding (elem, either, seq) +import Math.NumberTheory.Powers.Squares +import Math.NumberTheory.Logarithms +import Data.Word +--import Debug.Trace + +import qualified Data.Array.IArray as Array +import qualified Data.Either as Either +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.HashSet as HashSet +import qualified Data.Map as Map +import qualified Data.Set as Set + +-- | An exception to be thrown if an illegal argument is given to +-- 'encode', 'decode'. +data IllegalArgument = IllegalArgument !String + deriving Typeable + +instance Show IllegalArgument where + show (IllegalArgument "") = "Illegal argument" + show (IllegalArgument s) = "Illegal argument: " ++ s + +instance Exception IllegalArgument + +-- | Type for an encoding. The structure of this type is deliberately +-- hidden from users. Use the 'mkEncoding' functions to construct +-- 'Encoding's, and the seven functions to use them. +data Encoding ty = + Encoding { + -- | Encode a @ty@ as a positive integer. + encEncode :: ty -> Integer, + -- | Decode a positive integer into a @ty@. + encDecode :: Integer -> ty, + -- | The size of an encoding, or 'Nothing' if it is infinite. + encSize :: !(Maybe Integer), + -- | Indicate whether or not a value is in the domain of the encoding. + encInDomain :: ty -> Bool + } + +-- | Create an encoding from all the necessary components. +mkEncoding :: (ty -> Integer) + -- ^ The encoding function. + -> (Integer -> ty) + -- ^ The decoding function. Can assume all inputs are positive. + -> Maybe Integer + -- ^ The number of mappings, or 'Nothing' if it is infinite. + -> (ty -> Bool) + -- ^ A function indicating whether or not a given value is + -- in the domain of values. + -> Encoding ty +mkEncoding encodefunc decodefunc sizeval indomain = + Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomain } + +-- | Create an infinite-sized encoding. This variant does not need a +-- size. +mkInfEncoding :: (ty -> Integer) + -- ^ The encoding function. + -> (Integer -> ty) + -- ^ The decoding function. Can assume all inputs are positive. + -> (ty -> Bool) + -- ^ A function indicating whether or not a given value is + -- in the domain of values. + -> Encoding ty +mkInfEncoding encodefunc decodefunc indomain = + mkEncoding encodefunc decodefunc Nothing indomain + +-- | Encode a @ty@ as a positive 'Integer' (ie. a natural number). +-- +-- If the given @ty@ is not in the domain of the 'Encoding' (meaning, +-- 'inDomain' returns 'False'), the underlying implementation /may/ +-- throw 'IllegalArgument'. However, this is not /strictly/ required; +-- therefore, do not rely on 'IllegalArgument' being thrown. +encode :: Encoding ty + -- ^ Encoding to use. + -> ty + -- ^ Value to encode. + -> Integer + -- ^ Encoded value. +encode encoding = encEncode encoding + +-- | Decode a @ty@ from a positive 'Integer' (ie. a natural number). +-- +-- If the given 'Integer' is out of bounds (ie. it is bigger than +-- 'size'), the underlying implementation /may/ throw +-- 'IllegalArgument'. However, this not /strictly/ required; +-- therefore, do not rely on 'IllegalArgument' being thrown. +decode :: Encoding ty + -- ^ Encoding to use. + -> Integer + -- ^ Number to decode. + -> ty + -- ^ Decoded value. +decode encoding num + | num < 0 = + throw (IllegalArgument ("decode argument " ++ show num ++ " is negative")) + | maybe False (<= num) (size encoding) = + throw (IllegalArgument ("decode argument " ++ show num ++ + " is out of bounds")) + | otherwise = (encDecode encoding) num + +-- | Get the size of an 'Encoding', or 'Nothing' if it is infinite. +size :: Encoding ty + -- ^ Encoding to use. + -> Maybe Integer + -- ^ Number of values mapped, or 'Nothing' for infinity. +size = encSize + +-- | Indicate whether or not a value is in the domain of the encoding. +inDomain :: Encoding ty + -- ^ Encoding to use. + -> ty + -- ^ Value to query. + -> Bool + -- ^ Whether or not the value is in the domain of the encoding. +inDomain encoding = encInDomain encoding + +-- | The identity encoding. Maps every positive 'Integer' to itself. +-- +-- Note: only positive integers are in the domain of this encoding. +-- For all an encoding whose domain is all integers, use 'integral'. +identity :: Encoding Integer +identity = mkInfEncoding id id (>= 0) + +-- | A singleton encoding. Maps a singular value to 0. +singleton :: Eq ty => ty -> Encoding ty +singleton val = mkEncoding (const 0) (const val) (Just 1) (val ==) + +-- | An encoding of /all/ integers. +-- +-- Note: this is /not/ an identity mapping. +integral :: Integral n => Encoding n +integral = + let + encodefunc num + | num < 0 = ((abs (toInteger num) - 1) `shiftL` 1) `setBit` 0 + | otherwise = (toInteger num) `shiftL` 1 + + decodefunc num + | num `testBit` 0 = fromInteger (-((num `shiftR` 1) + 1)) + | otherwise = fromInteger (num `shiftR` 1) + in + mkInfEncoding encodefunc decodefunc (const True) + +-- | Build an encoding from a finite range of 'Integral's. +-- +-- Both the upper and lower bounds are inclusive. This allows an +-- 'Encoding' to be created for bounded integer datatypes, such as +-- 'Int8'. +interval :: Integral n + => n + -- ^ The (inclusive) lower bound on the range. + -> n + -- ^ The (inclusive) upper bound on the range. + -> Encoding n +interval lower upper + | lower <= upper = + let + biglower = toInteger lower + encodefunc num = (toInteger num) - biglower + decodefunc num = fromInteger (num + biglower) + sizeval = Just ((toInteger upper) - (toInteger lower) + 1) + indomainfunc val = lower <= val && val <= upper + in + mkEncoding encodefunc decodefunc sizeval indomainfunc + | otherwise = error "Lower bound is not less than upper bound" + +-- | Build an encoding from a list of items with a 'Hashable' instance. +fromHashableList :: forall ty. (Hashable ty, Ord ty) + => [ty] + -- ^ A list of items to encode. + -> Encoding ty + -- ^ An encoding mapping the items in the list to + -- natural numbers. +fromHashableList elems = + let + len = fromIntegral (length elems) + + revmap :: Array Word ty + revmap = Array.listArray (0, len) elems + + fwdmap = HashMap.fromList (zip elems [0..len]) + encodefunc = toInteger . (HashMap.!) fwdmap + decodefunc = (Array.!) revmap . fromInteger + sizeval = Just (toInteger len) + indomainfunc = (flip HashMap.member) fwdmap + in + mkEncoding encodefunc decodefunc sizeval indomainfunc + +-- | Build an encoding from a list of items with an 'Ord' instance. +fromOrdList :: forall ty . Ord ty + => [ty] + -- ^ A list of items to encode. + -> Encoding ty + -- ^ An encoding mapping the items in the list to natural + -- numbers. +fromOrdList elems = + let + len = fromIntegral (length elems) + + revmap :: Array Word ty + revmap = Array.listArray (0, len) elems + + fwdmap = Map.fromList (zip elems [0..len]) + encodefunc = toInteger . (Map.!) fwdmap + decodefunc = (Array.!) revmap . fromInteger + sizeval = Just (toInteger len) + indomainfunc = (flip Map.member) fwdmap + in + mkEncoding encodefunc decodefunc sizeval indomainfunc + +-- | Wrap an encoding using a pair of functions. These functions must +-- also define an isomorphism. +wrap :: (a -> Maybe b) + -- ^ The forward encoding function. + -> (b -> Maybe a) + -- ^ The reverse encoding function. + -> Encoding b + -- ^ The inner encoding. + -> Encoding a +wrap fwd rev enc @ Encoding { encEncode = encodefunc, encDecode = decodefunc, + encInDomain = indomainfunc } = + let + safefwd val = + case fwd val of + Just val' -> val' + Nothing -> throw (IllegalArgument "No mapping into underlying domain") + + saferev val = + case rev val of + Just val' -> val' + Nothing -> throw (IllegalArgument "No mapping into external domain") + in + enc { encEncode = encodefunc . safefwd, + encDecode = saferev . decodefunc, + encInDomain = maybe False indomainfunc . fwd } + +-- | Generate an encoding for @Maybe ty@ from an inner encoding for +-- @ty@. +optional :: Encoding ty -> Encoding (Maybe ty) +optional Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomainfunc } = + let + newsize = sizeval >>= return . (+ 1) + newindomain = maybe True indomainfunc + + newencode Nothing = 0 + newencode (Just val) = 1 + encodefunc val + + newdecode 0 = Nothing + newdecode num = Just (decodefunc (num - 1)) + in + Encoding { encEncode = newencode, encDecode = newdecode, + encSize = newsize, encInDomain = newindomain } + +-- | The dual of @optional@. This construction assumes that @Nothing@ +-- maps to @0@, and removes it from the input domain. +-- +-- Using this construction on encodings for @Maybe ty@ which are not +-- produced by @optional@ may have unexpected results. +mandatory :: Encoding (Maybe ty) -> Encoding ty +mandatory Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomainfunc } = + let + dec n = n - 1 + newencode = dec . encodefunc . Just + newdecode = fromJust . decodefunc . (+ 1) + newsize = sizeval >>= return . dec + newindomain = indomainfunc . Just + in + Encoding { encEncode = newencode, encDecode = newdecode, + encSize = newsize, encInDomain = newindomain } + +-- | Removes the mapping to @0@ (ie. the first mapping). This has the +-- same effect as @exclude [x]@, where @x@ is the value that maps to +-- @0@. It is also similar to @mandatory@, except that it does not +-- change the base type. +nonzero :: Encoding ty -> Encoding ty +nonzero enc @ Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomainfunc } = + let + dec n = n - 1 + newencode = dec . encodefunc + newdecode = decodefunc . (+ 1) + newsize = sizeval >>= return . dec + newindomain val = indomainfunc val && 0 /= encodefunc val + in + enc { encEncode = newencode, encDecode = newdecode, + encSize = newsize, encInDomain = newindomain } + +-- | A simple binary tree structure, for use with exclude. +data BinTree key val = + Branch key val (BinTree key val) (BinTree key val) + | Nil + deriving Show + +-- | Find the tree node with the highest index less than the given key +-- and return its data. +closestBelow :: Ord key => key -> BinTree key val -> Maybe (key, val) +closestBelow target = + let + closestBelow' out Nil = out + closestBelow' out (Branch k v left right) = + case compare k target of + LT -> closestBelow' (Just (k, v)) right + _ -> closestBelow' out left + in + closestBelow' Nothing + +-- | Simple binary tree lookup, for use with exclude. +closestWithin :: Ord key => key -> BinTree key val -> Maybe (key, val) +closestWithin target = + let + closestWithin' out Nil = out + closestWithin' out (Branch k v left right) = + case compare k target of + GT -> closestWithin' out left + _ -> closestWithin' (Just (k, v)) right + in + closestWithin' Nothing + +-- | Convert a list to a binary tree, for use with excludes. +toBinTree :: [(key, val)] -> BinTree key val +toBinTree vals = + let + toBinTree' 0 [] = Nil + toBinTree' 0 _ = error "Zero size with non-empty list" + toBinTree' _ [] = error "Empty list with non-zero size" + toBinTree' len vals' = + let + halflo = len `shiftR` 1 + halfhi = len - halflo + (lows, (k, v) : highs) = splitAt halflo vals' + left = toBinTree' halflo lows + right = toBinTree' (halfhi - 1) highs + in + Branch k v left right + in + toBinTree' (length vals) vals + +-- | Removes the mapping to the items in the list. The resulting +-- @encode@, @decode@, and @highestIndex@ are O(@length excludes@), so +-- this should only be used with a very short excludes list. +exclude :: [ty] + -- ^ The list of items to exclude. + -> Encoding ty + -- ^ The base @Encoding@. + -> Encoding ty +exclude [] enc = enc +exclude excludes enc @ Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomainfunc } = + let + forbidden = HashSet.fromList (map encodefunc excludes) + sortedlist = sort (map encodefunc excludes) + + fwdoffsets :: [(Integer, Integer)] + (_, fwdoffsets) = mapAccumL (\offset v -> (offset + 1, (v, offset))) + 1 sortedlist + fwdtree = toBinTree fwdoffsets + + revoffsets :: [(Integer, Integer)] + revoffsets = + let + foldfun :: [(Integer, Integer)] -> (Integer, Integer) -> + [(Integer, Integer)] + foldfun accum @ ((v', _) : rest) elem @ (v, _) + | v == v' = elem : rest + | otherwise = elem : accum + foldfun _ _ = error "Should not fold over an empty list" + + (first : adjusted) = + map (\(v, offset) -> (v - (offset - 1), offset)) fwdoffsets + in + reverse (foldl foldfun [first] adjusted) + + revtree = toBinTree revoffsets + + toExcluded n = + case closestBelow n fwdtree of + Just (_, offset) -> n - offset + Nothing -> n + + fromExcluded n = + case closestWithin n revtree of + Just (_, offset) -> n + offset + Nothing -> n + + newEncode = toExcluded . encodefunc + newDecode = decodefunc . fromExcluded + + newSize = + do + n <- sizeval + return $! (n - (toInteger (length excludes))) + + newInDomain val = + indomainfunc val && not (HashSet.member (encodefunc val) forbidden) + in + enc { encEncode = newEncode, encDecode = newDecode, + encSize = newSize, encInDomain = newInDomain } + +-- | Combine two encodings into a single encoding that returns an +-- @Either@ of the two types. +either :: Encoding ty1 + -- ^ The @Encoding@ that will be represented by @Left@. + -> Encoding ty2 + -- ^ The @Encoding@ that will be represented by @Right@. + -> Encoding (Either ty1 ty2) +either Encoding { encEncode = encode1, encDecode = decode1, + encInDomain = indomain1, encSize = sizeval1 } + Encoding { encEncode = encode2, encDecode = decode2, + encInDomain = indomain2, encSize = sizeval2 } = + let + -- There are three cases here, depending on the size of the two + -- mappings. This does replicate code, but it also does a lot of + -- figuring things when the encoding is created as opposed to + -- later. + (isLeft, leftIdxFwd, rightIdxFwd, leftIdxRev, rightIdxRev) = + case (sizeval1, sizeval2) of + -- Simplest case: both mappings are infinite. Map all the + -- evens to the left, and all the odds to the right. + (Nothing, Nothing) -> + (\num -> not (testBit num 0), + \idx -> idx `shiftL` 1, + \idx -> setBit (idx `shiftL` 1) 0, + \idx -> idx `shiftR` 1, + \idx -> idx `shiftR` 1) + -- Left is smaller: do the even/odd mapping until we exhaust + -- the left, then just map directly to the right. + (Just size1, _) | maybe True (size1 <) sizeval2 -> + let + size1shifted = (size1 `shiftL` 1) + isLeft' num = num < size1shifted && not (testBit num 0) + leftIdxFwd' idx = idx `shiftL` 1 + + rightIdxFwd' idx + | size1 <= idx = size1shifted + (idx - size1) + | otherwise = setBit (idx `shiftL` 1) 0 + + leftIdxRev' idx = idx `shiftR` 1 + + rightIdxRev' idx + | size1shifted <= idx = size1 + (idx - size1shifted) + | otherwise = idx `shiftR` 1 + in + (isLeft', leftIdxFwd', rightIdxFwd', leftIdxRev', rightIdxRev') + -- Right is smaller: do the even/odd mapping until we exhaust + -- the right, then just map directly to the left. + (_, Just size2) -> + let + size2shifted = (size2 `shiftL` 1) + isLeft' num = num > size2shifted || not (testBit num 0) + + leftIdxFwd' idx + | size2 <= idx = size2shifted + (idx - size2) + | otherwise = idx `shiftL` 1 + + rightIdxFwd' idx = setBit (idx `shiftL` 1) 0 + + leftIdxRev' idx + | size2shifted <= idx = size2 + (idx - size2shifted) + | otherwise = idx `shiftR` 1 + + rightIdxRev' idx = idx `shiftR` 1 + in + (isLeft', leftIdxFwd', rightIdxFwd', leftIdxRev', rightIdxRev') + _ -> error "This case should never happen" + + newSize = + do + size1 <- sizeval1 + size2 <- sizeval2 + return (size1 + size2) + + eitherIndex lfunc rfunc idx + | isLeft idx = lfunc (leftIdxRev idx) + | otherwise = rfunc (rightIdxRev idx) + + newEncode = Either.either (leftIdxFwd . encode1) (rightIdxFwd . encode2) + newDecode = eitherIndex (Left . decode1) (Right . decode2) + + newInDomain = Either.either indomain1 indomain2 + in + Encoding { encEncode = newEncode, encDecode = newDecode, + encSize = newSize, encInDomain = newInDomain } + +sortfunc :: Maybe Integer -> Maybe Integer -> Ordering +sortfunc Nothing Nothing = EQ +sortfunc Nothing _ = GT +sortfunc _ Nothing = LT +sortfunc (Just a) (Just b) = compare a b + +-- | Combine a set of encodings with the result type into a single +-- encoding which represents the disjoint union of the components. +union :: forall ty. + [Encoding ty] + -- ^ The components of the union. + -> Encoding ty +union [] = error "union encoding with no arguments" +union encodings = + let + numelems :: Int + numelems = length encodings + + sortpair (a, _) (b, _) = sortfunc a b + + (sizes, sortedencodings) = + unzip (sortBy sortpair (map (\enc -> (size enc, enc)) encodings)) + -- Turn the sorted element encodings into an array for fast access + encodingarr :: Array.Array Int (Encoding ty) + encodingarr = Array.listArray (0, numelems - 1) sortedencodings + + (fwdmapnum, revmapnum) = + let + -- An ordered list of the sizes of isomorphisms and how far into + -- the array to start. + sizeclasses = + let + foldfun (ind, accum) elemsize = + case accum of + (elemsize', _) : _ | elemsize == elemsize' -> + (ind + 1, accum) + _ -> (ind + 1, (elemsize, ind) : accum) + + (_, out) = foldl foldfun (0, []) sizes + in + reverse out + + -- The mapping functions used to encode within a single size + -- class. + fwdmapbasic base width num enc = + let + adjustedenc = enc - (numelems - width) + in + ((num * toInteger width) + (toInteger adjustedenc) + base) + revmapbasic base width num + | (fromInteger num) < width = + let + adjustedenc = fromInteger num + (numelems - width) + in + (base, adjustedenc) + | otherwise = ((num `quot` toInteger width) + base, + fromInteger (num `mod` toInteger width) + + (numelems - width)) + in case sizeclasses of + -- If there is only one size class, then + [ _ ] -> (fwdmapbasic 0 numelems, revmapbasic 0 numelems) + (Just firstsize, _) : rest -> + let + (fwdtree, revtree) = + let + foldfun (lastsize, offset, fwds, revs) (Nothing, idx) = + let + thisnumencs = numelems - idx + in + (undefined, undefined, + (lastsize, (offset, thisnumencs)) : fwds, + (offset, (lastsize, thisnumencs)) : revs) + foldfun (lastsize, offset, fwds, revs) (Just thissize, idx) = + let + thisnumencs = numelems - idx + sizediff = thissize - lastsize + in + (thissize, offset + (sizediff * toInteger thisnumencs), + (lastsize, (offset, thisnumencs)) : fwds, + (offset, (lastsize, thisnumencs)) : revs) + + (_, _, fwdvals, revvals) = + foldl foldfun + (firstsize, (firstsize * toInteger numelems), [], []) + rest + in + (toBinTree (reverse fwdvals), toBinTree (reverse revvals)) + + fwdmap num enc = + case closestWithin num fwdtree of + Nothing -> fwdmapbasic 0 numelems num enc + Just (sizeclass, (base, numencs)) -> + fwdmapbasic base numencs (num - sizeclass) enc + + revmap num = + case closestWithin num revtree of + Nothing -> revmapbasic 0 numelems num + Just (offset, (base, numencs)) -> + revmapbasic base numencs (num - offset) + in + (fwdmap, revmap) + _ -> error "Internal error" + + encodefunc val = + case findIndex ((flip inDomain) val) sortedencodings of + Just encidx -> + let + enc = (Array.!) encodingarr encidx + num = encode enc val + in + fwdmapnum num encidx + Nothing -> throw (IllegalArgument "Value not in domain of any component") + + decodefunc num = + let + (encnum, encidx) = revmapnum num + encoding = (Array.!) encodingarr encidx + in + decode encoding encnum + + -- Sum up all the sizes, going to infinity if one of them in + -- infinite + sizeval = + let + foldfun accum n = + do + accumval <- accum + nval <- n + return (nval + accumval) + in + foldl foldfun (Just 0) sizes + + indomainfunc val = any ((flip inDomain) val) sortedencodings + in + Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomainfunc } + +isqrt :: Integer -> Integer +isqrt = integerSquareRoot' + +mkPairCore :: Encoding ty1 -> Encoding ty2 -> + ((ty1, ty2) -> Integer, Integer -> (ty1, ty2), Maybe Integer) +mkPairCore Encoding { encEncode = encode1, encDecode = decode1, + encSize = sizeval1 } + Encoding { encEncode = encode2, encDecode = decode2, + encSize = sizeval2 } = + let + (convertidx, decodefunc) = case (sizeval1, sizeval2) of + (Just maxval, _) -> + let + convertidx' idx1 idx2 = (idx2 * maxval) + idx1 + newdecode num = (decode1 (num `mod` maxval), decode2 (num `quot` maxval)) + in + (convertidx', newdecode) + (_, Just maxval) -> + let + convertidx' idx1 idx2 = (idx1 * maxval) + idx2 + newdecode num = (decode1 (num `quot` maxval), decode2 (num `mod` maxval)) + in + (convertidx', newdecode) + (Nothing, Nothing) -> + let + convertidx' idx1 idx2 = + let + sumval = idx1 + idx2 + base = (((sumval + 1) * sumval)) `quot` 2 + in + base + idx2 + + newdecode num = + let + sumval = (isqrt ((8 * num) + 1) - 1) `quot` 2 + base = (((sumval + 1) * sumval)) `quot` 2 + num2 = num - base + num1 = sumval - num2 + in + (decode1 num1, decode2 num2) + in + (convertidx', newdecode) + + encodefunc (val1, val2) = convertidx (encode1 val1) (encode2 val2) + + sizeval = + do + size1 <- sizeval1 + size2 <- sizeval2 + return (size1 * size2) + in + (encodefunc, decodefunc, sizeval) + +-- | Take encodings for two datatypes A and B, and build an encoding +-- for a pair (A, B). +pair :: Encoding ty1 -> Encoding ty2 -> Encoding (ty1, ty2) +pair enc1 @ Encoding { encInDomain = indomain1 } + enc2 @ Encoding { encInDomain = indomain2 } = + let + (encodefunc, decodefunc, sizeval) = mkPairCore enc1 enc2 + + indomainfunc (val1, val2) = indomain1 val1 && indomain2 val2 + in + Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomainfunc } + + +-- | Construct an encoding for a 3-tuple from the encodings for the +-- three components. This is actually just a wrapper around @pair@. +triple :: Encoding ty1 -> Encoding ty2 -> Encoding ty3 -> + Encoding (ty1, ty2, ty3) +triple enc1 enc2 enc3 = + let + fwdshuffle (val1, val2, val3) = ((val1, val2), val3) + revshuffle ((val1, val2), val3) = (val1, val2, val3) + + Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomainfunc } = + pair (pair enc1 enc2) enc3 + + newencode = encodefunc . fwdshuffle + newdecode = revshuffle . decodefunc + newindomain = indomainfunc . fwdshuffle + in + Encoding { encEncode = newencode, encDecode = newdecode, + encSize = sizeval, encInDomain = newindomain } + +-- | Construct an encoding for a 4-tuple from the encodings for the +-- four components. This is actually just a wrapper around @pair@. +quad :: Encoding ty1 -> Encoding ty2 -> Encoding ty3 -> Encoding ty4 -> + Encoding (ty1, ty2, ty3, ty4) +quad enc1 enc2 enc3 enc4 = + let + fwdshuffle (val1, val2, val3, val4) = ((val1, val2), (val3, val4)) + revshuffle ((val1, val2), (val3, val4)) = (val1, val2, val3, val4) + + Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomainfunc } = + pair (pair enc1 enc2) (pair enc3 enc4) + + newencode = encodefunc . fwdshuffle + newdecode = revshuffle . decodefunc + newindomain = indomainfunc . fwdshuffle + in + Encoding { encEncode = newencode, encDecode = newdecode, + encSize = sizeval, encInDomain = newindomain } + + +-- | Construct an encoding for a 5-tuple from the encodings for the +-- five components. This is actually just a wrapper around @pair@. +quint :: Encoding ty1 -> Encoding ty2 -> Encoding ty3 -> + Encoding ty4 -> Encoding ty5 -> + Encoding (ty1, ty2, ty3, ty4, ty5) +quint enc1 enc2 enc3 enc4 enc5 = + let + fwdshuffle (val1, val2, val3, val4, val5) = (((val1, val2), val3), (val4, val5)) + revshuffle (((val1, val2), val3), (val4, val5)) = (val1, val2, val3, val4, val5) + + Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomainfunc } = + pair (pair (pair enc1 enc2) enc3) (pair enc4 enc5) + + newencode = encodefunc . fwdshuffle + newdecode = revshuffle . decodefunc + newindomain = indomainfunc . fwdshuffle + in + Encoding { encEncode = newencode, encDecode = newdecode, + encSize = sizeval, encInDomain = newindomain } + +-- | Construct an encoding for a 6-tuple from the encodings for the +-- six components. This is actually just a wrapper around @pair@. +sextet :: Encoding ty1 -> Encoding ty2 -> Encoding ty3 -> + Encoding ty4 -> Encoding ty5 -> Encoding ty6 -> + Encoding (ty1, ty2, ty3, ty4, ty5, ty6) +sextet enc1 enc2 enc3 enc4 enc5 enc6 = + let + fwdshuffle (val1, val2, val3, val4, val5, val6) = + (((val1, val2), val3), ((val4, val5), val6)) + revshuffle (((val1, val2), val3), ((val4, val5), val6)) = + (val1, val2, val3, val4, val5, val6) + + Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomainfunc } = + pair (pair (pair enc1 enc2) enc3) (pair (pair enc4 enc5) enc6) + + newencode = encodefunc . fwdshuffle + newdecode = revshuffle . decodefunc + newindomain = indomainfunc . fwdshuffle + in + Encoding { encEncode = newencode, encDecode = newdecode, + encSize = sizeval, encInDomain = newindomain } + +-- | Construct an encoding for a 7-tuple from the encodings for the +-- seven components. This is actually just a wrapper around @pair@. +septet :: Encoding ty1 -> Encoding ty2 -> Encoding ty3 -> Encoding ty4 -> + Encoding ty5 -> Encoding ty6 -> Encoding ty7 -> + Encoding (ty1, ty2, ty3, ty4, ty5, ty6, ty7) +septet enc1 enc2 enc3 enc4 enc5 enc6 enc7 = + let + fwdshuffle (val1, val2, val3, val4, val5, val6, val7) = + (((val1, val2), (val3, val4)), ((val5, val6), val7)) + revshuffle (((val1, val2), (val3, val4)), ((val5, val6), val7)) = + (val1, val2, val3, val4, val5, val6, val7) + + Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomainfunc } = + pair (pair (pair enc1 enc2) (pair enc3 enc4)) (pair (pair enc5 enc6) enc7) + + newencode = encodefunc . fwdshuffle + newdecode = revshuffle . decodefunc + newindomain = indomainfunc . fwdshuffle + in + Encoding { encEncode = newencode, encDecode = newdecode, + encSize = sizeval, encInDomain = newindomain } + +-- | Construct an encoding for an 8-tuple from the encodings for the +-- eight components. This is actually just a wrapper around @pair@. +octet :: Encoding ty1 -> Encoding ty2 -> Encoding ty3 -> + Encoding ty4 -> Encoding ty5 -> Encoding ty6 -> + Encoding ty7 -> Encoding ty8 -> + Encoding (ty1, ty2, ty3, ty4, ty5, ty6, ty7, ty8) +octet enc1 enc2 enc3 enc4 enc5 enc6 enc7 enc8 = + let + fwdshuffle (val1, val2, val3, val4, val5, val6, val7, val8) = + (((val1, val2), (val3, val4)), ((val5, val6), (val7, val8))) + revshuffle (((val1, val2), (val3, val4)), ((val5, val6), (val7, val8))) = + (val1, val2, val3, val4, val5, val6, val7, val8) + + Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomainfunc } = + pair (pair (pair enc1 enc2) (pair enc3 enc4)) + (pair (pair enc5 enc6) (pair enc7 enc8)) + + newencode = encodefunc . fwdshuffle + newdecode = revshuffle . decodefunc + newindomain = indomainfunc . fwdshuffle + in + Encoding { encEncode = newencode, encDecode = newdecode, + encSize = sizeval, encInDomain = newindomain } + +-- | Construct an encoding for a 9-tuple from the encodings for the +-- nine components. This is actually just a wrapper around @pair@. +nonet :: Encoding ty1 -> Encoding ty2 -> Encoding ty3 -> Encoding ty4 -> + Encoding ty5 -> Encoding ty6 -> Encoding ty7 -> + Encoding ty8 -> Encoding ty9 -> + Encoding (ty1, ty2, ty3, ty4, ty5, ty6, ty7, ty8, ty9) +nonet enc1 enc2 enc3 enc4 enc5 enc6 enc7 enc8 enc9 = + let + fwdshuffle (val1, val2, val3, val4, val5, val6, val7, val8, val9) = + ((((val1, val2), val3), (val4, val5)), ((val6, val7), (val8, val9))) + revshuffle ((((val1, val2), val3), (val4, val5)), ((val6, val7), (val8, val9))) = + (val1, val2, val3, val4, val5, val6, val7, val8, val9) + + Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomainfunc } = + pair (pair (pair (pair enc1 enc2) enc3) (pair enc4 enc5)) + (pair (pair enc6 enc7) (pair enc8 enc9)) + + newencode = encodefunc . fwdshuffle + newdecode = revshuffle . decodefunc + newindomain = indomainfunc . fwdshuffle + in + Encoding { encEncode = newencode, encDecode = newdecode, + encSize = sizeval, encInDomain = newindomain } + +-- | Construct an encoding for a 10-tuple from the encodings for the +-- ten components. This is actually just a wrapper around @pair@. +dectet :: Encoding ty1 -> Encoding ty2 -> Encoding ty3 -> Encoding ty4 -> + Encoding ty5 -> Encoding ty6 -> Encoding ty7 -> + Encoding ty8 -> Encoding ty9 -> Encoding ty10 -> + Encoding (ty1, ty2, ty3, ty4, ty5, ty6, ty7, ty8, ty9, ty10) +dectet enc1 enc2 enc3 enc4 enc5 enc6 enc7 enc8 enc9 enc10 = + let + fwdshuffle (val1, val2, val3, val4, val5, val6, val7, val8, val9, val10) = + ((((val1, val2), val3), (val4, val5)), (((val6, val7), val8), (val9, val10))) + revshuffle ((((val1, val2), val3), (val4, val5)), + (((val6, val7), val8), (val9, val10))) = + (val1, val2, val3, val4, val5, val6, val7, val8, val9, val10) + + Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomainfunc } = + pair (pair (pair (pair enc1 enc2) enc3) (pair enc4 enc5)) + (pair (pair (pair enc6 enc7) enc8) (pair enc9 enc10)) + + newencode = encodefunc . fwdshuffle + newdecode = revshuffle . decodefunc + newindomain = indomainfunc . fwdshuffle + in + Encoding { encEncode = newencode, encDecode = newdecode, + encSize = sizeval, encInDomain = newindomain } + +-- | Common idiom in bounded sets and sequences: take an entropy value +-- and generate a list of entropy values of a particular length. +toProdList :: Integer -> Integer -> [Integer] +toProdList = + let + productList' accum 1 entropy = reverse (entropy : accum) + productList' _ 0 _ = [] + productList' accum count entropy = + let + sumval = (isqrt ((8 * entropy) + 1) - 1) `quot` 2 + base = (((sumval + 1) * sumval)) `quot` 2 + num2 = entropy - base + num1 = sumval - num2 + in + productList' (num1 : accum) (count - 1) num2 + in + productList' [] + +fromProdList :: [Integer] -> Integer +fromProdList [] = 0 +fromProdList vals = + let + (first : rest) = reverse vals + fromProdList' accum [] = accum + fromProdList' accum (first' : rest') = + let + sumval = accum + first' + base = (((sumval + 1) * sumval)) `quot` 2 + in + fromProdList' (base + accum) rest' + in + fromProdList' first rest + +-- | Take an @Encoding@ for elements and a length and produce an +-- @Encoding@ for lists of exactly that length. +-- +-- This differs from 'boundedSeq' in that the resulting list is +-- /exactly/ the given length, as opposed to upper-bounded by it. +power :: Integer + -- ^ Number of elements in the resulting lists + -> Encoding ty + -- ^ @Encoding@ for the elements + -> Encoding [ty] +power len Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomainfunc } = + let + (newencode, newdecode, newsize) = + case sizeval of + Just finitesize -> + let + newencode' accum [] = accum + newencode' accum (first : rest) = + newencode' ((accum * finitesize) + encodefunc first) rest + + newdecode' accum 1 entropy = (decodefunc entropy : accum) + newdecode' _ 0 _ = [] + newdecode' accum count entropy = + let + thisentropy = entropy `mod` finitesize + restentropy = entropy `quot` finitesize + this = decodefunc thisentropy + in + newdecode' (this : accum) (count - 1) restentropy + in + (newencode' 0, newdecode' [] len, Just (finitesize ^ len)) + Nothing -> + let + newencode' = fromProdList . map encodefunc + newdecode' = map decodefunc . toProdList len + in + (newencode', newdecode', Nothing) + + newindomain vals = length vals == fromInteger len && all indomainfunc vals + in + Encoding { encEncode = newencode, encDecode = newdecode, + encSize = newsize, encInDomain = newindomain } + +-- | Build an encoding for /finite/ sets of values of a given datatype +-- from an encoding for that datatype. +-- +-- Note: this encoding and its variants can produce very large numbers +-- for a very small set. +set :: Ord ty => Encoding ty -> Encoding (Set ty) +set Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomainfunc } = + let + newEncode = Set.foldl (\n -> setBit n . fromInteger . encodefunc) 0 + + newDecode = + let + decode' out _ 0 = out + decode' out idx n + | testBit n 0 = + decode' (Set.insert (decodefunc idx) out) (idx + 1) (n `shiftR` 1) + | otherwise = decode' out (idx + 1) (n `shiftR` 1) + in + decode' Set.empty 0 + + newSize = + do + elems <- sizeval + return (2 ^ elems) + + newInDomain = all indomainfunc . Set.toList + in + Encoding { encEncode = newEncode, encDecode = newDecode, + encSize = newSize, encInDomain = newInDomain } + +-- | Build an encoding for /finite/ sets of values of a given datatype +-- from an encoding for that datatype. Similar to @set@, but uses +-- @HashSet@ instead +hashSet :: (Hashable ty, Ord ty) => + Encoding ty -> Encoding (HashSet ty) +hashSet Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval, encInDomain = indomainfunc } = + let + newEncode = + HashSet.foldr (\elem n -> setBit n (fromInteger (encodefunc elem))) 0 + + newDecode = + let + decode' out _ 0 = out + decode' out idx n + | testBit n 0 = + decode' (HashSet.insert (decodefunc idx) out) + (idx + 1) (n `shiftR` 1) + | otherwise = decode' out (idx + 1) (n `shiftR` 1) + in + decode' HashSet.empty 0 + + newSize = + do + elems <- sizeval + return (2 ^ elems) + + newInDomain = all indomainfunc . HashSet.toList + in + Encoding { encEncode = newEncode, encDecode = newDecode, + encSize = newSize, encInDomain = newInDomain } + +seqCore :: Encoding ty -> ([ty] -> Integer, Integer -> [ty]) +seqCore Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval } = + case sizeval of + -- For encodings with a maximum size s, a list with n elements + -- e_i is encoded as e_n + s e_(n-1) + ... s^n e_1 + Just finitesize -> + let + newencodefunc = + let + foldfun accum = (((accum * finitesize) + 1) +) . encodefunc + in + foldl foldfun 0 + + newdecodefunc = + let + newdecodefunc' accum 0 = accum + newdecodefunc' accum num = + let + decoded = decodefunc ((num - 1) `mod` finitesize) + in + newdecodefunc' (decoded : accum) ((num - 1) `quot` finitesize) + in + newdecodefunc' [] + in + (newencodefunc, newdecodefunc) + -- For encodings with no maximum size, we use a dovetailing approach. + Nothing -> + let + newencodefunc [] = 0 + newencodefunc (first : rest) = + let + insertUnary bin val = + let + encoded = encodefunc val + shifted = bin `shiftL` (fromInteger encoded) + in + shifted .|. ((2 ^ encoded) - 1) + + foldfun accum val = + let + shifted = accum `shiftL` 1 + in + insertUnary shifted val + + initial = insertUnary 1 first + in + foldl foldfun initial rest + + newdecodefunc 0 = [] + newdecodefunc num = + let + -- Count leading ones + leadingOnes :: Integer -> Integer + leadingOnes = + let + leadingOnes' count n + | testBit n 0 = leadingOnes' (count + 1) (n `shiftR` 1) + | otherwise = count + in + leadingOnes' 0 + + extractUnary bin = + let + unaryLen = leadingOnes bin + shifted = bin `shiftR` (fromInteger (unaryLen + 1)) + decoded + | shifted /= 0 = decodefunc unaryLen + | otherwise = decodefunc (unaryLen - 1) + in + (decoded, shifted) + + doDecode accum 0 = accum + doDecode accum bin = + let + (val, newbin) = extractUnary bin + in + doDecode (val : accum) newbin + in + doDecode [] num + in + (newencodefunc, newdecodefunc) + +-- | Construct an encoding for /finite/ sequences of a type from an +-- encoding for values of that type. +-- +-- Note: This encoding can produce very large numbers for short +-- sequences. +seq :: Encoding ty -> Encoding [ty] +seq enc @ Encoding { encInDomain = indomainfunc } = + let + (newEncode, newDecode) = seqCore enc + newInDomain = all indomainfunc + in + Encoding { encEncode = newEncode, encDecode = newDecode, + encSize = Nothing, encInDomain = newInDomain } + +-- | Sum of finite geometric series +geometricSum :: Integer -> Integer -> Integer +geometricSum len base = (1 - base ^ (len + 1)) `quot` (1 - base) + +-- | Integer logarithm (for base b and n, find largest i such that b^i +-- <= n) +ilog :: Integer -> Integer -> Integer +ilog n = toInteger . integerLogBase' n + +boundedSeqCore :: Integer -> Encoding ty -> ([ty] -> Integer, Integer -> [ty]) +boundedSeqCore len Encoding { encEncode = encodefunc, encDecode = decodefunc, + encSize = sizeval } = + case sizeval of + Nothing -> + let + newencode [] = 0 + newencode vals = + let + thislen = toInteger (length vals) + contentnum = fromProdList (map encodefunc vals) + in + (contentnum * (len - 1)) + thislen + + newdecode 0 = [] + newdecode num = + let + adjusted = num - 1 + thislen = adjusted `mod` (len - 1) + 1 + contentnum = adjusted `quot` (len - 1) + in + map decodefunc (toProdList thislen contentnum) + in + (newencode, newdecode) + Just finitesize -> + let + newencode [] = 0 + newencode vals = + let + thislen = toInteger (length vals) + base = geometricSum (thislen - 1) finitesize + + newencode' accum [] = accum + newencode' accum (first : rest) = + newencode' ((accum * finitesize) + encodefunc first) rest + in + base + (newencode' 0 (reverse vals)) + + newdecode 0 = [] + newdecode num = + let + lowlen = ilog finitesize ((num * (finitesize - 1)) + 1) - 1 + thislen = lowlen + 1 + contentnum = num - (geometricSum lowlen finitesize) + + newdecode' accum 1 entropy = (decodefunc entropy : accum) + newdecode' _ 0 _ = [] + newdecode' accum count entropy = + let + thisentropy = entropy `mod` finitesize + restentropy = entropy `quot` finitesize + this = decodefunc thisentropy + in + newdecode' (this : accum) (count - 1) restentropy + in + reverse (newdecode' [] thislen contentnum) + in + (newencode, newdecode) + +-- | Construct an encoding for sequences whose length is bounded by a +-- given value from an encoding for elements of the sequence. +boundedSeq :: Integer + -- ^ The maximum length of the sequence + -> Encoding ty + -- ^ The @Encoding@ for the sequence elements + -> Encoding [ty] +boundedSeq len enc @ Encoding { encSize = sizeval, encInDomain = indomainfunc } = + let + (newencode, newdecode) = boundedSeqCore len enc + newsize = sizeval >>= return . geometricSum len + newindomain vals = length vals <= fromInteger len && all indomainfunc vals + in + Encoding { encEncode = newencode, encDecode = newdecode, + encSize = newsize, encInDomain = newindomain } + +-- | Take a function which takes a self-reference and produces a +-- recursive encoding, and produce the fixed-point encoding. +recursive :: (Encoding ty -> Encoding ty) + -- ^ A function that, given a self-reference, + -- constructs an encoding. + -> Encoding ty +recursive genfunc = + let + enc = Encoding { encEncode = encode (genfunc enc), + encDecode = decode (genfunc enc), + encInDomain = inDomain (genfunc enc), + encSize = Nothing } + in + enc + +-- | A recursive construction for two mutually-recursive constructions. +recursive2 :: ((Encoding ty1, Encoding ty2) -> Encoding ty1) + -- ^ A function that, given self-references to both encodings, + -- constructs the first encoding. + -> ((Encoding ty1, Encoding ty2) -> Encoding ty2) + -- ^ A function that, given self-references to both encodings, + -- constructs the second encoding. + -> (Encoding ty1, Encoding ty2) +recursive2 genfunc1 genfunc2 = + let + encs = + (Encoding { encEncode = encode (genfunc1 encs), + encDecode = decode (genfunc1 encs), + encInDomain = inDomain (genfunc1 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc2 encs), + encDecode = decode (genfunc2 encs), + encInDomain = inDomain (genfunc2 encs), + encSize = Nothing }) + in + encs + +-- | A recursive construction for three mutually-recursive constructions. +recursive3 :: ((Encoding ty1, Encoding ty2, Encoding ty3) -> Encoding ty1) + -- ^ A function that, given self-references to all encodings, + -- constructs the first encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3) -> Encoding ty2) + -- ^ A function that, given self-references to all encodings, + -- constructs the second encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3) -> Encoding ty3) + -- ^ A function that, given self-references to all encodings, + -- constructs the third encoding. + -> (Encoding ty1, Encoding ty2, Encoding ty3) +recursive3 genfunc1 genfunc2 genfunc3 = + let + encs = + (Encoding { encEncode = encode (genfunc1 encs), + encDecode = decode (genfunc1 encs), + encInDomain = inDomain (genfunc1 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc2 encs), + encDecode = decode (genfunc2 encs), + encInDomain = inDomain (genfunc2 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc3 encs), + encDecode = decode (genfunc3 encs), + encInDomain = inDomain (genfunc3 encs), + encSize = Nothing }) + in + encs + +-- | A recursive construction for four mutually-recursive constructions. +recursive4 :: ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4) -> + Encoding ty1) + -- ^ A function that, given self-references to all encodings, + -- constructs the first encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4) -> + Encoding ty2) + -- ^ A function that, given self-references to all encodings, + -- constructs the second encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4) -> + Encoding ty3) + -- ^ A function that, given self-references to all encodings, + -- constructs the third encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4) -> + Encoding ty4) + -- ^ A function that, given self-references to all encodings, + -- constructs the fourth encoding. + -> (Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4) +recursive4 genfunc1 genfunc2 genfunc3 genfunc4 = + let + encs = + (Encoding { encEncode = encode (genfunc1 encs), + encDecode = decode (genfunc1 encs), + encInDomain = inDomain (genfunc1 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc2 encs), + encDecode = decode (genfunc2 encs), + encInDomain = inDomain (genfunc2 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc3 encs), + encDecode = decode (genfunc3 encs), + encInDomain = inDomain (genfunc3 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc4 encs), + encDecode = decode (genfunc4 encs), + encInDomain = inDomain (genfunc4 encs), + encSize = Nothing }) + in + encs + +-- | A recursive construction for five mutually-recursive constructions. +recursive5 :: ((Encoding ty1, Encoding ty2, Encoding ty3, + Encoding ty4, Encoding ty5) -> Encoding ty1) + -- ^ A function that, given self-references to all encodings, + -- constructs the first encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, + Encoding ty4, Encoding ty5) -> Encoding ty2) + -- ^ A function that, given self-references to all encodings, + -- constructs the second encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, + Encoding ty4, Encoding ty5) -> Encoding ty3) + -- ^ A function that, given self-references to all encodings, + -- constructs the third encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, + Encoding ty4, Encoding ty5) -> Encoding ty4) + -- ^ A function that, given self-references to all encodings, + -- constructs the fourth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, + Encoding ty4, Encoding ty5) -> Encoding ty5) + -- ^ A function that, given self-references to all encodings, + -- constructs the fifth encoding. + -> (Encoding ty1, Encoding ty2, Encoding ty3, + Encoding ty4, Encoding ty5) +recursive5 genfunc1 genfunc2 genfunc3 genfunc4 genfunc5 = + let + encs = + (Encoding { encEncode = encode (genfunc1 encs), + encDecode = decode (genfunc1 encs), + encInDomain = inDomain (genfunc1 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc2 encs), + encDecode = decode (genfunc2 encs), + encInDomain = inDomain (genfunc2 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc3 encs), + encDecode = decode (genfunc3 encs), + encInDomain = inDomain (genfunc3 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc4 encs), + encDecode = decode (genfunc4 encs), + encInDomain = inDomain (genfunc4 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc5 encs), + encDecode = decode (genfunc5 encs), + encInDomain = inDomain (genfunc5 encs), + encSize = Nothing }) + in + encs + +-- | A recursive construction for six mutually-recursive constructions. +recursive6 :: ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6) -> Encoding ty1) + -- ^ A function that, given self-references to all encodings, + -- constructs the first encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6) -> Encoding ty2) + -- ^ A function that, given self-references to all encodings, + -- constructs the second encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6) -> Encoding ty3) + -- ^ A function that, given self-references to all encodings, + -- constructs the third encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6) -> Encoding ty4) + -- ^ A function that, given self-references to all encodings, + -- constructs the fourth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6) -> Encoding ty5) + -- ^ A function that, given self-references to all encodings, + -- constructs the fifth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6) -> Encoding ty6) + -- ^ A function that, given self-references to all encodings, + -- constructs the sixth encoding. + -> (Encoding ty1, Encoding ty2, Encoding ty3, + Encoding ty4, Encoding ty5, Encoding ty6) +recursive6 genfunc1 genfunc2 genfunc3 genfunc4 genfunc5 genfunc6 = + let + encs = + (Encoding { encEncode = encode (genfunc1 encs), + encDecode = decode (genfunc1 encs), + encInDomain = inDomain (genfunc1 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc2 encs), + encDecode = decode (genfunc2 encs), + encInDomain = inDomain (genfunc2 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc3 encs), + encDecode = decode (genfunc3 encs), + encInDomain = inDomain (genfunc3 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc4 encs), + encDecode = decode (genfunc4 encs), + encInDomain = inDomain (genfunc4 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc5 encs), + encDecode = decode (genfunc5 encs), + encInDomain = inDomain (genfunc5 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc6 encs), + encDecode = decode (genfunc6 encs), + encInDomain = inDomain (genfunc6 encs), + encSize = Nothing }) + in + encs + +-- | A recursive construction for seven mutually-recursive constructions. +recursive7 :: ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7) -> Encoding ty1) + -- ^ A function that, given self-references to all encodings, + -- constructs the first encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7) -> Encoding ty2) + -- ^ A function that, given self-references to all encodings, + -- constructs the second encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7) -> Encoding ty3) + -- ^ A function that, given self-references to all encodings, + -- constructs the third encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7) -> Encoding ty4) + -- ^ A function that, given self-references to all encodings, + -- constructs the fourth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7) -> Encoding ty5) + -- ^ A function that, given self-references to all encodings, + -- constructs the fifth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7) -> Encoding ty6) + -- ^ A function that, given self-references to all encodings, + -- constructs the sixth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7) -> Encoding ty7) + -- ^ A function that, given self-references to all encodings, + -- constructs the seventh encoding. + -> (Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7) +recursive7 genfunc1 genfunc2 genfunc3 genfunc4 genfunc5 genfunc6 genfunc7 = + let + encs = + (Encoding { encEncode = encode (genfunc1 encs), + encDecode = decode (genfunc1 encs), + encInDomain = inDomain (genfunc1 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc2 encs), + encDecode = decode (genfunc2 encs), + encInDomain = inDomain (genfunc2 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc3 encs), + encDecode = decode (genfunc3 encs), + encInDomain = inDomain (genfunc3 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc4 encs), + encDecode = decode (genfunc4 encs), + encInDomain = inDomain (genfunc4 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc5 encs), + encDecode = decode (genfunc5 encs), + encInDomain = inDomain (genfunc5 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc6 encs), + encDecode = decode (genfunc6 encs), + encInDomain = inDomain (genfunc6 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc7 encs), + encDecode = decode (genfunc7 encs), + encInDomain = inDomain (genfunc7 encs), + encSize = Nothing }) + in + encs + +-- | A recursive construction for eight mutually-recursive constructions. +recursive8 :: ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8) -> + Encoding ty1) + -- ^ A function that, given self-references to all encodings, + -- constructs the first encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8) -> + Encoding ty2) + -- ^ A function that, given self-references to all encodings, + -- constructs the second encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8) -> + Encoding ty3) + -- ^ A function that, given self-references to all encodings, + -- constructs the third encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8) -> + Encoding ty4) + -- ^ A function that, given self-references to all encodings, + -- constructs the fourth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8) -> + Encoding ty5) + -- ^ A function that, given self-references to all encodings, + -- constructs the fifth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8) -> + Encoding ty6) + -- ^ A function that, given self-references to all encodings, + -- constructs the sixth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8) -> + Encoding ty7) + -- ^ A function that, given self-references to all encodings, + -- constructs the seventh encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8) -> + Encoding ty8) + -- ^ A function that, given self-references to all encodings, + -- constructs the eighth encoding. + -> (Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8) +recursive8 genfunc1 genfunc2 genfunc3 genfunc4 genfunc5 genfunc6 genfunc7 genfunc8 = + let + encs = + (Encoding { encEncode = encode (genfunc1 encs), + encDecode = decode (genfunc1 encs), + encInDomain = inDomain (genfunc1 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc2 encs), + encDecode = decode (genfunc2 encs), + encInDomain = inDomain (genfunc2 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc3 encs), + encDecode = decode (genfunc3 encs), + encInDomain = inDomain (genfunc3 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc4 encs), + encDecode = decode (genfunc4 encs), + encInDomain = inDomain (genfunc4 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc5 encs), + encDecode = decode (genfunc5 encs), + encInDomain = inDomain (genfunc5 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc6 encs), + encDecode = decode (genfunc6 encs), + encInDomain = inDomain (genfunc6 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc7 encs), + encDecode = decode (genfunc7 encs), + encInDomain = inDomain (genfunc7 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc8 encs), + encDecode = decode (genfunc8 encs), + encInDomain = inDomain (genfunc8 encs), + encSize = Nothing }) + in + encs + +-- | A recursive construction for nine mutually-recursive constructions. +recursive9 :: ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, + Encoding ty8, Encoding ty9) -> Encoding ty1) + -- ^ A function that, given self-references to all encodings, + -- constructs the first encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, + Encoding ty8, Encoding ty9) -> Encoding ty2) + -- ^ A function that, given self-references to all encodings, + -- constructs the second encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, + Encoding ty8, Encoding ty9) -> Encoding ty3) + -- ^ A function that, given self-references to all encodings, + -- constructs the third encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, + Encoding ty8, Encoding ty9) -> Encoding ty4) + -- ^ A function that, given self-references to all encodings, + -- constructs the fourth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, + Encoding ty8, Encoding ty9) -> Encoding ty5) + -- ^ A function that, given self-references to all encodings, + -- constructs the fifth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, + Encoding ty8, Encoding ty9) -> Encoding ty6) + -- ^ A function that, given self-references to all encodings, + -- constructs the sixth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, + Encoding ty8, Encoding ty9) -> Encoding ty7) + -- ^ A function that, given self-references to all encodings, + -- constructs the seventh encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, + Encoding ty8, Encoding ty9) -> Encoding ty8) + -- ^ A function that, given self-references to all encodings, + -- constructs the eighth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, + Encoding ty8, Encoding ty9) -> Encoding ty9) + -- ^ A function that, given self-references to all encodings, + -- constructs the ninth encoding. + -> (Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, Encoding ty5, + Encoding ty6, Encoding ty7, Encoding ty8, Encoding ty9) +recursive9 genfunc1 genfunc2 genfunc3 genfunc4 genfunc5 + genfunc6 genfunc7 genfunc8 genfunc9 = + let + encs = + (Encoding { encEncode = encode (genfunc1 encs), + encDecode = decode (genfunc1 encs), + encInDomain = inDomain (genfunc1 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc2 encs), + encDecode = decode (genfunc2 encs), + encInDomain = inDomain (genfunc2 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc3 encs), + encDecode = decode (genfunc3 encs), + encInDomain = inDomain (genfunc3 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc4 encs), + encDecode = decode (genfunc4 encs), + encInDomain = inDomain (genfunc4 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc5 encs), + encDecode = decode (genfunc5 encs), + encInDomain = inDomain (genfunc5 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc6 encs), + encDecode = decode (genfunc6 encs), + encInDomain = inDomain (genfunc6 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc7 encs), + encDecode = decode (genfunc7 encs), + encInDomain = inDomain (genfunc7 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc8 encs), + encDecode = decode (genfunc8 encs), + encInDomain = inDomain (genfunc8 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc9 encs), + encDecode = decode (genfunc9 encs), + encInDomain = inDomain (genfunc9 encs), + encSize = Nothing }) + in + encs + +-- | A recursive construction for ten mutually-recursive constructions. +recursive10 :: ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8, + Encoding ty9, Encoding ty10) -> Encoding ty1) + -- ^ A function that, given self-references to all encodings, + -- constructs the first encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8, + Encoding ty9, Encoding ty10) -> Encoding ty2) + -- ^ A function that, given self-references to all encodings, + -- constructs the second encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8, + Encoding ty9, Encoding ty10) -> Encoding ty3) + -- ^ A function that, given self-references to all encodings, + -- constructs the third encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8, + Encoding ty9, Encoding ty10) -> Encoding ty4) + -- ^ A function that, given self-references to all encodings, + -- constructs the fourth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8, + Encoding ty9, Encoding ty10) -> Encoding ty5) + -- ^ A function that, given self-references to all encodings, + -- constructs the fifth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8, + Encoding ty9, Encoding ty10) -> Encoding ty6) + -- ^ A function that, given self-references to all encodings, + -- constructs the sixth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8, + Encoding ty9, Encoding ty10) -> Encoding ty7) + -- ^ A function that, given self-references to all encodings, + -- constructs the seventh encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8, + Encoding ty9, Encoding ty10) -> Encoding ty8) + -- ^ A function that, given self-references to all encodings, + -- constructs the eighth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8, + Encoding ty9, Encoding ty10) -> Encoding ty9) + -- ^ A function that, given self-references to all encodings, + -- constructs the ninth encoding. + -> ((Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8, + Encoding ty9, Encoding ty10) -> Encoding ty10) + -- ^ A function that, given self-references to all encodings, + -- constructs the tenth encoding. + -> (Encoding ty1, Encoding ty2, Encoding ty3, Encoding ty4, + Encoding ty5, Encoding ty6, Encoding ty7, Encoding ty8, + Encoding ty9, Encoding ty10) +recursive10 genfunc1 genfunc2 genfunc3 genfunc4 genfunc5 + genfunc6 genfunc7 genfunc8 genfunc9 genfunc10 = + let + encs = + (Encoding { encEncode = encode (genfunc1 encs), + encDecode = decode (genfunc1 encs), + encInDomain = inDomain (genfunc1 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc2 encs), + encDecode = decode (genfunc2 encs), + encInDomain = inDomain (genfunc2 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc3 encs), + encDecode = decode (genfunc3 encs), + encInDomain = inDomain (genfunc3 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc4 encs), + encDecode = decode (genfunc4 encs), + encInDomain = inDomain (genfunc4 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc5 encs), + encDecode = decode (genfunc5 encs), + encInDomain = inDomain (genfunc5 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc6 encs), + encDecode = decode (genfunc6 encs), + encInDomain = inDomain (genfunc6 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc7 encs), + encDecode = decode (genfunc7 encs), + encInDomain = inDomain (genfunc7 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc8 encs), + encDecode = decode (genfunc8 encs), + encInDomain = inDomain (genfunc8 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc9 encs), + encDecode = decode (genfunc9 encs), + encInDomain = inDomain (genfunc9 encs), + encSize = Nothing }, + Encoding { encEncode = encode (genfunc10 encs), + encDecode = decode (genfunc10 encs), + encInDomain = inDomain (genfunc10 encs), + encSize = Nothing }) + in + encs diff --git a/src/Data/ArithEncode/Util.hs b/src/Data/ArithEncode/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/ArithEncode/Util.hs @@ -0,0 +1,275 @@ +--- 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 #-} +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} + +-- | Derived encodings for standard datatypes. +-- +-- This module contains a number of useful constructions which can be +-- defined using the constructions from "Basic". +module Data.ArithEncode.Util( + -- * Simple Encodings + unit, + void, + + -- * Non-Empty Containers + nonEmptySeq, + nonEmptyOptionSeq, + nonEmptySet, + nonEmptyHashSet, + + -- * Functions and Relations + function, + functionHashable, + relation, + relationHashable, +{- + hashMap, + hashFunc, + -} + -- * Trees + tree + ) where + +import Control.Exception +import Data.ArithEncode.Basic +import Data.Hashable +import Data.List +import Data.Maybe +import Data.Set(Set) +import Data.HashMap.Lazy(HashMap) +import Data.HashSet(HashSet) +import Data.Tree +import Prelude hiding (seq) +--import Debug.Trace + +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.Map as Map +import qualified Data.Set as Set + +-- | An encoding that produces @()@. +unit :: Encoding () +unit = singleton () + +-- | An empty encoding, which contains no mappings. +void :: Encoding b +void = mkEncoding (\_ -> throw (IllegalArgument "void encoding")) + (\_ -> throw (IllegalArgument "void encoding")) + (Just 0) (const False) + +-- | Build an encoding that produces non-empty sequences from an +-- encoding for the elements of the sequence. +nonEmptySeq :: Encoding ty + -- ^ The encoding for the element type + -> Encoding [ty] +nonEmptySeq = nonzero . seq + + +-- | Build an encoding that produces non-empty sets from an encoding +-- for the elements of the set. +nonEmptySet :: Ord ty => + Encoding ty + -- ^ The encoding for the element type + -> Encoding (Set ty) +nonEmptySet = nonzero . set + +-- | Build an encoding that produces non-empty hash sets from an encoding +-- for the elements of the set. +nonEmptyHashSet :: (Hashable ty, Ord ty) => + Encoding ty + -- ^ The encoding for the element type + -> Encoding (HashSet ty) +nonEmptyHashSet = nonzero . hashSet + +-- | Build an encoding for lists of @Maybe@s, where the last element +-- of the list is always guaranteed not to be @Nothing@. This is +-- useful for building function encodings. +nonEmptyOptionSeq :: Encoding ty + -- ^ The encoding for the element type + -> Encoding [Maybe ty] +nonEmptyOptionSeq enc = + let + fwdfunc Nothing = Just [] + fwdfunc (Just (first, rest)) = Just (reverse (Just first : rest)) + + revfunc' [] = Just Nothing + revfunc' (Just first : rest) = Just (Just (first, rest)) + revfunc' _ = Nothing + + revfunc = revfunc' . reverse + in + wrap revfunc fwdfunc (optional (pair enc (seq (optional enc)))) + +-- | Build an encoding for bounded-length lists of @Maybe@s, where the +-- last element of the list is always guaranteed not to be @Nothing@. +-- This is useful for building function encodings. +nonEmptyBoundedOptionSeq :: Integer + -- ^ The maximum length of the sequence + -> Encoding ty + -- ^ The encoding for the element type + -> Encoding [Maybe ty] +nonEmptyBoundedOptionSeq len enc = + let + fwdfunc Nothing = Just [] + fwdfunc (Just (first, rest)) = Just (reverse (Just first : rest)) + + revfunc' [] = Just Nothing + revfunc' (Just first : rest) = Just (Just (first, rest)) + revfunc' _ = Nothing + + revfunc = revfunc' . reverse + in + wrap revfunc fwdfunc (optional (pair enc (boundedSeq (len - 1) (optional enc)))) + +-- | Build an encoding that produces a (finite partial) function from +-- one type to another. This function is represented using a @Map@. +function :: Ord keyty => + Encoding keyty + -- ^ The encoding for the domain type (ie. key type) + -> Encoding valty + -- ^ The encoding for the range type (ie. value type) + -> Encoding (Map.Map keyty valty) +function keyenc valenc = + let + seqToMap val = + let + convertEnt (_, Nothing) = Nothing + convertEnt (key', Just val') = Just (decode keyenc key', val') + + contents = catMaybes (map convertEnt (zip (iterate (+ 1) 0) val)) + in + Just (Map.fromList contents) + + mapToSeq val + | all (inDomain keyenc) (Map.keys val) = + let + foldfun (count, accum) (idx, val') = + (idx + 1, + Just val' : replicate (fromInteger (idx - count)) Nothing ++ accum) + + sorted = sortBy (\(a, _) (b, _) -> compare a b) + (map (\(key, val') -> (encode keyenc key, val')) + (Map.assocs val)) + + (_, out) = foldl foldfun (0, []) sorted + reversed = reverse out + in + Just reversed + | otherwise = Nothing + + innerenc = + case size keyenc of + Just finitesize -> nonEmptyBoundedOptionSeq finitesize valenc + Nothing -> nonEmptyOptionSeq valenc + in + wrap mapToSeq seqToMap innerenc + +-- | Build an encoding that produces a (finite partial) function from +-- one type to another. This function is represented using a @HashMap@. +functionHashable :: (Ord keyty, Hashable keyty) => + Encoding keyty + -- ^ The encoding for the domain type (ie. key type) + -> Encoding valty + -- ^ The encoding for the range type (ie. value type) + -> Encoding (HashMap keyty valty) +functionHashable keyenc valenc = + let + seqToMap val = + let + convertEnt (_, Nothing) = Nothing + convertEnt (key', Just val') = Just (decode keyenc key', val') + + contents = catMaybes (map convertEnt (zip (iterate (+ 1) 0) val)) + in + Just (HashMap.fromList contents) + + mapToSeq val + | all (inDomain keyenc) (HashMap.keys val) = + let + foldfun (count, accum) (idx, val') = + (idx + 1, + Just val' : replicate (fromInteger (idx - count)) Nothing ++ accum) + + sorted = sortBy (\(a, _) (b, _) -> compare a b) + (map (\(key, val') -> (encode keyenc key, val')) + (HashMap.toList val)) + + (_, out) = foldl foldfun (0, []) sorted + reversed = reverse out + in + Just reversed + | otherwise = Nothing + + innerenc = + case size keyenc of + Just finitesize -> nonEmptyBoundedOptionSeq finitesize valenc + Nothing -> nonEmptyOptionSeq valenc + in + wrap mapToSeq seqToMap innerenc + +-- | Build an encoding that produces relations between two types. +-- These relations are represented as @Map@s from the first type to +-- @Set@s of the second. +relation :: (Ord keyty, Ord valty) => + Encoding keyty + -- ^ The encoding for the left-hand type (ie. key type) + -> Encoding valty + -- ^ The encoding for the right-hand type (ie. value type) + -> Encoding (Map.Map keyty (Set.Set valty)) +relation keyenc = function keyenc . nonEmptySet + +-- | Build an encoding that produces relations between two types. +-- These relations are represented as @HashMap@s from the first type to +-- @HashSet@s of the second. +relationHashable :: (Hashable keyty, Ord keyty, Hashable valty, Ord valty) => + Encoding keyty + -- ^ The encoding for the left-hand type (ie. key type) + -> Encoding valty + -- ^ The encoding for the right-hand type (ie. value type) + -> Encoding (HashMap keyty (HashSet valty)) +relationHashable keyenc = functionHashable keyenc . nonEmptyHashSet + +-- | Build an encoding that produces trees from an encoding for the +-- node labels. +tree :: Encoding ty + -- ^ The encoding for the node data type + -> Encoding (Tree ty) +tree enc = + let + makeNode (label, children) = + Just Node { rootLabel = label, subForest = children } + + unmakeNode Node { rootLabel = label, subForest = children } = + Just (label, children) + + nodeEncoding nodeenc = + wrap unmakeNode makeNode (pair enc (seq nodeenc)) + in + recursive nodeEncoding diff --git a/test/UnitTest.hs b/test/UnitTest.hs new file mode 100644 --- /dev/null +++ b/test/UnitTest.hs @@ -0,0 +1,43 @@ +-- 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. + +module Main(main) where + +import Test.HUnitPlus + +import qualified Tests.Data as Data + +tests = [ Data.tests ] + +testsuite = TestSuite { suiteName = "UnitTests", suiteConcurrently = True, + suiteTests = tests, suiteOptions = [] } + +main :: IO () +main = createMain [testsuite]