cantor-pairing 0.1.1.0 → 0.2.0.0
raw patch · 5 files changed
+493/−268 lines, 5 filesdep ~arithmoidep ~basedep ~containersPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: arithmoi, base, containers, integer-gmp, integer-logarithms
API changes (from Hackage documentation)
- Cantor: Finite :: Integer -> Cardinality
- Cantor: instance GHC.Base.Semigroup (Cantor.ES a)
+ Cantor: pattern Finite :: Integer -> Cardinality
- Cantor: fCardinality :: Finite a => Integer
+ Cantor: fCardinality :: forall a. Finite a => Integer
Files
- CHANGELOG.md +5/−1
- cantor-pairing.cabal +7/−7
- src/Cantor.hs +212/−251
- src/Cantor/Huge.hs +259/−0
- test/Spec.hs +10/−9
CHANGELOG.md view
@@ -1,7 +1,11 @@ # Revision history for cantor-pairing +## 0.2.0.0++- `cantorEnumeration` is now productive in more cases due to better handling of large numbers internally (thanks Bodigrim!)+ ## 0.1.1.0 -- Instances for `Int`, `Word`, `IntSet`, and `Set+- Instances for `Int`, `Word`, `IntSet`, and `Set` - Basic recursion is now detected generically, so there is now no need to manually specify that the cardinality is `Countable`
cantor-pairing.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: cantor-pairing-version: 0.1.1.0+version: 0.2.0.0 synopsis: Convert data to and from a natural number representation description: Convert data to and from a natural number representation conveniently using GHC Generics. homepage: https://github.com/identicalsnowflake/cantor-pairing@@ -20,13 +20,13 @@ library exposed-modules: Cantor- -- other-modules:- -- other-extensions:- build-depends: arithmoi ^>= 0.8.0.0- , base ^>=4.12.0.0- , containers ^>= 0.6.0.1+ other-modules:+ Cantor.Huge+ build-depends: arithmoi >= 0.8.0.0 && < 0.11+ , base >= 4.12.0.0 && < 5+ , containers >= 0.6.0.1 && < 0.7 , integer-gmp ^>= 1.0.2.0- , integer-logarithms ^>= 1.0.2.2+ , integer-logarithms >= 1.0.2.2 && < 2.0 hs-source-dirs: src ghc-options: -Wall -Wextra default-language: Haskell2010
src/Cantor.hs view
@@ -6,14 +6,16 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ViewPatterns #-} -- | Cantor pairing gives us an isomorphism between a single natural number and pairs of natural numbers. This package provides a modern API to this functionality using GHC generics, allowing the encoding of arbitrary combinations of finite or countably infinite types in natural number form.--- +-- -- As a user, all you need to do is derive generic and get the instances for free. -- -- = Example@@ -28,18 +30,21 @@ -- -- instance Cantor MyType -- @--- This should work nicely even with simple inductive types: -- -- = Recursive example+--+-- This should work nicely even with simple inductive types:+-- -- @ -- data Tree a = Leaf | Branch (Tree a) a (Tree a) deriving (Generic) -- -- instance Cantor a => Cantor (Tree a) -- @ ----- If your type is finite, you can specify this by deriving the @Finite@ typeclass, which is a subclass of @Cantor@:--- -- = Finite example+--+-- If your type is finite, you can specify this by deriving the @Finite@ typeclass, which is a subclass of @Cantor@:+-- -- @ -- data Color = Red | Green | Blue deriving (Generic) --@@ -47,12 +52,28 @@ -- instance Finite Color -- @ --+-- +-- = Mutually-recursive types+-- +-- If you have mutually-recursive types, unfortunately you'll need to manually specify the cardinality for now, but you can still get the to/from encodings for free:+-- +-- @+-- data Foo = FooNil | Foo Bool Bar deriving (Generic,Show)+-- data Bar = BarNil | Bar Bool Foo deriving (Generic,Show)+-- +-- instance Cantor Foo where+-- cardinality = Countable+-- instance Cantor Bar+-- @ + module Cantor ( cantorEnumeration- , Cardinality(..)+ , Cardinality(Countable)+ , pattern Finite , Cantor(..)- , Finite(..)+ , Finite+ , fCardinality ) where import GHC.Generics@@ -66,16 +87,16 @@ import Data.Proxy import Math.NumberTheory.Powers.Squares (integerSquareRoot') import Data.Void-import Data.Bits (finiteBitSize) import Data.Bits import Data.Foldable (foldl') import Math.NumberTheory.Logarithms -import qualified Data.Map as M import qualified Data.Sequence import qualified Data.Set import qualified Data.IntSet +import Cantor.Huge+ -- internal value-level representation, currently only used for function enumeration data ESpace a = ESpace { eCardinality :: Cardinality@@ -83,6 +104,7 @@ , eFromCantor :: a -> Integer } +{-# INLINE defaultSpace #-} defaultSpace :: forall a . Cantor a => ESpace a defaultSpace = ESpace { eCardinality = cardinality @a@@ -90,62 +112,92 @@ , eFromCantor = fromCantor } +{-# INLINE enumerateSpace #-} enumerateSpace :: ESpace a -> [ a ] enumerateSpace (ESpace c te _) = case c of- Finite 0 -> []- Finite i -> te <$> [ 0 .. (i - 1) ]+ Finite' 0 -> []+ Finite' i -> te <$> takeWhile (\k -> fromInteger k < i) [0..] Countable -> te <$> [ 0 .. ] -- | Enumerates all values of a type by mapping @toCantor@ over the naturals or finite subset of naturals with the correct cardinality.--- --- If the cardinality of the type is large and finite, (e.g., @IntSet@), you will need to try fixing the amount of items you want instead like @toCantor @IntSet <$> [ 0 .. 10 ]@. This is unfortunately necessary because even though the list is computed lazily in @cantorEnumeration@, its *size* is not, and the size of @IntSet@ is a *very* large number which is not feasible to compute even on a modern system (it has more than 200k terabytes of digits!). Note that if you defer to using even larger types like @Integer@ which have true non-finite cardinality instead of finite approximations like @Int@, you will naturally tend to avoid this problem.+--+-- >>> take 5 cantorEnumeration :: [Data.IntSet.IntSet]+-- [fromList [],fromList [0],fromList [1],fromList [0,1],fromList [2]]+{-# INLINABLE cantorEnumeration #-} cantorEnumeration :: Cantor a => [ a ] cantorEnumeration = enumerateSpace defaultSpace instance forall a b . (Finite a , Cantor b) => Cantor (a -> b) where+ {-# INLINE cardinality #-} cardinality = case (cardinality @a , cardinality @b) of- (Finite 0 , _) -> Finite 1 -- anything to the zero power is one (including zero!)- (Finite c1 , Finite c2) -> Finite (c2 ^ c1)+ (Finite' 0 , _) -> Finite' 1 -- anything to the zero power is one (including zero!)+ (Finite' c1 , Finite' c2) -> Finite' (c2 `pow` c1) _ -> Countable - toCantor i a = m M.! fromCantor a+ toCantor 0 _ = toCantor 0+ toCantor i a = toCantor $ cantorExp (fCardinality @a) (fromCantor a) i where- m :: M.Map Integer b- m = M.fromList $ zip [ 0 .. ] (eToCantor es i)- - es :: ESpace [ b ]- es = nary (fCardinality @a) defaultSpace+ cantorExp :: Integer -> Integer -> Integer -> Integer+ cantorExp 1 _ f = f+ cantorExp t x f = if x < b1+ then cantorExp b1 x $ fst (cantorSplit f)+ else cantorExp b2 (x - b1) $ snd (cantorSplit f)+ where+ (# t' , m' #) = divModInteger t 2+ !b1 = t' + m'+ b2 = t' - fromCantor g = eFromCantor es . fmap ((M.!) m) $ [ 0 .. (fCardinality @a - 1) ]+ fromCantor g = uncantorExp (fCardinality @a) (fromCantor . g . toCantor) where- es :: ESpace [ b ]- es = nary (fCardinality @a) defaultSpace- - m :: M.Map Integer b- m = M.fromList $ (\x -> (fromCantor x , g x)) <$> enumerateSpace (defaultSpace @a)+ uncantorExp :: Integer -> (Integer -> Integer) -> Integer+ uncantorExp 1 f = f 0+ uncantorExp t f = cantorUnsplit (uncantorExp b1 f , uncantorExp b2 (\x -> f (x + b1)))+ where+ (# t' , m' #) = divModInteger t 2+ !b1 = t' + m'+ b2 = t' instance (Finite a , Finite b) => Finite (a -> b) -- | @Cardinality@ can be either @Finite@ or @Countable@. @Countable@ cardinality entails that a type has the same cardinality as the natural numbers. Note that not all infinite types are countable: for example, @Natural -> Natural@ is an infinite type, but it is not countably infinite; the basic intuition is that there is no possible way to enumerate all values of type @Natural -> Natural@ without "skipping" almost all of them. This is in contrast to the naturals, where despite their being infinite, we can trivially (by definition, in fact!) enumerate all of them without skipping any. data Cardinality =- Finite Integer+ Finite' Huge | Countable- deriving (Generic,Eq,Ord,Show)+ deriving (Generic,Eq,Ord) +instance Show Cardinality where+ show Countable = "Countable"+ show (Finite i) = "Finite " <> show i++-- | Finite cardinality.+pattern Finite :: Integer -> Cardinality+pattern Finite n <- Finite' (evalWith (^) -> n)+ where+ Finite n = Finite' (fromInteger n)++{-# COMPLETE Finite, Countable #-}+ -- | The @Finite@ typeclass simply entails that the @Cardinality@ of the set is finite. class Cantor a => Finite a where- fCardinality :: Integer- fCardinality = case cardinality @a of- Finite i -> i+ {-# INLINE fCardinality' #-}+ fCardinality' :: Huge+ fCardinality' = case cardinality @a of+ Finite' i -> i _ -> error "Expected finite cardinality, got Countable." +-- | Cardinality of a finite type.+fCardinality :: forall a. Finite a => Integer+fCardinality = evalWith (^) (fCardinality' @a)+ -- | The @Cantor@ class gives a way to convert a type to and from the natural numbers, as well as specifies the cardinality of the type. class Cantor a where cardinality :: Cardinality- ++ {-# INLINE cardinality #-} default cardinality :: GCantor a (Rep a) => Cardinality cardinality = gCardinality' @a @(Rep a)- ++ {-# INLINABLE toCantor #-} toCantor :: Integer -> a -- ideally this should be `Fin n -> a` (for finite types) -- or `N` (for countably infinite types). -- I chose not to use `Natural` from `GHC.Natural`@@ -154,14 +206,18 @@ default toCantor :: (Generic a , GCantor a (Rep a)) => Integer -> a toCantor = to . gToCantor' @a @(Rep a) + {-# INLINABLE fromCantor #-} fromCantor :: a -> Integer default fromCantor :: (Generic a , GCantor a (Rep a)) => a -> Integer fromCantor = gFromCantor' @a @(Rep a) . from- + instance Cantor Natural where+ {-# INLINE cardinality #-} cardinality = Countable+ {-# INLINE toCantor #-} toCantor = fromInteger+ {-# INLINE fromCantor #-} fromCantor = toInteger data IntAlg = Zero | Neg Natural | Pos Natural deriving (Generic,Show)@@ -180,93 +236,130 @@ fromIntAlg (Pos x) = toInteger x + 1 instance Cantor Integer where+ {-# INLINE cardinality #-} cardinality = Countable- + toCantor = fromIntAlg . toCantor- + fromCantor = fromCantor . toIntAlg +instance Cantor () where instance Finite ()-instance Cantor () instance Cantor Void instance Finite Void instance Finite Bool instance Cantor Bool where- cardinality = Finite 2+ {-# INLINE cardinality #-}+ cardinality = Finite' 2 + {-# INLINE toCantor #-} toCantor 0 = False toCantor _ = True- ++ {-# INLINE fromCantor #-} fromCantor False = 0 fromCantor _ = 1 instance Finite Int8 instance Cantor Int8 where- cardinality = Finite $ 2 ^ (8 :: Integer)+ {-# INLINE cardinality #-}+ cardinality = Finite' $ 2 ^ (8 :: Integer)+ {-# INLINE toCantor #-} toCantor = fromInteger . toCantor @Integer+ {-# INLINE fromCantor #-} fromCantor = fromCantor @Integer . toInteger instance Finite Int16 instance Cantor Int16 where- cardinality = Finite $ 2 ^ (16 :: Integer)+ {-# INLINE cardinality #-}+ cardinality = Finite' $ 2 ^ (16 :: Integer)+ {-# INLINE toCantor #-} toCantor = fromInteger . toCantor @Integer+ {-# INLINE fromCantor #-} fromCantor = fromCantor @Integer . toInteger instance Finite Int32 instance Cantor Int32 where- cardinality = Finite $ 2 ^ (32 :: Integer)+ {-# INLINE cardinality #-}+ cardinality = Finite' $ 2 ^ (32 :: Integer)+ {-# INLINE toCantor #-} toCantor = fromInteger . toCantor @Integer+ {-# INLINE fromCantor #-} fromCantor = fromCantor @Integer . toInteger instance Finite Int64 instance Cantor Int64 where- cardinality = Finite $ 2 ^ (64 :: Integer)+ {-# INLINE cardinality #-}+ cardinality = Finite' $ 2 ^ (64 :: Integer)+ {-# INLINE toCantor #-} toCantor = fromInteger . toCantor @Integer+ {-# INLINE fromCantor #-} fromCantor = fromCantor @Integer . toInteger instance Finite Int instance Cantor Int where- cardinality = Finite $ 2 ^ (finiteBitSize @Int undefined)+ {-# INLINE cardinality #-}+ cardinality = Finite' $ 2 ^ (finiteBitSize @Int undefined)+ {-# INLINE toCantor #-} toCantor = fromInteger . toCantor @Integer+ {-# INLINE fromCantor #-} fromCantor = fromCantor @Integer . toInteger instance Finite Word8 instance Cantor Word8 where- cardinality = Finite $ 2 ^ (8 :: Integer)+ {-# INLINE cardinality #-}+ cardinality = Finite' $ 2 ^ (8 :: Integer)+ {-# INLINE toCantor #-} toCantor = fromIntegral+ {-# INLINE fromCantor #-} fromCantor = fromIntegral instance Finite Word16 instance Cantor Word16 where- cardinality = Finite $ 2 ^ (16 :: Integer)+ {-# INLINE cardinality #-}+ cardinality = Finite' $ 2 ^ (16 :: Integer)+ {-# INLINE toCantor #-} toCantor = fromIntegral+ {-# INLINE fromCantor #-} fromCantor = fromIntegral instance Finite Word32 instance Cantor Word32 where- cardinality = Finite $ 2 ^ (32 :: Integer)+ {-# INLINE cardinality #-}+ cardinality = Finite' $ 2 ^ (32 :: Integer)+ {-# INLINE toCantor #-} toCantor = fromIntegral+ {-# INLINE fromCantor #-} fromCantor = fromIntegral instance Finite Word64 instance Cantor Word64 where- cardinality = Finite $ 2 ^ (64 :: Integer)+ {-# INLINE cardinality #-}+ cardinality = Finite' $ 2 ^ (64 :: Integer)+ {-# INLINE toCantor #-} toCantor = fromIntegral+ {-# INLINE fromCantor #-} fromCantor = fromIntegral instance Finite Word instance Cantor Word where- cardinality = Finite $ 2 ^ (finiteBitSize @Word undefined)- toCantor = fromIntegral + {-# INLINE cardinality #-}+ cardinality = Finite' $ 2 ^ (finiteBitSize @Word undefined)+ {-# INLINE toCantor #-}+ toCantor = fromIntegral+ {-# INLINE fromCantor #-} fromCantor = fromIntegral instance Finite Char instance Cantor Char where- cardinality = Finite . fromIntegral $ (fromEnum (maxBound :: Char) :: Int) + 1+ {-# INLINE cardinality #-}+ cardinality = Finite' . fromIntegral $ (fromEnum (maxBound :: Char) :: Int) + 1+ {-# INLINE toCantor #-} toCantor x = toEnum (fromIntegral x :: Int)+ {-# INLINE fromCantor #-} fromCantor x = fromIntegral (fromEnum x :: Int) instance (Cantor a , Cantor b) => Cantor (a , b)@@ -315,6 +408,7 @@ instance Cantor a => Cantor [ a ] instance Cantor a => Cantor (Data.Sequence.Seq a) where+ {-# INLINE cardinality #-} cardinality = cardinality @[ a ] toCantor = Data.Sequence.fromList . toCantor fromCantor = fromCantor . foldr (:) []@@ -326,7 +420,7 @@ -- where -- m :: M.Map a b -- m = M.fromList $ mapMaybe (\(a,w) -> (,) a <$> w) $ zip (toCantor <$> [ 0 .. ]) (eToCantor es i)- + -- es :: ESpace [ Maybe b ] -- es = nary (fCardinality @a) defaultSpace @@ -338,8 +432,8 @@ -- instance (Ord a , Finite a , Finite b) => Finite (M.Map a b) -- espace for `Set (Fin c)`-fSetEnum :: Integer -> ESpace (Data.Set.Set Integer)-fSetEnum c = ESpace (Finite (2 ^ c)) t f+fSetEnum :: Huge -> ESpace (Data.Set.Set Integer)+fSetEnum c = ESpace (Finite' (2 `pow` c)) t f where t :: Integer -> Data.Set.Set Integer t 0 = Data.Set.empty@@ -357,17 +451,18 @@ g a i = setBit a (fromInteger i) instance (Ord a , Finite a) => Cantor (Data.Set.Set a) where- cardinality = Finite (2 ^ fCardinality @a)+ {-# INLINE cardinality #-}+ cardinality = Finite' (2 `pow` fCardinality' @a) -- would be nice to map monotonic and save a log here, but that only works when -- Ord a respects the ordering on Integer, which we have no assurance of- toCantor = Data.Set.map toCantor . eToCantor (fSetEnum (fCardinality @a))- fromCantor = eFromCantor (fSetEnum (fCardinality @a)) . Data.Set.map fromCantor+ toCantor = Data.Set.map toCantor . eToCantor (fSetEnum (fCardinality' @a))+ fromCantor = eFromCantor (fSetEnum (fCardinality' @a)) . Data.Set.map fromCantor instance (Ord a , Finite a) => Finite (Data.Set.Set a) -- espace for `IntSet (Fin c)`, where c is in proper range-fSetEnum' :: Integer -> ESpace Data.IntSet.IntSet-fSetEnum' c = ESpace (Finite (2 ^ c)) t f+fSetEnum' :: Huge -> ESpace Data.IntSet.IntSet+fSetEnum' c = ESpace (Finite' (2 `pow` c)) t f where t :: Integer -> Data.IntSet.IntSet t 0 = Data.IntSet.empty@@ -385,9 +480,10 @@ g a i = setBit a i instance Cantor Data.IntSet.IntSet where- cardinality = Finite (2 ^ fCardinality @Int)- toCantor = eToCantor (fSetEnum' (fCardinality @Int))- fromCantor = eFromCantor (fSetEnum' (fCardinality @Int))+ {-# INLINE cardinality #-}+ cardinality = Finite' (2 `pow` fCardinality' @Int)+ toCantor = eToCantor (fSetEnum' (fCardinality' @Int))+ fromCantor = eFromCantor (fSetEnum' (fCardinality' @Int)) instance Finite Data.IntSet.IntSet @@ -411,174 +507,13 @@ -- (is , as) -> cantorUnsplit (fromCantor s , eFromCantor es as) -- where -- s = Data.IntSet.fromAscList is- + -- es :: ESpace [ a ] -- es = nary (toInteger (Data.IntSet.size s)) defaultSpace -- instance Finite a => Finite (Data.IntMap.Lazy.IntMap a) --- ES is just an alias to get in a position to use stimes for nary to get the nice algorithm-data ES a = ES !Int (ESpace (Endo [ a ])) (ESpace [ a ])--instance Semigroup (ES a) where- (<>) (ES a x x') (ES b y y') = ES (a + b) s1 s2- where- s1 :: ESpace (Endo [ a ])- s1 = case x *** y of- (ESpace c f _) -> ESpace c f' undefined- where- f' :: Integer -> Endo [ a ]- f' i = case f i of- (xs , ys) -> xs <> ys-- s2 :: ESpace [ a ]- s2 = case x' *** y' of- (ESpace c _ t) -> ESpace c undefined t'- where- t' :: [ a ] -> Integer- t' = t . splitAt a--nary :: forall a . Integer -> ESpace a -> ESpace [ a ]-nary 0 _ = undefined-nary i (ESpace c f t) = case stimes i es' of- (ES _ (ESpace c' f' _) (ESpace _ _ t')) -> ESpace c' (flip appEndo [] . f') t'- where- toE :: [ a ] -> Endo [ a ]- toE = Endo . (<>)- - es' :: ES a- es' = ES 1 (ESpace c (\j -> toE [ f j ]) undefined) $ ESpace c undefined $ \case- [ x ] -> t x- _ -> error "Bounds error."---infixr 7 ***-(***) :: forall a b . ESpace a -> ESpace b -> ESpace (a , b)-(***) (ESpace (Finite ca) tea fea) (ESpace (Finite cb) teb feb) =- ESpace (Finite (ca * cb)) tec fec- where- tec i =- let par_s = min ca cb -- small altitude of the parallelogram- tri_l = par_s - 1- tri_a = (tri_l * (tri_l + 1)) `div` 2- in- -- optimisation - if tri_l is 0, one or both of these is trivial and we have a line- if i < tri_a- then -- we're in the triangle, so just use cantor- case cantorSplit i of- (a , b) -> (tea a , teb b)- else let j = i - tri_a -- shadowing would make this so much safer, alas...- par_l = max ca cb - tri_l- par_a = par_s * par_l in- if j < par_a- then -- find their coordinates in the box- -- and then skew them to the real grid- case divModInteger j par_s of- (# l , s #) ->- let c1 = (l + tri_l) - s- c2 = s- (a , b) = if ca <= cb- then (c2 , c1)- else (c1 , c2)- in- (tea a , teb b)- else let k = j - par_a- l = tri_a - (k + 1) in- case cantorSplit l of- (a , b) -> (tea (ca - (a + 1)) , teb (cb - (b + 1)))-- fec (a , b) =- let (x , y) = (fea a , feb b)- par_s = min ca cb- tri_l = par_s - 1- in- if y < tri_l - x- then cantorUnsplit $ (x , y)- else let x'' = ca - (x + 1)- y'' = cb - (y + 1)- in- if y'' < tri_l - x''- then (ca * cb) - (cantorUnsplit (x'' , y'') + 1)- else let (x' , y') = if ca <= cb- then (x , y - (tri_l - x))- else (y , x - (tri_l - y))- tri_a = (tri_l * (tri_l + 1)) `div` 2- in- tri_a + x' + y' * par_s-(***) (ESpace (Finite ca) tea fea) (ESpace Countable teb feb) =- ESpace (if ca == 0 then Finite 0 else Countable) tec fec- where- tec i =- let par_s = ca -- small altitude of the parallelogram- tri_l = par_s - 1- tri_a = (tri_l * (tri_l + 1)) `div` 2- in- if i < tri_a- then case cantorSplit i of- (a , b) -> (tea a , teb b)- else let j = i - tri_a -- shadowing would make this so much safer, alas...- in- case divModInteger j par_s of- (# l , s #) ->- let c1 = (l + tri_l) - s- c2 = s- (a , b) = (c2 , c1)- in- (tea a , teb b)-- fec (a , b) =- let (x , y) = (fea a , feb b)- par_s = ca- tri_l = par_s - 1- in- if y < tri_l - x- then cantorUnsplit $ (x , y)- else let (x' , y') = (x , y - (tri_l - x))- tri_a = (tri_l * (tri_l + 1)) `div` 2- in- tri_a + x' + y' * par_s-(***) (ESpace Countable tea fea) (ESpace (Finite cb) teb feb) =- ESpace (if cb == 0 then Finite 0 else Countable) tec fec- where- tec i =- let par_s = cb -- small altitude of the parallelogram- tri_l = par_s - 1- tri_a = (tri_l * (tri_l + 1)) `div` 2- in- if i < tri_a- then case cantorSplit i of- (a , b) -> (tea a , teb b)- else let j = i - tri_a -- shadowing would make this so much safer, alas...- in- case divModInteger j par_s of- (# l , s #) ->- let c1 = (l + tri_l) - s- c2 = s- (a , b) = (c1 , c2)- in- (tea a , teb b)-- fec (a , b) =- let (x , y) = (fea a , feb b)- par_s = cb- tri_l = par_s - 1- in- if y < tri_l - x- then cantorUnsplit $ (x , y)- else let (x' , y') = (y , x - (tri_l - y))- tri_a = (tri_l * (tri_l + 1)) `div` 2- in- tri_a + x' + y' * par_s-(***) (ESpace _ tea fea) (ESpace _ teb feb) =- ESpace Countable tec fec- where- tec i = case cantorSplit i of- (a , b) -> (tea a , teb b)-- fec (a , b) = cantorUnsplit (fea a , feb b)-- -- https://en.wikipedia.org/wiki/Pairing_function#Cantor_pairing_function -- adapted for integer square rooting in the w, which should yield the same result -- but benchmarks significantly faster. buuut on closer inspection that makes no sense, since@@ -586,15 +521,16 @@ -- -- also, maybe try this https://gist.github.com/orlp/3481770 cantorSplit :: Integer -> (Integer , Integer)-cantorSplit i = - let w = (integerSquareRoot' (8 * i + 1) - 1) `div` 2 - -- original implementation (convert to/from float for the sqrt)+cantorSplit i =+ let -- original implementation (convert to/from float for the sqrt) -- w :: Int = floor (0.5 * (sqrt (8 * fromIntegral i + 1 :: Double) - 1)) t = (w^(2 :: Int) + w) `quot` 2 y = i - t x = w - y in (x , y)+ where+ w = (integerSquareRoot' (8 * i + 1) - 1) `div` 2 cantorUnsplit :: (Integer , Integer) -> Integer cantorUnsplit (x , y) = (((x + y + 1) * (x + y)) `quot` 2) + y@@ -606,39 +542,56 @@ gFromCantor' :: f a -> Integer instance GCantor s V1 where+ {-# INLINE hasExit #-} hasExit = False- gCardinality' = Finite 0+ {-# INLINE gCardinality' #-}+ gCardinality' = Finite' 0 gToCantor' = undefined gFromCantor' = undefined instance GCantor s U1 where+ {-# INLINE hasExit #-} hasExit = True- gCardinality' = Finite 1+ {-# INLINE gCardinality' #-}+ gCardinality' = Finite' 1+ {-# INLINE gToCantor' #-} gToCantor' _ = U1+ {-# INLINE gFromCantor' #-} gFromCantor' _ = 0 instance {-# OVERLAPPING #-} Cantor a => GCantor a (K1 i a) where+ {-# INLINE hasExit #-} hasExit = False+ {-# INLINE gCardinality' #-} gCardinality' = Countable+ {-# INLINE gToCantor' #-} gToCantor' = K1 . toCantor+ {-# INLINE gFromCantor' #-} gFromCantor' (K1 x) = fromCantor x instance {-# OVERLAPPABLE #-} Cantor b => GCantor w (K1 i b) where+ {-# INLINE hasExit #-} hasExit = True+ {-# INLINE gCardinality' #-} gCardinality' = cardinality @b+ {-# INLINE gToCantor' #-} gToCantor' = K1 . toCantor+ {-# INLINE gFromCantor' #-} gFromCantor' (K1 x) = fromCantor x instance (GCantor s a , GCantor s b) => GCantor s (a :*: b) where+ {-# INLINE hasExit #-} hasExit = hasExit @s @a && hasExit @s @b+ {-# INLINE gCardinality' #-} gCardinality' = case (gCardinality' @s @a , gCardinality' @s @b) of- (Finite i , Finite j) -> Finite (i * j)- (Finite 0 , _) -> Finite 0- (_ , Finite 0) -> Finite 0+ (Finite' i , Finite' j) -> Finite' (i * j)+ (Finite' 0 , _) -> Finite' 0+ (_ , Finite' 0) -> Finite' 0 _ -> Countable + {-# INLINABLE gToCantor' #-} gToCantor' i = case (gCardinality' @s @a , gCardinality' @s @b) of- (Finite ca , Finite cb) ->+ (Finite ca, Finite cb) -> let par_s = min ca cb -- small altitude of the parallelogram tri_l = par_s - 1 tri_a = (tri_l * (tri_l + 1)) `div` 2@@ -667,7 +620,7 @@ l = tri_a - (k + 1) in case cantorSplit l of (a , b) -> (gToCantor' @s @a (ca - (a + 1)) :*: gToCantor' @s @b (cb - (b + 1)))- (Finite ca , Countable) ->+ (Finite ca, Countable) -> let par_s = ca -- small altitude of the parallelogram tri_l = par_s - 1 tri_a = (tri_l * (tri_l + 1)) `div` 2@@ -684,7 +637,7 @@ (a , b) = (c2 , c1) in (gToCantor' @s @a a :*: gToCantor' @s @b b)- + (Countable , Finite cb) -> let par_s = cb -- small altitude of the parallelogram tri_l = par_s - 1@@ -704,9 +657,10 @@ (gToCantor' @s @a a :*: gToCantor' @s @b b) _ -> case cantorSplit i of (a , b) -> (gToCantor' @s @a a :*: gToCantor' @s @b b)- ++ {-# INLINABLE gFromCantor' #-} gFromCantor' (a :*: b) = case (gCardinality' @s @a , gCardinality' @s @b) of- (Finite ca , Finite cb) ->+ (Finite ca, Finite cb) -> let (x , y) = (gFromCantor' @s @a a , gFromCantor' @s @b b) par_s = min ca cb tri_l = par_s - 1@@ -724,7 +678,7 @@ tri_a = (tri_l * (tri_l + 1)) `div` 2 in tri_a + x' + y' * par_s- (Finite ca , Countable) ->+ (Finite ca, Countable) -> let (x , y) = (gFromCantor' @s @a a , gFromCantor' @s @b b) par_s = ca tri_l = par_s - 1@@ -735,7 +689,7 @@ tri_a = (tri_l * (tri_l + 1)) `div` 2 in tri_a + x' + y' * par_s- (Countable , Finite cb) ->+ (Countable, Finite cb) -> let (x , y) = (gFromCantor' @s @a a , gFromCantor' @s @b b) par_s = cb tri_l = par_s - 1@@ -752,25 +706,28 @@ -- in this instance, make sure we head towards the exit if there is one, otherwise we can get -- stuck endlessly in the labyrinth instance (GCantor s a , GCantor s b) => GCantor s (a :+: b) where+ {-# INLINE hasExit #-} hasExit = hasExit @s @a || hasExit @s @b+ {-# INLINE gCardinality' #-} gCardinality' = case (gCardinality' @s @a , gCardinality' @s @b) of- (Finite i , Finite j) -> Finite (i + j)+ (Finite' i , Finite' j) -> Finite' (i + j) _ -> Countable + {-# INLINABLE gToCantor' #-} gToCantor' i = case (gCardinality' @s @a , gCardinality' @s @b) of- (Finite ca , Finite cb) -> if i < 2 * min ca cb+ (Finite ca, Finite cb) -> if i < 2 * min ca cb then case divModInteger i 2 of (# k , 0 #) -> L1 $ gToCantor' @s @a k (# k , _ #) -> R1 $ gToCantor' @s @b k else if ca > cb then L1 $ gToCantor' @s @a (i - cb) else R1 $ gToCantor' @s @b (i - ca)- (Finite ca , Countable) -> if i < 2 * ca+ (Finite ca, Countable) -> if i < 2 * ca then case divModInteger i 2 of (# k , 0 #) -> L1 $ gToCantor' @s @a k (# k , _ #) -> R1 $ gToCantor' @s @b k else R1 $ gToCantor' @s @b (i - ca)- (Countable , Finite _) -> case gToCantor' @s @(b :+: a) i of+ (Countable , Finite{}) -> case gToCantor' @s @(b :+: a) i of L1 x -> R1 x R1 x -> L1 x _ -> if not (hasExit @s @a) && hasExit @s @b@@ -781,12 +738,13 @@ (# k , 0 #) -> L1 $ gToCantor' @s @a k (# k , _ #) -> R1 $ gToCantor' @s @b k + {-# INLINABLE gFromCantor' #-} gFromCantor' (L1 x) = case gCardinality' @s @b of- Finite cb -> case gCardinality' @s @a of+ Finite' cb -> case gCardinality' @s @a of Countable -> gFromCantor' @s @(b :+: a) $ R1 x _ -> case gFromCantor' @s @a x of 0 -> 0- i -> i + min cb i+ i -> i + evalWith (^) (min cb (fromInteger i)) Countable -> case gCardinality' @s @a of Countable -> if not (hasExit @s @a) && hasExit @s @b then gFromCantor' @s @(b :+: a) $ R1 x@@ -797,11 +755,11 @@ 0 -> 0 i -> 2 * i gFromCantor' (R1 x) = case gCardinality' @s @a of- Finite ca -> case gFromCantor' @s @b x of+ Finite' ca -> case gFromCantor' @s @b x of 0 -> 1- i -> i + min ca (i + 1)+ i -> i + evalWith (^) (min ca (fromInteger (i + 1))) Countable -> case gCardinality' @s @b of- Finite _ -> gFromCantor' @s @(b :+: a) $ L1 x+ Finite{} -> gFromCantor' @s @(b :+: a) $ L1 x Countable -> if not (hasExit @s @a) && hasExit @s @b then gFromCantor' @s @(b :+: a) $ L1 x else case gFromCantor' @s @b x of@@ -809,11 +767,14 @@ i -> 2 * i + 1 instance GCantor s f => GCantor s (M1 i t f) where+ {-# INLINE hasExit #-} hasExit = hasExit @s @f + {-# INLINE gCardinality' #-} gCardinality' = gCardinality' @s @f- ++ {-# INLINE gToCantor' #-} gToCantor' = M1 . gToCantor' @s @f- - gFromCantor' (M1 x) = gFromCantor' @s @f x + {-# INLINE gFromCantor' #-}+ gFromCantor' (M1 x) = gFromCantor' @s @f x
+ src/Cantor/Huge.hs view
@@ -0,0 +1,259 @@+-- |+-- Module: Cantor.Huge+-- Copyright: (c) 2020 Andrew Lelechenko+-- Licence: MIT+-- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>++{-# LANGUAGE LambdaCase #-}++module Cantor.Huge+ ( Huge+ , pow+ , evalWith+ ) where++import Prelude hiding ((^^))+import Control.Exception+import Math.NumberTheory.Powers+import Math.NumberTheory.Logarithms+import Numeric.Natural++-- | Lazy huge numbers with an efficient 'Ord' instance.+data Huge+ = Nat Natural+ | Add Huge Huge+ | Mul Huge Huge+ | Pow Huge Huge++instance Show Huge where+ show = \case+ Nat n -> show n+ Add x y -> "(" ++ show x ++ " + " ++ show y ++ ")"+ Mul x y -> "(" ++ show x ++ " * " ++ show y ++ ")"+ Pow x y -> "(" ++ show x ++ " ^ " ++ show y ++ ")"++instance Num Huge where+ (+) = add+ (*) = mul+ abs = id+ signum = const 1+ negate = throw Underflow+ fromInteger = Nat . fromInteger++{-# RULES "Huge/pow" forall x p. x ^ p = x `pow` p #-}++add :: Huge -> Huge -> Huge+add (Nat 0) y = y+add x (Nat 0) = x+-- add (Nat x) (Nat y) = Nat $ x + y+add x y = Add x y++mul :: Huge -> Huge -> Huge+mul (Nat 0) _ = Nat 0+mul _ (Nat 0) = Nat 0+mul (Nat 1) y = y+mul x (Nat 1) = x+-- mul (Nat x) (Nat y) = Nat $ x * y+mul x y = Mul x y++-- | Exponentiation.+pow :: Huge -> Huge -> Huge+pow _ (Nat 0) = Nat 1+pow (Nat 0) _ = Nat 0+pow x (Nat 1) = x+pow (Nat 1) _ = Nat 1+pow x y = Pow x y++-- | Convert 'Huge' to another numeric type,+-- using provided function for exponentiation.+evalWith :: Num a => (a -> a -> a) -> Huge -> a+evalWith (^^) = go+ where+ go = \case+ Nat n -> fromIntegral n+ Add x y -> go x + go y+ Mul x y -> go x * go y+ Pow x y -> go x ^^ go y++-- | Simply 'evalWith' '(^)'.+eval :: Huge -> Natural+eval = evalWith (^)++instance Eq Huge where+ x == y = x `compare` y == EQ++instance Ord Huge where+ x `compare` y = x `compareHuge` y++-- Assuming the second argument has been constructed+-- using smart constructors.+compareNat :: Natural -> Huge -> Ordering+compareNat m = go+ where+ go = \case+ Nat n -> m `compare` n+ Add x y+ | Nat n <- x -> if m < n then LT else (m - n) `compareNat` y+ | Nat n <- y -> if m < n then LT else (m - n) `compareNat` x+ | go x == LT -> LT+ | go y == LT -> LT+ | x <= y -> (m - eval x) `compareNat` y+ | otherwise -> (m - eval y) `compareNat` x+ Mul x y+ | Nat n <- x -> if m < n then LT else unwrap quotPerf m n y+ | Nat n <- y -> if m < n then LT else unwrap quotPerf m n x+ | go x /= GT -> LT+ | go y /= GT -> LT+ | x <= y -> unwrap quotPerf m (eval x) y+ | otherwise -> unwrap quotPerf m (eval y) x+ Pow x y+ | Nat n <- x -> if m < n then LT else unwrap logPerf m n y+ | Nat n <- y -> if m < n then LT else unwrap rootPerf m n x+ | go x /= GT -> LT+ | go y /= GT -> LT+ | x <= y -> unwrap logPerf m (eval x) y+ | otherwise -> unwrap rootPerf m (eval y) x++data Perfectness = Perfect | Imperfect+ deriving (Eq, Ord, Show)++unwrap+ :: (Natural -> Natural -> (Natural, Perfectness))+ -> Natural+ -> Natural+ -> Huge+ -> Ordering+unwrap f m n y = case m `f` n of+ (q, r) -> q `compareNat` y <> (r `compare` Perfect)++quotPerf :: Natural -> Natural -> (Natural, Perfectness)+quotPerf m x = (q, r)+ where+ q = m `quot` x+ r = if q * x == m then Perfect else Imperfect++rootPerf :: Natural -> Natural -> (Natural, Perfectness)+rootPerf m x = (q, r)+ where+ q = integerRoot x m+ r = if q ^ x == m then Perfect else Imperfect++logPerf :: Natural -> Natural -> (Natural, Perfectness)+logPerf m x = (fromIntegral q, r)+ where+ q = naturalLogBase x m+ r = if x ^ q == m then Perfect else Imperfect++inverse :: Ordering -> Ordering+inverse = \case+ LT -> GT+ EQ -> EQ+ GT -> LT++-- Assuming both arguments have been constructed+-- using smart constructors.+compareHuge :: Huge -> Huge -> Ordering+Nat m `compareHuge` z = compareNat m z+z `compareHuge` Nat m = inverse $ compareNat m z+Add x y `compareHuge` Add u v = compareAddAdd x y u v+Add x y `compareHuge` Mul u v = compareAscNodes Add Mul x y u v+Add x y `compareHuge` Pow u v = compareAscNodes Add Pow x y u v+Mul x y `compareHuge` Add u v = inverse $ compareAscNodes Add Mul u v x y+Mul x y `compareHuge` Mul u v = compareMulMul x y u v+Mul x y `compareHuge` Pow u v = compareAscNodes Mul Pow x y u v+Pow x y `compareHuge` Add u v = inverse $ compareAscNodes Add Pow u v x y+Pow x y `compareHuge` Mul u v = inverse $ compareAscNodes Mul Pow u v x y+Pow x y `compareHuge` Pow u v = comparePowPow x y u v++-- Compare Add vs. Mul, Add vs. Pow or Mul vs. Pow,+-- but not vice versa.+compareAscNodes+ :: (Huge -> Huge -> Huge)+ -> (Huge -> Huge -> Huge)+ -> Huge+ -> Huge+ -> Huge+ -> Huge+ -> Ordering+compareAscNodes fxy fuv x y u v =+ case (x `compare` u, x `compare` v, y `compare` u, y `compare` v) of+ (LT, _, _, LT) -> LT+ ( _, LT, LT, _) -> LT++ (GT, GT, _, _) -> uvSimpler+ (GT, _, _, GT) -> uvSimpler+ ( _, GT, GT, _) -> uvSimpler+ ( _, _, GT, GT) -> uvSimpler++ (LT, _, LT, _) -> xySimpler+ (LT, _, EQ, _) -> xySimpler+ (EQ, _, LT, _) -> xySimpler+ (EQ, _, EQ, _) -> xySimpler++ ( _, LT, _, LT) -> xySimpler+ ( _, LT, _, EQ) -> xySimpler+ ( _, EQ, _, LT) -> xySimpler+ ( _, EQ, _, EQ) -> xySimpler+ where+ uvSimpler = inverse $ compareNat (eval (fuv u v)) (fxy x y)+ xySimpler = compareNat (eval (fxy x y)) (fuv u v)++compareAddAdd :: Huge -> Huge -> Huge -> Huge -> Ordering+compareAddAdd x y u v =+ case (x `compare` u, x `compare` v, y `compare` u, y `compare` v) of+ (EQ, _, _, yv) -> yv+ ( _, EQ, yu, _) -> yu+ ( _, xv, EQ, _) -> xv+ (xu, _, _, EQ) -> xu++ (GT, _, _, GT) -> GT+ ( _, GT, GT, _) -> GT+ (LT, _, _, LT) -> LT+ ( _, LT, LT, _) -> LT++ -- x > u > y, x > v > y+ (GT, GT, LT, LT)+ | u <= v -> x `compare` Add (Nat (eval u - eval y)) v+ | otherwise -> x `compare` Add u (Nat (eval v - eval y))+ -- y > u > x, y > v > x+ (LT, LT, GT, GT)+ | u <= v -> y `compare` Add (Nat (eval u - eval x)) v+ | otherwise -> y `compare` Add u (Nat (eval v - eval x))+ -- u > x > v, u > y > v+ (LT, GT, LT, GT)+ | x <= y -> Add (Nat (eval x - eval v)) y `compare` u+ | otherwise -> Add x (Nat (eval y - eval v)) `compare` u+ -- v > x > u, v > y > u+ (GT, LT, GT, LT)+ | x <= y -> Add (Nat (eval x - eval u)) y `compare` v+ | otherwise -> Add x (Nat (eval y - eval u)) `compare` v++compareMulMul :: Huge -> Huge -> Huge -> Huge -> Ordering+compareMulMul x y u v =+ case (x `compare` u, x `compare` v, y `compare` u, y `compare` v) of+ (EQ, _, _, yv) -> yv+ ( _, EQ, yu, _) -> yu+ ( _, xv, EQ, _) -> xv+ (xu, _, _, EQ) -> xu++ (GT, _, _, GT) -> GT+ ( _, GT, GT, _) -> GT+ (LT, _, _, LT) -> LT+ ( _, LT, LT, _) -> LT++ (GT, GT, LT, LT) -> uvSimpler+ (LT, LT, GT, GT) -> uvSimpler+ (LT, GT, LT, GT) -> xySimpler+ (GT, LT, GT, LT) -> xySimpler+ where+ uvSimpler = inverse $ compareNat (eval (Mul u v)) (Mul x y)+ xySimpler = compareNat (eval (Mul x y)) (Mul u v)++comparePowPow :: Huge -> Huge -> Huge -> Huge -> Ordering+comparePowPow x y u v = case (x `compare` u, y `compare` v) of+ (EQ, yv) -> yv+ (xu, EQ) -> xu+ (LT, LT) -> LT+ (GT, GT) -> GT+ (LT, GT) -> inverse $ compareNat (eval (Pow u v)) (Pow x y)+ (GT, LT) -> compareNat (eval (Pow x y)) (Pow u v)
test/Spec.hs view
@@ -7,9 +7,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +import Data.Void import GHC.Generics (Generic) import Test.Hspec-import Data.Void import Cantor @@ -102,26 +102,28 @@ describe "uniqueness and isomorphism for countable types" $ do it "for C x Integer" $ (checkUISO @(C , Integer)) `shouldBe` True- + it "for Integer x C" $ (checkUISO @(C , Integer)) `shouldBe` True- + it "for Integer x Integer" $ (checkUISO @(Integer , Integer)) `shouldBe` True- + it "for C -> Integer" $ (checkUISO @(C -> Integer)) `shouldBe` True- + it "for [ C -> Integer ]" $ (checkUISO @([ (C -> Integer) ])) `shouldBe` True it "for TreeL Bool" $- (checkUISO @(TreeL Bool)) `shouldBe` True + (checkUISO @(TreeL Bool)) `shouldBe` True it "for TreeR Bool" $ (checkUISO @(TreeR Bool)) `shouldBe` True - + describe "function enumeration even for large domains" $ do+ it "should be fast" $+ (head (cantorEnumeration @(Word -> Int)) 42173) `shouldBe` 0 where fcheckUISO :: forall a . (Eq a , Finite a) => Bool fcheckUISO = e == fmap (toCantor . fromCantor) e@@ -133,5 +135,4 @@ checkUISO = e == fmap (toCantor . fromCantor) e where e :: [ a ]- e = take 500 cantorEnumeration-+ e = take 5000 cantorEnumeration