├── CHANGELOG.md ├── LICENSE ├── README.md ├── cabal.project ├── cantor-pairing.cabal ├── src ├── Cantor.hs └── Cantor │ └── Huge.hs └── test └── Spec.hs /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for cantor-pairing 2 | 3 | ## 0.2.0.0 4 | 5 | - `cantorEnumeration` is now productive in more cases due to better handling of large numbers internally (thanks Bodigrim!) 6 | 7 | ## 0.1.1.0 8 | 9 | - Instances for `Int`, `Word`, `IntSet`, and `Set` 10 | - Basic recursion is now detected generically, so there is now no need to manually specify that the cardinality is `Countable` 11 | 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019 Identical Snowflake 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # cantor-pairing 2 | 3 | This package implements a beefed-up version of `Enum` via GHC generics called `Cantor` which works for both finite and countably-infinite types. 4 | 5 | ## Example 6 | ```haskell 7 | import GHC.Generics 8 | import Cantor 9 | 10 | data MyType = MyType { 11 | value1 :: [ Maybe Bool ] 12 | , value2 :: Integer 13 | } deriving (Generic,Cantor,Show) 14 | 15 | example :: IO () 16 | example = do 17 | putStrLn "The first 5 elements of the enumeration are:" 18 | print $ take 5 xs 19 | where 20 | xs :: [ MyType ] 21 | xs = cantorEnumeration 22 | 23 | ``` 24 | This should work nicely even with simple inductive types: 25 | 26 | ## Recursive example 27 | ```haskell 28 | data Tree a = Leaf | Branch (Tree a) a (Tree a) deriving (Generic,Cantor) 29 | ``` 30 | 31 | If your type is finite, you can specify this by deriving the `Finite` typeclass, which is a subclass of `Cantor`: 32 | 33 | ## Finite example 34 | ```haskell 35 | data Color = Red | Green | Blue deriving (Generic,Cantor,Finite) 36 | ``` 37 | 38 | ## Mutually-recursive types 39 | 40 | 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: 41 | 42 | ```haskell 43 | data Foo = FooNil | Foo Bool Bar deriving (Generic,Show) 44 | data Bar = BarNil | Bar Bool Foo deriving (Generic,Show) 45 | 46 | instance Cantor Foo where 47 | cardinality = Countable 48 | instance Cantor Bar 49 | ``` 50 | 51 | Once you have a valid instance of `Cantor a`, you may lazily inspect all values of the type using `cantorEnumeration :: [ a ]` and convert a point to and from its integer encoding using `toCantor :: Integer -> a` and `fromCantor :: a -> Integer`. 52 | 53 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | optimization: 2 3 | -------------------------------------------------------------------------------- /cantor-pairing.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: cantor-pairing 3 | version: 0.2.0.1 4 | synopsis: Convert data to and from a natural number representation 5 | description: Convert data to and from a natural number representation conveniently using GHC Generics. 6 | homepage: https://github.com/identicalsnowflake/cantor-pairing 7 | bug-reports: https://github.com/identicalsnowflake/cantor-pairing/issues 8 | license: MIT 9 | license-file: LICENSE 10 | author: Identical Snowflake 11 | maintainer: identicalsnowflake@protonmail.com 12 | copyright: 2018 13 | category: Data 14 | extra-source-files: CHANGELOG.md 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/identicalsnowflake/cantor-pairing 19 | 20 | library 21 | exposed-modules: 22 | Cantor 23 | other-modules: 24 | Cantor.Huge 25 | build-depends: base >= 4.12.0.0 && < 5 26 | , containers >= 0.6.0.1 && < 0.7 27 | , integer-gmp ^>= 1.0.2.0 28 | , integer-logarithms >= 1.0.2.2 && < 2.0 29 | , integer-roots >= 1.0 && < 1.1 30 | hs-source-dirs: src 31 | ghc-options: -Wall -Wextra 32 | default-language: Haskell2010 33 | 34 | test-suite spec 35 | ghc-options: -threaded -rtsopts -Wall -Wextra 36 | type: exitcode-stdio-1.0 37 | main-is: test/Spec.hs 38 | build-depends: 39 | base 40 | , cantor-pairing 41 | , containers 42 | , hspec >= 2 && < 3 43 | , mtl >= 2.2.2 44 | build-tool-depends: hspec-discover:hspec-discover 45 | default-language: Haskell2010 46 | 47 | -------------------------------------------------------------------------------- /src/Cantor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE DefaultSignatures #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE PatternSynonyms #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE UnboxedTuples #-} 15 | {-# LANGUAGE ViewPatterns #-} 16 | 17 | -- | This package implements a beefed-up version of `Enum` via GHC generics called `Cantor` which works for both finite and countably-infinite types. 18 | -- 19 | -- = Example 20 | -- @ 21 | -- import GHC.Generics 22 | -- import Cantor 23 | -- 24 | -- data MyType = MyType { 25 | -- value1 :: [ Maybe Bool ] 26 | -- , value2 :: Integer 27 | -- } deriving (Generic,Cantor,Show) 28 | -- 29 | -- example :: IO () 30 | -- example = do 31 | -- putStrLn "The first 5 elements of the enumeration are:" 32 | -- print $ take 5 xs 33 | -- where 34 | -- xs :: [ MyType ] 35 | -- xs = cantorEnumeration 36 | -- @ 37 | -- 38 | -- = Recursive example 39 | -- 40 | -- This should work nicely even with simple inductive types: 41 | -- 42 | -- @ 43 | -- data Tree a = Leaf | Branch (Tree a) a (Tree a) deriving (Generic,Cantor) 44 | -- @ 45 | -- 46 | -- = Finite example 47 | -- 48 | -- If your type is finite, you can specify this by deriving the @Finite@ typeclass, which is a subclass of @Cantor@: 49 | -- 50 | -- @ 51 | -- data Color = Red | Green | Blue deriving (Generic,Cantor,Finite) 52 | -- @ 53 | -- 54 | -- 55 | -- = Mutually-recursive types 56 | -- 57 | -- 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: 58 | -- 59 | -- @ 60 | -- data Foo = FooNil | Foo Bool Bar deriving (Generic,Show) 61 | -- data Bar = BarNil | Bar Bool Foo deriving (Generic,Show) 62 | -- 63 | -- instance Cantor Foo where 64 | -- cardinality = Countable 65 | -- instance Cantor Bar 66 | -- @ 67 | -- 68 | -- Once you have a valid instance of @Cantor a@, you may lazily inspect all values of the type using @cantorEnumeration :: [ a ]@ and convert a point to and from its integer encoding using @toCantor :: Integer -> a@ and @fromCantor :: a -> Integer@. 69 | 70 | module Cantor 71 | ( cantorEnumeration 72 | , Cardinality(Countable,Finite) 73 | , Cantor(..) 74 | , Finite 75 | , fCardinality 76 | ) where 77 | 78 | import GHC.Generics 79 | import GHC.Integer 80 | import GHC.Int 81 | import GHC.Word 82 | import GHC.Natural 83 | import Data.Semigroup 84 | import Data.Functor.Identity 85 | import qualified Data.Functor.Const 86 | import Data.Proxy 87 | import Math.NumberTheory.Roots (integerSquareRoot) 88 | import Data.Void 89 | import Data.Bits 90 | import Data.Foldable (foldl') 91 | import Math.NumberTheory.Logarithms 92 | 93 | import qualified Data.Sequence 94 | import qualified Data.Set 95 | import qualified Data.IntSet 96 | 97 | import Cantor.Huge 98 | 99 | -- internal value-level representation, currently only used for function enumeration 100 | data ESpace a = ESpace { 101 | eCardinality :: Cardinality 102 | , eToCantor :: Integer -> a 103 | , eFromCantor :: a -> Integer 104 | } 105 | 106 | {-# INLINE defaultSpace #-} 107 | defaultSpace :: forall a . Cantor a => ESpace a 108 | defaultSpace = ESpace { 109 | eCardinality = cardinality @a 110 | , eToCantor = toCantor 111 | , eFromCantor = fromCantor 112 | } 113 | 114 | {-# INLINE enumerateSpace #-} 115 | enumerateSpace :: ESpace a -> [ a ] 116 | enumerateSpace (ESpace c te _) = case c of 117 | Finite' 0 -> [] 118 | Finite' i -> te <$> takeWhile (\k -> fromInteger k < i) [0..] 119 | Countable -> te <$> [ 0 .. ] 120 | 121 | -- | Enumerates all values of a type by mapping @toCantor@ over the naturals or finite subset of naturals with the correct cardinality. 122 | -- 123 | -- >>> take 5 cantorEnumeration :: [ Data.IntSet.IntSet ] 124 | -- [fromList [],fromList [0],fromList [1],fromList [0,1],fromList [2]] 125 | {-# INLINABLE cantorEnumeration #-} 126 | cantorEnumeration :: Cantor a => [ a ] 127 | cantorEnumeration = enumerateSpace defaultSpace 128 | 129 | instance forall a b . (Finite a , Cantor b) => Cantor (a -> b) where 130 | {-# INLINE cardinality #-} 131 | cardinality = case (cardinality @a , cardinality @b) of 132 | (Finite' 0 , _) -> Finite' 1 -- anything to the zero power is one (including zero!) 133 | (Finite' c1 , Finite' c2) -> Finite' (c2 `pow` c1) 134 | _ -> Countable 135 | 136 | toCantor 0 _ = toCantor 0 137 | toCantor i a = toCantor $ cantorExp (fCardinality @a) (fromCantor a) i 138 | where 139 | cantorExp :: Integer -> Integer -> Integer -> Integer 140 | cantorExp 1 _ f = f 141 | cantorExp t x f = if x < b1 142 | then cantorExp b1 x $ fst (cantorSplit f) 143 | else cantorExp b2 (x - b1) $ snd (cantorSplit f) 144 | where 145 | (# t' , m' #) = divModInteger t 2 146 | !b1 = t' + m' 147 | b2 = t' 148 | 149 | fromCantor g = uncantorExp (fCardinality @a) (fromCantor . g . toCantor) 150 | where 151 | uncantorExp :: Integer -> (Integer -> Integer) -> Integer 152 | uncantorExp 1 f = f 0 153 | uncantorExp t f = cantorUnsplit (uncantorExp b1 f , uncantorExp b2 (\x -> f (x + b1))) 154 | where 155 | (# t' , m' #) = divModInteger t 2 156 | !b1 = t' + m' 157 | b2 = t' 158 | 159 | instance (Finite a , Finite b) => Finite (a -> b) 160 | 161 | -- | @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. 162 | data Cardinality = 163 | Finite' Huge 164 | | Countable' 165 | deriving (Generic,Eq,Ord) 166 | 167 | instance Show Cardinality where 168 | show Countable = "Countable" 169 | show (Finite i) = "Finite " <> show i 170 | 171 | pattern Countable :: Cardinality 172 | pattern Countable <- Countable' 173 | where 174 | Countable = Countable' 175 | 176 | pattern Finite :: Integer -> Cardinality 177 | pattern Finite n <- Finite' (evalWith (^) -> n) 178 | where 179 | Finite n = Finite' (fromInteger n) 180 | 181 | {-# COMPLETE Finite, Countable #-} 182 | {-# COMPLETE Finite', Countable #-} 183 | 184 | -- | The @Finite@ typeclass simply entails that the @Cardinality@ of the set is finite. 185 | class Cantor a => Finite a where 186 | {-# INLINE fCardinality' #-} 187 | fCardinality' :: Huge 188 | fCardinality' = case cardinality @a of 189 | Finite' i -> i 190 | _ -> error "Expected finite cardinality, got Countable." 191 | 192 | -- | Cardinality of a finite type. 193 | fCardinality :: forall a. Finite a => Integer 194 | fCardinality = evalWith (^) (fCardinality' @a) 195 | 196 | -- | 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. 197 | class Cantor a where 198 | cardinality :: Cardinality 199 | 200 | {-# INLINE cardinality #-} 201 | default cardinality :: GCantor a (Rep a) => Cardinality 202 | cardinality = gCardinality' @a @(Rep a) 203 | 204 | {-# INLINABLE toCantor #-} 205 | toCantor :: Integer -> a -- ideally this should be `Fin n -> a` (for finite types) 206 | -- or `N` (for countably infinite types). 207 | -- I chose not to use `Natural` from `GHC.Natural` 208 | -- because it's turned out to be a huge pain and integrates 209 | -- poorly with the haskell ecosystem 210 | default toCantor :: (Generic a , GCantor a (Rep a)) => Integer -> a 211 | toCantor = to . gToCantor' @a @(Rep a) 212 | 213 | {-# INLINABLE fromCantor #-} 214 | fromCantor :: a -> Integer 215 | default fromCantor :: (Generic a , GCantor a (Rep a)) => a -> Integer 216 | fromCantor = gFromCantor' @a @(Rep a) . from 217 | 218 | 219 | instance Cantor Natural where 220 | {-# INLINE cardinality #-} 221 | cardinality = Countable 222 | {-# INLINE toCantor #-} 223 | toCantor = fromInteger 224 | {-# INLINE fromCantor #-} 225 | fromCantor = toInteger 226 | 227 | data IntAlg = Zero | Neg Natural | Pos Natural deriving (Generic,Show) 228 | 229 | instance Cantor IntAlg 230 | 231 | toIntAlg :: Integer -> IntAlg 232 | toIntAlg 0 = Zero 233 | toIntAlg x = if x < 0 234 | then Neg $ fromInteger $ negate (x + 1) 235 | else Pos $ fromInteger $ x - 1 236 | 237 | fromIntAlg :: IntAlg -> Integer 238 | fromIntAlg Zero = 0 239 | fromIntAlg (Neg x) = negate (toInteger x) - 1 240 | fromIntAlg (Pos x) = toInteger x + 1 241 | 242 | instance Cantor Integer where 243 | {-# INLINE cardinality #-} 244 | cardinality = Countable 245 | 246 | toCantor = fromIntAlg . toCantor 247 | 248 | fromCantor = fromCantor . toIntAlg 249 | 250 | instance Cantor () where 251 | instance Finite () 252 | 253 | instance Cantor Void 254 | instance Finite Void 255 | 256 | instance Finite Bool 257 | instance Cantor Bool where 258 | {-# INLINE cardinality #-} 259 | cardinality = Finite' 2 260 | 261 | {-# INLINE toCantor #-} 262 | toCantor 0 = False 263 | toCantor _ = True 264 | 265 | {-# INLINE fromCantor #-} 266 | fromCantor False = 0 267 | fromCantor _ = 1 268 | 269 | 270 | instance Finite Int8 271 | instance Cantor Int8 where 272 | {-# INLINE cardinality #-} 273 | cardinality = Finite' $ 2 ^ (8 :: Integer) 274 | {-# INLINE toCantor #-} 275 | toCantor = fromInteger . toCantor @Integer 276 | {-# INLINE fromCantor #-} 277 | fromCantor = fromCantor @Integer . toInteger 278 | 279 | instance Finite Int16 280 | instance Cantor Int16 where 281 | {-# INLINE cardinality #-} 282 | cardinality = Finite' $ 2 ^ (16 :: Integer) 283 | {-# INLINE toCantor #-} 284 | toCantor = fromInteger . toCantor @Integer 285 | {-# INLINE fromCantor #-} 286 | fromCantor = fromCantor @Integer . toInteger 287 | 288 | instance Finite Int32 289 | instance Cantor Int32 where 290 | {-# INLINE cardinality #-} 291 | cardinality = Finite' $ 2 ^ (32 :: Integer) 292 | {-# INLINE toCantor #-} 293 | toCantor = fromInteger . toCantor @Integer 294 | {-# INLINE fromCantor #-} 295 | fromCantor = fromCantor @Integer . toInteger 296 | 297 | instance Finite Int64 298 | instance Cantor Int64 where 299 | {-# INLINE cardinality #-} 300 | cardinality = Finite' $ 2 ^ (64 :: Integer) 301 | {-# INLINE toCantor #-} 302 | toCantor = fromInteger . toCantor @Integer 303 | {-# INLINE fromCantor #-} 304 | fromCantor = fromCantor @Integer . toInteger 305 | 306 | instance Finite Int 307 | instance Cantor Int where 308 | {-# INLINE cardinality #-} 309 | cardinality = Finite' $ 2 ^ (finiteBitSize @Int undefined) 310 | {-# INLINE toCantor #-} 311 | toCantor = fromInteger . toCantor @Integer 312 | {-# INLINE fromCantor #-} 313 | fromCantor = fromCantor @Integer . toInteger 314 | 315 | instance Finite Word8 316 | instance Cantor Word8 where 317 | {-# INLINE cardinality #-} 318 | cardinality = Finite' $ 2 ^ (8 :: Integer) 319 | {-# INLINE toCantor #-} 320 | toCantor = fromIntegral 321 | {-# INLINE fromCantor #-} 322 | fromCantor = fromIntegral 323 | 324 | instance Finite Word16 325 | instance Cantor Word16 where 326 | {-# INLINE cardinality #-} 327 | cardinality = Finite' $ 2 ^ (16 :: Integer) 328 | {-# INLINE toCantor #-} 329 | toCantor = fromIntegral 330 | {-# INLINE fromCantor #-} 331 | fromCantor = fromIntegral 332 | 333 | instance Finite Word32 334 | instance Cantor Word32 where 335 | {-# INLINE cardinality #-} 336 | cardinality = Finite' $ 2 ^ (32 :: Integer) 337 | {-# INLINE toCantor #-} 338 | toCantor = fromIntegral 339 | {-# INLINE fromCantor #-} 340 | fromCantor = fromIntegral 341 | 342 | instance Finite Word64 343 | instance Cantor Word64 where 344 | {-# INLINE cardinality #-} 345 | cardinality = Finite' $ 2 ^ (64 :: Integer) 346 | {-# INLINE toCantor #-} 347 | toCantor = fromIntegral 348 | {-# INLINE fromCantor #-} 349 | fromCantor = fromIntegral 350 | 351 | instance Finite Word 352 | instance Cantor Word where 353 | {-# INLINE cardinality #-} 354 | cardinality = Finite' $ 2 ^ (finiteBitSize @Word undefined) 355 | {-# INLINE toCantor #-} 356 | toCantor = fromIntegral 357 | {-# INLINE fromCantor #-} 358 | fromCantor = fromIntegral 359 | 360 | instance Finite Char 361 | instance Cantor Char where 362 | {-# INLINE cardinality #-} 363 | cardinality = Finite' . fromIntegral $ (fromEnum (maxBound :: Char) :: Int) + 1 364 | {-# INLINE toCantor #-} 365 | toCantor x = toEnum (fromIntegral x :: Int) 366 | {-# INLINE fromCantor #-} 367 | fromCantor x = fromIntegral (fromEnum x :: Int) 368 | 369 | instance (Cantor a , Cantor b) => Cantor (a , b) 370 | instance (Cantor a , Cantor b , Cantor c) => Cantor (a , b , c) 371 | instance (Cantor a , Cantor b , Cantor c , Cantor d) => Cantor (a , b , c , d) 372 | instance (Cantor a , Cantor b , Cantor c , Cantor d , Cantor e) => Cantor (a , b , c , d , e) 373 | instance (Cantor a , Cantor b , Cantor c , Cantor d , Cantor e , Cantor f) => Cantor (a , b , c , d , e , f) 374 | instance (Cantor a , Cantor b , Cantor c , Cantor d , Cantor e , Cantor f , Cantor g) => Cantor (a , b , c , d , e , f , g) 375 | 376 | instance Cantor a => Cantor (Product a) 377 | instance Cantor a => Cantor (Sum a) 378 | instance Cantor a => Cantor (Last a) 379 | instance Cantor a => Cantor (First a) 380 | instance Cantor a => Cantor (Identity a) 381 | instance Cantor a => Cantor (Data.Functor.Const.Const a b) 382 | instance Cantor a => Cantor (Option a) 383 | instance Cantor a => Cantor (Min a) 384 | instance Cantor a => Cantor (Max a) 385 | instance Cantor (Proxy a) 386 | instance (Cantor a , Cantor b) => Cantor (Arg a b) 387 | 388 | instance Cantor a => Cantor (Maybe a) 389 | instance (Cantor a , Cantor b) => Cantor (Either a b) 390 | 391 | instance (Finite a , Finite b) => Finite (a , b) 392 | instance (Finite a , Finite b , Finite c) => Finite (a , b , c) 393 | instance (Finite a , Finite b , Finite c , Finite d) => Finite (a , b , c , d) 394 | instance (Finite a , Finite b , Finite c , Finite d , Finite e) => Finite (a , b , c , d , e) 395 | instance (Finite a , Finite b , Finite c , Finite d , Finite e , Finite f) => Finite (a , b , c , d , e , f) 396 | instance (Finite a , Finite b , Finite c , Finite d , Finite e , Finite f , Finite g) => Finite (a , b , c , d , e , f , g) 397 | 398 | instance Finite a => Finite (Product a) 399 | instance Finite a => Finite (Sum a) 400 | instance Finite a => Finite (Last a) 401 | instance Finite a => Finite (First a) 402 | instance Finite a => Finite (Identity a) 403 | instance Finite a => Finite (Data.Functor.Const.Const a b) 404 | instance Finite a => Finite (Option a) 405 | instance Finite a => Finite (Min a) 406 | instance Finite a => Finite (Max a) 407 | instance Finite (Proxy a) 408 | instance (Finite a , Finite b) => Finite (Arg a b) 409 | 410 | instance Finite a => Finite (Maybe a) 411 | instance (Finite a , Finite b) => Finite (Either a b) 412 | 413 | instance Cantor a => Cantor [ a ] 414 | instance Cantor a => Cantor (Data.Sequence.Seq a) where 415 | {-# INLINE cardinality #-} 416 | cardinality = cardinality @[ a ] 417 | toCantor = Data.Sequence.fromList . toCantor 418 | fromCantor = fromCantor . foldr (:) [] 419 | 420 | -- this algorithm is correct, but too slow for large a 421 | -- instance (Ord a , Finite a , Cantor b) => Cantor (M.Map a b) where 422 | -- cardinality = cardinality @(a -> Maybe b) 423 | -- toCantor i = m 424 | -- where 425 | -- m :: M.Map a b 426 | -- m = M.fromList $ mapMaybe (\(a,w) -> (,) a <$> w) $ zip (toCantor <$> [ 0 .. ]) (eToCantor es i) 427 | 428 | -- es :: ESpace [ Maybe b ] 429 | -- es = nary (fCardinality @a) defaultSpace 430 | 431 | -- fromCantor g = eFromCantor es . fmap (\i -> M.lookup (toCantor i) g) $ [ 0 .. (fCardinality @a - 1) ] 432 | -- where 433 | -- es :: ESpace [ Maybe b ] 434 | -- es = nary (fCardinality @a) defaultSpace 435 | 436 | -- instance (Ord a , Finite a , Finite b) => Finite (M.Map a b) 437 | 438 | -- espace for `Set (Fin c)` 439 | fSetEnum :: Huge -> ESpace (Data.Set.Set Integer) 440 | fSetEnum c = ESpace (Finite' (2 `pow` c)) t f 441 | where 442 | t :: Integer -> Data.Set.Set Integer 443 | t 0 = Data.Set.empty 444 | t m = Data.Set.fromAscList $ foldr g mempty [ 0 .. (integerLog2 m + 1) ] 445 | where 446 | g :: Int -> [ Integer ] -> [ Integer ] 447 | g i s = if testBit m i 448 | then toInteger i : s 449 | else s 450 | 451 | f :: Data.Set.Set Integer -> Integer 452 | f = foldl' g 0 453 | where 454 | g :: Integer -> Integer -> Integer 455 | g a i = setBit a (fromInteger i) 456 | 457 | instance (Ord a , Finite a) => Cantor (Data.Set.Set a) where 458 | {-# INLINE cardinality #-} 459 | cardinality = Finite' (2 `pow` fCardinality' @a) 460 | -- would be nice to map monotonic and save a log here, but that only works when 461 | -- Ord a respects the ordering on Integer, which we have no assurance of 462 | toCantor = Data.Set.map toCantor . eToCantor (fSetEnum (fCardinality' @a)) 463 | fromCantor = eFromCantor (fSetEnum (fCardinality' @a)) . Data.Set.map fromCantor 464 | 465 | instance (Ord a , Finite a) => Finite (Data.Set.Set a) 466 | 467 | -- espace for `IntSet (Fin c)`, where c is in proper range 468 | fSetEnum' :: Huge -> ESpace Data.IntSet.IntSet 469 | fSetEnum' c = ESpace (Finite' (2 `pow` c)) t f 470 | where 471 | t :: Integer -> Data.IntSet.IntSet 472 | t 0 = Data.IntSet.empty 473 | t m = Data.IntSet.fromAscList $ foldr g mempty [ 0 .. (integerLog2 m + 1) ] 474 | where 475 | g :: Int -> [ Int ] -> [ Int ] 476 | g i s = if testBit m i 477 | then i : s 478 | else s 479 | 480 | f :: Data.IntSet.IntSet -> Integer 481 | f = Data.IntSet.foldl' g 0 482 | where 483 | g :: Integer -> Int -> Integer 484 | g a i = setBit a i 485 | 486 | instance Cantor Data.IntSet.IntSet where 487 | {-# INLINE cardinality #-} 488 | cardinality = Finite' (2 `pow` fCardinality' @Int) 489 | toCantor = eToCantor (fSetEnum' (fCardinality' @Int)) 490 | fromCantor = eFromCantor (fSetEnum' (fCardinality' @Int)) 491 | 492 | instance Finite Data.IntSet.IntSet 493 | 494 | -- this algorithm is wrong; only works on Countable a. 495 | -- instance Cantor a => Cantor (Data.IntMap.Lazy.IntMap a) where 496 | -- cardinality = case cardinality @a of 497 | -- Countable -> Countable 498 | -- Finite c -> Finite $ (c + 1) ^ fCardinality @Int 499 | -- toCantor i = if i == 0 then mempty else case cantorSplit i of 500 | -- (j , k) -> Data.IntMap.Lazy.fromAscList $ zip (Data.IntSet.toAscList s) as 501 | -- where 502 | -- s :: Data.IntSet.IntSet 503 | -- s = toCantor (j + 1) 504 | 505 | -- es :: ESpace [ a ] 506 | -- es = nary (toInteger (Data.IntSet.size s)) defaultSpace 507 | 508 | -- as :: [ a ] 509 | -- as = eToCantor es k 510 | -- fromCantor m = if Data.IntMap.Lazy.null m then 0 else case unzip (Data.IntMap.Lazy.toAscList m) of 511 | -- (is , as) -> cantorUnsplit (fromCantor s , eFromCantor es as) 512 | -- where 513 | -- s = Data.IntSet.fromAscList is 514 | 515 | -- es :: ESpace [ a ] 516 | -- es = nary (toInteger (Data.IntSet.size s)) defaultSpace 517 | 518 | -- instance Finite a => Finite (Data.IntMap.Lazy.IntMap a) 519 | 520 | 521 | -- https://en.wikipedia.org/wiki/Pairing_function#Cantor_pairing_function 522 | -- adapted for integer square rooting in the w, which should yield the same result 523 | -- but benchmarks significantly faster. buuut on closer inspection that makes no sense, since 524 | -- this is exactly what arithmoi is doing anyway... 525 | -- 526 | -- also, maybe try this https://gist.github.com/orlp/3481770 527 | cantorSplit :: Integer -> (Integer , Integer) 528 | cantorSplit i = 529 | let -- original implementation (convert to/from float for the sqrt) 530 | -- w :: Int = floor (0.5 * (sqrt (8 * fromIntegral i + 1 :: Double) - 1)) 531 | t = (w^(2 :: Int) + w) `quot` 2 532 | y = i - t 533 | x = w - y 534 | in 535 | (x , y) 536 | where 537 | w = (integerSquareRoot (8 * i + 1) - 1) `div` 2 538 | 539 | cantorUnsplit :: (Integer , Integer) -> Integer 540 | cantorUnsplit (x , y) = (((x + y + 1) * (x + y)) `quot` 2) + y 541 | 542 | class GCantor s f where 543 | hasExit :: Bool 544 | gCardinality' :: Cardinality 545 | gToCantor' :: Integer -> f a 546 | gFromCantor' :: f a -> Integer 547 | 548 | instance GCantor s V1 where 549 | {-# INLINE hasExit #-} 550 | hasExit = False 551 | {-# INLINE gCardinality' #-} 552 | gCardinality' = Finite' 0 553 | gToCantor' = undefined 554 | gFromCantor' = undefined 555 | 556 | instance GCantor s U1 where 557 | {-# INLINE hasExit #-} 558 | hasExit = True 559 | {-# INLINE gCardinality' #-} 560 | gCardinality' = Finite' 1 561 | {-# INLINE gToCantor' #-} 562 | gToCantor' _ = U1 563 | {-# INLINE gFromCantor' #-} 564 | gFromCantor' _ = 0 565 | 566 | instance {-# OVERLAPPING #-} Cantor a => GCantor a (K1 i a) where 567 | {-# INLINE hasExit #-} 568 | hasExit = False 569 | {-# INLINE gCardinality' #-} 570 | gCardinality' = Countable 571 | {-# INLINE gToCantor' #-} 572 | gToCantor' = K1 . toCantor 573 | {-# INLINE gFromCantor' #-} 574 | gFromCantor' (K1 x) = fromCantor x 575 | 576 | instance {-# OVERLAPPABLE #-} Cantor b => GCantor w (K1 i b) where 577 | {-# INLINE hasExit #-} 578 | hasExit = True 579 | {-# INLINE gCardinality' #-} 580 | gCardinality' = cardinality @b 581 | {-# INLINE gToCantor' #-} 582 | gToCantor' = K1 . toCantor 583 | {-# INLINE gFromCantor' #-} 584 | gFromCantor' (K1 x) = fromCantor x 585 | 586 | instance (GCantor s a , GCantor s b) => GCantor s (a :*: b) where 587 | {-# INLINE hasExit #-} 588 | hasExit = hasExit @s @a && hasExit @s @b 589 | {-# INLINE gCardinality' #-} 590 | gCardinality' = case (gCardinality' @s @a , gCardinality' @s @b) of 591 | (Finite' i , Finite' j) -> Finite' (i * j) 592 | (Finite' 0 , _) -> Finite' 0 593 | (_ , Finite' 0) -> Finite' 0 594 | _ -> Countable 595 | 596 | {-# INLINABLE gToCantor' #-} 597 | gToCantor' i = case (gCardinality' @s @a , gCardinality' @s @b) of 598 | (Finite ca, Finite cb) -> 599 | let par_s = min ca cb -- small altitude of the parallelogram 600 | tri_l = par_s - 1 601 | tri_a = (tri_l * (tri_l + 1)) `div` 2 602 | in 603 | -- optimisation - if tri_l is 0, one or both of these is trivial and we have a line 604 | if i < tri_a 605 | then -- we're in the triangle, so just use cantor 606 | case cantorSplit i of 607 | (a , b) -> (gToCantor' @s @a a :*: gToCantor' @s @b b) 608 | else let j = i - tri_a -- shadowing would make this so much safer, alas... 609 | par_l = max ca cb - tri_l 610 | par_a = par_s * par_l in 611 | if j < par_a 612 | then -- find their coordinates in the box 613 | -- and then skew them to the real grid 614 | case divModInteger j par_s of 615 | (# l , s #) -> 616 | let c1 = (l + tri_l) - s 617 | c2 = s 618 | (a , b) = if ca <= cb 619 | then (c2 , c1) 620 | else (c1 , c2) 621 | in 622 | (gToCantor' @s @a a :*: gToCantor' @s @b b) 623 | else let k = j - par_a 624 | l = tri_a - (k + 1) in 625 | case cantorSplit l of 626 | (a , b) -> (gToCantor' @s @a (ca - (a + 1)) :*: gToCantor' @s @b (cb - (b + 1))) 627 | (Finite ca, Countable) -> 628 | let par_s = ca -- small altitude of the parallelogram 629 | tri_l = par_s - 1 630 | tri_a = (tri_l * (tri_l + 1)) `div` 2 631 | in 632 | if i < tri_a 633 | then case cantorSplit i of 634 | (a , b) -> (gToCantor' @s @a a :*: gToCantor' @s @b b) 635 | else let j = i - tri_a -- shadowing would make this so much safer, alas... 636 | in 637 | case divModInteger j par_s of 638 | (# l , s #) -> 639 | let c1 = (l + tri_l) - s 640 | c2 = s 641 | (a , b) = (c2 , c1) 642 | in 643 | (gToCantor' @s @a a :*: gToCantor' @s @b b) 644 | 645 | (Countable , Finite cb) -> 646 | let par_s = cb -- small altitude of the parallelogram 647 | tri_l = par_s - 1 648 | tri_a = (tri_l * (tri_l + 1)) `div` 2 649 | in 650 | if i < tri_a 651 | then case cantorSplit i of 652 | (a , b) -> (gToCantor' @s @a a :*: gToCantor' @s @b b) 653 | else let j = i - tri_a -- shadowing would make this so much safer, alas... 654 | in 655 | case divModInteger j par_s of 656 | (# l , s #) -> 657 | let c1 = (l + tri_l) - s 658 | c2 = s 659 | (a , b) = (c1 , c2) 660 | in 661 | (gToCantor' @s @a a :*: gToCantor' @s @b b) 662 | _ -> case cantorSplit i of 663 | (a , b) -> (gToCantor' @s @a a :*: gToCantor' @s @b b) 664 | 665 | {-# INLINABLE gFromCantor' #-} 666 | gFromCantor' (a :*: b) = case (gCardinality' @s @a , gCardinality' @s @b) of 667 | (Finite ca, Finite cb) -> 668 | let (x , y) = (gFromCantor' @s @a a , gFromCantor' @s @b b) 669 | par_s = min ca cb 670 | tri_l = par_s - 1 671 | in 672 | if y < tri_l - x 673 | then cantorUnsplit $ (x , y) 674 | else let x'' = ca - (x + 1) 675 | y'' = cb - (y + 1) 676 | in 677 | if y'' < tri_l - x'' 678 | then (ca * cb) - (cantorUnsplit (x'' , y'') + 1) 679 | else let (x' , y') = if ca <= cb 680 | then (x , y - (tri_l - x)) 681 | else (y , x - (tri_l - y)) 682 | tri_a = (tri_l * (tri_l + 1)) `div` 2 683 | in 684 | tri_a + x' + y' * par_s 685 | (Finite ca, Countable) -> 686 | let (x , y) = (gFromCantor' @s @a a , gFromCantor' @s @b b) 687 | par_s = ca 688 | tri_l = par_s - 1 689 | in 690 | if y < tri_l - x 691 | then cantorUnsplit $ (x , y) 692 | else let (x' , y') = (x , y - (tri_l - x)) 693 | tri_a = (tri_l * (tri_l + 1)) `div` 2 694 | in 695 | tri_a + x' + y' * par_s 696 | (Countable, Finite cb) -> 697 | let (x , y) = (gFromCantor' @s @a a , gFromCantor' @s @b b) 698 | par_s = cb 699 | tri_l = par_s - 1 700 | in 701 | if y < tri_l - x 702 | then cantorUnsplit $ (x , y) 703 | else let (x' , y') = (y , x - (tri_l - y)) 704 | tri_a = (tri_l * (tri_l + 1)) `div` 2 705 | in 706 | tri_a + x' + y' * par_s 707 | _ -> cantorUnsplit (gFromCantor' @s @a a , gFromCantor' @s @b b) 708 | 709 | 710 | -- in this instance, make sure we head towards the exit if there is one, otherwise we can get 711 | -- stuck endlessly in the labyrinth 712 | instance (GCantor s a , GCantor s b) => GCantor s (a :+: b) where 713 | {-# INLINE hasExit #-} 714 | hasExit = hasExit @s @a || hasExit @s @b 715 | {-# INLINE gCardinality' #-} 716 | gCardinality' = case (gCardinality' @s @a , gCardinality' @s @b) of 717 | (Finite' i , Finite' j) -> Finite' (i + j) 718 | _ -> Countable 719 | 720 | {-# INLINABLE gToCantor' #-} 721 | gToCantor' i = case (gCardinality' @s @a , gCardinality' @s @b) of 722 | (Finite ca, Finite cb) -> if i < 2 * min ca cb 723 | then case divModInteger i 2 of 724 | (# k , 0 #) -> L1 $ gToCantor' @s @a k 725 | (# k , _ #) -> R1 $ gToCantor' @s @b k 726 | else if ca > cb 727 | then L1 $ gToCantor' @s @a (i - cb) 728 | else R1 $ gToCantor' @s @b (i - ca) 729 | (Finite ca, Countable) -> if i < 2 * ca 730 | then case divModInteger i 2 of 731 | (# k , 0 #) -> L1 $ gToCantor' @s @a k 732 | (# k , _ #) -> R1 $ gToCantor' @s @b k 733 | else R1 $ gToCantor' @s @b (i - ca) 734 | (Countable , Finite{}) -> case gToCantor' @s @(b :+: a) i of 735 | L1 x -> R1 x 736 | R1 x -> L1 x 737 | _ -> if not (hasExit @s @a) && hasExit @s @b 738 | then case gToCantor' @s @(b :+: a) i of 739 | L1 x -> R1 x 740 | R1 x -> L1 x 741 | else case divModInteger i 2 of 742 | (# k , 0 #) -> L1 $ gToCantor' @s @a k 743 | (# k , _ #) -> R1 $ gToCantor' @s @b k 744 | 745 | {-# INLINABLE gFromCantor' #-} 746 | gFromCantor' (L1 x) = case gCardinality' @s @b of 747 | Finite' cb -> case gCardinality' @s @a of 748 | Countable -> gFromCantor' @s @(b :+: a) $ R1 x 749 | _ -> case gFromCantor' @s @a x of 750 | 0 -> 0 751 | i -> i + evalWith (^) (min cb (fromInteger i)) 752 | Countable -> case gCardinality' @s @a of 753 | Countable -> if not (hasExit @s @a) && hasExit @s @b 754 | then gFromCantor' @s @(b :+: a) $ R1 x 755 | else case gFromCantor' @s @a x of 756 | 0 -> 0 757 | i -> 2 * i 758 | _ -> case gFromCantor' @s @a x of 759 | 0 -> 0 760 | i -> 2 * i 761 | gFromCantor' (R1 x) = case gCardinality' @s @a of 762 | Finite' ca -> case gFromCantor' @s @b x of 763 | 0 -> 1 764 | i -> i + evalWith (^) (min ca (fromInteger (i + 1))) 765 | Countable -> case gCardinality' @s @b of 766 | Finite{} -> gFromCantor' @s @(b :+: a) $ L1 x 767 | Countable -> if not (hasExit @s @a) && hasExit @s @b 768 | then gFromCantor' @s @(b :+: a) $ L1 x 769 | else case gFromCantor' @s @b x of 770 | 0 -> 1 771 | i -> 2 * i + 1 772 | 773 | instance GCantor s f => GCantor s (M1 i t f) where 774 | {-# INLINE hasExit #-} 775 | hasExit = hasExit @s @f 776 | 777 | {-# INLINE gCardinality' #-} 778 | gCardinality' = gCardinality' @s @f 779 | 780 | {-# INLINE gToCantor' #-} 781 | gToCantor' = M1 . gToCantor' @s @f 782 | 783 | {-# INLINE gFromCantor' #-} 784 | gFromCantor' (M1 x) = gFromCantor' @s @f x 785 | -------------------------------------------------------------------------------- /src/Cantor/Huge.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Cantor.Huge 3 | -- Copyright: (c) 2020 Andrew Lelechenko 4 | -- Licence: MIT 5 | -- Maintainer: Andrew Lelechenko 6 | 7 | {-# LANGUAGE LambdaCase #-} 8 | 9 | module Cantor.Huge 10 | ( Huge 11 | , pow 12 | , evalWith 13 | ) where 14 | 15 | import Prelude hiding ((^^)) 16 | import Control.Exception 17 | import Math.NumberTheory.Logarithms 18 | import Math.NumberTheory.Roots 19 | import Numeric.Natural 20 | 21 | -- | Lazy huge numbers with an efficient 'Ord' instance. 22 | data Huge 23 | = Nat Natural 24 | | Add Huge Huge 25 | | Mul Huge Huge 26 | | Pow Huge Huge 27 | 28 | instance Show Huge where 29 | show = \case 30 | Nat n -> show n 31 | Add x y -> "(" ++ show x ++ " + " ++ show y ++ ")" 32 | Mul x y -> "(" ++ show x ++ " * " ++ show y ++ ")" 33 | Pow x y -> "(" ++ show x ++ " ^ " ++ show y ++ ")" 34 | 35 | instance Num Huge where 36 | (+) = add 37 | (*) = mul 38 | abs = id 39 | signum = const 1 40 | negate = throw Underflow 41 | fromInteger = Nat . fromInteger 42 | 43 | {-# RULES "Huge/pow" forall x p. x ^ p = x `pow` p #-} 44 | 45 | add :: Huge -> Huge -> Huge 46 | add (Nat 0) y = y 47 | add x (Nat 0) = x 48 | -- add (Nat x) (Nat y) = Nat $ x + y 49 | add x y = Add x y 50 | 51 | mul :: Huge -> Huge -> Huge 52 | mul (Nat 0) _ = Nat 0 53 | mul _ (Nat 0) = Nat 0 54 | mul (Nat 1) y = y 55 | mul x (Nat 1) = x 56 | -- mul (Nat x) (Nat y) = Nat $ x * y 57 | mul x y = Mul x y 58 | 59 | -- | Exponentiation. 60 | pow :: Huge -> Huge -> Huge 61 | pow _ (Nat 0) = Nat 1 62 | pow (Nat 0) _ = Nat 0 63 | pow x (Nat 1) = x 64 | pow (Nat 1) _ = Nat 1 65 | pow x y = Pow x y 66 | 67 | -- | Convert 'Huge' to another numeric type, 68 | -- using provided function for exponentiation. 69 | evalWith :: Num a => (a -> a -> a) -> Huge -> a 70 | evalWith (^^) = go 71 | where 72 | go = \case 73 | Nat n -> fromIntegral n 74 | Add x y -> go x + go y 75 | Mul x y -> go x * go y 76 | Pow x y -> go x ^^ go y 77 | 78 | -- | Simply 'evalWith' '(^)'. 79 | eval :: Huge -> Natural 80 | eval = evalWith (^) 81 | 82 | instance Eq Huge where 83 | x == y = x `compare` y == EQ 84 | 85 | instance Ord Huge where 86 | x `compare` y = x `compareHuge` y 87 | 88 | -- Assuming the second argument has been constructed 89 | -- using smart constructors. 90 | compareNat :: Natural -> Huge -> Ordering 91 | compareNat m = go 92 | where 93 | go = \case 94 | Nat n -> m `compare` n 95 | Add x y 96 | | Nat n <- x -> if m < n then LT else (m - n) `compareNat` y 97 | | Nat n <- y -> if m < n then LT else (m - n) `compareNat` x 98 | | go x == LT -> LT 99 | | go y == LT -> LT 100 | | x <= y -> (m - eval x) `compareNat` y 101 | | otherwise -> (m - eval y) `compareNat` x 102 | Mul x y 103 | | Nat n <- x -> if m < n then LT else unwrap quotPerf m n y 104 | | Nat n <- y -> if m < n then LT else unwrap quotPerf m n x 105 | | go x /= GT -> LT 106 | | go y /= GT -> LT 107 | | x <= y -> unwrap quotPerf m (eval x) y 108 | | otherwise -> unwrap quotPerf m (eval y) x 109 | Pow x y 110 | | Nat n <- x -> if m < n then LT else unwrap logPerf m n y 111 | | Nat n <- y -> if m < n then LT else unwrap rootPerf m n x 112 | | go x /= GT -> LT 113 | | go y /= GT -> LT 114 | | x <= y -> unwrap logPerf m (eval x) y 115 | | otherwise -> unwrap rootPerf m (eval y) x 116 | 117 | data Perfectness = Perfect | Imperfect 118 | deriving (Eq, Ord, Show) 119 | 120 | unwrap 121 | :: (Natural -> Natural -> (Natural, Perfectness)) 122 | -> Natural 123 | -> Natural 124 | -> Huge 125 | -> Ordering 126 | unwrap f m n y = case m `f` n of 127 | (q, r) -> q `compareNat` y <> (r `compare` Perfect) 128 | 129 | quotPerf :: Natural -> Natural -> (Natural, Perfectness) 130 | quotPerf m x = (q, r) 131 | where 132 | q = m `quot` x 133 | r = if q * x == m then Perfect else Imperfect 134 | 135 | rootPerf :: Natural -> Natural -> (Natural, Perfectness) 136 | rootPerf m x = (q, r) 137 | where 138 | q = integerRoot x m 139 | r = if q ^ x == m then Perfect else Imperfect 140 | 141 | logPerf :: Natural -> Natural -> (Natural, Perfectness) 142 | logPerf m x = (fromIntegral q, r) 143 | where 144 | q = naturalLogBase x m 145 | r = if x ^ q == m then Perfect else Imperfect 146 | 147 | inverse :: Ordering -> Ordering 148 | inverse = \case 149 | LT -> GT 150 | EQ -> EQ 151 | GT -> LT 152 | 153 | -- Assuming both arguments have been constructed 154 | -- using smart constructors. 155 | compareHuge :: Huge -> Huge -> Ordering 156 | Nat m `compareHuge` z = compareNat m z 157 | z `compareHuge` Nat m = inverse $ compareNat m z 158 | Add x y `compareHuge` Add u v = compareAddAdd x y u v 159 | Add x y `compareHuge` Mul u v = compareAscNodes Add Mul x y u v 160 | Add x y `compareHuge` Pow u v = compareAscNodes Add Pow x y u v 161 | Mul x y `compareHuge` Add u v = inverse $ compareAscNodes Add Mul u v x y 162 | Mul x y `compareHuge` Mul u v = compareMulMul x y u v 163 | Mul x y `compareHuge` Pow u v = compareAscNodes Mul Pow x y u v 164 | Pow x y `compareHuge` Add u v = inverse $ compareAscNodes Add Pow u v x y 165 | Pow x y `compareHuge` Mul u v = inverse $ compareAscNodes Mul Pow u v x y 166 | Pow x y `compareHuge` Pow u v = comparePowPow x y u v 167 | 168 | -- Compare Add vs. Mul, Add vs. Pow or Mul vs. Pow, 169 | -- but not vice versa. 170 | compareAscNodes 171 | :: (Huge -> Huge -> Huge) 172 | -> (Huge -> Huge -> Huge) 173 | -> Huge 174 | -> Huge 175 | -> Huge 176 | -> Huge 177 | -> Ordering 178 | compareAscNodes fxy fuv x y u v = 179 | case (x `compare` u, x `compare` v, y `compare` u, y `compare` v) of 180 | (LT, _, _, LT) -> LT 181 | ( _, LT, LT, _) -> LT 182 | 183 | (GT, GT, _, _) -> uvSimpler 184 | (GT, _, _, GT) -> uvSimpler 185 | ( _, GT, GT, _) -> uvSimpler 186 | ( _, _, GT, GT) -> uvSimpler 187 | 188 | (LT, _, LT, _) -> xySimpler 189 | (LT, _, EQ, _) -> xySimpler 190 | (EQ, _, LT, _) -> xySimpler 191 | (EQ, _, EQ, _) -> xySimpler 192 | 193 | ( _, LT, _, LT) -> xySimpler 194 | ( _, LT, _, EQ) -> xySimpler 195 | ( _, EQ, _, LT) -> xySimpler 196 | ( _, EQ, _, EQ) -> xySimpler 197 | where 198 | uvSimpler = inverse $ compareNat (eval (fuv u v)) (fxy x y) 199 | xySimpler = compareNat (eval (fxy x y)) (fuv u v) 200 | 201 | compareAddAdd :: Huge -> Huge -> Huge -> Huge -> Ordering 202 | compareAddAdd x y u v = 203 | case (x `compare` u, x `compare` v, y `compare` u, y `compare` v) of 204 | (EQ, _, _, yv) -> yv 205 | ( _, EQ, yu, _) -> yu 206 | ( _, xv, EQ, _) -> xv 207 | (xu, _, _, EQ) -> xu 208 | 209 | (GT, _, _, GT) -> GT 210 | ( _, GT, GT, _) -> GT 211 | (LT, _, _, LT) -> LT 212 | ( _, LT, LT, _) -> LT 213 | 214 | -- x > u > y, x > v > y 215 | (GT, GT, LT, LT) 216 | | u <= v -> x `compare` Add (Nat (eval u - eval y)) v 217 | | otherwise -> x `compare` Add u (Nat (eval v - eval y)) 218 | -- y > u > x, y > v > x 219 | (LT, LT, GT, GT) 220 | | u <= v -> y `compare` Add (Nat (eval u - eval x)) v 221 | | otherwise -> y `compare` Add u (Nat (eval v - eval x)) 222 | -- u > x > v, u > y > v 223 | (LT, GT, LT, GT) 224 | | x <= y -> Add (Nat (eval x - eval v)) y `compare` u 225 | | otherwise -> Add x (Nat (eval y - eval v)) `compare` u 226 | -- v > x > u, v > y > u 227 | (GT, LT, GT, LT) 228 | | x <= y -> Add (Nat (eval x - eval u)) y `compare` v 229 | | otherwise -> Add x (Nat (eval y - eval u)) `compare` v 230 | 231 | compareMulMul :: Huge -> Huge -> Huge -> Huge -> Ordering 232 | compareMulMul x y u v = 233 | case (x `compare` u, x `compare` v, y `compare` u, y `compare` v) of 234 | (EQ, _, _, yv) -> yv 235 | ( _, EQ, yu, _) -> yu 236 | ( _, xv, EQ, _) -> xv 237 | (xu, _, _, EQ) -> xu 238 | 239 | (GT, _, _, GT) -> GT 240 | ( _, GT, GT, _) -> GT 241 | (LT, _, _, LT) -> LT 242 | ( _, LT, LT, _) -> LT 243 | 244 | (GT, GT, LT, LT) -> uvSimpler 245 | (LT, LT, GT, GT) -> uvSimpler 246 | (LT, GT, LT, GT) -> xySimpler 247 | (GT, LT, GT, LT) -> xySimpler 248 | where 249 | uvSimpler = inverse $ compareNat (eval (Mul u v)) (Mul x y) 250 | xySimpler = compareNat (eval (Mul x y)) (Mul u v) 251 | 252 | comparePowPow :: Huge -> Huge -> Huge -> Huge -> Ordering 253 | comparePowPow x y u v = case (x `compare` u, y `compare` v) of 254 | (EQ, yv) -> yv 255 | (xu, EQ) -> xu 256 | (LT, LT) -> LT 257 | (GT, GT) -> GT 258 | (LT, GT) -> inverse $ compareNat (eval (Pow u v)) (Pow x y) 259 | (GT, LT) -> compareNat (eval (Pow x y)) (Pow u v) 260 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | 8 | {-# OPTIONS_GHC -fno-warn-orphans #-} 9 | 10 | import Data.Void 11 | import GHC.Generics (Generic) 12 | import Test.Hspec 13 | 14 | import Cantor 15 | 16 | 17 | data TreeL a = NodeL | BranchL (TreeL a) a (TreeL a) deriving (Generic,Eq) 18 | 19 | instance Cantor a => Cantor (TreeL a) 20 | 21 | data TreeR a = BranchR (TreeR a) a (TreeR a) | NodeR deriving (Generic,Eq) 22 | 23 | instance Cantor a => Cantor (TreeR a) 24 | 25 | 26 | instance (Finite a , Cantor b) => Eq (a -> b) where 27 | (==) f g = fmap (fromCantor . f) cantorEnumeration == fmap (fromCantor . g) cantorEnumeration 28 | 29 | data C = R | G | B deriving (Generic,Eq,Ord,Show,Cantor,Finite) 30 | 31 | 32 | main :: IO () 33 | main = hspec $ do 34 | describe "cardinality" $ do 35 | it "returns 3 for the cardinality of C" $ do 36 | (fCardinality @C) `shouldBe` 3 37 | 38 | it "returns 9 for the cardinality of C x C" $ 39 | (fCardinality @(C , C)) `shouldBe` 9 40 | 41 | it "returns 6 for the cardinality of Bool x C" $ 42 | (fCardinality @(Bool , C)) `shouldBe` 6 43 | 44 | it "returns 6 for the cardinality of C x Bool" $ 45 | (fCardinality @(C , Bool)) `shouldBe` 6 46 | 47 | it "returns 0 for the cardinality of Void x Bool" $ 48 | (fCardinality @(Void , Bool)) `shouldBe` 0 49 | 50 | it "returns 0 for the cardinality of Bool x Void" $ 51 | (fCardinality @(Bool , Void)) `shouldBe` 0 52 | 53 | it "returns Countable for the cardinality of Bool x Integer" $ 54 | (cardinality @(Bool , Integer)) `shouldBe` Countable 55 | 56 | it "returns Countable for the cardinality of Integer x Bool" $ 57 | (cardinality @(Integer , Bool)) `shouldBe` Countable 58 | 59 | it "returns Finite 0 for the cardinality of Void x Integer" $ 60 | (cardinality @(Void , Integer)) `shouldBe` Finite 0 61 | 62 | it "returns Finite 0 for the cardinality of Integer x Void" $ 63 | (cardinality @(Integer , Void)) `shouldBe` Finite 0 64 | 65 | it "returns 8 for the cardinality of (C -> Bool)" $ 66 | (fCardinality @(C -> Bool)) `shouldBe` 8 67 | 68 | it "returns 9 for the cardinality of (Bool -> C)" $ 69 | (fCardinality @(Bool -> C)) `shouldBe` 9 70 | 71 | it "returns Countable for the cardinality of (Bool -> Integer)" $ 72 | (cardinality @(Bool -> Integer)) `shouldBe` Countable 73 | 74 | it "returns Countable for the cardinality of [ C ]" $ 75 | (cardinality @([ C ])) `shouldBe` Countable 76 | 77 | 78 | describe "uniqueness and isomorphism for finite types" $ do 79 | it "for C" $ 80 | (fcheckUISO @C) `shouldBe` True 81 | 82 | it "for C x Bool" $ 83 | (fcheckUISO @(C , Bool)) `shouldBe` True 84 | 85 | it "for Bool x C" $ 86 | (fcheckUISO @(Bool , C)) `shouldBe` True 87 | 88 | it "for (Bool x Bool) x C" $ 89 | (fcheckUISO @((Bool , Bool) , C)) `shouldBe` True 90 | 91 | it "for Void x C" $ 92 | (fcheckUISO @(Void , C)) `shouldBe` True 93 | 94 | it "for C x Void" $ 95 | (fcheckUISO @(C , Void)) `shouldBe` True 96 | 97 | it "for C -> Bool" $ 98 | (fcheckUISO @(C -> Bool)) `shouldBe` True 99 | 100 | it "for Bool -> C" $ 101 | (fcheckUISO @(Bool -> C)) `shouldBe` True 102 | 103 | describe "uniqueness and isomorphism for countable types" $ do 104 | it "for C x Integer" $ 105 | (checkUISO @(C , Integer)) `shouldBe` True 106 | 107 | it "for Integer x C" $ 108 | (checkUISO @(C , Integer)) `shouldBe` True 109 | 110 | it "for Integer x Integer" $ 111 | (checkUISO @(Integer , Integer)) `shouldBe` True 112 | 113 | it "for C -> Integer" $ 114 | (checkUISO @(C -> Integer)) `shouldBe` True 115 | 116 | it "for [ C -> Integer ]" $ 117 | (checkUISO @([ (C -> Integer) ])) `shouldBe` True 118 | 119 | it "for TreeL Bool" $ 120 | (checkUISO @(TreeL Bool)) `shouldBe` True 121 | 122 | it "for TreeR Bool" $ 123 | (checkUISO @(TreeR Bool)) `shouldBe` True 124 | 125 | describe "function enumeration even for large domains" $ do 126 | it "should be fast" $ 127 | (head (cantorEnumeration @(Word -> Int)) 42173) `shouldBe` 0 128 | where 129 | fcheckUISO :: forall a . (Eq a , Finite a) => Bool 130 | fcheckUISO = e == fmap (toCantor . fromCantor) e 131 | where 132 | e :: [ a ] 133 | e = cantorEnumeration 134 | 135 | checkUISO :: forall a . (Eq a , Cantor a) => Bool 136 | checkUISO = e == fmap (toCantor . fromCantor) e 137 | where 138 | e :: [ a ] 139 | e = take 5000 cantorEnumeration 140 | --------------------------------------------------------------------------------