diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for enumeration +## 0.2 (3 July 2019) + +Added `Data.Enumeration.Invertible`. + ## 0.1 (14 May 2019) Initial release. diff --git a/simple-enumeration.cabal b/simple-enumeration.cabal --- a/simple-enumeration.cabal +++ b/simple-enumeration.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simple-enumeration -version: 0.1 +version: 0.2 synopsis: Finite or countably infinite sequences of values. description: Finite or countably infinite sequences of values, supporting efficient indexing and random sampling. @@ -24,8 +24,9 @@ library exposed-modules: Data.Enumeration + Data.Enumeration.Invertible hs-source-dirs: src - build-depends: base >=4.7 && <5 + build-depends: base >=4.7 && <5, integer-gmp default-language: Haskell2010 test-suite doctests diff --git a/src/Data/Enumeration.hs b/src/Data/Enumeration.hs --- a/src/Data/Enumeration.hs +++ b/src/Data/Enumeration.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -47,6 +48,9 @@ -- >>> select trees 12345 -- B (B (B (B L (B L L)) L) (B L (B (B L L) L))) (B (B L (B L L)) (B (B L L) (B L (B L L)))) -- +-- For /invertible/ enumerations, /i.e./ bijections between some set +-- of values and natural numbers (or finite prefix thereof), see +-- "Data.Enumeration.Invertible". ----------------------------------------------------------------------------- @@ -54,6 +58,7 @@ ( -- * Enumerations Enumeration + , mkEnumeration -- ** Using enumerations @@ -90,6 +95,8 @@ , maybeOf , eitherOf , listOf + , finiteSubsetOf + , finiteEnumerationOf -- * Utilities @@ -99,9 +106,13 @@ import Control.Applicative +import Data.Bits ((.&.)) import Data.Ratio -import Data.Tuple (swap) +import Data.Tuple (swap) +import GHC.Base (Int (I#)) +import GHC.Integer.Logarithms (integerLog2#) + ------------------------------------------------------------ -- Setup for doctest examples ------------------------------------------------------------ @@ -188,6 +199,11 @@ } deriving Functor +-- | Create an enumeration primitively out of a cardinality and an +-- index function. +mkEnumeration :: Cardinality -> (Index -> a) -> Enumeration a +mkEnumeration = Enumeration + -- | The @Applicative@ instance for @Enumeration@ works similarly to -- the instance for lists: @pure = singleton@, and @f '<*>' x@ takes -- the Cartesian product of @f@ and @x@ (see ('><')) and applies @@ -221,9 +237,10 @@ -- | List the elements of an enumeration in order. Inverse of -- 'finiteList'. enumerate :: Enumeration a -> [a] -enumerate e = case card e of - Infinite -> map (select e) [0 ..] - Finite c -> map (select e) [0 .. c-1] +enumerate e = map (select e) $ + case card e of + Infinite -> [0 ..] + Finite c -> [0 .. c-1] ------------------------------------------------------------ -- Constructing Enumerations @@ -248,8 +265,8 @@ -- [()] unit :: Enumeration () unit = Enumeration - { card = 1 - , select = \case { 0 -> (); i -> error $ "select unit " ++ show i } + { card = 1 + , select = const () } -- | An enumeration of a single given element. @@ -431,7 +448,7 @@ -- trees = infinite $ singleton L '<|>' B '<$>' trees '<*>' trees -- @ -- --- Trying to use @treeBad@ at all will simply hang, since trying to +-- Trying to use @treesBad@ at all will simply hang, since trying to -- compute its cardinality leads to infinite recursion. -- -- @ @@ -439,7 +456,7 @@ -- ^CInterrupted. -- @ -- --- However, using 'infinite', as in the definition of 'trees', +-- However, using 'infinite', as in the definition of @trees@, -- provides the needed laziness: -- -- >>> card trees @@ -477,15 +494,14 @@ -- If you want to interleave an infinite enumeration of finite -- enumerations, you are out of luck. interleave :: Enumeration (Enumeration a) -> Enumeration a -interleave e = case card e of - Finite n -> Enumeration - { card = Infinite - , select = \k -> let (i,j) = k `divMod` n in select (select e j) i - } - Infinite -> Enumeration - { card = Infinite - , select = \k -> let (i,j) = diagonal k in select (select e j) i - } +interleave e = Enumeration + { card = Infinite + , select = \k -> + let (i,j) = case card e of + Finite n -> k `divMod` n + Infinite -> diagonal k + in select (select e j) i + } -- | Zip two enumerations in parallel, producing the pair of -- elements at each index. The resulting enumeration is truncated @@ -637,7 +653,7 @@ -- >>> enumerate $ maybeOf (finiteList [1,2,3]) -- [Nothing,Just 1,Just 2,Just 3] maybeOf :: Enumeration a -> Enumeration (Maybe a) -maybeOf e = singleton Nothing <|> Just <$> e +maybeOf a = singleton Nothing <|> Just <$> a -- | Enumerae all possible values of type @Either a b@ with inner values -- taken from the given enumerations. @@ -645,19 +661,69 @@ -- >>> enumerate . takeE 6 $ eitherOf nat nat -- [Left 0,Right 0,Left 1,Right 1,Left 2,Right 2] eitherOf :: Enumeration a -> Enumeration b -> Enumeration (Either a b) -eitherOf e1 e2 = Left <$> e1 <|> Right <$> e2 +eitherOf a b = Left <$> a <|> Right <$> b --- | Enumerate all possible lists containing values from the given enumeration. +-- | Enumerate all possible finite lists containing values from the given enumeration. -- -- >>> enumerate . takeE 15 $ listOf nat -- [[],[0],[0,0],[1],[0,0,0],[1,0],[2],[0,1],[1,0,0],[2,0],[3],[0,0,0,0],[1,1],[2,0,0],[3,0]] listOf :: Enumeration a -> Enumeration [a] -listOf e = case card e of +listOf a = case card a of Finite 0 -> empty - _ -> listOfE + _ -> listOfA where - listOfE = infinite $ singleton [] <|> (:) <$> e <*> listOfE + listOfA = infinite $ singleton [] <|> (:) <$> a <*> listOfA +-- | Enumerate all possible finite subsets of values from the given enumeration. +-- +-- >>> enumerate $ finiteSubsetOf (finite 3) +-- [[],[0],[1],[0,1],[2],[0,2],[1,2],[0,1,2]] +finiteSubsetOf :: Enumeration a -> Enumeration [a] +finiteSubsetOf as = pick <$> bitstrings + where + bitstrings = case card as of + Infinite -> nat + Finite k -> finite (2^k) + + pick 0 = [] + pick n = select as (integerLog2 l) : pick (n - l) + where + l = lsb n + + lsb :: Integer -> Integer + lsb n = n .&. (-n) + + integerLog2 :: Integer -> Integer + integerLog2 n = fromIntegral (I# (integerLog2# n)) + +-- | @finiteEnumerationOf n a@ creates an enumeration of all sequences +-- of exactly n items taken from the enumeration @a@. +finiteEnumerationOf :: Int -> Enumeration a -> Enumeration (Enumeration a) +finiteEnumerationOf 0 _ = singleton empty +finiteEnumerationOf n a = case card a of + Finite k -> selectEnum k <$> finite (k^n) + Infinite -> foldr cons (singleton empty) (replicate n a) + + where + selectEnum k = fmap (select a) . finiteList . reverse . take n . toBase k + + toBase _ 0 = repeat 0 + toBase k n = n `mod` k : toBase k (n `div` k) + + cons :: Enumeration a -> Enumeration (Enumeration a) -> Enumeration (Enumeration a) + cons a as = (<|>) <$> (singleton <$> a) <*> as + +-- https://mail.haskell.org/pipermail/haskell-cafe/2008-February/039465.html +-- imLog :: Integer->Integer->Integer +-- > > imLog b x +-- > > = if x < b then +-- > > 0 +-- > > else +-- > > let +-- > > l = 2 * imLog (b*b) x +-- > > doDiv x l = if x < b then l else doDiv (x`div`b) (l+1) +-- > > in +-- > > doDiv (x`div`(b^l)) l -- Note: more efficient integerSqrt in arithmoi -- (Math.NumberTheory.Powers.Squares), but it's a rather heavyweight diff --git a/src/Data/Enumeration/Invertible.hs b/src/Data/Enumeration/Invertible.hs new file mode 100644 --- /dev/null +++ b/src/Data/Enumeration/Invertible.hs @@ -0,0 +1,668 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- SPDX-License-Identifier: BSD-3-Clause + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Enumeration.Invertible +-- Copyright : Brent Yorgey +-- Maintainer : byorgey@gmail.com +-- +-- An /invertible enumeration/ is a bijection between a set of values +-- and the natural numbers (or a finite prefix thereof), represented +-- as a pair of inverse functions, one in each direction. Hence they +-- support efficient indexing and can be constructed for very large +-- finite sets. A few examples are shown below. +-- +-- Compared to "Data.Enumeration", one can also build invertible +-- enumerations of functions (or other type formers with contravariant +-- arguments); however, invertible enumerations no longer make for +-- valid 'Functor', 'Applicative', or 'Alternative' instances. +-- +-- This module exports many of the same names as "Data.Enumeration"; +-- the expectation is that you will choose one or the other to import, +-- though of course it is possible to import both if you qualify the +-- imports. +-- +----------------------------------------------------------------------------- + +module Data.Enumeration.Invertible + ( -- * Invertible enumerations + + IEnumeration + + -- ** Using enumerations + + , Cardinality(..), card + , Index, select, locate + + , isFinite + , enumerate + + -- ** Primitive enumerations + + , void + , unit + , singleton + , finite + , finiteList + , boundedEnum + + , nat + , int + , cw + , rat + + -- ** Enumeration combinators + + , mapE + , takeE, dropE + , zipE + , infinite + , (<+>) + , (><) + , interleave + + , maybeOf + , eitherOf + , listOf + , finiteSubsetOf + , finiteEnumerationOf + , functionOf + + -- * Utilities + + , undiagonal + ) where + +import Control.Applicative (Alternative (..)) +import Data.Bits (shiftL, (.|.)) +import Data.List (findIndex, foldl') +import Data.Maybe (fromJust) +import Data.Ratio + +import Data.Enumeration (Cardinality (..), Enumeration, Index) +import qualified Data.Enumeration as E + +------------------------------------------------------------ +-- Setup for doctest examples +------------------------------------------------------------ + +-- $setup +-- >>> :set -XTypeApplications +-- >>> import Control.Arrow ((&&&)) +-- >>> :{ +-- data Tree = L | B Tree Tree deriving Show +-- treesUpTo :: Int -> IEnumeration Tree +-- treesUpTo 0 = singleton L +-- treesUpTo n = mapE toTree fromTree (unit <+> (t' >< t')) +-- where +-- t' = treesUpTo (n-1) +-- trees :: IEnumeration Tree +-- trees = infinite $ mapE toTree fromTree (unit <+> (trees >< trees)) +-- toTree :: Either () (Tree, Tree) -> Tree +-- toTree = either (const L) (uncurry B) +-- fromTree :: Tree -> Either () (Tree, Tree) +-- fromTree L = Left () +-- fromTree (B l r) = Right (l,r) +-- :} + +------------------------------------------------------------ +-- Invertible enumerations +------------------------------------------------------------ + +-- | An invertible enumeration is a bijection between a set of +-- enumerated values and the natural numbers, or a finite prefix of +-- the natural numbers. An invertible enumeration is represented as +-- a function from natural numbers to values, paired with an inverse +-- function that returns the natural number index of a given value. +-- Enumerations can thus easily be constructed for very large sets, +-- and support efficient indexing and random sampling. +-- +-- Note that 'IEnumeration' cannot be made an instance of 'Functor', +-- 'Applicative', or 'Alternative'. However, it does support the +-- 'functionOf' combinator which cannot be supported by +-- "Data.Enumeration". + +data IEnumeration a = IEnumeration + { baseEnum :: Enumeration a + -- | Compute the index of a particular value in its enumeration. + -- Note that the result of 'locate' is only valid when given a + -- value which is actually in the range of the enumeration. + , locate :: a -> Index + } + +-- | Map a pair of inverse functions over an invertible enumeration of +-- @a@ values to turn it into an invertible enumeration of @b@ +-- values. Because invertible enumerations contain a /bijection/ to +-- the natural numbers, we really do need both directions of a +-- bijection between @a@ and @b@ in order to map. This is why +-- 'IEnumeration' cannot be an instance of 'Functor'. +mapE :: (a -> b) -> (b -> a) -> IEnumeration a -> IEnumeration b +mapE f g (IEnumeration e l) = IEnumeration (f <$> e) (l . g) + +------------------------------------------------------------ +-- Using enumerations +------------------------------------------------------------ + +-- | Select the value at a particular index. Precondition: the index +-- must be strictly less than the cardinality. +select :: IEnumeration a -> (Index -> a) +select = E.select . baseEnum + +-- | Get the cardinality of an enumeration. +card :: IEnumeration a -> Cardinality +card = E.card . baseEnum + +-- | Test whether an enumeration is finite. +-- +-- >>> isFinite (finiteList [1,2,3]) +-- True +-- +-- >>> isFinite nat +-- False +isFinite :: IEnumeration a -> Bool +isFinite (IEnumeration e _) = E.isFinite e + +-- | List the elements of an enumeration in order. Inverse of +-- 'finiteList'. +enumerate :: IEnumeration a -> [a] +enumerate e = case card e of + Infinite -> map (select e) [0 ..] + Finite c -> map (select e) [0 .. c-1] + +------------------------------------------------------------ +-- Constructing Enumerations +------------------------------------------------------------ + +-- | The empty enumeration, with cardinality zero and no elements. +-- +-- >>> card void +-- Finite 0 +-- +-- >>> enumerate void +-- [] +void :: IEnumeration a +void = IEnumeration empty (error "locate void") + +-- | The unit enumeration, with a single value of @()@ at index 0. +-- +-- >>> card unit +-- Finite 1 +-- +-- >>> enumerate unit +-- [()] +-- +-- >>> locate unit () +-- 0 +unit :: IEnumeration () +unit = IEnumeration E.unit (const 0) + +-- | An enumeration of a single given element at index 0. +-- +-- >>> card (singleton 17) +-- Finite 1 +-- +-- >>> enumerate (singleton 17) +-- [17] +-- +-- >>> locate (singleton 17) 17 +-- 0 +singleton :: a -> IEnumeration a +singleton a = IEnumeration (E.singleton a) (const 0) + +-- | A finite prefix of the natural numbers. +-- +-- >>> card (finite 5) +-- Finite 5 +-- >>> card (finite 1234567890987654321) +-- Finite 1234567890987654321 +-- +-- >>> enumerate (finite 5) +-- [0,1,2,3,4] +-- >>> enumerate (finite 0) +-- [] +-- +-- >>> locate (finite 5) 2 +-- 2 +finite :: Integer -> IEnumeration Integer +finite n = IEnumeration (E.finite n) id + +-- | Construct an enumeration from the elements of a /finite/ list. +-- The elements of the list must all be distinct. To turn an +-- enumeration back into a list, use 'enumerate'. +-- +-- >>> enumerate (finiteList [2,3,8,1]) +-- [2,3,8,1] +-- >>> select (finiteList [2,3,8,1]) 2 +-- 8 +-- >>> locate (finiteList [2,3,8,1]) 8 +-- 2 +-- +-- 'finiteList' does not work on infinite lists: inspecting the +-- cardinality of the resulting enumeration (something many of the +-- enumeration combinators need to do) will hang trying to compute +-- the length of the infinite list. +-- +-- 'finiteList' uses ('!!') and 'findIndex' internally (which both +-- take $O(n)$ time), so you probably want to avoid using it on long +-- lists. It would be possible to make a version with better +-- indexing performance by allocating a vector internally, but I am +-- too lazy to do it. If you have a good use case let me know +-- (better yet, submit a pull request). +finiteList :: Eq a => [a] -> IEnumeration a +finiteList as = IEnumeration (E.finiteList as) locateFinite + -- Note the use of !! and findIndex is not very efficient, but for + -- small lists it probably still beats the overhead of allocating a + -- vector. Most likely this will only ever be used with very small + -- lists anyway. If it becomes a problem we could add another + -- combinator that behaves just like finiteList but allocates a + -- Vector internally. + + where + locateFinite a = fromIntegral . fromJust $ findIndex (==a) as + +-- | Enumerate all the values of a bounded 'Enum' instance. +-- +-- >>> enumerate (boundedEnum @Bool) +-- [False,True] +-- +-- >>> select (boundedEnum @Char) 97 +-- 'a' +-- >>> locate (boundedEnum @Char) 'Z' +-- 90 +-- +-- >>> card (boundedEnum @Int) +-- Finite 18446744073709551616 +-- >>> select (boundedEnum @Int) 0 +-- -9223372036854775808 +boundedEnum :: forall a. (Enum a, Bounded a) => IEnumeration a +boundedEnum = IEnumeration E.boundedEnum (subtract lo . fromIntegral . fromEnum) + where + lo :: Index + lo = fromIntegral (fromEnum (minBound @a)) + +-- | The natural numbers, @0, 1, 2, ...@. +-- +-- >>> enumerate . takeE 10 $ nat +-- [0,1,2,3,4,5,6,7,8,9] +nat :: IEnumeration Integer +nat = IEnumeration E.nat id + +-- | All integers in the order @0, 1, -1, 2, -2, 3, -3, ...@. +int :: IEnumeration Integer +int = IEnumeration E.int locateInt + where + locateInt z + | z <= 0 = 2 * abs z + | otherwise = 2*z - 1 + +-- | The positive rational numbers, enumerated according to the +-- [Calkin-Wilf sequence](http://www.cs.ox.ac.uk/publications/publication1664-abstract.html). +-- +-- >>> enumerate . takeE 10 $ cw +-- [1 % 1,1 % 2,2 % 1,1 % 3,3 % 2,2 % 3,3 % 1,1 % 4,4 % 3,3 % 5] +-- >>> locate cw (3 % 2) +-- 4 +-- >>> locate cw (23 % 99) +-- 3183 +cw :: IEnumeration Rational +cw = IEnumeration E.cw (pred . locateCW) + where + locateCW r = go (numerator r, denominator r) + go (1,1) = 1 + go (a,b) + | a < b = 2 * go (a, b - a) + | otherwise = 1 + 2 * go (a - b, b) + +-- | An enumeration of all rational numbers: 0 first, then each +-- rational in the Calkin-Wilf sequence followed by its negative. +-- +-- >>> enumerate . takeE 10 $ rat +-- [0 % 1,1 % 1,(-1) % 1,1 % 2,(-1) % 2,2 % 1,(-2) % 1,1 % 3,(-1) % 3,3 % 2] +-- >>> locate rat (-45 % 61) +-- 2540 + +rat :: IEnumeration Rational +rat = mapE + (either (const 0) (either id negate)) + unrat + (unit <+> (cw <+> cw)) + where + unrat 0 = Left () + unrat r + | r > 0 = Right (Left r) + | otherwise = Right (Right (-r)) + +-- | Take a finite prefix from the beginning of an enumeration. @takeE +-- k e@ always yields the empty enumeration for \(k \leq 0\), and +-- results in @e@ whenever @k@ is greater than or equal to the +-- cardinality of the enumeration. Otherwise @takeE k e@ has +-- cardinality @k@ and matches @e@ from @0@ to @k-1@. +-- +-- >>> enumerate $ takeE 3 (boundedEnum @Int) +-- [-9223372036854775808,-9223372036854775807,-9223372036854775806] +-- +-- >>> enumerate $ takeE 2 (finiteList [1..5]) +-- [1,2] +-- +-- >>> enumerate $ takeE 0 (finiteList [1..5]) +-- [] +-- +-- >>> enumerate $ takeE 7 (finiteList [1..5]) +-- [1,2,3,4,5] +takeE :: Integer -> IEnumeration a -> IEnumeration a +takeE k (IEnumeration e l) = IEnumeration (E.takeE k e) l + +-- | Drop some elements from the beginning of an enumeration. @dropE k +-- e@ yields @e@ unchanged if \(k \leq 0\), and results in the empty +-- enumeration whenever @k@ is greater than or equal to the +-- cardinality of @e@. +-- +-- >>> enumerate $ dropE 2 (finiteList [1..5]) +-- [3,4,5] +-- +-- >>> enumerate $ dropE 0 (finiteList [1..5]) +-- [1,2,3,4,5] +-- +-- >>> enumerate $ dropE 7 (finiteList [1..5]) +-- [] +dropE :: Integer -> IEnumeration a -> IEnumeration a +dropE k (IEnumeration e l) = IEnumeration (E.dropE k e) (subtract (max 0 k) . l) + +-- | Explicitly mark an enumeration as having an infinite cardinality, +-- ignoring the previous cardinality. It is sometimes necessary to +-- use this as a "hint" when constructing a recursive enumeration +-- whose cardinality would otherwise consist of an infinite sum of +-- finite cardinalities. +-- +-- For example, consider the following definitions: +-- +-- @ +-- data Tree = L | B Tree Tree deriving Show +-- +-- toTree :: Either () (Tree, Tree) -> Tree +-- toTree = either (const L) (uncurry B) +-- +-- fromTree :: Tree -> Either () (Tree, Tree) +-- fromTree L = Left () +-- fromTree (B l r) = Right (l,r) +-- +-- treesBad :: IEnumeration Tree +-- treesBad = mapE toTree fromTree (unit '<+>' (treesBad '><' treesBad)) +-- +-- trees :: IEnumeration Tree +-- trees = infinite $ mapE toTree fromTree (unit '<+>' (trees '><' trees)) +-- @ +-- +-- Trying to use @treesBad@ at all will simply hang, since trying to +-- compute its cardinality leads to infinite recursion. +-- +-- @ +-- \>>>\ select treesBad 5 +-- ^CInterrupted. +-- @ +-- +-- However, using 'infinite', as in the definition of @trees@, +-- provides the needed laziness: +-- +-- >>> card trees +-- Infinite +-- >>> enumerate . takeE 3 $ trees +-- [L,B L L,B L (B L L)] +-- >>> select trees 87239862967296 +-- B (B (B (B (B L L) (B (B (B L L) L) L)) (B L (B L (B L L)))) (B (B (B L (B L (B L L))) (B (B L L) (B L L))) (B (B L (B L (B L L))) L))) (B (B L (B (B (B L (B L L)) (B L L)) L)) (B (B (B L (B L L)) L) L)) +-- >>> select trees 123 +-- B (B L (B L L)) (B (B L (B L L)) (B L (B L L))) +-- >>> locate trees (B (B L (B L L)) (B (B L (B L L)) (B L (B L L)))) +-- 123 + +infinite :: IEnumeration a -> IEnumeration a +infinite (IEnumeration e l) = IEnumeration (E.infinite e) l + +-- | Fairly interleave a set of /infinite/ enumerations. +-- +-- For a finite set of infinite enumerations, a round-robin +-- interleaving is used. That is, if we think of an enumeration of +-- enumerations as a 2D matrix read off row-by-row, this corresponds +-- to taking the transpose of a matrix with finitely many infinite +-- rows, turning it into one with infinitely many finite rows. For +-- an infinite set of infinite enumerations, /i.e./ an infinite 2D +-- matrix, the resulting enumeration reads off the matrix by +-- 'Data.Enumeration.diagonal's. +-- +-- Note that the type of this function is slightly different than +-- its counterpart in "Data.Enumeration": each enumerated value in +-- the output is tagged with an index indicating which input +-- enumeration it came from. This is required to make the result +-- invertible, and is analogous to the way the output values of +-- '<+>' are tagged with 'Left' or 'Right'; in fact, 'interleave' +-- can be thought of as an iterated version of '<+>', but with a +-- more efficient implementation. + +interleave :: IEnumeration (IEnumeration a) -> IEnumeration (Index, a) +interleave e = IEnumeration + { baseEnum = E.mkEnumeration Infinite $ \k -> + let (i,j) = case card e of + Finite n -> k `divMod` n + Infinite -> E.diagonal k + in (j, select (select e j) i) + , locate = \(j, a) -> + let i = locate (select e j) a + in case card e of + Finite n -> i*n + j + Infinite -> undiagonal (i,j) + } + +-- | Zip two enumerations in parallel, producing the pair of +-- elements at each index. The resulting enumeration is truncated +-- to the cardinality of the smaller of the two arguments. +-- +-- Note that defining @zipWithE@ as in "Data.Enumeration" is not +-- possible since there would be no way to invert it in general. +-- However, one can use 'zipE' in combination with 'mapE' to achieve +-- a similar result. +-- +-- >>> enumerate $ zipE nat (boundedEnum @Bool) +-- [(0,False),(1,True)] +-- +-- >>> cs = mapE (uncurry replicate) (length &&& head) (zipE (finiteList [1..10]) (dropE 35 (boundedEnum @Char))) +-- >>> enumerate cs +-- ["#","$$","%%%","&&&&","'''''","((((((",")))))))","********","+++++++++",",,,,,,,,,,"] +-- >>> locate cs "********" +-- 7 + +zipE :: IEnumeration a -> IEnumeration b -> IEnumeration (a,b) +zipE ea eb = IEnumeration + { baseEnum = E.zipE (baseEnum ea) (baseEnum eb) + , locate = locate ea . fst + } + +-- | Sum, /i.e./ disjoint union, of two enumerations. If both are +-- finite, all the values of the first will be enumerated before the +-- values of the second. If only one is finite, the values from the +-- finite enumeration will be listed first. If both are infinite, a +-- fair (alternating) interleaving is used, so that every value ends +-- up at a finite index in the result. +-- +-- Note that this has a different type than the version in +-- "Data.Enumeration". Here we require the output to carry an +-- explicit 'Either' tag to make it invertible. +-- +-- >>> enumerate . takeE 5 $ singleton 17 <+> nat +-- [Left 17,Right 0,Right 1,Right 2,Right 3] +-- +-- >>> enumerate . takeE 5 $ nat <+> singleton 17 +-- [Right 17,Left 0,Left 1,Left 2,Left 3] +-- +-- >>> enumerate . takeE 5 $ nat <+> nat +-- [Left 0,Right 0,Left 1,Right 1,Left 2] +-- +-- >>> locate (nat <+> nat) (Right 35) +-- 71 + +(<+>) :: IEnumeration a -> IEnumeration b -> IEnumeration (Either a b) +a <+> b = IEnumeration (Left <$> baseEnum a <|> Right <$> baseEnum b) (locateEither a b) + where + locateEither :: IEnumeration a -> IEnumeration b -> (Either a b -> Index) + locateEither a b = case (card a, card b) of + (Finite k1, _) -> either (locate a) ((+k1) . locate b) + (_, Finite k2) -> either ((+k2) . locate a) (locate b) + _ -> either ((*2) . locate a) (succ . (*2) . locate b) + + +-- | The other half of the isomorphism between \(\mathbb{N}\) and +-- \(\mathbb{N} \times \mathbb{N}\) which enumerates by diagonals: +-- turn a pair of natural numbers giving a position in the 2D grid +-- into the number in the cell, according to this numbering scheme: +-- +-- @ +-- 0 1 3 6 ... +-- 2 4 7 +-- 5 8 +-- 9 +-- @ +undiagonal :: (Integer, Integer) -> Integer +undiagonal (r,c) = (r+c) * (r+c+1) `div` 2 + r + +-- | Cartesian product of enumerations. If both are finite, uses a +-- simple lexicographic ordering. If only one is finite, the +-- resulting enumeration is still in lexicographic order, with the +-- infinite enumeration as the most significant component. For two +-- infinite enumerations, uses a fair 'Data.Enumeration.diagonal' interleaving. +-- +-- >>> enumerate $ finiteList [1..3] >< finiteList "abcd" +-- [(1,'a'),(1,'b'),(1,'c'),(1,'d'),(2,'a'),(2,'b'),(2,'c'),(2,'d'),(3,'a'),(3,'b'),(3,'c'),(3,'d')] +-- +-- >>> enumerate . takeE 10 $ finiteList "abc" >< nat +-- [('a',0),('b',0),('c',0),('a',1),('b',1),('c',1),('a',2),('b',2),('c',2),('a',3)] +-- +-- >>> enumerate . takeE 10 $ nat >< finiteList "abc" +-- [(0,'a'),(0,'b'),(0,'c'),(1,'a'),(1,'b'),(1,'c'),(2,'a'),(2,'b'),(2,'c'),(3,'a')] +-- +-- >>> enumerate . takeE 10 $ nat >< nat +-- [(0,0),(0,1),(1,0),(0,2),(1,1),(2,0),(0,3),(1,2),(2,1),(3,0)] +-- +-- >>> locate (nat >< nat) (1,1) +-- 4 +-- >>> locate (nat >< nat) (36,45) +-- 3357 +-- +-- Like ('<+>'), this operation is also not associative (not even up +-- to reassociating tuples). +(><) :: IEnumeration a -> IEnumeration b -> IEnumeration (a,b) +a >< b = IEnumeration (baseEnum a E.>< baseEnum b) (locatePair a b) + where + locatePair :: IEnumeration a -> IEnumeration b -> ((a,b) -> Index) + locatePair a b = case (card a, card b) of + (_, Finite k2) -> \(x,y) -> k2 * locate a x + locate b y + (Finite k1, _) -> \(x,y) -> k1 * locate b y + locate a x + _ -> \(x,y) -> undiagonal (locate a x, locate b y) + +------------------------------------------------------------ +-- Building standard data types +------------------------------------------------------------ + +-- | Enumerate all possible values of type `Maybe a`, where the values +-- of type `a` are taken from the given enumeration. +-- +-- >>> enumerate $ maybeOf (finiteList [1,2,3]) +-- [Nothing,Just 1,Just 2,Just 3] +-- >>> locate (maybeOf (maybeOf (finiteList [1,2,3]))) (Just (Just 2)) +-- 3 +maybeOf :: IEnumeration a -> IEnumeration (Maybe a) +maybeOf a = mapE (either (const Nothing) Just) (maybe (Left ()) Right) (unit <+> a) + +-- | Enumerae all possible values of type @Either a b@ with inner values +-- taken from the given enumerations. +-- +-- Note that for invertible enumerations, 'eitherOf' is simply a +-- synonym for '<+>'. +-- +-- >>> enumerate . takeE 6 $ eitherOf nat nat +-- [Left 0,Right 0,Left 1,Right 1,Left 2,Right 2] +eitherOf :: IEnumeration a -> IEnumeration b -> IEnumeration (Either a b) +eitherOf = (<+>) + +-- | Enumerate all possible finite lists containing values from the +-- given enumeration. +-- +-- >>> enumerate . takeE 15 $ listOf nat +-- [[],[0],[0,0],[1],[0,0,0],[1,0],[2],[0,1],[1,0,0],[2,0],[3],[0,0,0,0],[1,1],[2,0,0],[3,0]] +-- >>> locate (listOf nat) [3,4,20,5,19] +-- 666270815854068922513792635440014 +listOf :: IEnumeration a -> IEnumeration [a] +listOf a = case card a of + Finite 0 -> singleton [] + _ -> listOfA + where + listOfA = infinite $ + mapE (either (const []) (uncurry (:))) uncons (unit <+> (a >< listOfA)) + uncons [] = Left () + uncons (a:as) = Right (a, as) + +-- | Enumerate all possible finite subsets of values from the given +-- enumeration. The elements in each list will always occur in +-- increasing order of their index in the given enumeration. +-- +-- >>> enumerate $ finiteSubsetOf (finite 3) +-- [[],[0],[1],[0,1],[2],[0,2],[1,2],[0,1,2]] +-- +-- >>> locate (finiteSubsetOf nat) [2,3,6,8] +-- 332 +-- >>> 332 == 2^8 + 2^6 + 2^3 + 2^2 +-- True +finiteSubsetOf :: IEnumeration a -> IEnumeration [a] +finiteSubsetOf a = IEnumeration (E.finiteSubsetOf (baseEnum a)) unpick + where + unpick = foldl' (.|.) 0 . map ((1 `shiftL`) . fromIntegral . locate a) + +-- | @finiteEnumerationOf n a@ creates an enumeration of all sequences +-- of exactly n items taken from the enumeration @a@. +-- +-- >>> map E.enumerate . enumerate $ finiteEnumerationOf 2 (finite 3) +-- [[0,0],[0,1],[0,2],[1,0],[1,1],[1,2],[2,0],[2,1],[2,2]] +-- +-- >>> map E.enumerate . take 10 . enumerate $ finiteEnumerationOf 3 nat +-- [[0,0,0],[0,0,1],[1,0,0],[0,1,0],[1,0,1],[2,0,0],[0,0,2],[1,1,0],[2,0,1],[3,0,0]] +finiteEnumerationOf :: Int -> IEnumeration a -> IEnumeration (Enumeration a) +finiteEnumerationOf 0 _ = singleton empty +finiteEnumerationOf n a = case card a of + Finite k -> IEnumeration (E.finiteEnumerationOf n (baseEnum a)) (locateEnum k) + Infinite -> foldr prod (singleton empty) (replicate n a) + + where + locateEnum k = fromBase k . reverse . E.enumerate . fmap (locate a) + + fromBase k = foldr (\d r -> d + k*r) 0 + + prod :: IEnumeration a -> IEnumeration (Enumeration a) -> IEnumeration (Enumeration a) + prod a as = mapE (\(a,e) -> E.singleton a <|> e) (\e -> (E.select e 0, E.dropE 1 e)) + (a >< as) + +-- | @functionOf a b@ creates an enumeration of all functions taking +-- values from the enumeration @a@ and returning values from the +-- enumeration @b@. As a precondition, @a@ must be finite; +-- otherwise @functionOf@ throws an error. +-- +-- >>> bbs = functionOf (boundedEnum @Bool) (boundedEnum @Bool) +-- >>> card bbs +-- Finite 4 +-- >>> map (select bbs 2) [False, True] +-- [True,False] +-- >>> locate bbs not +-- 2 +-- +-- >>> locate (functionOf bbs (boundedEnum @Bool)) (\f -> f True) +-- 5 +functionOf :: IEnumeration a -> IEnumeration b -> IEnumeration (a -> b) +functionOf as bs = case card as of + Infinite -> error "functionOf with infinite domain" + Finite n -> mapE toFunc fromFunc (finiteEnumerationOf (fromIntegral n) bs) + + where + toFunc bTuple a = E.select bTuple (locate as a) + fromFunc f = f <$> baseEnum as diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -1,2 +1,2 @@ import Test.DocTest -main = doctest ["-isrc", "src/Data/Enumeration.hs"] +main = doctest ["-isrc", "src/Data/Enumeration.hs", "src/Data/Enumeration/Invertible.hs"]