diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Changelog for enumeration +## 0.3 (22 April 2025) + +- Fix `Enumeration.listOf empty` to return singleton list containing + empty list instead of empty list (thanks to Koji Miyazato) +- New modules `Data.ProEnumeration` and `Data.CoEnumeration` (thanks + to Koji Miyazato) +- Test up through GHC 9.12 + ## 0.2.1 (25 June 2020) [Make `Data.Enumeration.Invertible.functionOf` a bit more permissive.](https://github.com/byorgey/enumeration/commit/59090f46ce01d7eda7371ba673fe54763b96c97e) 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.2.1 +version: 0.3 synopsis: Finite or countably infinite sequences of values. description: Finite or countably infinite sequences of values, supporting efficient indexing and random sampling. @@ -17,6 +17,7 @@ extra-source-files: README.md ChangeLog.md +tested-with: GHC ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.1 || ==9.12.1 source-repository head type: git @@ -25,8 +26,10 @@ library exposed-modules: Data.Enumeration Data.Enumeration.Invertible + Data.CoEnumeration + Data.ProEnumeration hs-source-dirs: src - build-depends: base >=4.7 && <5, integer-gmp + build-depends: base >=4.7 && <5, integer-gmp, contravariant default-language: Haskell2010 test-suite doctests diff --git a/src/Data/CoEnumeration.hs b/src/Data/CoEnumeration.hs new file mode 100644 --- /dev/null +++ b/src/Data/CoEnumeration.hs @@ -0,0 +1,439 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- SPDX-License-Identifier: BSD-3-Clause + +----------------------------------------------------------------------------- +-- | +-- Module : Data.CoEnumeration +-- Copyright : Brent Yorgey, Koji Miyazato +-- Maintainer : byorgey@gmail.com +-- +-- A /coenumeration/ is a function from values to finite or countably infinite +-- sets, canonically represented by non-negative integers less than its cardinality. +-- +-- Alternatively, a coenumeration can be thought of as a classification of values +-- into finite or countably infinite classes, with each class labelled with +-- integers. +-- +-- This module provides many ways to construct @CoEnumeration@ values, +-- and most of them are implemented as inverses of enumerations made with +-- functions in "Data.Enumeration". +-- +-- == Example +-- +-- Through examples of this module, "Data.Enumeration" module is +-- referred by alias @E@. +-- +-- > import qualified Data.Enumeration as E +-- +-- >>> take 5 . drop 5 $ E.enumerate (E.listOf E.nat) +-- [[1,0],[2],[0,1],[1,0,0],[2,0]] +-- >>> locate (listOf nat) <$> [[1,0],[2],[0,1],[1,0,0],[2,0]] +-- [5,6,7,8,9] +-- +-- >>> locate (listOf nat) [3,1,4,1,5,9,2] +-- 78651719792187121765701606023038613403478037124236785850350 +-- >>> E.select (E.listOf E.nat) 78651719792187121765701606023038613403478037124236785850350 +-- [3,1,4,1,5,9,2] +module Data.CoEnumeration + ( -- * Coenumerations + CoEnumeration(), card, locate, isFinite + , unsafeMkCoEnumeration + + -- * Cardinality and Index + , Index, Cardinality(..) + + -- * Primitive coenumerations + , unit, lost + , boundedEnum + , nat + , int + , cw + , rat + + -- * Coenumeration combinators + , takeC, dropC, modulo, overlayC + , infinite + , (><), (<+>) + , maybeOf, eitherOf, listOf, finiteSubsetOf + , finiteFunctionOf + + -- * Utilities + , unList, unSet + ) where + +import Data.Void +import Data.Bits +import Data.List (foldl') +import Data.Ratio + +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Divisible(lost, Divisible(..), Decidable(..)) + +import Data.Enumeration (Index, Cardinality(..)) +import Data.Enumeration.Invertible (undiagonal) + + +------------------------------------------------------------ +-- Setup for doctest examples +------------------------------------------------------------ + +-- $setup +-- >>> :set -XTypeApplications +-- >>> import qualified Data.Enumeration as E + +-- | A /coenumeration/ is a function from values to finite or countably infinite +-- sets, canonically represented by non-negative integers less than its cardinality. +-- +-- Alternatively, a coenumeration can be thought of as a classification of values +-- into finite or countably infinite classes, with each class labelled with +-- integers. +-- +-- 'CoEnumeration' is an instance of the following type classes: +-- +-- * 'Contravariant' (you can change the type of base values contravariantly) +-- * 'Divisible' (representing Cartesian product of finite number of coenumerations) +-- +-- * Binary cartesian product ('><') +-- * Coenumeration onto singleton set as an unit ('unit') +-- +-- * 'Decidable' (representing disjoint union of finite number of coenumerations) +-- +-- * Binary disjoint union ('<+>') +-- * Coenumeration of uninhabited type 'Void'. It's not exported directly, +-- but only through a method of the class +-- +-- 'lose' @:: Decidable f => (a -> Void) -> f Void@ +-- +-- or +-- +-- 'lost' @:: Decidable f => f Void@. +data CoEnumeration a = CoEnumeration + { -- | Get the cardinality of a coenumeration. + -- Under \"classification\" interpretation, + -- it is the cardinality of the set of classes. + card :: Cardinality + + -- | Compute the index of a particular value. + , locate :: a -> Index + } + +-- | Returns if the the cardinality of coenumeration is finite. +isFinite :: CoEnumeration a -> Bool +isFinite = (Infinite /=) . card + +-- | Constructs a coenumeration. +-- +-- To construct valid coenumeration by @unsafeMkCoEnumeration n f@, +-- for all @x :: a@, it must satisfy @(Finite (f x) < n)@. +-- +-- This functions does not (and never could) check the validity +-- of its arguments. +unsafeMkCoEnumeration :: Cardinality -> (a -> Index) -> CoEnumeration a +unsafeMkCoEnumeration = CoEnumeration + +instance Contravariant CoEnumeration where + contramap f e = e{ locate = locate e . f } + +-- | Associativity of 'divide' is maintained only when +-- arguments are finite. +instance Divisible CoEnumeration where + divide f a b = contramap f $ a >< b + conquer = unit + +-- | Associativity of 'choose' is maintained only when +-- arguments are finite. +instance Decidable CoEnumeration where + choose f a b = contramap f $ a <+> b + lose f = contramap f void + +-- | Coenumeration to the singleton set. +-- +-- >>> card unit +-- Finite 1 +-- >>> locate unit True +-- 0 +-- >>> locate unit (3 :: Int) +-- 0 +-- >>> locate unit (cos :: Float -> Float) +-- 0 +unit :: CoEnumeration a +unit = CoEnumeration{ card = 1, locate = const 0 } + +-- | Coenumeration of an uninhabited type 'Void'. +-- +-- >>> card void +-- Finite 0 +-- +-- Note that when a coenumeration of a type @t@ has cardinality 0, +-- it should indicate /No/ value of @t@ can be created without +-- using bottoms like @undefined@. +void :: CoEnumeration Void +void = CoEnumeration{ card = 0, locate = const (error "locate void") } + +-- | An inverse of forward 'E.boundedEnum' +boundedEnum :: forall a. (Enum a, Bounded a) => CoEnumeration a +boundedEnum = CoEnumeration{ card = size, locate = loc } + where loc = toInteger . subtract lo . fromEnum + lo = fromEnum (minBound @a) + hi = fromEnum (maxBound @a) + size = Finite $ 1 + toInteger hi - toInteger lo + +-- | 'nat' is an inverse of forward enumeration 'E.nat'. +-- +-- For a negative integer @x@ which 'E.nat' doesn't enumerate, +-- @locate nat x@ returns the same index to the absolute value of @x@, +-- i.e. @locate nat x == locate nat (abs x)@. +-- +-- >>> locate nat <$> [-3 .. 3] +-- [3,2,1,0,1,2,3] +nat :: CoEnumeration Integer +nat = CoEnumeration{ card = Infinite, locate = abs } + +-- | 'int' is the inverse of forward enumeration 'E.int', which is +-- all integers ordered as the sequence @0, 1, -1, 2, -2, ...@ +-- +-- >>> locate int <$> [1, 2, 3, 4, 5] +-- [1,3,5,7,9] +-- >>> locate int <$> [0, -1 .. -5] +-- [0,2,4,6,8,10] +int :: CoEnumeration Integer +int = CoEnumeration{ card = Infinite, locate = integerToNat } + where + integerToNat :: Integer -> Integer + integerToNat n + | n <= 0 = 2 * negate n + | otherwise = 2 * n - 1 + +-- | 'cw' is an inverse of forward enumeration 'E.cw'. +-- +-- Because 'E.cw' only enumerates positive 'Rational' values, +-- @locate cw x@ for zero or less rational number @x@ could be arbitrary. +-- +-- This implementation chose @locate cw x = 33448095@ for all @x <= 0@, which is +-- the index of @765 % 4321@, rather than returning @undefined@. +-- +-- >>> locate cw <$> [1 % 1, 1 % 2, 2 % 1, 1 % 3, 3 % 2] +-- [0,1,2,3,4] +-- >>> locate cw (765 % 4321) +-- 33448095 +-- >>> locate cw 0 +-- 33448095 +cw :: CoEnumeration Rational +cw = CoEnumeration{ card = Infinite, locate = locateCW } + where + locateCW x = case numerator x of + n | n > 0 -> go n (denominator x) [] - 1 + | otherwise -> 33448095 {- Magic number, see the haddock above -} + + go 1 1 acc = foldl' (\i b -> 2 * i + b) 1 acc + go a b acc + | a > b = go (a - b) b (1 : acc) + | a < b = go a (b - a) (0 : acc) + | otherwise = error "cw: locateCW: Never reach here!" + +-- | 'rat' is the inverse of forward enumeration 'E.rat'. +-- +-- >>> let xs = E.enumerate . E.takeE 6 $ E.rat +-- >>> (xs, locate rat <$> xs) +-- ([0 % 1,1 % 1,(-1) % 1,1 % 2,(-1) % 2,2 % 1],[0,1,2,3,4,5]) +-- >>> locate rat (E.select E.rat 1000) +-- 1000 +rat :: CoEnumeration Rational +rat = contramap caseBySign $ maybeOf (cw <+> cw) + where + caseBySign :: Rational -> Maybe (Either Rational Rational) + caseBySign x = case compare x 0 of + LT -> Just (Right (negate x)) + EQ -> Nothing + GT -> Just (Left x) + +-- | Sets the cardinality of given coenumeration to 'Infinite' +infinite :: CoEnumeration a -> CoEnumeration a +infinite e = e{ card = Infinite } + +-- | Cartesian product of coenumeration, made to be an inverse of +-- cartesian product of enumeration '(E.><)'. +-- +-- >>> let a = E.finite 3 E.>< (E.boundedEnum @Bool) +-- >>> let a' = modulo 3 >< boundedEnum @Bool +-- >>> (E.enumerate a, locate a' <$> E.enumerate a) +-- ([(0,False),(0,True),(1,False),(1,True),(2,False),(2,True)],[0,1,2,3,4,5]) +-- +-- This operation is not associative if and only if one of arguments +-- is not finite. +(><) :: CoEnumeration a -> CoEnumeration b -> CoEnumeration (a,b) +e1 >< e2 = CoEnumeration{ card = n1 * n2, locate = locatePair } + where + n1 = card e1 + n2 = card e2 + locatePair = case (n1, n2) of + (_, Finite n2') -> \(a,b) -> locate e1 a * n2' + locate e2 b + (Finite n1', Infinite) -> \(a,b) -> locate e1 a + locate e2 b * n1' + (Infinite, Infinite) -> \(a,b) -> undiagonal (locate e1 a, locate e2 b) + +-- | Sum, or disjoint union, of two coenumerations. +-- +-- It corresponds to disjoint union of enumerations 'E.eitherOf'. +-- +-- Its type can't be @CoEnumeration a -> CoEnumeration a -> CoEnumeration a@, +-- like 'Data.Enumeration.Enumeration' which is covariant functor, +-- because @CoEnumeration@ is 'Contravariant' functor. +-- +-- >>> let a = E.finite 3 `E.eitherOf` (E.boundedEnum @Bool) +-- >>> let a' = modulo 3 <+> boundedEnum @Bool +-- >>> (E.enumerate a, locate a' <$> E.enumerate a) +-- ([Left 0,Left 1,Left 2,Right False,Right True],[0,1,2,3,4]) +-- +-- This operation is not associative if and only if one of arguments +-- is not finite. +(<+>) :: CoEnumeration a -> CoEnumeration b -> CoEnumeration (Either a b) +e1 <+> e2 = CoEnumeration{ card = n1 + n2, locate = locateEither } + where + n1 = card e1 + n2 = card e2 + locateEither = case (n1, n2) of + (Finite n1', _) -> either (locate e1) ((n1' +) . locate e2) + (Infinite, Finite n2') -> either ((n2' +) . locate e1) (locate e2) + (Infinite, Infinite) -> either ((*2) . locate e1) (succ . (*2) . locate e2) + +-- | +-- +-- >>> locate (dropC 3 nat) <$> [0..5] +-- [0,0,0,0,1,2] +dropC :: Integer -> CoEnumeration a -> CoEnumeration a +dropC k e + | k == 0 = e + | card e == 0 = e + | card e <= Finite k = error "Impossible empty coenumeration" + | otherwise = CoEnumeration{ card = size, locate = loc } + where + size = card e - Finite k + loc = max 0 . subtract k . locate e + +-- | +-- >>> locate (takeC 3 nat) <$> [0..5] +-- [0,1,2,2,2,2] +takeC :: Integer -> CoEnumeration a -> CoEnumeration a +takeC k + | k <= 0 = checkEmpty + | otherwise = aux + where + aux e = + let size = min (Finite k) (card e) + loc = min (k-1) . locate e + in CoEnumeration{ card = size, locate = loc } + +checkEmpty :: CoEnumeration a -> CoEnumeration a +checkEmpty e + | card e == 0 = e + | otherwise = error "Impossible empty coenumeration" + +-- | +-- >>> locate (modulo 3) <$> [0..7] +-- [0,1,2,0,1,2,0,1] +-- >>> locate (modulo 3) (-4) +-- 2 +modulo :: Integer -> CoEnumeration Integer +modulo n + | n <= 0 = error $ "modulo: invalid argument " ++ show n + | otherwise = CoEnumeration{ card = Finite n, locate = (`mod` n) } + +-- | @overlayC a b@ combines two coenumerations in parallel, sharing +-- indices of two coenumerations. +-- +-- The resulting coenumeration has cardinality of the larger of the +-- two arguments. +overlayC :: CoEnumeration a -> CoEnumeration b -> CoEnumeration (Either a b) +overlayC e1 e2 = CoEnumeration{ + card = max (card e1) (card e2) + , locate = either (locate e1) (locate e2) + } + +-- | The inverse of forward 'E.maybeOf' +maybeOf :: CoEnumeration a -> CoEnumeration (Maybe a) +maybeOf e = contramap (maybe (Left ()) Right) $ unit <+> e + +-- | Synonym of '(<+>)' +eitherOf :: CoEnumeration a -> CoEnumeration b -> CoEnumeration (Either a b) +eitherOf = (<+>) + +-- | Coenumerate all possible finite lists using given coenumeration. +-- +-- If a coenumeration @a@ is the inverse of enumeration @b@, +-- 'listOf' @a@ is the inverse of forward enumeration 'E.listOf' @b@. +-- +-- >>> E.enumerate . E.takeE 6 $ E.listOf E.nat +-- [[],[0],[0,0],[1],[0,0,0],[1,0]] +-- >>> locate (listOf nat) <$> [[],[0],[0,0],[1],[0,0,0],[1,0]] +-- [0,1,2,3,4,5] +-- >>> E.select (E.listOf E.nat) 1000000 +-- [1008,26,0] +-- >>> locate (listOf nat) [1008,26,0] +-- 1000000 +listOf :: CoEnumeration a -> CoEnumeration [a] +listOf e = CoEnumeration{ card = size, locate = locateList } + where + n = card e + size | n == 0 = 1 + | otherwise = Infinite + locateList = unList n . fmap (locate e) + +unList :: Cardinality -> [Index] -> Index +unList (Finite k) = foldl' (\n a -> 1 + (a + n * k)) 0 . reverse +unList Infinite = foldl' (\n a -> 1 + undiagonal (a, n)) 0 . reverse + +-- | An inverse of 'E.finiteSubsetOf'. +-- +-- Given a coenumeration of @a@, make a coenumeration of finite sets of +-- @a@, by ignoring order and repetition from @[a]@. +-- +-- >>> as = take 11 . E.enumerate $ E.finiteSubsetOf E.nat +-- >>> (as, locate (finiteSubsetOf nat) <$> as) +-- ([[],[0],[1],[0,1],[2],[0,2],[1,2],[0,1,2],[3],[0,3],[1,3]],[0,1,2,3,4,5,6,7,8,9,10]) +finiteSubsetOf :: CoEnumeration a -> CoEnumeration [a] +finiteSubsetOf e = CoEnumeration{ card = size, locate = unSet . fmap (locate e) } + where + size = case card e of + Finite k -> Finite (2 ^ k) + Infinite -> Infinite + +unSet :: [Index] -> Index +unSet = foldl' (\n i -> n .|. bit (fromInteger i)) 0 + +-- | An inverse of 'E.finiteEnumerationOf'. +-- +-- Given a coenumeration of @a@, make a coenumeration of function from +-- finite sets to @a@. +-- +-- Ideally, its type should be the following dependent type +-- +-- > {n :: Integer} -> CoEnumeration a -> CoEnumeration ({k :: Integer | k < n} -> a) +-- +-- >>> let as = E.finiteEnumerationOf 3 (E.takeE 2 E.nat) +-- >>> map E.enumerate $ E.enumerate as +-- [[0,0,0],[0,0,1],[0,1,0],[0,1,1],[1,0,0],[1,0,1],[1,1,0],[1,1,1]] +-- >>> let inv_as = finiteFunctionOf 3 (takeC 2 nat) +-- >>> locate inv_as (E.select (E.finiteList [0,1,1])) +-- 3 +finiteFunctionOf :: Integer -> CoEnumeration a -> CoEnumeration (Integer -> a) +finiteFunctionOf 0 _ = unit +finiteFunctionOf n a = CoEnumeration{ card = size, locate = locateEnum } + where + size = case card a of + Finite k -> Finite (k^n) + Infinite -> Infinite + + step = case card a of + Finite k -> \r d -> k * r + d + Infinite -> curry undiagonal + + locateEnum f = + let go i !acc + | i == n = acc + | otherwise = go (i+1) (step acc (locate a (f i))) + in go 0 0 diff --git a/src/Data/Enumeration.hs b/src/Data/Enumeration.hs --- a/src/Data/Enumeration.hs +++ b/src/Data/Enumeration.hs @@ -667,9 +667,11 @@ -- -- >>> 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]] +-- >>> enumerate $ listOf empty :: [[Data.Void.Void]] +-- [[]] listOf :: Enumeration a -> Enumeration [a] listOf a = case card a of - Finite 0 -> empty + Finite 0 -> singleton [] _ -> listOfA where listOfA = infinite $ singleton [] <|> (:) <$> a <*> listOfA @@ -731,6 +733,22 @@ -- Implementation of `integerSqrt` taken from the Haskell wiki: -- https://wiki.haskell.org/Generic_number_type#squareRoot + +-- | Find the square root (rounded down) of a positive integer. +-- +-- >>> integerSqrt 0 +-- 0 +-- >>> integerSqrt 1 +-- 1 +-- >>> integerSqrt 3 +-- 1 +-- >>> integerSqrt 4 +-- 2 +-- >>> integerSqrt 38 +-- 6 +-- >>> integerSqrt 763686362402795580983595318628819602756 +-- 27634875834763498734 + integerSqrt :: Integer -> Integer integerSqrt 0 = 0 integerSqrt 1 = 1 @@ -739,9 +757,14 @@ (lowerRoot, lowerN) = last $ takeWhile ((n>=) . snd) $ zip (1:twopows) twopows newtonStep x = div (x + div n x) 2 - iters = iterate newtonStep (integerSqrt (div n lowerN ) * lowerRoot) isRoot r = r^!2 <= n && n < (r+1)^!2 - in head $ dropWhile (not . isRoot) iters + initGuess = integerSqrt (div n lowerN ) * lowerRoot + in iterUntil isRoot newtonStep initGuess + +iterUntil :: (a -> Bool) -> (a -> a) -> a -> a +iterUntil p f a + | p a = a + | otherwise = iterUntil p f (f a) (^!) :: Num a => a -> Int -> a (^!) x n = x^n diff --git a/src/Data/Enumeration/Invertible.hs b/src/Data/Enumeration/Invertible.hs --- a/src/Data/Enumeration/Invertible.hs +++ b/src/Data/Enumeration/Invertible.hs @@ -94,6 +94,7 @@ -- $setup -- >>> :set -XTypeApplications -- >>> import Control.Arrow ((&&&)) +-- >>> import Data.Maybe (fromMaybe, listToMaybe) -- >>> :{ -- data Tree = L | B Tree Tree deriving Show -- treesUpTo :: Int -> IEnumeration Tree @@ -469,7 +470,8 @@ -- >>> enumerate $ zipE nat (boundedEnum @Bool) -- [(0,False),(1,True)] -- --- >>> cs = mapE (uncurry replicate) (length &&& head) (zipE (finiteList [1..10]) (dropE 35 (boundedEnum @Char))) +-- >>> headD x = fromMaybe x . listToMaybe +-- >>> cs = mapE (uncurry replicate) (length &&& headD ' ') (zipE (finiteList [1..10]) (dropE 35 (boundedEnum @Char))) -- >>> enumerate cs -- ["#","$$","%%%","&&&&","'''''","((((((",")))))))","********","+++++++++",",,,,,,,,,,"] -- >>> locate cs "********" diff --git a/src/Data/ProEnumeration.hs b/src/Data/ProEnumeration.hs new file mode 100644 --- /dev/null +++ b/src/Data/ProEnumeration.hs @@ -0,0 +1,496 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- SPDX-License-Identifier: BSD-3-Clause + +----------------------------------------------------------------------------- +-- | +-- Module : Data.ProEnumeration +-- Copyright : Brent Yorgey, Koji Miyazato +-- Maintainer : byorgey@gmail.com +-- +-- A /proenumeration/ is a pair of a 'CoEnumeration' and an 'Enumeration' +-- sharing the same cardinality. +-- +-- A /proenumeration/ can be seen as a function with an explicitly enumerated +-- range. +-- +-- Through documentations of this module, these import aliases are used: +-- +-- > import qualified Data.Enumeration as E +-- > import qualified Data.CoEnumeration as C + +----------------------------------------------------------------------------- + +module Data.ProEnumeration( + -- * Proenumeration type + ProEnumeration() + , card, select, locate + + , isFinite + , baseEnum, baseCoEnum, run + , enumerateRange + + , unsafeMkProEnumeration + , mkProEnumeration + + -- * ProEnumeration is a Profunctor + , dimap, (.@), (@.) + + -- * Using Cardinality + , Cardinality(..), Index + + -- * Primitive proenumerations + , unit, empty + , singleton + , modulo, clamped, boundsChecked + , finiteList, finiteCycle + , boundedEnum + , nat, int, cw, rat + + -- * Combinators + , infinite + , compose + , (><), (<+>) + , maybeOf, eitherOf + , listOf, finiteSubsetOf + + , enumerateP, coenumerateP + , proenumerationOf + , finiteFunctionOf +) where + +import qualified Control.Applicative as Ap (Alternative (empty)) +import Data.Void + +import Data.Functor.Contravariant + +import Data.CoEnumeration (CoEnumeration) +import qualified Data.CoEnumeration as C +import Data.Enumeration (Cardinality (..), Enumeration, + Index) +import qualified Data.Enumeration as E + +-- | A /proenumeration/ is a pair of a 'CoEnumeration' and an 'Enumeration' +-- sharing the same cardinality. +-- Alternatively, a /proenumeration/ can be seen as a function with an +-- explicitly enumerated range. +-- +-- Through this documentation, +-- proenumerations are shown in diagrams of the following shape: +-- +-- > f g +-- > a ---> N ---> b :: ProEnumeration a b +-- +-- Which means it is a value @p :: ProEnumeration a b@ with +-- cardinality @N@, @locate p = f@, and @select p = g@. +-- +-- We can see @N@ in the diagram as a subset of integers: +-- +-- > N = {i :: Integer | i < N} +-- +-- Then it is actually a (category-theoretic) +-- diagram showing values of @ProEnumeration a b@. +data ProEnumeration a b = + ProEnumeration { + -- | Get the cardinality of a proenumeration + card :: Cardinality + + -- | See @E.'E.select'@ + , select :: Index -> b + + -- | See @C.'C.locate'@ + , locate :: a -> Index + } + deriving (Functor) + +-- | Returns if the the cardinality of a proenumeration is finite. +isFinite :: ProEnumeration a b -> Bool +isFinite = (/= Infinite) . card + +-- | ProEnumeration is a Profunctor +-- +-- > dimap l r p = l .@ p @. r +dimap :: (a' -> a) -> (b -> b') -> ProEnumeration a b -> ProEnumeration a' b' +dimap l r p = p{ select = r . select p, locate = locate p . l } + +-- | > p @. r = dimap id r p +(@.) :: ProEnumeration a b -> (b -> b') -> ProEnumeration a b' +(@.) = flip fmap + +infixl 7 @. + +-- | > l .@ p = dimap l id p +(.@) :: (a' -> a) -> ProEnumeration a b -> ProEnumeration a' b +l .@ p = p{ locate = locate p . l } + +infixr 8 .@ + +-- | Take an 'Enumeration' from a proenumeration, +-- discarding the @CoEnumeration@ part +baseEnum :: ProEnumeration a b -> Enumeration b +baseEnum p = E.mkEnumeration (card p) (select p) + +-- | Take an 'CoEnumeration' from a proenumeration, +-- discarding @Enumeration@ part +baseCoEnum :: ProEnumeration a b -> CoEnumeration a +baseCoEnum p = C.unsafeMkCoEnumeration (card p) (locate p) + +-- | Turn a proenumeration into a normal function. +-- +-- > run p = (select p :: Index -> b) . (locate p :: a -> Index) +run :: ProEnumeration a b -> a -> b +run p = select p . locate p + +-- * Primitive proenumerations + +-- | @enumerateRange = E.enumerate . 'baseEnum'@ +enumerateRange :: ProEnumeration a b -> [b] +enumerateRange = E.enumerate . baseEnum + +-- | Constructs a proenumeration from a 'CoEnumeration' and an 'Enumeration'. +-- +-- The cardinalities of the two arguments must be equal. +-- Otherwise, 'mkProEnumeration' returns an error. +-- +-- > baseEnum (mkProEnumeration a b) = b +-- > baseCoEnum (mkProEnumeration a b) = a +-- +-- >>> p = mkProEnumeration (C.modulo 3) (E.finiteList "abc") +-- >>> (card p, locate p 4, select p 1) +-- (Finite 3,1,'b') +mkProEnumeration :: CoEnumeration a -> Enumeration b -> ProEnumeration a b +mkProEnumeration a b + | na == nb = p + | otherwise = error $ "mkProEnumeration cardinality mismatch:" ++ show (na, nb) + where + na = C.card a + nb = E.card b + p = ProEnumeration{ card = na, select = E.select b, locate = C.locate a } + +-- | Constructs a proenumeration. +-- +-- To construct a valid proenumeration by @unsafeMkProEnumeration n f g@, +-- it must satisfy the following conditions: +-- +-- * For all @i :: Integer@, if @0 <= i && i < n@, then @f i@ should be +-- \"valid\" (usually, it means @f i@ should evaluate without exception). +-- * For all @x :: a@, @(Finite (g x) < n)@. +-- +-- This functions does not (and never could) check the validity +-- of its arguments. +unsafeMkProEnumeration + :: Cardinality-> (Index -> b) -> (a -> Index) -> ProEnumeration a b +unsafeMkProEnumeration = ProEnumeration + +-- | @unit = 'mkProEnumeration' C.'C.unit' E.'E.unit'@ +unit :: ProEnumeration a () +unit = mkProEnumeration C.unit E.unit + +-- | @singleton b = b <$ 'unit' = 'mkProEnumeration' C.'C.unit' (E.'E.singleton' b)@ +singleton :: b -> ProEnumeration a b +singleton b = mkProEnumeration C.unit (E.singleton b) + +-- | @empty = 'mkProEnumeration' 'lost' 'Ap.empty'@ +empty :: ProEnumeration Void b +empty = mkProEnumeration C.lost Ap.empty + +-- | @boundedEnum = 'mkProEnumeration' C.'C.boundedEnum' E.'E.boundedEnum'@ +boundedEnum :: (Enum a, Bounded a) => ProEnumeration a a +boundedEnum = mkProEnumeration C.boundedEnum E.boundedEnum + +-- | @modulo k = 'mkProEnumeration' (C.'C.modulo' k) (E.'E.finite' k)@ +-- +-- >>> card (modulo 13) == Finite 13 +-- True +-- >>> run (modulo 13) 1462325 == 1462325 `mod` 13 +-- True +modulo :: Integer -> ProEnumeration Integer Integer +modulo k = mkProEnumeration (C.modulo k) (E.finite k) + +-- | @clamped lo hi@ is a proenumeration of integers, +-- which does not modify integers between @lo@ and @hi@, inclusive, +-- and limits smaller (larger) integer to @lo@ (@hi@). +-- +-- It is an error to call this function if @lo > hi@. +-- +-- > run (clamped lo hi) = min hi . max lo +-- +-- >>> card (clamped (-2) 2) +-- Finite 5 +-- >>> enumerateRange (clamped (-2) 2) +-- [-2,-1,0,1,2] +-- >>> run (clamped (-2) 2) <$> [-4 .. 4] +-- [-2,-2,-2,-1,0,1,2,2,2] +clamped :: Integer -> Integer -> ProEnumeration Integer Integer +clamped lo hi + | lo <= hi = ProEnumeration + { card = Finite (1 + hi - lo) + , select = (+ lo) + , locate = \i -> min (hi - lo) (max 0 (i - lo)) + } + | otherwise = error "Empty range" + +-- | @boundsChecked lo hi@ is a proenumeration of a \"bounds check\" function, +-- which validates that an input is between @lo@ and @hi@, inclusive, +-- and returns @Nothing@ if it is outside those bounds. +-- +-- > run (boundsChecked lo hi) i +-- | lo <= i && i <= hi = Just i +-- | otherwise = Nothing +-- +-- >>> card (boundsChecked (-2) 2) +-- Finite 6 +-- >>> -- Justs of [-2 .. 2] and Nothing +-- >>> enumerateRange (boundsChecked (-2) 2) +-- [Just (-2),Just (-1),Just 0,Just 1,Just 2,Nothing] +-- >>> run (boundsChecked (-2) 2) <$> [-4 .. 4] +-- [Nothing,Nothing,Just (-2),Just (-1),Just 0,Just 1,Just 2,Nothing,Nothing] +boundsChecked :: Integer -> Integer -> ProEnumeration Integer (Maybe Integer) +boundsChecked lo hi = ProEnumeration + { card = Finite size + , select = sel + , locate = loc + } + where + n = 1 + hi - lo + size = 1 + max 0 n + sel i + | 0 <= i && i < n = Just (i + lo) + | i == n = Nothing + | otherwise = error "out of bounds" + loc k | lo <= k && k <= hi = k - lo + | otherwise = n + + +-- | @finiteList as@ is a proenumeration of a \"bounds checked\" +-- indexing of @as@. +-- +-- > run (finiteList as) i +-- | 0 <= i && i < length as = Just (as !! i) +-- | otherwise = Nothing +-- +-- Note that 'finiteList' uses '!!' on the input list +-- under the hood, which has bad performance for long lists. +-- See also the documentation of Data.Enumeration.'E.finiteList'. +-- >>> card (finiteList "HELLO") +-- Finite 6 +-- >>> -- Justs and Nothing +-- >>> enumerateRange (finiteList "HELLO") +-- [Just 'H',Just 'E',Just 'L',Just 'L',Just 'O',Nothing] +-- >>> run (finiteList "HELLO") <$> [0 .. 6] +-- [Just 'H',Just 'E',Just 'L',Just 'L',Just 'O',Nothing,Nothing] +finiteList :: [a] -> ProEnumeration Integer (Maybe a) +finiteList as = boundsChecked 0 (n-1) @. (fmap sel) + where + as' = E.finiteList as + Finite n = E.card as' + sel = E.select as' + +-- | @finiteCycle as@ is a proenumeration of an indexing of @as@, +-- where every integer is a valid index by taking it modulo @length as@. +-- +-- > run (finiteCycle as) i = as !! (i `mod` length as) +-- +-- If @as@ is an empty list, it is an error. +-- +-- >>> card (finiteCycle "HELLO") +-- Finite 5 +-- >>> enumerateRange (finiteCycle "HELLO") +-- "HELLO" +-- >>> run (finiteCycle "HELLO") <$> [0 .. 10] +-- "HELLOHELLOH" +finiteCycle :: [a] -> ProEnumeration Integer a +finiteCycle as = modulo n @. sel + where + as' = E.finiteList as + Finite n = E.card as' + sel = E.select as' + +-- | @nat = 'mkProEnumeration' C.'C.nat' E.'E.nat'@ +nat :: ProEnumeration Integer Integer +nat = mkProEnumeration C.nat E.nat + +-- | @int = 'mkProEnumeration' C.'C.int' E.'E.int'@ +int :: ProEnumeration Integer Integer +int = mkProEnumeration C.int E.int + +-- | @cw = 'mkProEnumeration' C.'C.cw' E.'E.cw'@ +cw :: ProEnumeration Rational Rational +cw = mkProEnumeration C.cw E.cw + +-- | @rat = 'mkProEnumeration' C.'C.rat' E.'E.rat'@ +rat :: ProEnumeration Rational Rational +rat = mkProEnumeration C.rat E.rat + +-- | Sets the cardinality of given proenumeration to 'Infinite' +infinite :: ProEnumeration a b -> ProEnumeration a b +infinite p = p{ card = Infinite } + +-- * Proenumeration combinators + +-- | From two proenumerations @p, q@, we can make a proenumeration +-- @compose p q@ which behaves as a composed function +-- (in diagrammatic order like 'Control.Category.>>>'.) +-- +-- > run (compose p q) = run q . run p +-- +-- @p@ and @q@ can be drawn in a diagram as follows: +-- +-- > [_______p______] [______q______] +-- > +-- > lp sp lq sq +-- > a ----> N ----> b ----> M ----> c +-- +-- To get a proenumeration @a -> ?? -> c@, there are two obvious choices: +-- +-- > run p >>> lq sq +-- > a --------------------> M ----> c +-- > lp sp >>> run q +-- > a ----> N --------------------> c +-- +-- This function chooses the option with the smaller cardinality. +compose :: ProEnumeration a b -> ProEnumeration b c -> ProEnumeration a c +compose p q + | card p <= card q = p @. run q + | otherwise = run p .@ q + +-- | Cartesian product of proenumerations. +-- +-- @ +-- p >< q = 'mkProEnumeration' (baseCoEnum p C.'C.><' baseCoEnum q) +-- (baseEnum p E.'E.><' baseEnum q) +-- @ +-- +-- This operation is not associative if and only if one of the arguments +-- is not finite. +(><) :: ProEnumeration a1 b1 -> ProEnumeration a2 b2 -> ProEnumeration (a1,a2) (b1,b2) +p >< q = mkProEnumeration (baseCoEnum p C.>< baseCoEnum q) (baseEnum p E.>< baseEnum q) + +-- | Disjoint sum of proenumerations. +-- +-- @ +-- p <+> q = 'mkProEnumeration' +-- (baseCoEnum p C.'C.<+>' baseCoEnum q) +-- (baseEnum p `E.'E.eitherOf'` baseEnum q) +-- @ +-- This operation is not associative if and only if one of the arguments +-- is not finite. +(<+>) :: ProEnumeration a1 b1 -> ProEnumeration a2 b2 + -> ProEnumeration (Either a1 a2) (Either b1 b2) +p <+> q = mkProEnumeration (baseCoEnum p C.<+> baseCoEnum q) (E.eitherOf (baseEnum p) (baseEnum q)) + +-- | @maybeOf p = 'mkProEnumeration' (C.'C.maybeOf' (baseCoEnum p)) (E.'E.maybeOf' (baseEnum p))@ +maybeOf :: ProEnumeration a b -> ProEnumeration (Maybe a) (Maybe b) +maybeOf p = dimap (maybe (Left ()) Right) (either (const Nothing) Just) $ + unit <+> p + +-- | Synonym of '(<+>)' +eitherOf :: ProEnumeration a1 b1 -> ProEnumeration a2 b2 + -> ProEnumeration (Either a1 a2) (Either b1 b2) +eitherOf = (<+>) + +-- | @listOf p = 'mkProEnumeration' (C.'C.listOf' (baseCoEnum p)) (E.'E.listOf' (baseEnum p))@ +listOf :: ProEnumeration a b -> ProEnumeration [a] [b] +listOf p = mkProEnumeration (C.listOf (baseCoEnum p)) (E.listOf (baseEnum p)) + +-- | +-- @ +-- finiteSubsetOf p = 'mkProEnumeration' +-- (C.'C.finiteSubsetOf' (baseCoEnum p)) +-- (E.'E.finiteSubsetOf' (baseEnum p)) +-- @ +finiteSubsetOf :: ProEnumeration a b -> ProEnumeration [a] [b] +finiteSubsetOf p = + mkProEnumeration (C.finiteSubsetOf (baseCoEnum p)) (E.finiteSubsetOf (baseEnum p)) + +-- | Enumerate every possible proenumeration. +-- +-- @enumerateP a b@ generates proenumerations @p@ +-- such that the function @run p@ has the following properties: +-- +-- * The range of @run p@ is a subset of @b :: Enumeration b@. +-- * If @locate a x = locate a y@, then @run p x = run p y@. +-- In other words, @run p@ factors through @locate a@. +-- +-- This function generates proenumerations @p@ in such a way that +-- every function of type @a -> b@ with the above properties uniquely +-- appears as @run p@ for some enumerated @p@. +enumerateP :: CoEnumeration a -> Enumeration b -> Enumeration (ProEnumeration a b) +enumerateP a b = case (C.card a, E.card b) of + (0, _) -> E.singleton (mkProEnumeration a Ap.empty) + (_, 1) -> E.singleton (mkProEnumeration C.unit b) + (Finite k,_) -> mkProEnumeration a <$> E.finiteEnumerationOf (fromInteger k) b + (Infinite,_) -> error "infinite domain" + +-- | Coenumerate every possible function. +-- +-- @coenumerateP as bs@ classifies functions of type @a -> b@ +-- by the following criterion: +-- +-- @f@ and @g@ have the same index +-- +-- /if and only if/ +-- +-- For all elements @a@ of @as :: Enumeration a@, +-- @locate bs (f a) = locate bs (g a)@. +-- +-- /Note/: The suffix @P@ suggests it coenumerates @ProEnumeration a b@, +-- but it actually coenumerates @a -> b@. The reason is that +-- @ProEnumeration a b@ carries extra data and constraints like its cardinality, +-- but the classification does not care about those. Thus, it is more permissive to +-- accept any function of type @a -> b@. +-- +-- To force it to coenumerate proenumerations, +-- @'contramap' 'run'@ can be applied. +coenumerateP :: Enumeration a -> CoEnumeration b -> CoEnumeration (a -> b) +coenumerateP a b = case (E.card a, C.card b) of + (0, _) -> C.unit + (_, 1) -> C.unit + (Finite k,_) -> contramap (\f -> f . E.select a) $ C.finiteFunctionOf k b + (Infinite,_) -> error "infinite domain" + +{- | 'enumerateP' and 'coenumerateP' combined. + +> l_a s_a +> a -----> N -----> a' :: ProEnumeration a a' +> +> l_b s_b +> b -----> M -----> b' :: ProEnumeration b b' +> +> +> (N -> b) ---> (N -> M) ---> (N -> b') +> ^ || | +> | (. s_a) || | (. l_a) +> | || v +> (a' -> b) (M ^ N) (a -> b') + +* When @N@ is finite, @(M ^ N)@ is at most countable, since @M@ is + at most countable. + +* The enumerated functions (of type @a -> b'@) are compositions + of @l_a :: a -> N@ and functions of type @N -> b@. + It is beneficial to tell this fact by the type, + which happens to be @ProEnumeration a b'@. + +-} +proenumerationOf + :: ProEnumeration a a' + -> ProEnumeration b b' + -> ProEnumeration (a' -> b) (ProEnumeration a b') +proenumerationOf a b + = mkProEnumeration + (coenumerateP (baseEnum a) (baseCoEnum b)) + (enumerateP (baseCoEnum a) (baseEnum b)) + +-- | @finiteFunctionOf k p@ is a proenumeration of products of @k@ copies of +-- @a@ and @b@ respectively. +-- +-- If @p@ is a invertible enumeration, @finiteFunctionOf k p@ is too. +-- +-- It is implemented using 'proenumerationOf'. +finiteFunctionOf + :: Integer -> ProEnumeration a b -> ProEnumeration (Integer -> a) (Integer -> b) +finiteFunctionOf k p = proenumerationOf (modulo k) p @. select diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -1,2 +1,10 @@ import Test.DocTest -main = doctest ["-isrc", "src/Data/Enumeration.hs", "src/Data/Enumeration/Invertible.hs"] +main = doctest + ["-isrc" + ,"src/Data/Enumeration.hs" + ,"src/Data/Enumeration/Invertible.hs" + ,"src/Data/CoEnumeration.hs" + ,"src/Data/ProEnumeration.hs" + ,"--fast" + ,"-package contravariant" + ]