├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── notes.org ├── simple-enumeration.cabal ├── src └── Data │ ├── CoEnumeration.hs │ ├── Enumeration.hs │ ├── Enumeration │ ├── Invertible.hs │ └── Sized.hs │ └── ProEnumeration.hs ├── stack.yaml └── test └── doctests.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'simple-enumeration.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250330 12 | # 13 | # REGENDATA ("0.19.20250330",["github","simple-enumeration.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-24.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.12.1 32 | compilerKind: ghc 33 | compilerVersion: 9.12.1 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.10.1 37 | compilerKind: ghc 38 | compilerVersion: 9.10.1 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.8.4 42 | compilerKind: ghc 43 | compilerVersion: 9.8.4 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.6.6 47 | compilerKind: ghc 48 | compilerVersion: 9.6.6 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.4.8 52 | compilerKind: ghc 53 | compilerVersion: 9.4.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | fail-fast: false 57 | steps: 58 | - name: apt-get install 59 | run: | 60 | apt-get update 61 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 62 | - name: Install GHCup 63 | run: | 64 | mkdir -p "$HOME/.ghcup/bin" 65 | curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" 66 | chmod a+x "$HOME/.ghcup/bin/ghcup" 67 | - name: Install cabal-install 68 | run: | 69 | "$HOME/.ghcup/bin/ghcup" install cabal 3.14.1.1-p1 || (cat "$HOME"/.ghcup/logs/*.* && false) 70 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.1.1-p1 -vnormal+nowrap" >> "$GITHUB_ENV" 71 | - name: Install GHC (GHCup) 72 | if: matrix.setup-method == 'ghcup' 73 | run: | 74 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 75 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 76 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 77 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 78 | echo "HC=$HC" >> "$GITHUB_ENV" 79 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 80 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 81 | env: 82 | HCKIND: ${{ matrix.compilerKind }} 83 | HCNAME: ${{ matrix.compiler }} 84 | HCVER: ${{ matrix.compilerVersion }} 85 | - name: Set PATH and environment variables 86 | run: | 87 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 88 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 89 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 90 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 91 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 92 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 93 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 94 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 95 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 96 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 97 | env: 98 | HCKIND: ${{ matrix.compilerKind }} 99 | HCNAME: ${{ matrix.compiler }} 100 | HCVER: ${{ matrix.compilerVersion }} 101 | - name: env 102 | run: | 103 | env 104 | - name: write cabal config 105 | run: | 106 | mkdir -p $CABAL_DIR 107 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 140 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 141 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 142 | rm -f cabal-plan.xz 143 | chmod a+x $HOME/.cabal/bin/cabal-plan 144 | cabal-plan --version 145 | - name: checkout 146 | uses: actions/checkout@v4 147 | with: 148 | path: source 149 | - name: initial cabal.project for sdist 150 | run: | 151 | touch cabal.project 152 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 153 | cat cabal.project 154 | - name: sdist 155 | run: | 156 | mkdir -p sdist 157 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 158 | - name: unpack 159 | run: | 160 | mkdir -p unpacked 161 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 162 | - name: generate cabal.project 163 | run: | 164 | PKGDIR_simple_enumeration="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/simple-enumeration-[0-9.]*')" 165 | echo "PKGDIR_simple_enumeration=${PKGDIR_simple_enumeration}" >> "$GITHUB_ENV" 166 | rm -f cabal.project cabal.project.local 167 | touch cabal.project 168 | touch cabal.project.local 169 | echo "packages: ${PKGDIR_simple_enumeration}" >> cabal.project 170 | echo "package simple-enumeration" >> cabal.project 171 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 172 | cat >> cabal.project <> cabal.project.local 175 | cat cabal.project 176 | cat cabal.project.local 177 | - name: dump install plan 178 | run: | 179 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 180 | cabal-plan 181 | - name: restore cache 182 | uses: actions/cache/restore@v4 183 | with: 184 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 185 | path: ~/.cabal/store 186 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 187 | - name: install dependencies 188 | run: | 189 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 190 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 191 | - name: build w/o tests 192 | run: | 193 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 194 | - name: build 195 | run: | 196 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 197 | - name: tests 198 | run: | 199 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 200 | - name: cabal check 201 | run: | 202 | cd ${PKGDIR_simple_enumeration} || false 203 | ${CABAL} -vnormal check 204 | - name: haddock 205 | run: | 206 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 207 | - name: unconstrained build 208 | run: | 209 | rm -f cabal.project.local 210 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 211 | - name: save cache 212 | if: always() 213 | uses: actions/cache/save@v4 214 | with: 215 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 216 | path: ~/.cabal/store 217 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | stack.yaml.lock 3 | *~ 4 | dist-newstyle/ 5 | dist/ 6 | TAGS 7 | cabal.project.local 8 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for enumeration 2 | 3 | ## 0.3 (22 April 2025) 4 | 5 | - Fix `Enumeration.listOf empty` to return singleton list containing 6 | empty list instead of empty list (thanks to Koji Miyazato) 7 | - New modules `Data.ProEnumeration` and `Data.CoEnumeration` (thanks 8 | to Koji Miyazato) 9 | - Test up through GHC 9.12 10 | 11 | ## 0.2.1 (25 June 2020) 12 | 13 | [Make `Data.Enumeration.Invertible.functionOf` a bit more permissive.](https://github.com/byorgey/enumeration/commit/59090f46ce01d7eda7371ba673fe54763b96c97e) 14 | 15 | ## 0.2 (3 July 2019) 16 | 17 | Added `Data.Enumeration.Invertible`. 18 | 19 | ## 0.1 (14 May 2019) 20 | 21 | Initial release. 22 | 23 | ## Unreleased changes 24 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2019 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![CI](https://github.com/byorgey/enumeration/workflows/CI/badge.svg) 2 | 3 | # Lightweight, efficiently indexable enumerations 4 | 5 | This package defines a type of *enumerations*, along with combinators 6 | for building and manipulating them. An enumeration is a finite or 7 | countably infinite sequence of values, represented as a function from 8 | an index to a value. Hence it is possible to work with even very large 9 | finite sets. Enumerations also naturally support (uniform) random 10 | sampling. 11 | 12 | Note the goal of this package is *not* to enumerate values of Haskell 13 | types; there already exist many other packages to do that. Rather, 14 | the goal is simply to provide an abstract framework for working with 15 | enumerations of any values at all. 16 | 17 | See the documentation for examples; see the [announcement blog 18 | post](https://byorgey.wordpress.com/2019/05/14/lightweight-efficiently-sampleable-enumerations-in-haskell/) 19 | for additional examples and discussion. 20 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /notes.org: -------------------------------------------------------------------------------- 1 | Other similar-ish packages: 2 | 3 | http://hackage.haskell.org/package/universe and friends 4 | http://hackage.haskell.org/package/enumerate 5 | http://hackage.haskell.org/package/enumerate-function 6 | http://hackage.haskell.org/package/enumerable 7 | http://hackage.haskell.org/package/size-based 8 | http://hackage.haskell.org/package/enumeration 9 | 10 | -------------------------------------------------------------------------------- /simple-enumeration.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | name: simple-enumeration 4 | version: 0.3 5 | synopsis: Finite or countably infinite sequences of values. 6 | description: Finite or countably infinite sequences of values, 7 | supporting efficient indexing and random sampling. 8 | category: Data 9 | homepage: https://github.com/byorgey/enumeration#readme 10 | bug-reports: https://github.com/byorgey/enumeration/issues 11 | author: Brent Yorgey 12 | maintainer: byorgey@gmail.com 13 | copyright: 2019 Brent Yorgey 14 | license: BSD3 15 | license-file: LICENSE 16 | build-type: Simple 17 | extra-source-files: 18 | README.md 19 | ChangeLog.md 20 | tested-with: GHC ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.1 || ==9.12.1 21 | 22 | source-repository head 23 | type: git 24 | location: https://github.com/byorgey/enumeration 25 | 26 | library 27 | exposed-modules: Data.Enumeration 28 | Data.Enumeration.Invertible 29 | Data.CoEnumeration 30 | Data.ProEnumeration 31 | hs-source-dirs: src 32 | build-depends: base >=4.7 && <5, integer-gmp, contravariant 33 | default-language: Haskell2010 34 | 35 | test-suite doctests 36 | type: exitcode-stdio-1.0 37 | main-is: doctests.hs 38 | hs-source-dirs: test 39 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 40 | build-depends: 41 | base >=4.7 && <5, doctest >= 0.8 42 | default-language: Haskell2010 43 | -------------------------------------------------------------------------------- /src/Data/CoEnumeration.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | -- SPDX-License-Identifier: BSD-3-Clause 8 | 9 | ----------------------------------------------------------------------------- 10 | -- | 11 | -- Module : Data.CoEnumeration 12 | -- Copyright : Brent Yorgey, Koji Miyazato 13 | -- Maintainer : byorgey@gmail.com 14 | -- 15 | -- A /coenumeration/ is a function from values to finite or countably infinite 16 | -- sets, canonically represented by non-negative integers less than its cardinality. 17 | -- 18 | -- Alternatively, a coenumeration can be thought of as a classification of values 19 | -- into finite or countably infinite classes, with each class labelled with 20 | -- integers. 21 | -- 22 | -- This module provides many ways to construct @CoEnumeration@ values, 23 | -- and most of them are implemented as inverses of enumerations made with 24 | -- functions in "Data.Enumeration". 25 | -- 26 | -- == Example 27 | -- 28 | -- Through examples of this module, "Data.Enumeration" module is 29 | -- referred by alias @E@. 30 | -- 31 | -- > import qualified Data.Enumeration as E 32 | -- 33 | -- >>> take 5 . drop 5 $ E.enumerate (E.listOf E.nat) 34 | -- [[1,0],[2],[0,1],[1,0,0],[2,0]] 35 | -- >>> locate (listOf nat) <$> [[1,0],[2],[0,1],[1,0,0],[2,0]] 36 | -- [5,6,7,8,9] 37 | -- 38 | -- >>> locate (listOf nat) [3,1,4,1,5,9,2] 39 | -- 78651719792187121765701606023038613403478037124236785850350 40 | -- >>> E.select (E.listOf E.nat) 78651719792187121765701606023038613403478037124236785850350 41 | -- [3,1,4,1,5,9,2] 42 | module Data.CoEnumeration 43 | ( -- * Coenumerations 44 | CoEnumeration(), card, locate, isFinite 45 | , unsafeMkCoEnumeration 46 | 47 | -- * Cardinality and Index 48 | , Index, Cardinality(..) 49 | 50 | -- * Primitive coenumerations 51 | , unit, lost 52 | , boundedEnum 53 | , nat 54 | , int 55 | , cw 56 | , rat 57 | 58 | -- * Coenumeration combinators 59 | , takeC, dropC, modulo, overlayC 60 | , infinite 61 | , (><), (<+>) 62 | , maybeOf, eitherOf, listOf, finiteSubsetOf 63 | , finiteFunctionOf 64 | 65 | -- * Utilities 66 | , unList, unSet 67 | ) where 68 | 69 | import Data.Void 70 | import Data.Bits 71 | import Data.List (foldl') 72 | import Data.Ratio 73 | 74 | import Data.Functor.Contravariant 75 | import Data.Functor.Contravariant.Divisible(lost, Divisible(..), Decidable(..)) 76 | 77 | import Data.Enumeration (Index, Cardinality(..)) 78 | import Data.Enumeration.Invertible (undiagonal) 79 | 80 | 81 | ------------------------------------------------------------ 82 | -- Setup for doctest examples 83 | ------------------------------------------------------------ 84 | 85 | -- $setup 86 | -- >>> :set -XTypeApplications 87 | -- >>> import qualified Data.Enumeration as E 88 | 89 | -- | A /coenumeration/ is a function from values to finite or countably infinite 90 | -- sets, canonically represented by non-negative integers less than its cardinality. 91 | -- 92 | -- Alternatively, a coenumeration can be thought of as a classification of values 93 | -- into finite or countably infinite classes, with each class labelled with 94 | -- integers. 95 | -- 96 | -- 'CoEnumeration' is an instance of the following type classes: 97 | -- 98 | -- * 'Contravariant' (you can change the type of base values contravariantly) 99 | -- * 'Divisible' (representing Cartesian product of finite number of coenumerations) 100 | -- 101 | -- * Binary cartesian product ('><') 102 | -- * Coenumeration onto singleton set as an unit ('unit') 103 | -- 104 | -- * 'Decidable' (representing disjoint union of finite number of coenumerations) 105 | -- 106 | -- * Binary disjoint union ('<+>') 107 | -- * Coenumeration of uninhabited type 'Void'. It's not exported directly, 108 | -- but only through a method of the class 109 | -- 110 | -- 'lose' @:: Decidable f => (a -> Void) -> f Void@ 111 | -- 112 | -- or 113 | -- 114 | -- 'lost' @:: Decidable f => f Void@. 115 | data CoEnumeration a = CoEnumeration 116 | { -- | Get the cardinality of a coenumeration. 117 | -- Under \"classification\" interpretation, 118 | -- it is the cardinality of the set of classes. 119 | card :: Cardinality 120 | 121 | -- | Compute the index of a particular value. 122 | , locate :: a -> Index 123 | } 124 | 125 | -- | Returns if the the cardinality of coenumeration is finite. 126 | isFinite :: CoEnumeration a -> Bool 127 | isFinite = (Infinite /=) . card 128 | 129 | -- | Constructs a coenumeration. 130 | -- 131 | -- To construct valid coenumeration by @unsafeMkCoEnumeration n f@, 132 | -- for all @x :: a@, it must satisfy @(Finite (f x) < n)@. 133 | -- 134 | -- This functions does not (and never could) check the validity 135 | -- of its arguments. 136 | unsafeMkCoEnumeration :: Cardinality -> (a -> Index) -> CoEnumeration a 137 | unsafeMkCoEnumeration = CoEnumeration 138 | 139 | instance Contravariant CoEnumeration where 140 | contramap f e = e{ locate = locate e . f } 141 | 142 | -- | Associativity of 'divide' is maintained only when 143 | -- arguments are finite. 144 | instance Divisible CoEnumeration where 145 | divide f a b = contramap f $ a >< b 146 | conquer = unit 147 | 148 | -- | Associativity of 'choose' is maintained only when 149 | -- arguments are finite. 150 | instance Decidable CoEnumeration where 151 | choose f a b = contramap f $ a <+> b 152 | lose f = contramap f void 153 | 154 | -- | Coenumeration to the singleton set. 155 | -- 156 | -- >>> card unit 157 | -- Finite 1 158 | -- >>> locate unit True 159 | -- 0 160 | -- >>> locate unit (3 :: Int) 161 | -- 0 162 | -- >>> locate unit (cos :: Float -> Float) 163 | -- 0 164 | unit :: CoEnumeration a 165 | unit = CoEnumeration{ card = 1, locate = const 0 } 166 | 167 | -- | Coenumeration of an uninhabited type 'Void'. 168 | -- 169 | -- >>> card void 170 | -- Finite 0 171 | -- 172 | -- Note that when a coenumeration of a type @t@ has cardinality 0, 173 | -- it should indicate /No/ value of @t@ can be created without 174 | -- using bottoms like @undefined@. 175 | void :: CoEnumeration Void 176 | void = CoEnumeration{ card = 0, locate = const (error "locate void") } 177 | 178 | -- | An inverse of forward 'E.boundedEnum' 179 | boundedEnum :: forall a. (Enum a, Bounded a) => CoEnumeration a 180 | boundedEnum = CoEnumeration{ card = size, locate = loc } 181 | where loc = toInteger . subtract lo . fromEnum 182 | lo = fromEnum (minBound @a) 183 | hi = fromEnum (maxBound @a) 184 | size = Finite $ 1 + toInteger hi - toInteger lo 185 | 186 | -- | 'nat' is an inverse of forward enumeration 'E.nat'. 187 | -- 188 | -- For a negative integer @x@ which 'E.nat' doesn't enumerate, 189 | -- @locate nat x@ returns the same index to the absolute value of @x@, 190 | -- i.e. @locate nat x == locate nat (abs x)@. 191 | -- 192 | -- >>> locate nat <$> [-3 .. 3] 193 | -- [3,2,1,0,1,2,3] 194 | nat :: CoEnumeration Integer 195 | nat = CoEnumeration{ card = Infinite, locate = abs } 196 | 197 | -- | 'int' is the inverse of forward enumeration 'E.int', which is 198 | -- all integers ordered as the sequence @0, 1, -1, 2, -2, ...@ 199 | -- 200 | -- >>> locate int <$> [1, 2, 3, 4, 5] 201 | -- [1,3,5,7,9] 202 | -- >>> locate int <$> [0, -1 .. -5] 203 | -- [0,2,4,6,8,10] 204 | int :: CoEnumeration Integer 205 | int = CoEnumeration{ card = Infinite, locate = integerToNat } 206 | where 207 | integerToNat :: Integer -> Integer 208 | integerToNat n 209 | | n <= 0 = 2 * negate n 210 | | otherwise = 2 * n - 1 211 | 212 | -- | 'cw' is an inverse of forward enumeration 'E.cw'. 213 | -- 214 | -- Because 'E.cw' only enumerates positive 'Rational' values, 215 | -- @locate cw x@ for zero or less rational number @x@ could be arbitrary. 216 | -- 217 | -- This implementation chose @locate cw x = 33448095@ for all @x <= 0@, which is 218 | -- the index of @765 % 4321@, rather than returning @undefined@. 219 | -- 220 | -- >>> locate cw <$> [1 % 1, 1 % 2, 2 % 1, 1 % 3, 3 % 2] 221 | -- [0,1,2,3,4] 222 | -- >>> locate cw (765 % 4321) 223 | -- 33448095 224 | -- >>> locate cw 0 225 | -- 33448095 226 | cw :: CoEnumeration Rational 227 | cw = CoEnumeration{ card = Infinite, locate = locateCW } 228 | where 229 | locateCW x = case numerator x of 230 | n | n > 0 -> go n (denominator x) [] - 1 231 | | otherwise -> 33448095 {- Magic number, see the haddock above -} 232 | 233 | go 1 1 acc = foldl' (\i b -> 2 * i + b) 1 acc 234 | go a b acc 235 | | a > b = go (a - b) b (1 : acc) 236 | | a < b = go a (b - a) (0 : acc) 237 | | otherwise = error "cw: locateCW: Never reach here!" 238 | 239 | -- | 'rat' is the inverse of forward enumeration 'E.rat'. 240 | -- 241 | -- >>> let xs = E.enumerate . E.takeE 6 $ E.rat 242 | -- >>> (xs, locate rat <$> xs) 243 | -- ([0 % 1,1 % 1,(-1) % 1,1 % 2,(-1) % 2,2 % 1],[0,1,2,3,4,5]) 244 | -- >>> locate rat (E.select E.rat 1000) 245 | -- 1000 246 | rat :: CoEnumeration Rational 247 | rat = contramap caseBySign $ maybeOf (cw <+> cw) 248 | where 249 | caseBySign :: Rational -> Maybe (Either Rational Rational) 250 | caseBySign x = case compare x 0 of 251 | LT -> Just (Right (negate x)) 252 | EQ -> Nothing 253 | GT -> Just (Left x) 254 | 255 | -- | Sets the cardinality of given coenumeration to 'Infinite' 256 | infinite :: CoEnumeration a -> CoEnumeration a 257 | infinite e = e{ card = Infinite } 258 | 259 | -- | Cartesian product of coenumeration, made to be an inverse of 260 | -- cartesian product of enumeration '(E.><)'. 261 | -- 262 | -- >>> let a = E.finite 3 E.>< (E.boundedEnum @Bool) 263 | -- >>> let a' = modulo 3 >< boundedEnum @Bool 264 | -- >>> (E.enumerate a, locate a' <$> E.enumerate a) 265 | -- ([(0,False),(0,True),(1,False),(1,True),(2,False),(2,True)],[0,1,2,3,4,5]) 266 | -- 267 | -- This operation is not associative if and only if one of arguments 268 | -- is not finite. 269 | (><) :: CoEnumeration a -> CoEnumeration b -> CoEnumeration (a,b) 270 | e1 >< e2 = CoEnumeration{ card = n1 * n2, locate = locatePair } 271 | where 272 | n1 = card e1 273 | n2 = card e2 274 | locatePair = case (n1, n2) of 275 | (_, Finite n2') -> \(a,b) -> locate e1 a * n2' + locate e2 b 276 | (Finite n1', Infinite) -> \(a,b) -> locate e1 a + locate e2 b * n1' 277 | (Infinite, Infinite) -> \(a,b) -> undiagonal (locate e1 a, locate e2 b) 278 | 279 | -- | Sum, or disjoint union, of two coenumerations. 280 | -- 281 | -- It corresponds to disjoint union of enumerations 'E.eitherOf'. 282 | -- 283 | -- Its type can't be @CoEnumeration a -> CoEnumeration a -> CoEnumeration a@, 284 | -- like 'Data.Enumeration.Enumeration' which is covariant functor, 285 | -- because @CoEnumeration@ is 'Contravariant' functor. 286 | -- 287 | -- >>> let a = E.finite 3 `E.eitherOf` (E.boundedEnum @Bool) 288 | -- >>> let a' = modulo 3 <+> boundedEnum @Bool 289 | -- >>> (E.enumerate a, locate a' <$> E.enumerate a) 290 | -- ([Left 0,Left 1,Left 2,Right False,Right True],[0,1,2,3,4]) 291 | -- 292 | -- This operation is not associative if and only if one of arguments 293 | -- is not finite. 294 | (<+>) :: CoEnumeration a -> CoEnumeration b -> CoEnumeration (Either a b) 295 | e1 <+> e2 = CoEnumeration{ card = n1 + n2, locate = locateEither } 296 | where 297 | n1 = card e1 298 | n2 = card e2 299 | locateEither = case (n1, n2) of 300 | (Finite n1', _) -> either (locate e1) ((n1' +) . locate e2) 301 | (Infinite, Finite n2') -> either ((n2' +) . locate e1) (locate e2) 302 | (Infinite, Infinite) -> either ((*2) . locate e1) (succ . (*2) . locate e2) 303 | 304 | -- | 305 | -- 306 | -- >>> locate (dropC 3 nat) <$> [0..5] 307 | -- [0,0,0,0,1,2] 308 | dropC :: Integer -> CoEnumeration a -> CoEnumeration a 309 | dropC k e 310 | | k == 0 = e 311 | | card e == 0 = e 312 | | card e <= Finite k = error "Impossible empty coenumeration" 313 | | otherwise = CoEnumeration{ card = size, locate = loc } 314 | where 315 | size = card e - Finite k 316 | loc = max 0 . subtract k . locate e 317 | 318 | -- | 319 | -- >>> locate (takeC 3 nat) <$> [0..5] 320 | -- [0,1,2,2,2,2] 321 | takeC :: Integer -> CoEnumeration a -> CoEnumeration a 322 | takeC k 323 | | k <= 0 = checkEmpty 324 | | otherwise = aux 325 | where 326 | aux e = 327 | let size = min (Finite k) (card e) 328 | loc = min (k-1) . locate e 329 | in CoEnumeration{ card = size, locate = loc } 330 | 331 | checkEmpty :: CoEnumeration a -> CoEnumeration a 332 | checkEmpty e 333 | | card e == 0 = e 334 | | otherwise = error "Impossible empty coenumeration" 335 | 336 | -- | 337 | -- >>> locate (modulo 3) <$> [0..7] 338 | -- [0,1,2,0,1,2,0,1] 339 | -- >>> locate (modulo 3) (-4) 340 | -- 2 341 | modulo :: Integer -> CoEnumeration Integer 342 | modulo n 343 | | n <= 0 = error $ "modulo: invalid argument " ++ show n 344 | | otherwise = CoEnumeration{ card = Finite n, locate = (`mod` n) } 345 | 346 | -- | @overlayC a b@ combines two coenumerations in parallel, sharing 347 | -- indices of two coenumerations. 348 | -- 349 | -- The resulting coenumeration has cardinality of the larger of the 350 | -- two arguments. 351 | overlayC :: CoEnumeration a -> CoEnumeration b -> CoEnumeration (Either a b) 352 | overlayC e1 e2 = CoEnumeration{ 353 | card = max (card e1) (card e2) 354 | , locate = either (locate e1) (locate e2) 355 | } 356 | 357 | -- | The inverse of forward 'E.maybeOf' 358 | maybeOf :: CoEnumeration a -> CoEnumeration (Maybe a) 359 | maybeOf e = contramap (maybe (Left ()) Right) $ unit <+> e 360 | 361 | -- | Synonym of '(<+>)' 362 | eitherOf :: CoEnumeration a -> CoEnumeration b -> CoEnumeration (Either a b) 363 | eitherOf = (<+>) 364 | 365 | -- | Coenumerate all possible finite lists using given coenumeration. 366 | -- 367 | -- If a coenumeration @a@ is the inverse of enumeration @b@, 368 | -- 'listOf' @a@ is the inverse of forward enumeration 'E.listOf' @b@. 369 | -- 370 | -- >>> E.enumerate . E.takeE 6 $ E.listOf E.nat 371 | -- [[],[0],[0,0],[1],[0,0,0],[1,0]] 372 | -- >>> locate (listOf nat) <$> [[],[0],[0,0],[1],[0,0,0],[1,0]] 373 | -- [0,1,2,3,4,5] 374 | -- >>> E.select (E.listOf E.nat) 1000000 375 | -- [1008,26,0] 376 | -- >>> locate (listOf nat) [1008,26,0] 377 | -- 1000000 378 | listOf :: CoEnumeration a -> CoEnumeration [a] 379 | listOf e = CoEnumeration{ card = size, locate = locateList } 380 | where 381 | n = card e 382 | size | n == 0 = 1 383 | | otherwise = Infinite 384 | locateList = unList n . fmap (locate e) 385 | 386 | unList :: Cardinality -> [Index] -> Index 387 | unList (Finite k) = foldl' (\n a -> 1 + (a + n * k)) 0 . reverse 388 | unList Infinite = foldl' (\n a -> 1 + undiagonal (a, n)) 0 . reverse 389 | 390 | -- | An inverse of 'E.finiteSubsetOf'. 391 | -- 392 | -- Given a coenumeration of @a@, make a coenumeration of finite sets of 393 | -- @a@, by ignoring order and repetition from @[a]@. 394 | -- 395 | -- >>> as = take 11 . E.enumerate $ E.finiteSubsetOf E.nat 396 | -- >>> (as, locate (finiteSubsetOf nat) <$> as) 397 | -- ([[],[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]) 398 | finiteSubsetOf :: CoEnumeration a -> CoEnumeration [a] 399 | finiteSubsetOf e = CoEnumeration{ card = size, locate = unSet . fmap (locate e) } 400 | where 401 | size = case card e of 402 | Finite k -> Finite (2 ^ k) 403 | Infinite -> Infinite 404 | 405 | unSet :: [Index] -> Index 406 | unSet = foldl' (\n i -> n .|. bit (fromInteger i)) 0 407 | 408 | -- | An inverse of 'E.finiteEnumerationOf'. 409 | -- 410 | -- Given a coenumeration of @a@, make a coenumeration of function from 411 | -- finite sets to @a@. 412 | -- 413 | -- Ideally, its type should be the following dependent type 414 | -- 415 | -- > {n :: Integer} -> CoEnumeration a -> CoEnumeration ({k :: Integer | k < n} -> a) 416 | -- 417 | -- >>> let as = E.finiteEnumerationOf 3 (E.takeE 2 E.nat) 418 | -- >>> map E.enumerate $ E.enumerate as 419 | -- [[0,0,0],[0,0,1],[0,1,0],[0,1,1],[1,0,0],[1,0,1],[1,1,0],[1,1,1]] 420 | -- >>> let inv_as = finiteFunctionOf 3 (takeC 2 nat) 421 | -- >>> locate inv_as (E.select (E.finiteList [0,1,1])) 422 | -- 3 423 | finiteFunctionOf :: Integer -> CoEnumeration a -> CoEnumeration (Integer -> a) 424 | finiteFunctionOf 0 _ = unit 425 | finiteFunctionOf n a = CoEnumeration{ card = size, locate = locateEnum } 426 | where 427 | size = case card a of 428 | Finite k -> Finite (k^n) 429 | Infinite -> Infinite 430 | 431 | step = case card a of 432 | Finite k -> \r d -> k * r + d 433 | Infinite -> curry undiagonal 434 | 435 | locateEnum f = 436 | let go i !acc 437 | | i == n = acc 438 | | otherwise = go (i+1) (step acc (locate a (f i))) 439 | in go 0 0 440 | -------------------------------------------------------------------------------- /src/Data/Enumeration.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE MagicHash #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | 8 | -- SPDX-License-Identifier: BSD-3-Clause 9 | 10 | ----------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Data.Enumeration 13 | -- Copyright : Brent Yorgey 14 | -- Maintainer : byorgey@gmail.com 15 | -- 16 | -- An /enumeration/ is a finite or countably infinite sequence of 17 | -- values, that is, enumerations are isomorphic to lists. However, 18 | -- enumerations are represented a functions from index to value, so 19 | -- they support efficient indexing and can be constructed for very 20 | -- large finite sets. A few examples are shown below. 21 | -- 22 | -- >>> enumerate . takeE 15 $ listOf nat 23 | -- [[],[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]] 24 | -- >>> select (listOf nat) 986235087203970702008108646 25 | -- [11987363624969,1854392,1613,15,0,2,0] 26 | -- 27 | -- @ 28 | -- data Tree = L | B Tree Tree deriving Show 29 | -- 30 | -- treesUpTo :: Int -> Enumeration Tree 31 | -- treesUpTo 0 = 'singleton' L 32 | -- treesUpTo n = 'singleton' L '<|>' B '<$>' t' '<*>' t' 33 | -- where t' = treesUpTo (n-1) 34 | -- 35 | -- trees :: Enumeration Tree 36 | -- trees = 'infinite' $ 'singleton' L '<|>' B '<$>' trees '<*>' trees 37 | -- @ 38 | -- 39 | -- >>> card (treesUpTo 1) 40 | -- Finite 2 41 | -- >>> card (treesUpTo 10) 42 | -- Finite 14378219780015246281818710879551167697596193767663736497089725524386087657390556152293078723153293423353330879856663164406809615688082297859526620035327291442156498380795040822304677 43 | -- >>> select (treesUpTo 5) 12345 44 | -- B (B L (B (B (B L L) L) (B L L))) (B (B (B L L) L) (B L L)) 45 | -- 46 | -- >>> card trees 47 | -- Infinite 48 | -- >>> select trees 12345 49 | -- B (B (B (B L (B L L)) L) (B L (B (B L L) L))) (B (B L (B L L)) (B (B L L) (B L (B L L)))) 50 | -- 51 | -- For /invertible/ enumerations, /i.e./ bijections between some set 52 | -- of values and natural numbers (or finite prefix thereof), see 53 | -- "Data.Enumeration.Invertible". 54 | 55 | ----------------------------------------------------------------------------- 56 | 57 | module Data.Enumeration 58 | ( -- * Enumerations 59 | 60 | Enumeration 61 | , mkEnumeration 62 | 63 | -- ** Using enumerations 64 | 65 | , Cardinality(..), card 66 | , Index, select 67 | 68 | , isFinite 69 | , enumerate 70 | 71 | -- ** Primitive enumerations 72 | 73 | , unit 74 | , singleton 75 | , always 76 | , finite 77 | , finiteList 78 | , boundedEnum 79 | 80 | , nat 81 | , int 82 | , cw 83 | , rat 84 | 85 | -- ** Enumeration combinators 86 | 87 | , takeE 88 | , dropE 89 | , infinite 90 | , zipE, zipWithE 91 | , (<+>) 92 | , (><) 93 | , interleave 94 | 95 | , maybeOf 96 | , eitherOf 97 | , listOf 98 | , finiteSubsetOf 99 | , finiteEnumerationOf 100 | 101 | -- * Utilities 102 | 103 | , diagonal 104 | 105 | ) where 106 | 107 | import Control.Applicative 108 | 109 | import Data.Bits ((.&.)) 110 | import Data.Ratio 111 | import Data.Tuple (swap) 112 | 113 | import GHC.Base (Int (I#)) 114 | import GHC.Integer.Logarithms (integerLog2#) 115 | 116 | ------------------------------------------------------------ 117 | -- Setup for doctest examples 118 | ------------------------------------------------------------ 119 | 120 | -- $setup 121 | -- >>> :set -XTypeApplications 122 | -- >>> :{ 123 | -- data Tree = L | B Tree Tree deriving Show 124 | -- treesUpTo :: Int -> Enumeration Tree 125 | -- treesUpTo 0 = singleton L 126 | -- treesUpTo n = singleton L <|> B <$> t' <*> t' 127 | -- where t' = treesUpTo (n-1) 128 | -- trees :: Enumeration Tree 129 | -- trees = infinite $ singleton L <|> B <$> trees <*> trees 130 | -- :} 131 | 132 | ------------------------------------------------------------ 133 | -- Enumerations 134 | ------------------------------------------------------------ 135 | 136 | -- | The cardinality of a countable set: either a specific finite 137 | -- natural number, or countably infinite. 138 | data Cardinality = Finite !Integer | Infinite 139 | deriving (Show, Eq, Ord) 140 | 141 | -- | @Cardinality@ has a @Num@ instance for convenience, so we can use 142 | -- numeric literals as finite cardinalities, and add, subtract, and 143 | -- multiply cardinalities. Note that: 144 | -- 145 | -- * subtraction is saturating (/i.e./ 3 - 5 = 0) 146 | -- 147 | -- * infinity - infinity is treated as zero 148 | -- 149 | -- * zero is treated as a "very strong" annihilator for multiplication: 150 | -- even infinity * zero = zero. 151 | instance Num Cardinality where 152 | fromInteger = Finite 153 | 154 | Infinite + _ = Infinite 155 | _ + Infinite = Infinite 156 | Finite a + Finite b = Finite (a + b) 157 | 158 | Finite 0 * _ = Finite 0 159 | _ * Finite 0 = Finite 0 160 | Infinite * _ = Infinite 161 | _ * Infinite = Infinite 162 | Finite a * Finite b = Finite (a * b) 163 | 164 | Finite a - Finite b = Finite (max 0 (a - b)) 165 | _ - Infinite = Finite 0 166 | _ - _ = Infinite 167 | 168 | negate = error "Can't negate Cardinality" 169 | signum = error "No signum for Cardinality" 170 | abs = error "No abs for Cardinality" 171 | 172 | -- | An index into an enumeration. 173 | type Index = Integer 174 | 175 | -- | An enumeration of a finite or countably infinite set of 176 | -- values. An enumeration is represented as a function from the natural numbers 177 | -- (for infinite enumerations) or a finite prefix of the natural numbers (for finite ones) 178 | -- to values. Enumerations can thus easily be constructed for very large sets, and 179 | -- support efficient indexing and random sampling. 180 | -- 181 | -- 'Enumeration' is an instance of the following type classes: 182 | -- 183 | -- * 'Functor' (you can map a function over every element of an enumeration) 184 | -- * 'Applicative' (representing Cartesian product of enumerations; see ('><')) 185 | -- * 'Alternative' (representing disjoint union of enumerations; see ('<+>')) 186 | -- 187 | -- 'Enumeration' is /not/ a 'Monad', since there is no way to 188 | -- implement 'Control.Monad.join' that works for any combination of 189 | -- finite and infinite enumerations (but see 'interleave'). 190 | data Enumeration a = Enumeration 191 | { -- | Get the cardinality of an enumeration. 192 | card :: Cardinality 193 | 194 | -- | Select the value at a particular index of an enumeration. 195 | -- Precondition: the index must be strictly less than the 196 | -- cardinality. For infinite sets, every possible value must 197 | -- occur at some finite index. 198 | , select :: Index -> a 199 | } 200 | deriving Functor 201 | 202 | -- | Create an enumeration primitively out of a cardinality and an 203 | -- index function. 204 | mkEnumeration :: Cardinality -> (Index -> a) -> Enumeration a 205 | mkEnumeration = Enumeration 206 | 207 | -- | The @Applicative@ instance for @Enumeration@ works similarly to 208 | -- the instance for lists: @pure = singleton@, and @f '<*>' x@ takes 209 | -- the Cartesian product of @f@ and @x@ (see ('><')) and applies 210 | -- each paired function and argument. 211 | instance Applicative Enumeration where 212 | pure = singleton 213 | f <*> x = uncurry ($) <$> (f >< x) 214 | 215 | -- | The @Alternative@ instance for @Enumeration@ represents the sum 216 | -- monoidal structure on enumerations: @empty@ is the empty 217 | -- enumeration, and @('<|>') = ('<+>')@ is disjoint union. 218 | instance Alternative Enumeration where 219 | empty = void 220 | (<|>) = (<+>) 221 | 222 | ------------------------------------------------------------ 223 | -- Using enumerations 224 | ------------------------------------------------------------ 225 | 226 | -- | Test whether an enumeration is finite. 227 | -- 228 | -- >>> isFinite (finiteList [1,2,3]) 229 | -- True 230 | -- 231 | -- >>> isFinite nat 232 | -- False 233 | isFinite :: Enumeration a -> Bool 234 | isFinite (Enumeration (Finite _) _) = True 235 | isFinite _ = False 236 | 237 | -- | List the elements of an enumeration in order. Inverse of 238 | -- 'finiteList'. 239 | enumerate :: Enumeration a -> [a] 240 | enumerate e = map (select e) $ 241 | case card e of 242 | Infinite -> [0 ..] 243 | Finite c -> [0 .. c-1] 244 | 245 | ------------------------------------------------------------ 246 | -- Constructing Enumerations 247 | ------------------------------------------------------------ 248 | 249 | -- | The empty enumeration, with cardinality zero and no elements. 250 | -- 251 | -- >>> card void 252 | -- Finite 0 253 | -- 254 | -- >>> enumerate void 255 | -- [] 256 | void :: Enumeration a 257 | void = Enumeration 0 (error "select void") 258 | 259 | -- | The unit enumeration, with a single value of @()@. 260 | -- 261 | -- >>> card unit 262 | -- Finite 1 263 | -- 264 | -- >>> enumerate unit 265 | -- [()] 266 | unit :: Enumeration () 267 | unit = Enumeration 268 | { card = 1 269 | , select = const () 270 | } 271 | 272 | -- | An enumeration of a single given element. 273 | -- 274 | -- >>> card (singleton 17) 275 | -- Finite 1 276 | -- 277 | -- >>> enumerate (singleton 17) 278 | -- [17] 279 | singleton :: a -> Enumeration a 280 | singleton a = Enumeration 1 (const a) 281 | 282 | -- | A constant infinite enumeration. 283 | -- 284 | -- >>> card (always 17) 285 | -- Infinite 286 | -- 287 | -- >>> enumerate . takeE 10 $ always 17 288 | -- [17,17,17,17,17,17,17,17,17,17] 289 | always :: a -> Enumeration a 290 | always a = Enumeration Infinite (const a) 291 | 292 | -- | A finite prefix of the natural numbers. 293 | -- 294 | -- >>> card (finite 5) 295 | -- Finite 5 296 | -- >>> card (finite 1234567890987654321) 297 | -- Finite 1234567890987654321 298 | -- 299 | -- >>> enumerate (finite 5) 300 | -- [0,1,2,3,4] 301 | -- >>> enumerate (finite 0) 302 | -- [] 303 | finite :: Integer -> Enumeration Integer 304 | finite n = Enumeration (Finite n) id 305 | 306 | -- | Construct an enumeration from the elements of a /finite/ list. To 307 | -- turn an enumeration back into a list, use 'enumerate'. 308 | -- 309 | -- >>> enumerate (finiteList [2,3,8,1]) 310 | -- [2,3,8,1] 311 | -- >>> select (finiteList [2,3,8,1]) 2 312 | -- 8 313 | -- 314 | -- 'finiteList' does not work on infinite lists: inspecting the 315 | -- cardinality of the resulting enumeration (something many of the 316 | -- enumeration combinators need to do) will hang trying to compute 317 | -- the length of the infinite list. To make an infinite enumeration, 318 | -- use something like @f '<$>' 'nat'@ where @f@ is a function to 319 | -- compute the value at any given index. 320 | -- 321 | -- 'finiteList' uses ('!!') internally, so you probably want to 322 | -- avoid using it on long lists. It would be possible to make a 323 | -- version with better indexing performance by allocating a vector 324 | -- internally, but I am too lazy to do it. If you have a good use 325 | -- case let me know (better yet, submit a pull request). 326 | finiteList :: [a] -> Enumeration a 327 | finiteList as = Enumeration (Finite (fromIntegral $ length as)) (\k -> as !! fromIntegral k) 328 | -- Note the use of !! is not very efficient, but for small lists it 329 | -- probably still beats the overhead of allocating a vector. Most 330 | -- likely this will only ever be used with very small lists anyway. 331 | -- If it becomes a problem we could add another combinator that 332 | -- behaves just like finiteList but allocates a Vector internally. 333 | 334 | -- | Enumerate all the values of a bounded 'Enum' instance. 335 | -- 336 | -- >>> enumerate (boundedEnum @Bool) 337 | -- [False,True] 338 | -- 339 | -- >>> select (boundedEnum @Char) 97 340 | -- 'a' 341 | -- 342 | -- >>> card (boundedEnum @Int) 343 | -- Finite 18446744073709551616 344 | -- >>> select (boundedEnum @Int) 0 345 | -- -9223372036854775808 346 | boundedEnum :: forall a. (Enum a, Bounded a) => Enumeration a 347 | boundedEnum = Enumeration 348 | { card = Finite (hi - lo + 1) 349 | , select = toEnum . fromIntegral . (+lo) 350 | } 351 | where 352 | lo, hi :: Index 353 | lo = fromIntegral (fromEnum (minBound @a)) 354 | hi = fromIntegral (fromEnum (maxBound @a)) 355 | 356 | -- | The natural numbers, @0, 1, 2, ...@. 357 | -- 358 | -- >>> enumerate . takeE 10 $ nat 359 | -- [0,1,2,3,4,5,6,7,8,9] 360 | nat :: Enumeration Integer 361 | nat = Enumeration Infinite id 362 | 363 | -- | All integers in the order @0, 1, -1, 2, -2, 3, -3, ...@. 364 | int :: Enumeration Integer 365 | int = negate <$> nat <|> dropE 1 nat 366 | 367 | -- | The positive rational numbers, enumerated according to the 368 | -- [Calkin-Wilf sequence](http://www.cs.ox.ac.uk/publications/publication1664-abstract.html). 369 | -- 370 | -- >>> enumerate . takeE 10 $ cw 371 | -- [1 % 1,1 % 2,2 % 1,1 % 3,3 % 2,2 % 3,3 % 1,1 % 4,4 % 3,3 % 5] 372 | cw :: Enumeration Rational 373 | cw = Enumeration { card = Infinite, select = uncurry (%) . go . succ } 374 | where 375 | go 1 = (1,1) 376 | go n 377 | | even n = left (go (n `div` 2)) 378 | | otherwise = right (go (n `div` 2)) 379 | left (!a, !b) = (a, a+b) 380 | right (!a, !b) = (a+b, b) 381 | 382 | -- | An enumeration of all rational numbers: 0 first, then each 383 | -- rational in the Calkin-Wilf sequence followed by its negative. 384 | -- 385 | -- >>> enumerate . takeE 10 $ rat 386 | -- [0 % 1,1 % 1,(-1) % 1,1 % 2,(-1) % 2,2 % 1,(-2) % 1,1 % 3,(-1) % 3,3 % 2] 387 | rat :: Enumeration Rational 388 | rat = singleton 0 <|> (cw <|> negate <$> cw) 389 | 390 | -- | Take a finite prefix from the beginning of an enumeration. @takeE 391 | -- k e@ always yields the empty enumeration for \(k \leq 0\), and 392 | -- results in @e@ whenever @k@ is greater than or equal to the 393 | -- cardinality of the enumeration. Otherwise @takeE k e@ has 394 | -- cardinality @k@ and matches @e@ from @0@ to @k-1@. 395 | -- 396 | -- >>> enumerate $ takeE 3 (boundedEnum @Int) 397 | -- [-9223372036854775808,-9223372036854775807,-9223372036854775806] 398 | -- 399 | -- >>> enumerate $ takeE 2 (finiteList [1..5]) 400 | -- [1,2] 401 | -- 402 | -- >>> enumerate $ takeE 0 (finiteList [1..5]) 403 | -- [] 404 | -- 405 | -- >>> enumerate $ takeE 7 (finiteList [1..5]) 406 | -- [1,2,3,4,5] 407 | takeE :: Integer -> Enumeration a -> Enumeration a 408 | takeE k e 409 | | k <= 0 = void 410 | | Finite k >= card e = e 411 | | otherwise = Enumeration (Finite k) (select e) 412 | 413 | -- | Drop some elements from the beginning of an enumeration. @dropE k 414 | -- e@ yields @e@ unchanged if \(k \leq 0\), and results in the empty 415 | -- enumeration whenever @k@ is greater than or equal to the 416 | -- cardinality of @e@. 417 | -- 418 | -- >>> enumerate $ dropE 2 (finiteList [1..5]) 419 | -- [3,4,5] 420 | -- 421 | -- >>> enumerate $ dropE 0 (finiteList [1..5]) 422 | -- [1,2,3,4,5] 423 | -- 424 | -- >>> enumerate $ dropE 7 (finiteList [1..5]) 425 | -- [] 426 | dropE :: Integer -> Enumeration a -> Enumeration a 427 | dropE k e 428 | | k <= 0 = e 429 | | Finite k >= card e = void 430 | | otherwise = Enumeration 431 | { card = card e - Finite k, select = select e . (+k) } 432 | 433 | -- | Explicitly mark an enumeration as having an infinite cardinality, 434 | -- ignoring the previous cardinality. It is sometimes necessary to 435 | -- use this as a "hint" when constructing a recursive enumeration 436 | -- whose cardinality would otherwise consist of an infinite sum of 437 | -- finite cardinalities. 438 | -- 439 | -- For example, consider the following definitions: 440 | -- 441 | -- @ 442 | -- data Tree = L | B Tree Tree deriving Show 443 | -- 444 | -- treesBad :: Enumeration Tree 445 | -- treesBad = singleton L '<|>' B '<$>' treesBad '<*>' treesBad 446 | -- 447 | -- trees :: Enumeration Tree 448 | -- trees = infinite $ singleton L '<|>' B '<$>' trees '<*>' trees 449 | -- @ 450 | -- 451 | -- Trying to use @treesBad@ at all will simply hang, since trying to 452 | -- compute its cardinality leads to infinite recursion. 453 | -- 454 | -- @ 455 | -- \>>>\ select treesBad 5 456 | -- ^CInterrupted. 457 | -- @ 458 | -- 459 | -- However, using 'infinite', as in the definition of @trees@, 460 | -- provides the needed laziness: 461 | -- 462 | -- >>> card trees 463 | -- Infinite 464 | -- >>> enumerate . takeE 3 $ trees 465 | -- [L,B L L,B L (B L L)] 466 | -- >>> select trees 87239862967296 467 | -- B (B (B (B (B L L) (B (B (B L L) L) L)) (B L (B L (B L L)))) (B (B (B L (B L (B L L))) (B (B L L) (B L L))) (B (B L (B L (B L L))) L))) (B (B L (B (B (B L (B L L)) (B L L)) L)) (B (B (B L (B L L)) L) L)) 468 | infinite :: Enumeration a -> Enumeration a 469 | infinite (Enumeration _ s) = Enumeration Infinite s 470 | 471 | -- | Fairly interleave a set of /infinite/ enumerations. 472 | -- 473 | -- For a finite set of infinite enumerations, a round-robin 474 | -- interleaving is used. That is, if we think of an enumeration of 475 | -- enumerations as a 2D matrix read off row-by-row, this corresponds 476 | -- to taking the transpose of a matrix with finitely many infinite 477 | -- rows, turning it into one with infinitely many finite rows. For 478 | -- an infinite set of infinite enumerations, /i.e./ an infinite 2D 479 | -- matrix, the resulting enumeration reads off the matrix by 480 | -- 'diagonal's. 481 | -- 482 | -- >>> enumerate . takeE 15 $ interleave (finiteList [nat, negate <$> nat, (*10) <$> nat]) 483 | -- [0,0,0,1,-1,10,2,-2,20,3,-3,30,4,-4,40] 484 | -- 485 | -- >>> enumerate . takeE 15 $ interleave (always nat) 486 | -- [0,0,1,0,1,2,0,1,2,3,0,1,2,3,4] 487 | -- 488 | -- This function is similar to 'Control.Monad.join' in a 489 | -- hypothetical 'Monad' instance for 'Enumeration', but it only 490 | -- works when the inner enumerations are all infinite. 491 | -- 492 | -- To interleave a finite enumeration of enumerations, some of which 493 | -- may be finite, you can use @'Data.Foldable.asum' . 'enumerate'@. 494 | -- If you want to interleave an infinite enumeration of finite 495 | -- enumerations, you are out of luck. 496 | interleave :: Enumeration (Enumeration a) -> Enumeration a 497 | interleave e = Enumeration 498 | { card = Infinite 499 | , select = \k -> 500 | let (i,j) = case card e of 501 | Finite n -> k `divMod` n 502 | Infinite -> diagonal k 503 | in select (select e j) i 504 | } 505 | 506 | -- | Zip two enumerations in parallel, producing the pair of 507 | -- elements at each index. The resulting enumeration is truncated 508 | -- to the cardinality of the smaller of the two arguments. 509 | -- 510 | -- >>> enumerate $ zipE nat (boundedEnum @Bool) 511 | -- [(0,False),(1,True)] 512 | zipE :: Enumeration a -> Enumeration b -> Enumeration (a,b) 513 | zipE = zipWithE (,) 514 | 515 | -- | Zip two enumerations in parallel, applying the given function to 516 | -- the pair of elements at each index to produce a new element. The 517 | -- resulting enumeration is truncated to the cardinality of the 518 | -- smaller of the two arguments. 519 | -- 520 | -- >>> enumerate $ zipWithE replicate (finiteList [1..10]) (dropE 35 (boundedEnum @Char)) 521 | -- ["#","$$","%%%","&&&&","'''''","((((((",")))))))","********","+++++++++",",,,,,,,,,,"] 522 | 523 | zipWithE :: (a -> b -> c) -> Enumeration a -> Enumeration b -> Enumeration c 524 | zipWithE f e1 e2 = 525 | Enumeration (min (card e1) (card e2)) (\k -> f (select e1 k) (select e2 k)) 526 | 527 | -- | Sum, /i.e./ disjoint union, of two enumerations. If both are 528 | -- finite, all the values of the first will be enumerated before the 529 | -- values of the second. If only one is finite, the values from the 530 | -- finite enumeration will be listed first. If both are infinite, a 531 | -- fair (alternating) interleaving is used, so that every value ends 532 | -- up at a finite index in the result. 533 | -- 534 | -- Note that the ('<+>') operator is a synonym for ('<|>') from the 535 | -- 'Alternative' instance for 'Enumeration', which should be used in 536 | -- preference to ('<+>'). ('<+>') is provided as a separate 537 | -- standalone operator to make it easier to document. 538 | -- 539 | -- >>> enumerate . takeE 10 $ singleton 17 <|> nat 540 | -- [17,0,1,2,3,4,5,6,7,8] 541 | -- 542 | -- >>> enumerate . takeE 10 $ nat <|> singleton 17 543 | -- [17,0,1,2,3,4,5,6,7,8] 544 | -- 545 | -- >>> enumerate . takeE 10 $ nat <|> (negate <$> nat) 546 | -- [0,0,1,-1,2,-2,3,-3,4,-4] 547 | -- 548 | -- Note that this is not associative in a strict sense. In 549 | -- particular, it may fail to be associative when mixing finite and 550 | -- infinite enumerations: 551 | -- 552 | -- >>> enumerate . takeE 10 $ nat <|> (singleton 17 <|> nat) 553 | -- [0,17,1,0,2,1,3,2,4,3] 554 | -- 555 | -- >>> enumerate . takeE 10 $ (nat <|> singleton 17) <|> nat 556 | -- [17,0,0,1,1,2,2,3,3,4] 557 | -- 558 | -- However, it is associative in several weaker senses: 559 | -- 560 | -- * If all the enumerations are finite 561 | -- * If all the enumerations are infinite 562 | -- * If enumerations are considered equivalent up to reordering 563 | -- (they are not, but considering them so may be acceptable in 564 | -- some applications). 565 | (<+>) :: Enumeration a -> Enumeration a -> Enumeration a 566 | e1 <+> e2 = case (card e1, card e2) of 567 | 568 | -- optimize for void <+> e2. 569 | (Finite 0, _) -> e2 570 | 571 | -- Note we don't want to add a case for e1 <+> void right away since 572 | -- that would require forcing the cardinality of e2, and we'd rather 573 | -- let the following case work lazily in the cardinality of e2. 574 | 575 | -- First enumeration is finite: just put it first 576 | (Finite k1, _) -> Enumeration 577 | { card = card e1 + card e2 578 | , select = \k -> if k < k1 then select e1 k else select e2 (k - k1) 579 | } 580 | 581 | -- First is infinite but second is finite: put all the second values first 582 | (_, Finite _) -> e2 <+> e1 583 | 584 | -- Both are infinite: use a fair (alternating) interleaving 585 | _ -> interleave (Enumeration 2 (\case {0 -> e1; 1 -> e2})) 586 | 587 | -- | One half of the isomorphism between \(\mathbb{N}\) and 588 | -- \(\mathbb{N} \times \mathbb{N}\) which enumerates by diagonals: 589 | -- turn a particular natural number index into its position in the 590 | -- 2D grid. That is, given this numbering of a 2D grid: 591 | -- 592 | -- @ 593 | -- 0 1 3 6 ... 594 | -- 2 4 7 595 | -- 5 8 596 | -- 9 597 | -- @ 598 | -- 599 | -- 'diagonal' maps \(0 \mapsto (0,0), 1 \mapsto (0,1), 2 \mapsto (1,0) \dots\) 600 | diagonal :: Integer -> (Integer, Integer) 601 | diagonal k = (k - t, d - (k - t)) 602 | where 603 | d = (integerSqrt (1 + 8*k) - 1) `div` 2 604 | t = d*(d+1) `div` 2 605 | 606 | -- | Cartesian product of enumerations. If both are finite, uses a 607 | -- simple lexicographic ordering. If only one is finite, the 608 | -- resulting enumeration is still in lexicographic order, with the 609 | -- infinite enumeration as the most significant component. For two 610 | -- infinite enumerations, uses a fair 'diagonal' interleaving. 611 | -- 612 | -- >>> enumerate $ finiteList [1..3] >< finiteList "abcd" 613 | -- [(1,'a'),(1,'b'),(1,'c'),(1,'d'),(2,'a'),(2,'b'),(2,'c'),(2,'d'),(3,'a'),(3,'b'),(3,'c'),(3,'d')] 614 | -- 615 | -- >>> enumerate . takeE 10 $ finiteList "abc" >< nat 616 | -- [('a',0),('b',0),('c',0),('a',1),('b',1),('c',1),('a',2),('b',2),('c',2),('a',3)] 617 | -- 618 | -- >>> enumerate . takeE 10 $ nat >< finiteList "abc" 619 | -- [(0,'a'),(0,'b'),(0,'c'),(1,'a'),(1,'b'),(1,'c'),(2,'a'),(2,'b'),(2,'c'),(3,'a')] 620 | -- 621 | -- >>> enumerate . takeE 10 $ nat >< nat 622 | -- [(0,0),(0,1),(1,0),(0,2),(1,1),(2,0),(0,3),(1,2),(2,1),(3,0)] 623 | -- 624 | -- Like ('<+>'), this operation is also not associative (not even up 625 | -- to reassociating tuples). 626 | (><) :: Enumeration a -> Enumeration b -> Enumeration (a,b) 627 | e1 >< e2 = case (card e1, card e2) of 628 | 629 | -- The second enumeration is finite: use lexicographic ordering with 630 | -- the first as the most significant component 631 | (_, Finite k2) -> Enumeration 632 | { card = card e1 * card e2 633 | , select = \k -> let (i,j) = k `divMod` k2 in (select e1 i, select e2 j) 634 | } 635 | 636 | -- The first is finite but the second is infinite: lexicographic 637 | -- with the second as most significant. 638 | (Finite _, _) -> swap <$> (e2 >< e1) 639 | 640 | -- Both are infinite: enumerate by diagonals 641 | _ -> Enumeration 642 | { card = Infinite 643 | , select = \k -> let (i,j) = diagonal k in (select e1 i, select e2 j) 644 | } 645 | 646 | ------------------------------------------------------------ 647 | -- Building standard data types 648 | ------------------------------------------------------------ 649 | 650 | -- | Enumerate all possible values of type `Maybe a`, where the values 651 | -- of type `a` are taken from the given enumeration. 652 | -- 653 | -- >>> enumerate $ maybeOf (finiteList [1,2,3]) 654 | -- [Nothing,Just 1,Just 2,Just 3] 655 | maybeOf :: Enumeration a -> Enumeration (Maybe a) 656 | maybeOf a = singleton Nothing <|> Just <$> a 657 | 658 | -- | Enumerae all possible values of type @Either a b@ with inner values 659 | -- taken from the given enumerations. 660 | -- 661 | -- >>> enumerate . takeE 6 $ eitherOf nat nat 662 | -- [Left 0,Right 0,Left 1,Right 1,Left 2,Right 2] 663 | eitherOf :: Enumeration a -> Enumeration b -> Enumeration (Either a b) 664 | eitherOf a b = Left <$> a <|> Right <$> b 665 | 666 | -- | Enumerate all possible finite lists containing values from the given enumeration. 667 | -- 668 | -- >>> enumerate . takeE 15 $ listOf nat 669 | -- [[],[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]] 670 | -- >>> enumerate $ listOf empty :: [[Data.Void.Void]] 671 | -- [[]] 672 | listOf :: Enumeration a -> Enumeration [a] 673 | listOf a = case card a of 674 | Finite 0 -> singleton [] 675 | _ -> listOfA 676 | where 677 | listOfA = infinite $ singleton [] <|> (:) <$> a <*> listOfA 678 | 679 | -- | Enumerate all possible finite subsets of values from the given enumeration. 680 | -- 681 | -- >>> enumerate $ finiteSubsetOf (finite 3) 682 | -- [[],[0],[1],[0,1],[2],[0,2],[1,2],[0,1,2]] 683 | finiteSubsetOf :: Enumeration a -> Enumeration [a] 684 | finiteSubsetOf as = pick <$> bitstrings 685 | where 686 | bitstrings = case card as of 687 | Infinite -> nat 688 | Finite k -> finite (2^k) 689 | 690 | pick 0 = [] 691 | pick n = select as (integerLog2 l) : pick (n - l) 692 | where 693 | l = lsb n 694 | 695 | lsb :: Integer -> Integer 696 | lsb n = n .&. (-n) 697 | 698 | integerLog2 :: Integer -> Integer 699 | integerLog2 n = fromIntegral (I# (integerLog2# n)) 700 | 701 | -- | @finiteEnumerationOf n a@ creates an enumeration of all sequences 702 | -- of exactly n items taken from the enumeration @a@. 703 | finiteEnumerationOf :: Int -> Enumeration a -> Enumeration (Enumeration a) 704 | finiteEnumerationOf 0 _ = singleton empty 705 | finiteEnumerationOf n a = case card a of 706 | Finite k -> selectEnum k <$> finite (k^n) 707 | Infinite -> foldr cons (singleton empty) (replicate n a) 708 | 709 | where 710 | selectEnum k = fmap (select a) . finiteList . reverse . take n . toBase k 711 | 712 | toBase _ 0 = repeat 0 713 | toBase k n = n `mod` k : toBase k (n `div` k) 714 | 715 | cons :: Enumeration a -> Enumeration (Enumeration a) -> Enumeration (Enumeration a) 716 | cons a as = (<|>) <$> (singleton <$> a) <*> as 717 | 718 | -- https://mail.haskell.org/pipermail/haskell-cafe/2008-February/039465.html 719 | -- imLog :: Integer->Integer->Integer 720 | -- > > imLog b x 721 | -- > > = if x < b then 722 | -- > > 0 723 | -- > > else 724 | -- > > let 725 | -- > > l = 2 * imLog (b*b) x 726 | -- > > doDiv x l = if x < b then l else doDiv (x`div`b) (l+1) 727 | -- > > in 728 | -- > > doDiv (x`div`(b^l)) l 729 | 730 | -- Note: more efficient integerSqrt in arithmoi 731 | -- (Math.NumberTheory.Powers.Squares), but it's a rather heavyweight 732 | -- dependency to pull in just for this. 733 | 734 | -- Implementation of `integerSqrt` taken from the Haskell wiki: 735 | -- https://wiki.haskell.org/Generic_number_type#squareRoot 736 | 737 | -- | Find the square root (rounded down) of a positive integer. 738 | -- 739 | -- >>> integerSqrt 0 740 | -- 0 741 | -- >>> integerSqrt 1 742 | -- 1 743 | -- >>> integerSqrt 3 744 | -- 1 745 | -- >>> integerSqrt 4 746 | -- 2 747 | -- >>> integerSqrt 38 748 | -- 6 749 | -- >>> integerSqrt 763686362402795580983595318628819602756 750 | -- 27634875834763498734 751 | 752 | integerSqrt :: Integer -> Integer 753 | integerSqrt 0 = 0 754 | integerSqrt 1 = 1 755 | integerSqrt n = 756 | let twopows = iterate (^!2) 2 757 | (lowerRoot, lowerN) = 758 | last $ takeWhile ((n>=) . snd) $ zip (1:twopows) twopows 759 | newtonStep x = div (x + div n x) 2 760 | isRoot r = r^!2 <= n && n < (r+1)^!2 761 | initGuess = integerSqrt (div n lowerN ) * lowerRoot 762 | in iterUntil isRoot newtonStep initGuess 763 | 764 | iterUntil :: (a -> Bool) -> (a -> a) -> a -> a 765 | iterUntil p f a 766 | | p a = a 767 | | otherwise = iterUntil p f (f a) 768 | 769 | (^!) :: Num a => a -> Int -> a 770 | (^!) x n = x^n 771 | -------------------------------------------------------------------------------- /src/Data/Enumeration/Invertible.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | -- SPDX-License-Identifier: BSD-3-Clause 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Data.Enumeration.Invertible 11 | -- Copyright : Brent Yorgey 12 | -- Maintainer : byorgey@gmail.com 13 | -- 14 | -- An /invertible enumeration/ is a bijection between a set of values 15 | -- and the natural numbers (or a finite prefix thereof), represented 16 | -- as a pair of inverse functions, one in each direction. Hence they 17 | -- support efficient indexing and can be constructed for very large 18 | -- finite sets. A few examples are shown below. 19 | -- 20 | -- Compared to "Data.Enumeration", one can also build invertible 21 | -- enumerations of functions (or other type formers with contravariant 22 | -- arguments); however, invertible enumerations no longer make for 23 | -- valid 'Functor', 'Applicative', or 'Alternative' instances. 24 | -- 25 | -- This module exports many of the same names as "Data.Enumeration"; 26 | -- the expectation is that you will choose one or the other to import, 27 | -- though of course it is possible to import both if you qualify the 28 | -- imports. 29 | -- 30 | ----------------------------------------------------------------------------- 31 | 32 | module Data.Enumeration.Invertible 33 | ( -- * Invertible enumerations 34 | 35 | IEnumeration 36 | 37 | -- ** Using enumerations 38 | 39 | , Cardinality(..), card 40 | , Index, select, locate 41 | 42 | , isFinite 43 | , enumerate 44 | 45 | -- ** Primitive enumerations 46 | 47 | , void 48 | , unit 49 | , singleton 50 | , finite 51 | , finiteList 52 | , boundedEnum 53 | 54 | , nat 55 | , int 56 | , cw 57 | , rat 58 | 59 | -- ** Enumeration combinators 60 | 61 | , mapE 62 | , takeE, dropE 63 | , zipE 64 | , infinite 65 | , (<+>) 66 | , (><) 67 | , interleave 68 | 69 | , maybeOf 70 | , eitherOf 71 | , listOf 72 | , finiteSubsetOf 73 | , finiteEnumerationOf 74 | , functionOf 75 | 76 | -- * Utilities 77 | 78 | , undiagonal 79 | ) where 80 | 81 | import Control.Applicative (Alternative (..)) 82 | import Data.Bits (shiftL, (.|.)) 83 | import Data.List (findIndex, foldl') 84 | import Data.Maybe (fromJust) 85 | import Data.Ratio 86 | 87 | import Data.Enumeration (Cardinality (..), Enumeration, Index) 88 | import qualified Data.Enumeration as E 89 | 90 | ------------------------------------------------------------ 91 | -- Setup for doctest examples 92 | ------------------------------------------------------------ 93 | 94 | -- $setup 95 | -- >>> :set -XTypeApplications 96 | -- >>> import Control.Arrow ((&&&)) 97 | -- >>> import Data.Maybe (fromMaybe, listToMaybe) 98 | -- >>> :{ 99 | -- data Tree = L | B Tree Tree deriving Show 100 | -- treesUpTo :: Int -> IEnumeration Tree 101 | -- treesUpTo 0 = singleton L 102 | -- treesUpTo n = mapE toTree fromTree (unit <+> (t' >< t')) 103 | -- where 104 | -- t' = treesUpTo (n-1) 105 | -- trees :: IEnumeration Tree 106 | -- trees = infinite $ mapE toTree fromTree (unit <+> (trees >< trees)) 107 | -- toTree :: Either () (Tree, Tree) -> Tree 108 | -- toTree = either (const L) (uncurry B) 109 | -- fromTree :: Tree -> Either () (Tree, Tree) 110 | -- fromTree L = Left () 111 | -- fromTree (B l r) = Right (l,r) 112 | -- :} 113 | 114 | ------------------------------------------------------------ 115 | -- Invertible enumerations 116 | ------------------------------------------------------------ 117 | 118 | -- | An invertible enumeration is a bijection between a set of 119 | -- enumerated values and the natural numbers, or a finite prefix of 120 | -- the natural numbers. An invertible enumeration is represented as 121 | -- a function from natural numbers to values, paired with an inverse 122 | -- function that returns the natural number index of a given value. 123 | -- Enumerations can thus easily be constructed for very large sets, 124 | -- and support efficient indexing and random sampling. 125 | -- 126 | -- Note that 'IEnumeration' cannot be made an instance of 'Functor', 127 | -- 'Applicative', or 'Alternative'. However, it does support the 128 | -- 'functionOf' combinator which cannot be supported by 129 | -- "Data.Enumeration". 130 | 131 | data IEnumeration a = IEnumeration 132 | { baseEnum :: Enumeration a 133 | -- | Compute the index of a particular value in its enumeration. 134 | -- Note that the result of 'locate' is only valid when given a 135 | -- value which is actually in the range of the enumeration. 136 | , locate :: a -> Index 137 | } 138 | 139 | -- | Map a pair of inverse functions over an invertible enumeration of 140 | -- @a@ values to turn it into an invertible enumeration of @b@ 141 | -- values. Because invertible enumerations contain a /bijection/ to 142 | -- the natural numbers, we really do need both directions of a 143 | -- bijection between @a@ and @b@ in order to map. This is why 144 | -- 'IEnumeration' cannot be an instance of 'Functor'. 145 | mapE :: (a -> b) -> (b -> a) -> IEnumeration a -> IEnumeration b 146 | mapE f g (IEnumeration e l) = IEnumeration (f <$> e) (l . g) 147 | 148 | ------------------------------------------------------------ 149 | -- Using enumerations 150 | ------------------------------------------------------------ 151 | 152 | -- | Select the value at a particular index. Precondition: the index 153 | -- must be strictly less than the cardinality. 154 | select :: IEnumeration a -> (Index -> a) 155 | select = E.select . baseEnum 156 | 157 | -- | Get the cardinality of an enumeration. 158 | card :: IEnumeration a -> Cardinality 159 | card = E.card . baseEnum 160 | 161 | -- | Test whether an enumeration is finite. 162 | -- 163 | -- >>> isFinite (finiteList [1,2,3]) 164 | -- True 165 | -- 166 | -- >>> isFinite nat 167 | -- False 168 | isFinite :: IEnumeration a -> Bool 169 | isFinite (IEnumeration e _) = E.isFinite e 170 | 171 | -- | List the elements of an enumeration in order. Inverse of 172 | -- 'finiteList'. 173 | enumerate :: IEnumeration a -> [a] 174 | enumerate e = case card e of 175 | Infinite -> map (select e) [0 ..] 176 | Finite c -> map (select e) [0 .. c-1] 177 | 178 | ------------------------------------------------------------ 179 | -- Constructing Enumerations 180 | ------------------------------------------------------------ 181 | 182 | -- | The empty enumeration, with cardinality zero and no elements. 183 | -- 184 | -- >>> card void 185 | -- Finite 0 186 | -- 187 | -- >>> enumerate void 188 | -- [] 189 | void :: IEnumeration a 190 | void = IEnumeration empty (error "locate void") 191 | 192 | -- | The unit enumeration, with a single value of @()@ at index 0. 193 | -- 194 | -- >>> card unit 195 | -- Finite 1 196 | -- 197 | -- >>> enumerate unit 198 | -- [()] 199 | -- 200 | -- >>> locate unit () 201 | -- 0 202 | unit :: IEnumeration () 203 | unit = IEnumeration E.unit (const 0) 204 | 205 | -- | An enumeration of a single given element at index 0. 206 | -- 207 | -- >>> card (singleton 17) 208 | -- Finite 1 209 | -- 210 | -- >>> enumerate (singleton 17) 211 | -- [17] 212 | -- 213 | -- >>> locate (singleton 17) 17 214 | -- 0 215 | singleton :: a -> IEnumeration a 216 | singleton a = IEnumeration (E.singleton a) (const 0) 217 | 218 | -- | A finite prefix of the natural numbers. 219 | -- 220 | -- >>> card (finite 5) 221 | -- Finite 5 222 | -- >>> card (finite 1234567890987654321) 223 | -- Finite 1234567890987654321 224 | -- 225 | -- >>> enumerate (finite 5) 226 | -- [0,1,2,3,4] 227 | -- >>> enumerate (finite 0) 228 | -- [] 229 | -- 230 | -- >>> locate (finite 5) 2 231 | -- 2 232 | finite :: Integer -> IEnumeration Integer 233 | finite n = IEnumeration (E.finite n) id 234 | 235 | -- | Construct an enumeration from the elements of a /finite/ list. 236 | -- The elements of the list must all be distinct. To turn an 237 | -- enumeration back into a list, use 'enumerate'. 238 | -- 239 | -- >>> enumerate (finiteList [2,3,8,1]) 240 | -- [2,3,8,1] 241 | -- >>> select (finiteList [2,3,8,1]) 2 242 | -- 8 243 | -- >>> locate (finiteList [2,3,8,1]) 8 244 | -- 2 245 | -- 246 | -- 'finiteList' does not work on infinite lists: inspecting the 247 | -- cardinality of the resulting enumeration (something many of the 248 | -- enumeration combinators need to do) will hang trying to compute 249 | -- the length of the infinite list. 250 | -- 251 | -- 'finiteList' uses ('!!') and 'findIndex' internally (which both 252 | -- take $O(n)$ time), so you probably want to avoid using it on long 253 | -- lists. It would be possible to make a version with better 254 | -- indexing performance by allocating a vector internally, but I am 255 | -- too lazy to do it. If you have a good use case let me know 256 | -- (better yet, submit a pull request). 257 | finiteList :: Eq a => [a] -> IEnumeration a 258 | finiteList as = IEnumeration (E.finiteList as) locateFinite 259 | -- Note the use of !! and findIndex is not very efficient, but for 260 | -- small lists it probably still beats the overhead of allocating a 261 | -- vector. Most likely this will only ever be used with very small 262 | -- lists anyway. If it becomes a problem we could add another 263 | -- combinator that behaves just like finiteList but allocates a 264 | -- Vector internally. 265 | 266 | where 267 | locateFinite a = fromIntegral . fromJust $ findIndex (==a) as 268 | 269 | -- | Enumerate all the values of a bounded 'Enum' instance. 270 | -- 271 | -- >>> enumerate (boundedEnum @Bool) 272 | -- [False,True] 273 | -- 274 | -- >>> select (boundedEnum @Char) 97 275 | -- 'a' 276 | -- >>> locate (boundedEnum @Char) 'Z' 277 | -- 90 278 | -- 279 | -- >>> card (boundedEnum @Int) 280 | -- Finite 18446744073709551616 281 | -- >>> select (boundedEnum @Int) 0 282 | -- -9223372036854775808 283 | boundedEnum :: forall a. (Enum a, Bounded a) => IEnumeration a 284 | boundedEnum = IEnumeration E.boundedEnum (subtract lo . fromIntegral . fromEnum) 285 | where 286 | lo :: Index 287 | lo = fromIntegral (fromEnum (minBound @a)) 288 | 289 | -- | The natural numbers, @0, 1, 2, ...@. 290 | -- 291 | -- >>> enumerate . takeE 10 $ nat 292 | -- [0,1,2,3,4,5,6,7,8,9] 293 | nat :: IEnumeration Integer 294 | nat = IEnumeration E.nat id 295 | 296 | -- | All integers in the order @0, 1, -1, 2, -2, 3, -3, ...@. 297 | int :: IEnumeration Integer 298 | int = IEnumeration E.int locateInt 299 | where 300 | locateInt z 301 | | z <= 0 = 2 * abs z 302 | | otherwise = 2*z - 1 303 | 304 | -- | The positive rational numbers, enumerated according to the 305 | -- [Calkin-Wilf sequence](http://www.cs.ox.ac.uk/publications/publication1664-abstract.html). 306 | -- 307 | -- >>> enumerate . takeE 10 $ cw 308 | -- [1 % 1,1 % 2,2 % 1,1 % 3,3 % 2,2 % 3,3 % 1,1 % 4,4 % 3,3 % 5] 309 | -- >>> locate cw (3 % 2) 310 | -- 4 311 | -- >>> locate cw (23 % 99) 312 | -- 3183 313 | cw :: IEnumeration Rational 314 | cw = IEnumeration E.cw (pred . locateCW) 315 | where 316 | locateCW r = go (numerator r, denominator r) 317 | go (1,1) = 1 318 | go (a,b) 319 | | a < b = 2 * go (a, b - a) 320 | | otherwise = 1 + 2 * go (a - b, b) 321 | 322 | -- | An enumeration of all rational numbers: 0 first, then each 323 | -- rational in the Calkin-Wilf sequence followed by its negative. 324 | -- 325 | -- >>> enumerate . takeE 10 $ rat 326 | -- [0 % 1,1 % 1,(-1) % 1,1 % 2,(-1) % 2,2 % 1,(-2) % 1,1 % 3,(-1) % 3,3 % 2] 327 | -- >>> locate rat (-45 % 61) 328 | -- 2540 329 | 330 | rat :: IEnumeration Rational 331 | rat = mapE 332 | (either (const 0) (either id negate)) 333 | unrat 334 | (unit <+> (cw <+> cw)) 335 | where 336 | unrat 0 = Left () 337 | unrat r 338 | | r > 0 = Right (Left r) 339 | | otherwise = Right (Right (-r)) 340 | 341 | -- | Take a finite prefix from the beginning of an enumeration. @takeE 342 | -- k e@ always yields the empty enumeration for \(k \leq 0\), and 343 | -- results in @e@ whenever @k@ is greater than or equal to the 344 | -- cardinality of the enumeration. Otherwise @takeE k e@ has 345 | -- cardinality @k@ and matches @e@ from @0@ to @k-1@. 346 | -- 347 | -- >>> enumerate $ takeE 3 (boundedEnum @Int) 348 | -- [-9223372036854775808,-9223372036854775807,-9223372036854775806] 349 | -- 350 | -- >>> enumerate $ takeE 2 (finiteList [1..5]) 351 | -- [1,2] 352 | -- 353 | -- >>> enumerate $ takeE 0 (finiteList [1..5]) 354 | -- [] 355 | -- 356 | -- >>> enumerate $ takeE 7 (finiteList [1..5]) 357 | -- [1,2,3,4,5] 358 | takeE :: Integer -> IEnumeration a -> IEnumeration a 359 | takeE k (IEnumeration e l) = IEnumeration (E.takeE k e) l 360 | 361 | -- | Drop some elements from the beginning of an enumeration. @dropE k 362 | -- e@ yields @e@ unchanged if \(k \leq 0\), and results in the empty 363 | -- enumeration whenever @k@ is greater than or equal to the 364 | -- cardinality of @e@. 365 | -- 366 | -- >>> enumerate $ dropE 2 (finiteList [1..5]) 367 | -- [3,4,5] 368 | -- 369 | -- >>> enumerate $ dropE 0 (finiteList [1..5]) 370 | -- [1,2,3,4,5] 371 | -- 372 | -- >>> enumerate $ dropE 7 (finiteList [1..5]) 373 | -- [] 374 | dropE :: Integer -> IEnumeration a -> IEnumeration a 375 | dropE k (IEnumeration e l) = IEnumeration (E.dropE k e) (subtract (max 0 k) . l) 376 | 377 | -- | Explicitly mark an enumeration as having an infinite cardinality, 378 | -- ignoring the previous cardinality. It is sometimes necessary to 379 | -- use this as a "hint" when constructing a recursive enumeration 380 | -- whose cardinality would otherwise consist of an infinite sum of 381 | -- finite cardinalities. 382 | -- 383 | -- For example, consider the following definitions: 384 | -- 385 | -- @ 386 | -- data Tree = L | B Tree Tree deriving Show 387 | -- 388 | -- toTree :: Either () (Tree, Tree) -> Tree 389 | -- toTree = either (const L) (uncurry B) 390 | -- 391 | -- fromTree :: Tree -> Either () (Tree, Tree) 392 | -- fromTree L = Left () 393 | -- fromTree (B l r) = Right (l,r) 394 | -- 395 | -- treesBad :: IEnumeration Tree 396 | -- treesBad = mapE toTree fromTree (unit '<+>' (treesBad '><' treesBad)) 397 | -- 398 | -- trees :: IEnumeration Tree 399 | -- trees = infinite $ mapE toTree fromTree (unit '<+>' (trees '><' trees)) 400 | -- @ 401 | -- 402 | -- Trying to use @treesBad@ at all will simply hang, since trying to 403 | -- compute its cardinality leads to infinite recursion. 404 | -- 405 | -- @ 406 | -- \>>>\ select treesBad 5 407 | -- ^CInterrupted. 408 | -- @ 409 | -- 410 | -- However, using 'infinite', as in the definition of @trees@, 411 | -- provides the needed laziness: 412 | -- 413 | -- >>> card trees 414 | -- Infinite 415 | -- >>> enumerate . takeE 3 $ trees 416 | -- [L,B L L,B L (B L L)] 417 | -- >>> select trees 87239862967296 418 | -- B (B (B (B (B L L) (B (B (B L L) L) L)) (B L (B L (B L L)))) (B (B (B L (B L (B L L))) (B (B L L) (B L L))) (B (B L (B L (B L L))) L))) (B (B L (B (B (B L (B L L)) (B L L)) L)) (B (B (B L (B L L)) L) L)) 419 | -- >>> select trees 123 420 | -- B (B L (B L L)) (B (B L (B L L)) (B L (B L L))) 421 | -- >>> locate trees (B (B L (B L L)) (B (B L (B L L)) (B L (B L L)))) 422 | -- 123 423 | 424 | infinite :: IEnumeration a -> IEnumeration a 425 | infinite (IEnumeration e l) = IEnumeration (E.infinite e) l 426 | 427 | -- | Fairly interleave a set of /infinite/ enumerations. 428 | -- 429 | -- For a finite set of infinite enumerations, a round-robin 430 | -- interleaving is used. That is, if we think of an enumeration of 431 | -- enumerations as a 2D matrix read off row-by-row, this corresponds 432 | -- to taking the transpose of a matrix with finitely many infinite 433 | -- rows, turning it into one with infinitely many finite rows. For 434 | -- an infinite set of infinite enumerations, /i.e./ an infinite 2D 435 | -- matrix, the resulting enumeration reads off the matrix by 436 | -- 'Data.Enumeration.diagonal's. 437 | -- 438 | -- Note that the type of this function is slightly different than 439 | -- its counterpart in "Data.Enumeration": each enumerated value in 440 | -- the output is tagged with an index indicating which input 441 | -- enumeration it came from. This is required to make the result 442 | -- invertible, and is analogous to the way the output values of 443 | -- '<+>' are tagged with 'Left' or 'Right'; in fact, 'interleave' 444 | -- can be thought of as an iterated version of '<+>', but with a 445 | -- more efficient implementation. 446 | 447 | interleave :: IEnumeration (IEnumeration a) -> IEnumeration (Index, a) 448 | interleave e = IEnumeration 449 | { baseEnum = E.mkEnumeration Infinite $ \k -> 450 | let (i,j) = case card e of 451 | Finite n -> k `divMod` n 452 | Infinite -> E.diagonal k 453 | in (j, select (select e j) i) 454 | , locate = \(j, a) -> 455 | let i = locate (select e j) a 456 | in case card e of 457 | Finite n -> i*n + j 458 | Infinite -> undiagonal (i,j) 459 | } 460 | 461 | -- | Zip two enumerations in parallel, producing the pair of 462 | -- elements at each index. The resulting enumeration is truncated 463 | -- to the cardinality of the smaller of the two arguments. 464 | -- 465 | -- Note that defining @zipWithE@ as in "Data.Enumeration" is not 466 | -- possible since there would be no way to invert it in general. 467 | -- However, one can use 'zipE' in combination with 'mapE' to achieve 468 | -- a similar result. 469 | -- 470 | -- >>> enumerate $ zipE nat (boundedEnum @Bool) 471 | -- [(0,False),(1,True)] 472 | -- 473 | -- >>> headD x = fromMaybe x . listToMaybe 474 | -- >>> cs = mapE (uncurry replicate) (length &&& headD ' ') (zipE (finiteList [1..10]) (dropE 35 (boundedEnum @Char))) 475 | -- >>> enumerate cs 476 | -- ["#","$$","%%%","&&&&","'''''","((((((",")))))))","********","+++++++++",",,,,,,,,,,"] 477 | -- >>> locate cs "********" 478 | -- 7 479 | 480 | zipE :: IEnumeration a -> IEnumeration b -> IEnumeration (a,b) 481 | zipE ea eb = IEnumeration 482 | { baseEnum = E.zipE (baseEnum ea) (baseEnum eb) 483 | , locate = locate ea . fst 484 | } 485 | 486 | -- | Sum, /i.e./ disjoint union, of two enumerations. If both are 487 | -- finite, all the values of the first will be enumerated before the 488 | -- values of the second. If only one is finite, the values from the 489 | -- finite enumeration will be listed first. If both are infinite, a 490 | -- fair (alternating) interleaving is used, so that every value ends 491 | -- up at a finite index in the result. 492 | -- 493 | -- Note that this has a different type than the version in 494 | -- "Data.Enumeration". Here we require the output to carry an 495 | -- explicit 'Either' tag to make it invertible. 496 | -- 497 | -- >>> enumerate . takeE 5 $ singleton 17 <+> nat 498 | -- [Left 17,Right 0,Right 1,Right 2,Right 3] 499 | -- 500 | -- >>> enumerate . takeE 5 $ nat <+> singleton 17 501 | -- [Right 17,Left 0,Left 1,Left 2,Left 3] 502 | -- 503 | -- >>> enumerate . takeE 5 $ nat <+> nat 504 | -- [Left 0,Right 0,Left 1,Right 1,Left 2] 505 | -- 506 | -- >>> locate (nat <+> nat) (Right 35) 507 | -- 71 508 | 509 | (<+>) :: IEnumeration a -> IEnumeration b -> IEnumeration (Either a b) 510 | a <+> b = IEnumeration (Left <$> baseEnum a <|> Right <$> baseEnum b) (locateEither a b) 511 | where 512 | locateEither :: IEnumeration a -> IEnumeration b -> (Either a b -> Index) 513 | locateEither a b = case (card a, card b) of 514 | (Finite k1, _) -> either (locate a) ((+k1) . locate b) 515 | (_, Finite k2) -> either ((+k2) . locate a) (locate b) 516 | _ -> either ((*2) . locate a) (succ . (*2) . locate b) 517 | 518 | 519 | -- | The other half of the isomorphism between \(\mathbb{N}\) and 520 | -- \(\mathbb{N} \times \mathbb{N}\) which enumerates by diagonals: 521 | -- turn a pair of natural numbers giving a position in the 2D grid 522 | -- into the number in the cell, according to this numbering scheme: 523 | -- 524 | -- @ 525 | -- 0 1 3 6 ... 526 | -- 2 4 7 527 | -- 5 8 528 | -- 9 529 | -- @ 530 | undiagonal :: (Integer, Integer) -> Integer 531 | undiagonal (r,c) = (r+c) * (r+c+1) `div` 2 + r 532 | 533 | -- | Cartesian product of enumerations. If both are finite, uses a 534 | -- simple lexicographic ordering. If only one is finite, the 535 | -- resulting enumeration is still in lexicographic order, with the 536 | -- infinite enumeration as the most significant component. For two 537 | -- infinite enumerations, uses a fair 'Data.Enumeration.diagonal' interleaving. 538 | -- 539 | -- >>> enumerate $ finiteList [1..3] >< finiteList "abcd" 540 | -- [(1,'a'),(1,'b'),(1,'c'),(1,'d'),(2,'a'),(2,'b'),(2,'c'),(2,'d'),(3,'a'),(3,'b'),(3,'c'),(3,'d')] 541 | -- 542 | -- >>> enumerate . takeE 10 $ finiteList "abc" >< nat 543 | -- [('a',0),('b',0),('c',0),('a',1),('b',1),('c',1),('a',2),('b',2),('c',2),('a',3)] 544 | -- 545 | -- >>> enumerate . takeE 10 $ nat >< finiteList "abc" 546 | -- [(0,'a'),(0,'b'),(0,'c'),(1,'a'),(1,'b'),(1,'c'),(2,'a'),(2,'b'),(2,'c'),(3,'a')] 547 | -- 548 | -- >>> enumerate . takeE 10 $ nat >< nat 549 | -- [(0,0),(0,1),(1,0),(0,2),(1,1),(2,0),(0,3),(1,2),(2,1),(3,0)] 550 | -- 551 | -- >>> locate (nat >< nat) (1,1) 552 | -- 4 553 | -- >>> locate (nat >< nat) (36,45) 554 | -- 3357 555 | -- 556 | -- Like ('<+>'), this operation is also not associative (not even up 557 | -- to reassociating tuples). 558 | (><) :: IEnumeration a -> IEnumeration b -> IEnumeration (a,b) 559 | a >< b = IEnumeration (baseEnum a E.>< baseEnum b) (locatePair a b) 560 | where 561 | locatePair :: IEnumeration a -> IEnumeration b -> ((a,b) -> Index) 562 | locatePair a b = case (card a, card b) of 563 | (_, Finite k2) -> \(x,y) -> k2 * locate a x + locate b y 564 | (Finite k1, _) -> \(x,y) -> k1 * locate b y + locate a x 565 | _ -> \(x,y) -> undiagonal (locate a x, locate b y) 566 | 567 | ------------------------------------------------------------ 568 | -- Building standard data types 569 | ------------------------------------------------------------ 570 | 571 | -- | Enumerate all possible values of type `Maybe a`, where the values 572 | -- of type `a` are taken from the given enumeration. 573 | -- 574 | -- >>> enumerate $ maybeOf (finiteList [1,2,3]) 575 | -- [Nothing,Just 1,Just 2,Just 3] 576 | -- >>> locate (maybeOf (maybeOf (finiteList [1,2,3]))) (Just (Just 2)) 577 | -- 3 578 | maybeOf :: IEnumeration a -> IEnumeration (Maybe a) 579 | maybeOf a = mapE (either (const Nothing) Just) (maybe (Left ()) Right) (unit <+> a) 580 | 581 | -- | Enumerae all possible values of type @Either a b@ with inner values 582 | -- taken from the given enumerations. 583 | -- 584 | -- Note that for invertible enumerations, 'eitherOf' is simply a 585 | -- synonym for '<+>'. 586 | -- 587 | -- >>> enumerate . takeE 6 $ eitherOf nat nat 588 | -- [Left 0,Right 0,Left 1,Right 1,Left 2,Right 2] 589 | eitherOf :: IEnumeration a -> IEnumeration b -> IEnumeration (Either a b) 590 | eitherOf = (<+>) 591 | 592 | -- | Enumerate all possible finite lists containing values from the 593 | -- given enumeration. 594 | -- 595 | -- >>> enumerate . takeE 15 $ listOf nat 596 | -- [[],[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]] 597 | -- >>> locate (listOf nat) [3,4,20,5,19] 598 | -- 666270815854068922513792635440014 599 | listOf :: IEnumeration a -> IEnumeration [a] 600 | listOf a = case card a of 601 | Finite 0 -> singleton [] 602 | _ -> listOfA 603 | where 604 | listOfA = infinite $ 605 | mapE (either (const []) (uncurry (:))) uncons (unit <+> (a >< listOfA)) 606 | uncons [] = Left () 607 | uncons (a:as) = Right (a, as) 608 | 609 | -- | Enumerate all possible finite subsets of values from the given 610 | -- enumeration. The elements in each list will always occur in 611 | -- increasing order of their index in the given enumeration. 612 | -- 613 | -- >>> enumerate $ finiteSubsetOf (finite 3) 614 | -- [[],[0],[1],[0,1],[2],[0,2],[1,2],[0,1,2]] 615 | -- 616 | -- >>> locate (finiteSubsetOf nat) [2,3,6,8] 617 | -- 332 618 | -- >>> 332 == 2^8 + 2^6 + 2^3 + 2^2 619 | -- True 620 | finiteSubsetOf :: IEnumeration a -> IEnumeration [a] 621 | finiteSubsetOf a = IEnumeration (E.finiteSubsetOf (baseEnum a)) unpick 622 | where 623 | unpick = foldl' (.|.) 0 . map ((1 `shiftL`) . fromIntegral . locate a) 624 | 625 | -- | @finiteEnumerationOf n a@ creates an enumeration of all sequences 626 | -- of exactly n items taken from the enumeration @a@. 627 | -- 628 | -- >>> map E.enumerate . enumerate $ finiteEnumerationOf 2 (finite 3) 629 | -- [[0,0],[0,1],[0,2],[1,0],[1,1],[1,2],[2,0],[2,1],[2,2]] 630 | -- 631 | -- >>> map E.enumerate . take 10 . enumerate $ finiteEnumerationOf 3 nat 632 | -- [[0,0,0],[0,0,1],[1,0,0],[0,1,0],[1,0,1],[2,0,0],[0,0,2],[1,1,0],[2,0,1],[3,0,0]] 633 | finiteEnumerationOf :: Int -> IEnumeration a -> IEnumeration (Enumeration a) 634 | finiteEnumerationOf 0 _ = singleton empty 635 | finiteEnumerationOf n a = case card a of 636 | Finite k -> IEnumeration (E.finiteEnumerationOf n (baseEnum a)) (locateEnum k) 637 | Infinite -> foldr prod (singleton empty) (replicate n a) 638 | 639 | where 640 | locateEnum k = fromBase k . reverse . E.enumerate . fmap (locate a) 641 | 642 | fromBase k = foldr (\d r -> d + k*r) 0 643 | 644 | prod :: IEnumeration a -> IEnumeration (Enumeration a) -> IEnumeration (Enumeration a) 645 | prod a as = mapE (\(a,e) -> E.singleton a <|> e) (\e -> (E.select e 0, E.dropE 1 e)) 646 | (a >< as) 647 | 648 | -- | @functionOf a b@ creates an enumeration of all functions taking 649 | -- values from the enumeration @a@ and returning values from the 650 | -- enumeration @b@. As a precondition, @a@ must be finite; 651 | -- otherwise @functionOf@ throws an error. There are two exceptions: 652 | -- first, if @b@ has cardinality 1, we get an enumeration of exactly 653 | -- one function which constantly returns the one element of @b@, 654 | -- even if @a@ is infinite. Second, if @b@ has cardinality 0, we 655 | -- get a singleton enumeration if @a@ also has cardinality 0, and an 656 | -- empty enumeration otherwise (even if @a@ is infinite). 657 | -- 658 | -- >>> bbs = functionOf (boundedEnum @Bool) (boundedEnum @Bool) 659 | -- >>> card bbs 660 | -- Finite 4 661 | -- >>> map (select bbs 2) [False, True] 662 | -- [True,False] 663 | -- >>> locate bbs not 664 | -- 2 665 | -- 666 | -- >>> locate (functionOf bbs (boundedEnum @Bool)) (\f -> f True) 667 | -- 5 668 | -- 669 | -- >>> n2u = functionOf nat unit 670 | -- >>> card n2u 671 | -- Finite 1 672 | -- >>> (select n2u 0) 57 673 | -- () 674 | -- 675 | -- >>> n2o = functionOf nat void 676 | -- >>> card n2o 677 | -- Finite 0 678 | -- >>> o2o = functionOf void void 679 | -- >>> card o2o 680 | -- Finite 1 681 | functionOf :: IEnumeration a -> IEnumeration b -> IEnumeration (a -> b) 682 | functionOf as bs = case card bs of 683 | Finite 1 -> singleton (\_ -> select bs 0) -- 1^x = 1 684 | Finite 0 -> case card as of -- 0^0 = 1, 0^x = 0 685 | Finite 0 -> singleton (\_ -> error "called function with empty domain") 686 | _ -> void 687 | _ -> case card as of 688 | Infinite -> error "functionOf with infinite domain" 689 | Finite n -> mapE toFunc fromFunc (finiteEnumerationOf (fromIntegral n) bs) 690 | 691 | where 692 | toFunc bTuple a = E.select bTuple (locate as a) 693 | fromFunc f = f <$> baseEnum as 694 | -------------------------------------------------------------------------------- /src/Data/Enumeration/Sized.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Data.Enumeration.Sized 6 | -- Copyright : Brent Yorgey 7 | -- Maintainer : byorgey@gmail.com 8 | -- 9 | -- SPDX-License-Identifier: BSD-3-Clause 10 | -- 11 | -- An initial attempt at size-indexed enumerations, a la FEAT/species. 12 | -- Seems like it might be more trouble than it's worth. 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | {-# LANGUAGE LambdaCase #-} 17 | 18 | module Data.Enumeration.Sized 19 | ( -- * Sized enumerations 20 | 21 | SizedEnumeration 22 | 23 | , -- ** Constructing 24 | 25 | void, unit 26 | , singleton 27 | 28 | ) where 29 | 30 | import Prelude hiding (drop, zipWith) 31 | 32 | import qualified Data.Enumeration as E 33 | 34 | ------------------------------------------------------------ 35 | -- Sized enumerations 36 | 37 | -- XXX we're probably going to run into the same problems as FEAT with 38 | -- memoization etc. Is it worth doing this sized stuff? Can we make 39 | -- recursively defined (but unsized) enumerations? 40 | 41 | -- | A sized enumeration is just an enumeration of enumerations: the 42 | -- outer enumeration enumerates by size; the inner ones enumerate 43 | -- the elements of each given size. 44 | newtype SizedEnumeration a = SE (E.Enumeration (E.Enumeration a)) 45 | 46 | -- | The empty sized enumeration, with no elements of any size. 47 | void :: SizedEnumeration a 48 | void = SE E.void 49 | 50 | -- | The sized enumeration which contains only the single value @()@ 51 | -- of size 0. 52 | unit :: SizedEnumeration () 53 | unit = SE (E.unit <$ E.unit) 54 | 55 | -- | The sized enumeration which contains only the single given value, 56 | -- considered to have size 1. 57 | singleton :: a -> SizedEnumeration a 58 | singleton a = SE (E.singleton E.void E.+++ E.singleton (E.singleton a)) 59 | 60 | -- finiteList --- yield all structures of size 0? 61 | 62 | -- | XXX 63 | (+++) :: SizedEnumeration a -> SizedEnumeration a -> SizedEnumeration a 64 | SE e1 +++ SE e2 = SE $ E.zipWith (E.+++) e1 e2 65 | 66 | -- | XXX 67 | (><) :: SizedEnumeration a -> SizedEnumeration b -> SizedEnumeration (a,b) 68 | (SE e1) >< (SE e2) = SE $ E.Enumeration 69 | (E.card e1 + E.card e2) 70 | (\sz -> E.concat ((\k -> E.select e1 (sz - k) E.>< E.select e2 k) <$> E.finite (sz + 1))) 71 | 72 | -- (+++) : zip with + by size 73 | -- (><) : convolution by size 74 | 75 | -- Put this into a separate library 76 | 77 | -------------------------------------------------------------------------------- /src/Data/ProEnumeration.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | -- SPDX-License-Identifier: BSD-3-Clause 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Data.ProEnumeration 11 | -- Copyright : Brent Yorgey, Koji Miyazato 12 | -- Maintainer : byorgey@gmail.com 13 | -- 14 | -- A /proenumeration/ is a pair of a 'CoEnumeration' and an 'Enumeration' 15 | -- sharing the same cardinality. 16 | -- 17 | -- A /proenumeration/ can be seen as a function with an explicitly enumerated 18 | -- range. 19 | -- 20 | -- Through documentations of this module, these import aliases are used: 21 | -- 22 | -- > import qualified Data.Enumeration as E 23 | -- > import qualified Data.CoEnumeration as C 24 | 25 | ----------------------------------------------------------------------------- 26 | 27 | module Data.ProEnumeration( 28 | -- * Proenumeration type 29 | ProEnumeration() 30 | , card, select, locate 31 | 32 | , isFinite 33 | , baseEnum, baseCoEnum, run 34 | , enumerateRange 35 | 36 | , unsafeMkProEnumeration 37 | , mkProEnumeration 38 | 39 | -- * ProEnumeration is a Profunctor 40 | , dimap, (.@), (@.) 41 | 42 | -- * Using Cardinality 43 | , Cardinality(..), Index 44 | 45 | -- * Primitive proenumerations 46 | , unit, empty 47 | , singleton 48 | , modulo, clamped, boundsChecked 49 | , finiteList, finiteCycle 50 | , boundedEnum 51 | , nat, int, cw, rat 52 | 53 | -- * Combinators 54 | , infinite 55 | , compose 56 | , (><), (<+>) 57 | , maybeOf, eitherOf 58 | , listOf, finiteSubsetOf 59 | 60 | , enumerateP, coenumerateP 61 | , proenumerationOf 62 | , finiteFunctionOf 63 | ) where 64 | 65 | import qualified Control.Applicative as Ap (Alternative (empty)) 66 | import Data.Void 67 | 68 | import Data.Functor.Contravariant 69 | 70 | import Data.CoEnumeration (CoEnumeration) 71 | import qualified Data.CoEnumeration as C 72 | import Data.Enumeration (Cardinality (..), Enumeration, 73 | Index) 74 | import qualified Data.Enumeration as E 75 | 76 | -- | A /proenumeration/ is a pair of a 'CoEnumeration' and an 'Enumeration' 77 | -- sharing the same cardinality. 78 | -- Alternatively, a /proenumeration/ can be seen as a function with an 79 | -- explicitly enumerated range. 80 | -- 81 | -- Through this documentation, 82 | -- proenumerations are shown in diagrams of the following shape: 83 | -- 84 | -- > f g 85 | -- > a ---> N ---> b :: ProEnumeration a b 86 | -- 87 | -- Which means it is a value @p :: ProEnumeration a b@ with 88 | -- cardinality @N@, @locate p = f@, and @select p = g@. 89 | -- 90 | -- We can see @N@ in the diagram as a subset of integers: 91 | -- 92 | -- > N = {i :: Integer | i < N} 93 | -- 94 | -- Then it is actually a (category-theoretic) 95 | -- diagram showing values of @ProEnumeration a b@. 96 | data ProEnumeration a b = 97 | ProEnumeration { 98 | -- | Get the cardinality of a proenumeration 99 | card :: Cardinality 100 | 101 | -- | See @E.'E.select'@ 102 | , select :: Index -> b 103 | 104 | -- | See @C.'C.locate'@ 105 | , locate :: a -> Index 106 | } 107 | deriving (Functor) 108 | 109 | -- | Returns if the the cardinality of a proenumeration is finite. 110 | isFinite :: ProEnumeration a b -> Bool 111 | isFinite = (/= Infinite) . card 112 | 113 | -- | ProEnumeration is a Profunctor 114 | -- 115 | -- > dimap l r p = l .@ p @. r 116 | dimap :: (a' -> a) -> (b -> b') -> ProEnumeration a b -> ProEnumeration a' b' 117 | dimap l r p = p{ select = r . select p, locate = locate p . l } 118 | 119 | -- | > p @. r = dimap id r p 120 | (@.) :: ProEnumeration a b -> (b -> b') -> ProEnumeration a b' 121 | (@.) = flip fmap 122 | 123 | infixl 7 @. 124 | 125 | -- | > l .@ p = dimap l id p 126 | (.@) :: (a' -> a) -> ProEnumeration a b -> ProEnumeration a' b 127 | l .@ p = p{ locate = locate p . l } 128 | 129 | infixr 8 .@ 130 | 131 | -- | Take an 'Enumeration' from a proenumeration, 132 | -- discarding the @CoEnumeration@ part 133 | baseEnum :: ProEnumeration a b -> Enumeration b 134 | baseEnum p = E.mkEnumeration (card p) (select p) 135 | 136 | -- | Take an 'CoEnumeration' from a proenumeration, 137 | -- discarding @Enumeration@ part 138 | baseCoEnum :: ProEnumeration a b -> CoEnumeration a 139 | baseCoEnum p = C.unsafeMkCoEnumeration (card p) (locate p) 140 | 141 | -- | Turn a proenumeration into a normal function. 142 | -- 143 | -- > run p = (select p :: Index -> b) . (locate p :: a -> Index) 144 | run :: ProEnumeration a b -> a -> b 145 | run p = select p . locate p 146 | 147 | -- * Primitive proenumerations 148 | 149 | -- | @enumerateRange = E.enumerate . 'baseEnum'@ 150 | enumerateRange :: ProEnumeration a b -> [b] 151 | enumerateRange = E.enumerate . baseEnum 152 | 153 | -- | Constructs a proenumeration from a 'CoEnumeration' and an 'Enumeration'. 154 | -- 155 | -- The cardinalities of the two arguments must be equal. 156 | -- Otherwise, 'mkProEnumeration' returns an error. 157 | -- 158 | -- > baseEnum (mkProEnumeration a b) = b 159 | -- > baseCoEnum (mkProEnumeration a b) = a 160 | -- 161 | -- >>> p = mkProEnumeration (C.modulo 3) (E.finiteList "abc") 162 | -- >>> (card p, locate p 4, select p 1) 163 | -- (Finite 3,1,'b') 164 | mkProEnumeration :: CoEnumeration a -> Enumeration b -> ProEnumeration a b 165 | mkProEnumeration a b 166 | | na == nb = p 167 | | otherwise = error $ "mkProEnumeration cardinality mismatch:" ++ show (na, nb) 168 | where 169 | na = C.card a 170 | nb = E.card b 171 | p = ProEnumeration{ card = na, select = E.select b, locate = C.locate a } 172 | 173 | -- | Constructs a proenumeration. 174 | -- 175 | -- To construct a valid proenumeration by @unsafeMkProEnumeration n f g@, 176 | -- it must satisfy the following conditions: 177 | -- 178 | -- * For all @i :: Integer@, if @0 <= i && i < n@, then @f i@ should be 179 | -- \"valid\" (usually, it means @f i@ should evaluate without exception). 180 | -- * For all @x :: a@, @(Finite (g x) < n)@. 181 | -- 182 | -- This functions does not (and never could) check the validity 183 | -- of its arguments. 184 | unsafeMkProEnumeration 185 | :: Cardinality-> (Index -> b) -> (a -> Index) -> ProEnumeration a b 186 | unsafeMkProEnumeration = ProEnumeration 187 | 188 | -- | @unit = 'mkProEnumeration' C.'C.unit' E.'E.unit'@ 189 | unit :: ProEnumeration a () 190 | unit = mkProEnumeration C.unit E.unit 191 | 192 | -- | @singleton b = b <$ 'unit' = 'mkProEnumeration' C.'C.unit' (E.'E.singleton' b)@ 193 | singleton :: b -> ProEnumeration a b 194 | singleton b = mkProEnumeration C.unit (E.singleton b) 195 | 196 | -- | @empty = 'mkProEnumeration' 'lost' 'Ap.empty'@ 197 | empty :: ProEnumeration Void b 198 | empty = mkProEnumeration C.lost Ap.empty 199 | 200 | -- | @boundedEnum = 'mkProEnumeration' C.'C.boundedEnum' E.'E.boundedEnum'@ 201 | boundedEnum :: (Enum a, Bounded a) => ProEnumeration a a 202 | boundedEnum = mkProEnumeration C.boundedEnum E.boundedEnum 203 | 204 | -- | @modulo k = 'mkProEnumeration' (C.'C.modulo' k) (E.'E.finite' k)@ 205 | -- 206 | -- >>> card (modulo 13) == Finite 13 207 | -- True 208 | -- >>> run (modulo 13) 1462325 == 1462325 `mod` 13 209 | -- True 210 | modulo :: Integer -> ProEnumeration Integer Integer 211 | modulo k = mkProEnumeration (C.modulo k) (E.finite k) 212 | 213 | -- | @clamped lo hi@ is a proenumeration of integers, 214 | -- which does not modify integers between @lo@ and @hi@, inclusive, 215 | -- and limits smaller (larger) integer to @lo@ (@hi@). 216 | -- 217 | -- It is an error to call this function if @lo > hi@. 218 | -- 219 | -- > run (clamped lo hi) = min hi . max lo 220 | -- 221 | -- >>> card (clamped (-2) 2) 222 | -- Finite 5 223 | -- >>> enumerateRange (clamped (-2) 2) 224 | -- [-2,-1,0,1,2] 225 | -- >>> run (clamped (-2) 2) <$> [-4 .. 4] 226 | -- [-2,-2,-2,-1,0,1,2,2,2] 227 | clamped :: Integer -> Integer -> ProEnumeration Integer Integer 228 | clamped lo hi 229 | | lo <= hi = ProEnumeration 230 | { card = Finite (1 + hi - lo) 231 | , select = (+ lo) 232 | , locate = \i -> min (hi - lo) (max 0 (i - lo)) 233 | } 234 | | otherwise = error "Empty range" 235 | 236 | -- | @boundsChecked lo hi@ is a proenumeration of a \"bounds check\" function, 237 | -- which validates that an input is between @lo@ and @hi@, inclusive, 238 | -- and returns @Nothing@ if it is outside those bounds. 239 | -- 240 | -- > run (boundsChecked lo hi) i 241 | -- | lo <= i && i <= hi = Just i 242 | -- | otherwise = Nothing 243 | -- 244 | -- >>> card (boundsChecked (-2) 2) 245 | -- Finite 6 246 | -- >>> -- Justs of [-2 .. 2] and Nothing 247 | -- >>> enumerateRange (boundsChecked (-2) 2) 248 | -- [Just (-2),Just (-1),Just 0,Just 1,Just 2,Nothing] 249 | -- >>> run (boundsChecked (-2) 2) <$> [-4 .. 4] 250 | -- [Nothing,Nothing,Just (-2),Just (-1),Just 0,Just 1,Just 2,Nothing,Nothing] 251 | boundsChecked :: Integer -> Integer -> ProEnumeration Integer (Maybe Integer) 252 | boundsChecked lo hi = ProEnumeration 253 | { card = Finite size 254 | , select = sel 255 | , locate = loc 256 | } 257 | where 258 | n = 1 + hi - lo 259 | size = 1 + max 0 n 260 | sel i 261 | | 0 <= i && i < n = Just (i + lo) 262 | | i == n = Nothing 263 | | otherwise = error "out of bounds" 264 | loc k | lo <= k && k <= hi = k - lo 265 | | otherwise = n 266 | 267 | 268 | -- | @finiteList as@ is a proenumeration of a \"bounds checked\" 269 | -- indexing of @as@. 270 | -- 271 | -- > run (finiteList as) i 272 | -- | 0 <= i && i < length as = Just (as !! i) 273 | -- | otherwise = Nothing 274 | -- 275 | -- Note that 'finiteList' uses '!!' on the input list 276 | -- under the hood, which has bad performance for long lists. 277 | -- See also the documentation of Data.Enumeration.'E.finiteList'. 278 | -- >>> card (finiteList "HELLO") 279 | -- Finite 6 280 | -- >>> -- Justs and Nothing 281 | -- >>> enumerateRange (finiteList "HELLO") 282 | -- [Just 'H',Just 'E',Just 'L',Just 'L',Just 'O',Nothing] 283 | -- >>> run (finiteList "HELLO") <$> [0 .. 6] 284 | -- [Just 'H',Just 'E',Just 'L',Just 'L',Just 'O',Nothing,Nothing] 285 | finiteList :: [a] -> ProEnumeration Integer (Maybe a) 286 | finiteList as = boundsChecked 0 (n-1) @. (fmap sel) 287 | where 288 | as' = E.finiteList as 289 | Finite n = E.card as' 290 | sel = E.select as' 291 | 292 | -- | @finiteCycle as@ is a proenumeration of an indexing of @as@, 293 | -- where every integer is a valid index by taking it modulo @length as@. 294 | -- 295 | -- > run (finiteCycle as) i = as !! (i `mod` length as) 296 | -- 297 | -- If @as@ is an empty list, it is an error. 298 | -- 299 | -- >>> card (finiteCycle "HELLO") 300 | -- Finite 5 301 | -- >>> enumerateRange (finiteCycle "HELLO") 302 | -- "HELLO" 303 | -- >>> run (finiteCycle "HELLO") <$> [0 .. 10] 304 | -- "HELLOHELLOH" 305 | finiteCycle :: [a] -> ProEnumeration Integer a 306 | finiteCycle as = modulo n @. sel 307 | where 308 | as' = E.finiteList as 309 | Finite n = E.card as' 310 | sel = E.select as' 311 | 312 | -- | @nat = 'mkProEnumeration' C.'C.nat' E.'E.nat'@ 313 | nat :: ProEnumeration Integer Integer 314 | nat = mkProEnumeration C.nat E.nat 315 | 316 | -- | @int = 'mkProEnumeration' C.'C.int' E.'E.int'@ 317 | int :: ProEnumeration Integer Integer 318 | int = mkProEnumeration C.int E.int 319 | 320 | -- | @cw = 'mkProEnumeration' C.'C.cw' E.'E.cw'@ 321 | cw :: ProEnumeration Rational Rational 322 | cw = mkProEnumeration C.cw E.cw 323 | 324 | -- | @rat = 'mkProEnumeration' C.'C.rat' E.'E.rat'@ 325 | rat :: ProEnumeration Rational Rational 326 | rat = mkProEnumeration C.rat E.rat 327 | 328 | -- | Sets the cardinality of given proenumeration to 'Infinite' 329 | infinite :: ProEnumeration a b -> ProEnumeration a b 330 | infinite p = p{ card = Infinite } 331 | 332 | -- * Proenumeration combinators 333 | 334 | -- | From two proenumerations @p, q@, we can make a proenumeration 335 | -- @compose p q@ which behaves as a composed function 336 | -- (in diagrammatic order like 'Control.Category.>>>'.) 337 | -- 338 | -- > run (compose p q) = run q . run p 339 | -- 340 | -- @p@ and @q@ can be drawn in a diagram as follows: 341 | -- 342 | -- > [_______p______] [______q______] 343 | -- > 344 | -- > lp sp lq sq 345 | -- > a ----> N ----> b ----> M ----> c 346 | -- 347 | -- To get a proenumeration @a -> ?? -> c@, there are two obvious choices: 348 | -- 349 | -- > run p >>> lq sq 350 | -- > a --------------------> M ----> c 351 | -- > lp sp >>> run q 352 | -- > a ----> N --------------------> c 353 | -- 354 | -- This function chooses the option with the smaller cardinality. 355 | compose :: ProEnumeration a b -> ProEnumeration b c -> ProEnumeration a c 356 | compose p q 357 | | card p <= card q = p @. run q 358 | | otherwise = run p .@ q 359 | 360 | -- | Cartesian product of proenumerations. 361 | -- 362 | -- @ 363 | -- p >< q = 'mkProEnumeration' (baseCoEnum p C.'C.><' baseCoEnum q) 364 | -- (baseEnum p E.'E.><' baseEnum q) 365 | -- @ 366 | -- 367 | -- This operation is not associative if and only if one of the arguments 368 | -- is not finite. 369 | (><) :: ProEnumeration a1 b1 -> ProEnumeration a2 b2 -> ProEnumeration (a1,a2) (b1,b2) 370 | p >< q = mkProEnumeration (baseCoEnum p C.>< baseCoEnum q) (baseEnum p E.>< baseEnum q) 371 | 372 | -- | Disjoint sum of proenumerations. 373 | -- 374 | -- @ 375 | -- p <+> q = 'mkProEnumeration' 376 | -- (baseCoEnum p C.'C.<+>' baseCoEnum q) 377 | -- (baseEnum p `E.'E.eitherOf'` baseEnum q) 378 | -- @ 379 | -- This operation is not associative if and only if one of the arguments 380 | -- is not finite. 381 | (<+>) :: ProEnumeration a1 b1 -> ProEnumeration a2 b2 382 | -> ProEnumeration (Either a1 a2) (Either b1 b2) 383 | p <+> q = mkProEnumeration (baseCoEnum p C.<+> baseCoEnum q) (E.eitherOf (baseEnum p) (baseEnum q)) 384 | 385 | -- | @maybeOf p = 'mkProEnumeration' (C.'C.maybeOf' (baseCoEnum p)) (E.'E.maybeOf' (baseEnum p))@ 386 | maybeOf :: ProEnumeration a b -> ProEnumeration (Maybe a) (Maybe b) 387 | maybeOf p = dimap (maybe (Left ()) Right) (either (const Nothing) Just) $ 388 | unit <+> p 389 | 390 | -- | Synonym of '(<+>)' 391 | eitherOf :: ProEnumeration a1 b1 -> ProEnumeration a2 b2 392 | -> ProEnumeration (Either a1 a2) (Either b1 b2) 393 | eitherOf = (<+>) 394 | 395 | -- | @listOf p = 'mkProEnumeration' (C.'C.listOf' (baseCoEnum p)) (E.'E.listOf' (baseEnum p))@ 396 | listOf :: ProEnumeration a b -> ProEnumeration [a] [b] 397 | listOf p = mkProEnumeration (C.listOf (baseCoEnum p)) (E.listOf (baseEnum p)) 398 | 399 | -- | 400 | -- @ 401 | -- finiteSubsetOf p = 'mkProEnumeration' 402 | -- (C.'C.finiteSubsetOf' (baseCoEnum p)) 403 | -- (E.'E.finiteSubsetOf' (baseEnum p)) 404 | -- @ 405 | finiteSubsetOf :: ProEnumeration a b -> ProEnumeration [a] [b] 406 | finiteSubsetOf p = 407 | mkProEnumeration (C.finiteSubsetOf (baseCoEnum p)) (E.finiteSubsetOf (baseEnum p)) 408 | 409 | -- | Enumerate every possible proenumeration. 410 | -- 411 | -- @enumerateP a b@ generates proenumerations @p@ 412 | -- such that the function @run p@ has the following properties: 413 | -- 414 | -- * The range of @run p@ is a subset of @b :: Enumeration b@. 415 | -- * If @locate a x = locate a y@, then @run p x = run p y@. 416 | -- In other words, @run p@ factors through @locate a@. 417 | -- 418 | -- This function generates proenumerations @p@ in such a way that 419 | -- every function of type @a -> b@ with the above properties uniquely 420 | -- appears as @run p@ for some enumerated @p@. 421 | enumerateP :: CoEnumeration a -> Enumeration b -> Enumeration (ProEnumeration a b) 422 | enumerateP a b = case (C.card a, E.card b) of 423 | (0, _) -> E.singleton (mkProEnumeration a Ap.empty) 424 | (_, 1) -> E.singleton (mkProEnumeration C.unit b) 425 | (Finite k,_) -> mkProEnumeration a <$> E.finiteEnumerationOf (fromInteger k) b 426 | (Infinite,_) -> error "infinite domain" 427 | 428 | -- | Coenumerate every possible function. 429 | -- 430 | -- @coenumerateP as bs@ classifies functions of type @a -> b@ 431 | -- by the following criterion: 432 | -- 433 | -- @f@ and @g@ have the same index 434 | -- 435 | -- /if and only if/ 436 | -- 437 | -- For all elements @a@ of @as :: Enumeration a@, 438 | -- @locate bs (f a) = locate bs (g a)@. 439 | -- 440 | -- /Note/: The suffix @P@ suggests it coenumerates @ProEnumeration a b@, 441 | -- but it actually coenumerates @a -> b@. The reason is that 442 | -- @ProEnumeration a b@ carries extra data and constraints like its cardinality, 443 | -- but the classification does not care about those. Thus, it is more permissive to 444 | -- accept any function of type @a -> b@. 445 | -- 446 | -- To force it to coenumerate proenumerations, 447 | -- @'contramap' 'run'@ can be applied. 448 | coenumerateP :: Enumeration a -> CoEnumeration b -> CoEnumeration (a -> b) 449 | coenumerateP a b = case (E.card a, C.card b) of 450 | (0, _) -> C.unit 451 | (_, 1) -> C.unit 452 | (Finite k,_) -> contramap (\f -> f . E.select a) $ C.finiteFunctionOf k b 453 | (Infinite,_) -> error "infinite domain" 454 | 455 | {- | 'enumerateP' and 'coenumerateP' combined. 456 | 457 | > l_a s_a 458 | > a -----> N -----> a' :: ProEnumeration a a' 459 | > 460 | > l_b s_b 461 | > b -----> M -----> b' :: ProEnumeration b b' 462 | > 463 | > 464 | > (N -> b) ---> (N -> M) ---> (N -> b') 465 | > ^ || | 466 | > | (. s_a) || | (. l_a) 467 | > | || v 468 | > (a' -> b) (M ^ N) (a -> b') 469 | 470 | * When @N@ is finite, @(M ^ N)@ is at most countable, since @M@ is 471 | at most countable. 472 | 473 | * The enumerated functions (of type @a -> b'@) are compositions 474 | of @l_a :: a -> N@ and functions of type @N -> b@. 475 | It is beneficial to tell this fact by the type, 476 | which happens to be @ProEnumeration a b'@. 477 | 478 | -} 479 | proenumerationOf 480 | :: ProEnumeration a a' 481 | -> ProEnumeration b b' 482 | -> ProEnumeration (a' -> b) (ProEnumeration a b') 483 | proenumerationOf a b 484 | = mkProEnumeration 485 | (coenumerateP (baseEnum a) (baseCoEnum b)) 486 | (enumerateP (baseCoEnum a) (baseEnum b)) 487 | 488 | -- | @finiteFunctionOf k p@ is a proenumeration of products of @k@ copies of 489 | -- @a@ and @b@ respectively. 490 | -- 491 | -- If @p@ is a invertible enumeration, @finiteFunctionOf k p@ is too. 492 | -- 493 | -- It is implemented using 'proenumerationOf'. 494 | finiteFunctionOf 495 | :: Integer -> ProEnumeration a b -> ProEnumeration (Integer -> a) (Integer -> b) 496 | finiteFunctionOf k p = proenumerationOf (modulo k) p @. select 497 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-16.2 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - . 37 | # Dependency packages to be pulled from upstream that are not in the resolver 38 | # using the same syntax as the packages field. 39 | # (e.g., acme-missiles-0.3) 40 | # extra-deps: [] 41 | 42 | # Override default flag values for local packages and extra-deps 43 | # flags: {} 44 | 45 | # Extra package databases containing global packages 46 | # extra-package-dbs: [] 47 | 48 | # Control whether we use the GHC we find on the path 49 | # system-ghc: true 50 | # 51 | # Require a specific version of stack, using version ranges 52 | # require-stack-version: -any # Default 53 | # require-stack-version: ">=1.9" 54 | # 55 | # Override the architecture used by stack, especially useful on Windows 56 | # arch: i386 57 | # arch: x86_64 58 | # 59 | # Extra directories used by stack for building 60 | # extra-include-dirs: [/path/to/dir] 61 | # extra-lib-dirs: [/path/to/dir] 62 | # 63 | # Allow a newer minor version of GHC than the snapshot specifies 64 | # compiler-check: newer-minor 65 | -------------------------------------------------------------------------------- /test/doctests.hs: -------------------------------------------------------------------------------- 1 | import Test.DocTest 2 | main = doctest 3 | ["-isrc" 4 | ,"src/Data/Enumeration.hs" 5 | ,"src/Data/Enumeration/Invertible.hs" 6 | ,"src/Data/CoEnumeration.hs" 7 | ,"src/Data/ProEnumeration.hs" 8 | ,"--fast" 9 | ,"-package contravariant" 10 | ] 11 | --------------------------------------------------------------------------------