-- 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 -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.Logarithms import Math.NumberTheory.Roots import Data.Word 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 Data.Word.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 -- list of unit needs a special case to avoid 0/0 geometricSum len 1 = len + 1 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) + thislen newdecode 0 = [] newdecode num = let adjusted = num - 1 (remainingEntropy, lengthEntropy) = adjusted `quotRem` len thislen = lengthEntropy + 1 in map decodefunc (toProdList thislen remainingEntropy) in (newencode, newdecode) Just 0 -> (\[] -> 0, \0 -> []) Just 1 -> (genericLength, flip genericReplicate (decodefunc 0)) 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 = case len of 0 -> Just 1 --even if the list members are infinite _ -> fmap (geometricSum len) sizeval 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