├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── .stylish-haskell.yaml ├── CHANGELOG.md ├── CONTRIBUTING.md ├── LICENSE ├── README.md ├── Setup.lhs ├── cabal.haskell-ci ├── cabal.project ├── lattices.cabal ├── m2.png ├── m3.png ├── n5.png ├── src └── Algebra │ ├── Heyting.hs │ ├── Heyting │ ├── Free.hs │ └── Free │ │ └── Expr.hs │ ├── Lattice.hs │ ├── Lattice │ ├── Divisibility.hs │ ├── Dropped.hs │ ├── Free.hs │ ├── Free │ │ └── Final.hs │ ├── Levitated.hs │ ├── Lexicographic.hs │ ├── Lifted.hs │ ├── M2.hs │ ├── M3.hs │ ├── N5.hs │ ├── Op.hs │ ├── Ordered.hs │ ├── Unicode.hs │ ├── Wide.hs │ └── ZeroHalfOne.hs │ ├── PartialOrd.hs │ └── PartialOrd │ └── Instances.hs ├── test └── Tests.hs └── wide.png /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project' 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.20250506 12 | # 13 | # REGENDATA ("0.19.20250506",["github","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | push: 18 | branches: 19 | - master 20 | pull_request: 21 | branches: 22 | - master 23 | jobs: 24 | linux: 25 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 26 | runs-on: ubuntu-24.04 27 | timeout-minutes: 28 | 60 29 | container: 30 | image: buildpack-deps:jammy 31 | continue-on-error: ${{ matrix.allow-failure }} 32 | strategy: 33 | matrix: 34 | include: 35 | - compiler: ghc-9.12.2 36 | compilerKind: ghc 37 | compilerVersion: 9.12.2 38 | setup-method: ghcup 39 | allow-failure: false 40 | - compiler: ghc-9.10.2 41 | compilerKind: ghc 42 | compilerVersion: 9.10.2 43 | setup-method: ghcup 44 | allow-failure: false 45 | - compiler: ghc-9.8.4 46 | compilerKind: ghc 47 | compilerVersion: 9.8.4 48 | setup-method: ghcup 49 | allow-failure: false 50 | - compiler: ghc-9.6.7 51 | compilerKind: ghc 52 | compilerVersion: 9.6.7 53 | setup-method: ghcup 54 | allow-failure: false 55 | - compiler: ghc-9.4.8 56 | compilerKind: ghc 57 | compilerVersion: 9.4.8 58 | setup-method: ghcup 59 | allow-failure: false 60 | - compiler: ghc-9.2.8 61 | compilerKind: ghc 62 | compilerVersion: 9.2.8 63 | setup-method: ghcup 64 | allow-failure: false 65 | - compiler: ghc-9.0.2 66 | compilerKind: ghc 67 | compilerVersion: 9.0.2 68 | setup-method: ghcup 69 | allow-failure: false 70 | - compiler: ghc-8.10.4 71 | compilerKind: ghc 72 | compilerVersion: 8.10.4 73 | setup-method: ghcup 74 | allow-failure: false 75 | - compiler: ghc-8.8.3 76 | compilerKind: ghc 77 | compilerVersion: 8.8.3 78 | setup-method: ghcup 79 | allow-failure: false 80 | - compiler: ghc-8.6.5 81 | compilerKind: ghc 82 | compilerVersion: 8.6.5 83 | setup-method: ghcup 84 | allow-failure: false 85 | fail-fast: false 86 | steps: 87 | - name: apt-get install 88 | run: | 89 | apt-get update 90 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 91 | - name: Install GHCup 92 | run: | 93 | mkdir -p "$HOME/.ghcup/bin" 94 | curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" 95 | chmod a+x "$HOME/.ghcup/bin/ghcup" 96 | - name: Install cabal-install 97 | run: | 98 | "$HOME/.ghcup/bin/ghcup" install cabal 3.14.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 99 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" 100 | - name: Install GHC (GHCup) 101 | if: matrix.setup-method == 'ghcup' 102 | run: | 103 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 104 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 105 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 106 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 107 | echo "HC=$HC" >> "$GITHUB_ENV" 108 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 109 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 110 | env: 111 | HCKIND: ${{ matrix.compilerKind }} 112 | HCNAME: ${{ matrix.compiler }} 113 | HCVER: ${{ matrix.compilerVersion }} 114 | - name: Set PATH and environment variables 115 | run: | 116 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 117 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 118 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 119 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 120 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 121 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 122 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 123 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 124 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 125 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 126 | env: 127 | HCKIND: ${{ matrix.compilerKind }} 128 | HCNAME: ${{ matrix.compiler }} 129 | HCVER: ${{ matrix.compilerVersion }} 130 | - name: env 131 | run: | 132 | env 133 | - name: write cabal config 134 | run: | 135 | mkdir -p $CABAL_DIR 136 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 174 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 175 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 176 | rm -f cabal-plan.xz 177 | chmod a+x $HOME/.cabal/bin/cabal-plan 178 | cabal-plan --version 179 | - name: install cabal-docspec 180 | run: | 181 | mkdir -p $HOME/.cabal/bin 182 | curl -sL https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20240703/cabal-docspec-0.0.0.20240703-x86_64-linux.xz > cabal-docspec.xz 183 | echo '48bf3b7fd2f7f0caa6162afee57a755be8523e7f467b694900eb420f5f9a7b76 cabal-docspec.xz' | sha256sum -c - 184 | xz -d < cabal-docspec.xz > $HOME/.cabal/bin/cabal-docspec 185 | rm -f cabal-docspec.xz 186 | chmod a+x $HOME/.cabal/bin/cabal-docspec 187 | cabal-docspec --version 188 | - name: install doctest 189 | run: | 190 | if [ $((HCNUMVER < 90000)) -ne 0 ] ; then $CABAL --store-dir=$HOME/.haskell-ci-tools/store v2-install $ARG_COMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.22.0' ; fi 191 | if [ $((HCNUMVER < 90000)) -ne 0 ] ; then doctest --version ; fi 192 | - name: save cache (tools) 193 | if: always() 194 | uses: actions/cache/save@v4 195 | with: 196 | key: ${{ runner.os }}-${{ matrix.compiler }}-tools-91770216 197 | path: ~/.haskell-ci-tools 198 | - name: checkout 199 | uses: actions/checkout@v4 200 | with: 201 | path: source 202 | - name: initial cabal.project for sdist 203 | run: | 204 | touch cabal.project 205 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 206 | cat cabal.project 207 | - name: sdist 208 | run: | 209 | mkdir -p sdist 210 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 211 | - name: unpack 212 | run: | 213 | mkdir -p unpacked 214 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 215 | - name: generate cabal.project 216 | run: | 217 | PKGDIR_lattices="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/lattices-[0-9.]*')" 218 | echo "PKGDIR_lattices=${PKGDIR_lattices}" >> "$GITHUB_ENV" 219 | rm -f cabal.project cabal.project.local 220 | touch cabal.project 221 | touch cabal.project.local 222 | echo "packages: ${PKGDIR_lattices}" >> cabal.project 223 | echo "package lattices" >> cabal.project 224 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 225 | cat >> cabal.project <> cabal.project.local 228 | cat cabal.project 229 | cat cabal.project.local 230 | - name: dump install plan 231 | run: | 232 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 233 | cabal-plan 234 | - name: restore cache 235 | uses: actions/cache/restore@v4 236 | with: 237 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 238 | path: ~/.cabal/store 239 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 240 | - name: install dependencies 241 | run: | 242 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 243 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 244 | - name: build w/o tests 245 | run: | 246 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 247 | - name: build 248 | run: | 249 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 250 | - name: tests 251 | run: | 252 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 253 | - name: doctest 254 | run: | 255 | if [ $((HCNUMVER < 90000)) -ne 0 ] ; then cd ${PKGDIR_lattices} || false ; fi 256 | if [ $((HCNUMVER < 90000)) -ne 0 ] ; then doctest -XHaskell2010 src ; fi 257 | - name: docspec 258 | run: | 259 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all 260 | cabal-docspec $ARG_COMPILER 261 | - name: cabal check 262 | run: | 263 | cd ${PKGDIR_lattices} || false 264 | ${CABAL} -vnormal check 265 | - name: haddock 266 | run: | 267 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 268 | - name: unconstrained build 269 | run: | 270 | rm -f cabal.project.local 271 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 272 | - name: prepare for constraint sets 273 | run: | 274 | rm -f cabal.project.local 275 | - name: constraint set transformers-0.6 276 | run: | 277 | if [ $((HCNUMVER >= 80800)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='transformers ^>=0.6' all --dry-run ; fi 278 | if [ $((HCNUMVER >= 80800)) -ne 0 ] ; then cabal-plan topo | sort ; fi 279 | if [ $((HCNUMVER >= 80800)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='transformers ^>=0.6' --dependencies-only -j2 all ; fi 280 | if [ $((HCNUMVER >= 80800)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='transformers ^>=0.6' all ; fi 281 | - name: save cache 282 | if: always() 283 | uses: actions/cache/save@v4 284 | with: 285 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 286 | path: ~/.cabal/store 287 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | .ghc.environment.* 4 | .cabal-sandbox/ 5 | cabal.sandbox.config 6 | .stack-work 7 | .envrc 8 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - imports: 3 | align: group 4 | list_align: after_alias 5 | long_list_align: new_line 6 | empty_list_align: right_after 7 | list_padding: module_name 8 | - language_pragmas: 9 | style: vertical 10 | remove_redundant: true 11 | - trailing_whitespace: {} 12 | columns: 80 13 | language_extensions: 14 | - DataKinds 15 | - EmptyCase 16 | - ExplicitForAll 17 | - FlexibleContexts 18 | - MultiParamTypeClasses 19 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 2.2.1 (2024-05-16) 2 | 3 | - Support GHC-8.6.5..GHC-9.10.1 4 | 5 | # 2.2 (2022-03-15) 6 | 7 | - Drop `semigroupoids` dependency in favour of `foldable1-classes-compat`. 8 | Be careful with which `Foldable1` class you end up using. 9 | 10 | # 2.1 (2022-12-27) 11 | 12 | - Fix `comprable` for `PartialOrd (a,b)` instance 13 | - Remove `Stacked`, use `Either` instead for ordinal sum. 14 | There is no type for disjoint union / parallel composition. 15 | Open an issue if you need one. 16 | Terminology is from https://en.wikipedia.org/wiki/Partially_ordered_set#Sums_of_partially_ordered_sets 17 | 18 | # 2.0.3 (2021-10-30) 19 | 20 | - Add instances for `Solo` 21 | 22 | # 2.0.2 (2020-02-18) 23 | 24 | - Add `Algebra.Lattice.Stacked` 25 | [#99](https://github.com/phadej/lattices/pull/99) 26 | 27 | # 2.0.1 (2019-07-22) 28 | 29 | - Add `(PartialOrd a, PartialOrd b) => PartialOrd (Either a b)` instance 30 | 31 | # 2 (2019-04-17) 32 | 33 | - Reduce to three classes (from six): `Lattice`, `BoundedMeetSemiLattice`, 34 | `BoundedJoinSemiLattice`. 35 | The latter two names are kept to help migration. 36 | - Remove `Algebra.Enumerable` module. Use `universe` package. 37 | - Drop GHC-7.4.3 support (broken `ConstraintKinds`) 38 | - Move `Algebra.Lattice.Free` to `Algebra.Lattice.Free.Final` 39 | - Add concrete syntax `Algebra.Lattice.Free` and `Algebra.Heyting.Free` using 40 | LJT-proof search for `Eq` and `PartialOrd` 41 | - Change `PartialOrd [a]` to be `leq = isSubsequenceOf` 42 | 43 | # 1.7.1.1 (2019-07-05) 44 | 45 | - Allow newer dependencies, update cabal file 46 | 47 | # 1.7.1 (2018-01-29) 48 | 49 | - Correct *Safe Haskell* annotations. See https://github.com/ekmett/semigroupoids/issues/69 50 | - Bump lower bounds 51 | 52 | # 1.7 (2017-10-01) 53 | 54 | - `HashMap` instances changed 55 | - `PartialOrd Meet` and `Join` 56 | - `PartialOrd ()` and `Void` 57 | - `BoundedLattice (HashSet a)` 58 | - `PartialOrd [a]` (`leq = isInfixOf`) 59 | 60 | # 1.6.0 (2017-06-26) 61 | 62 | - Correct PartialOrd Map and IntMap instances 63 | - Add Lattice instance for `containers` types. 64 | - Change `meets1` and `joins1` to use `Foldable1` 65 | - Add `comparable` to `PartialOrd` 66 | - Add `Algebra.Lattice.Free` module 67 | - Add `Divisibility` lattice. 68 | - Fix `Lexicographic`. 69 | 70 | # 1.5.0 (2015-12-18) 71 | 72 | - Move `PartialOrd (k -> v)` instance into own module 73 | - `Const` and `Identity` instances 74 | - added `fromBool` 75 | - Add `Lexicographic`, `Ordered` and `Op` newtypes 76 | 77 | # 1.4.1 (2015-10-26) 78 | 79 | - `MINIMAL` pragma in with GHC 7.8 80 | - Add `DEPREACTED` pragma for `meet` and `join`, 81 | use infix version `\/` and `/\` 82 | 83 | # 1.4 (2015-09-19) 84 | 85 | - Infix operators 86 | - `meets` and `joins` generalised to work on any `Foldable` 87 | - Deprecate `Algebra.Enumerable`, use [universe package](http://hackage.haskell.org/package/universe) 88 | - Add `Applicative` and `Monad` typeclasses to `Dropped`, `Lifted` and `Levitated` 89 | - Add `Semigroup` instance to `Join` and `Meet` 90 | - Add instances for `()`, `Proxy`, `Tagged` and `Void` 91 | 92 | # 1.3 (2015-05-18) 93 | 94 | - relaxed constraint for `BoundedLattice (Levitated a)` 95 | - added instances to `Dropped`, `Levitated` and `Lifted`: 96 | - from base 97 | - `NFData` 98 | - `Hashable` 99 | - added `HashSet` and `HashMap` lattice instances 100 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | Patches welcome! 2 | 3 | - If you are only going to bump bounds: 4 | - If it's really **only bounds**, please simply open an issue (so you'll have a URL to refer to). I have a semi-automated process to make revisions, pull requests only disturb it. 5 | - If patch includes **source code change** (i.e. I'll need to make a release), and it's a patch to support **newer base/GHC version**: 6 | - Amend `tested-with` to include that GHC 7 | - Regenerate `.github/workflows/haskell-ci.yml` with `haskell-ci regenerate` (get the latest from [GitHub haskell-ci/haskell-ci](https://github.com/haskell-ci/haskell-ci)) 8 | 9 | - Don't edit `CHANGELOG.md`, rather include a copyable entry in your pull request description. I often process pull requests in bulk, and everyone editing the `CHANGELOG.md` causes unnecessary conflicts. 10 | - For the same reason, do not edit `version` or `x-revision` 11 | 12 | - I use [`stylish-haskell`](https://github.com/jaspervdj/stylish-haskell) to format imports. I encourage you to use it too, when contributing. 13 | - General code style is 4 spaces, just look around how it looks, it's not so strict. 14 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010-2015 Maximilian Bolingbroke, 2015 Oleg Grenrus 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted 5 | provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this list of 8 | conditions and the following disclaimer. 9 | * Redistributions in binary form must reproduce the above copyright notice, this list of 10 | conditions and the following disclaimer in the documentation and/or other materials 11 | provided with the distribution. 12 | * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to 13 | endorse or promote products derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 17 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 18 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 20 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 21 | IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 22 | OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # lattices 2 | 3 | [![Build Status](https://travis-ci.org/phadej/lattices.svg?branch=master)](https://travis-ci.org/phadej/lattices) 4 | [![Hackage](https://img.shields.io/hackage/v/lattices.svg)](http://hackage.haskell.org/package/lattices) 5 | 6 | Fine-grained library for constructing and manipulating lattices 7 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env runhaskell 2 | 3 | > import Distribution.Simple 4 | > main = defaultMain -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | branches: master 2 | doctest: <9.0 3 | docspec: True 4 | 5 | constraint-set transformers-0.6 6 | -- https://github.com/haskell-infra/hackage-trustees/issues/352 7 | ghc: >=8.8 8 | constraints: transformers ^>=0.6 9 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | tests: true 3 | -------------------------------------------------------------------------------- /lattices.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.18 2 | name: lattices 3 | version: 2.2.1 4 | x-revision: 2 5 | category: Math 6 | license: BSD3 7 | license-file: LICENSE 8 | author: 9 | Maximilian Bolingbroke , Oleg Grenrus 10 | 11 | maintainer: Oleg Grenrus 12 | homepage: http://github.com/phadej/lattices/ 13 | bug-reports: http://github.com/phadej/lattices/issues 14 | copyright: 15 | (C) 2010-2015 Maximilian Bolingbroke, 2016-2019 Oleg Grenrus 16 | 17 | build-type: Simple 18 | extra-source-files: CHANGELOG.md 19 | extra-doc-files: 20 | m2.png 21 | m3.png 22 | n5.png 23 | wide.png 24 | 25 | tested-with: 26 | GHC ==8.6.5 27 | || ==8.8.3 28 | || ==8.10.4 29 | || ==9.0.2 30 | || ==9.2.8 31 | || ==9.4.8 32 | || ==9.6.7 33 | || ==9.8.4 34 | || ==9.10.2 35 | || ==9.12.2 36 | 37 | synopsis: 38 | Fine-grained library for constructing and manipulating lattices 39 | 40 | description: 41 | In mathematics, a lattice is a partially ordered set in which every two 42 | elements @x@ and @y@ have a unique supremum (also called a least upper bound, join, or @x \\/ y@) 43 | and a unique infimum (also called a greatest lower bound, meet, or @x /\\ y@). 44 | . 45 | This package provide type-classes for different lattice types, as well 46 | as a class for the partial order. 47 | 48 | source-repository head 49 | type: git 50 | location: https://github.com/phadej/lattices.git 51 | 52 | library 53 | default-language: Haskell2010 54 | hs-source-dirs: src 55 | ghc-options: -Wall 56 | exposed-modules: 57 | Algebra.Lattice 58 | Algebra.Lattice.Divisibility 59 | Algebra.Lattice.Dropped 60 | Algebra.Lattice.Free 61 | Algebra.Lattice.Free.Final 62 | Algebra.Lattice.Levitated 63 | Algebra.Lattice.Lexicographic 64 | Algebra.Lattice.Lifted 65 | Algebra.Lattice.M2 66 | Algebra.Lattice.M3 67 | Algebra.Lattice.N5 68 | Algebra.Lattice.Op 69 | Algebra.Lattice.Ordered 70 | Algebra.Lattice.Unicode 71 | Algebra.Lattice.Wide 72 | Algebra.Lattice.ZeroHalfOne 73 | 74 | exposed-modules: 75 | Algebra.Heyting 76 | Algebra.Heyting.Free 77 | Algebra.Heyting.Free.Expr 78 | 79 | exposed-modules: 80 | Algebra.PartialOrd 81 | Algebra.PartialOrd.Instances 82 | 83 | build-depends: 84 | base >=4.12 && <4.22 85 | , containers >=0.5.0.0 && <0.8 86 | , deepseq >=1.3.0.0 && <1.6 87 | , hashable >=1.2.7.0 && <1.6 88 | , integer-logarithms >=1.0.3 && <1.1 89 | , QuickCheck >=2.12.6.1 && <2.16 90 | , tagged >=0.8.6 && <0.9 91 | , transformers >=0.3.0.0 && <0.7 92 | , universe-base >=1.1 && <1.2 93 | , universe-reverse-instances >=1.1 && <1.2 94 | , unordered-containers >=0.2.8.0 && <0.3 95 | 96 | if !impl(ghc >=9.6) 97 | build-depends: foldable1-classes-compat >=0.1 && <0.2 98 | 99 | if !impl(ghc >=9.2) 100 | if impl(ghc >=9.0) 101 | build-depends: ghc-prim 102 | else 103 | build-depends: OneTuple >=0.4 && <0.5 104 | 105 | test-suite test 106 | type: exitcode-stdio-1.0 107 | main-is: Tests.hs 108 | hs-source-dirs: test 109 | ghc-options: -Wall 110 | default-language: Haskell2010 111 | build-depends: 112 | base 113 | , containers 114 | , lattices 115 | , QuickCheck 116 | , quickcheck-instances >=0.3.19 && <0.4 117 | , tasty >=1.2.1 && <1.6 118 | , tasty-quickcheck >=0.10 && <0.11 119 | , transformers 120 | , universe-base 121 | , universe-reverse-instances 122 | , unordered-containers 123 | 124 | if !impl(ghc >=8.0) 125 | build-depends: semigroups 126 | -------------------------------------------------------------------------------- /m2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskellari/lattices/ddae50f63f7d221e84c95784ebc11f1f9c428ed7/m2.png -------------------------------------------------------------------------------- /m3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskellari/lattices/ddae50f63f7d221e84c95784ebc11f1f9c428ed7/m3.png -------------------------------------------------------------------------------- /n5.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskellari/lattices/ddae50f63f7d221e84c95784ebc11f1f9c428ed7/n5.png -------------------------------------------------------------------------------- /src/Algebra/Heyting.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE Safe #-} 4 | ---------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Algebra.Heyting 7 | -- Copyright : (C) 2019 Oleg Grenrus 8 | -- License : BSD-3-Clause (see the file LICENSE) 9 | -- 10 | -- Maintainer : Oleg Grenrus 11 | -- 12 | ---------------------------------------------------------------------------- 13 | module Algebra.Heyting where 14 | 15 | import Algebra.Lattice 16 | import Control.Applicative (Const (..)) 17 | import Data.Functor.Identity (Identity (..)) 18 | import Data.Hashable (Hashable (..)) 19 | import Data.Proxy (Proxy (..)) 20 | import Data.Semigroup (All (..), Any (..), Endo (..)) 21 | import Data.Tagged (Tagged (..)) 22 | import Data.Universe.Class (Finite (..)) 23 | 24 | import qualified Data.HashSet as HS 25 | import qualified Data.Set as Set 26 | 27 | #if MIN_VERSION_base(4,18,0) 28 | import Data.Tuple (Solo (MkSolo)) 29 | #elif MIN_VERSION_base(4,16,0) 30 | import Data.Tuple (Solo (Solo)) 31 | #define MkSolo Solo 32 | #elif MIN_VERSION_base(4,15,0) 33 | import GHC.Tuple (Solo (Solo)) 34 | #define MkSolo Solo 35 | #else 36 | import Data.Tuple.Solo (Solo (MkSolo)) 37 | #endif 38 | 39 | -- | A Heyting algebra is a bounded lattice equipped with a 40 | -- binary operation \(a \to b\) of implication. 41 | -- 42 | -- /Laws/ 43 | -- 44 | -- @ 45 | -- x '==>' x ≡ 'top' 46 | -- x '/\' (x '==>' y) ≡ x '/\' y 47 | -- y '/\' (x '==>' y) ≡ y 48 | -- x '==>' (y '/\' z) ≡ (x '==>' y) '/\' (x '==>' z) 49 | -- @ 50 | -- 51 | class BoundedLattice a => Heyting a where 52 | -- | Implication. 53 | (==>) :: a -> a -> a 54 | 55 | -- | Negation. 56 | -- 57 | -- @ 58 | -- 'neg' x = x '==>' 'bottom' 59 | -- @ 60 | neg :: a -> a 61 | neg x = x ==> bottom 62 | 63 | -- | Equivalence. 64 | -- 65 | -- @ 66 | -- x '<=>' y = (x '==>' y) '/\' (y '==>' x) 67 | -- @ 68 | (<=>) :: a -> a -> a 69 | x <=> y = (x ==> y) /\ (y ==> x) 70 | 71 | infixr 5 ==>, <=> 72 | 73 | ------------------------------------------------------------------------------- 74 | -- base 75 | ------------------------------------------------------------------------------- 76 | 77 | instance Heyting () where 78 | _ ==> _ = () 79 | neg _ = () 80 | _ <=> _ = () 81 | 82 | instance Heyting Bool where 83 | False ==> _ = True 84 | True ==> y = y 85 | 86 | neg = not 87 | (<=>) = (==) 88 | 89 | instance Heyting a => Heyting (b -> a) where 90 | f ==> g = \x -> f x ==> g x 91 | f <=> g = \x -> f x <=> g x 92 | neg f = neg . f 93 | 94 | ------------------------------------------------------------------------------- 95 | -- All, Any, Endo 96 | ------------------------------------------------------------------------------- 97 | 98 | instance Heyting All where 99 | All a ==> All b = All (a ==> b) 100 | neg (All a) = All (neg a) 101 | All a <=> All b = All (a <=> b) 102 | 103 | instance Heyting Any where 104 | Any a ==> Any b = Any (a ==> b) 105 | neg (Any a) = Any (neg a) 106 | Any a <=> Any b = Any (a <=> b) 107 | 108 | instance Heyting a => Heyting (Endo a) where 109 | Endo a ==> Endo b = Endo (a ==> b) 110 | neg (Endo a) = Endo (neg a) 111 | Endo a <=> Endo b = Endo (a <=> b) 112 | 113 | ------------------------------------------------------------------------------- 114 | -- Proxy, Tagged, Const, Identity, Solo 115 | ------------------------------------------------------------------------------- 116 | 117 | instance Heyting (Proxy a) where 118 | _ ==> _ = Proxy 119 | neg _ = Proxy 120 | _ <=> _ = Proxy 121 | 122 | instance Heyting a => Heyting (Identity a) where 123 | Identity a ==> Identity b = Identity (a ==> b) 124 | neg (Identity a) = Identity (neg a) 125 | Identity a <=> Identity b = Identity (a <=> b) 126 | 127 | instance Heyting a => Heyting (Tagged b a) where 128 | Tagged a ==> Tagged b = Tagged (a ==> b) 129 | neg (Tagged a) = Tagged (neg a) 130 | Tagged a <=> Tagged b = Tagged (a <=> b) 131 | 132 | instance Heyting a => Heyting (Const a b) where 133 | Const a ==> Const b = Const (a ==> b) 134 | neg (Const a) = Const (neg a) 135 | Const a <=> Const b = Const (a <=> b) 136 | 137 | -- | @since 2.0.3 138 | instance Heyting a => Heyting (Solo a) where 139 | MkSolo a ==> MkSolo b = MkSolo (a ==> b) 140 | neg (MkSolo a) = MkSolo (neg a) 141 | MkSolo a <=> MkSolo b = MkSolo (a <=> b) 142 | 143 | ------------------------------------------------------------------------------- 144 | -- Sets 145 | ------------------------------------------------------------------------------- 146 | 147 | instance (Ord a, Finite a) => Heyting (Set.Set a) where 148 | x ==> y = Set.union (neg x) y 149 | 150 | neg xs = Set.fromList [ x | x <- universeF, Set.notMember x xs] 151 | 152 | x <=> y = Set.fromList 153 | [ z 154 | | z <- universeF 155 | , Set.member z x <=> Set.member z y 156 | ] 157 | 158 | instance (Eq a, Hashable a, Finite a) => Heyting (HS.HashSet a) where 159 | x ==> y = HS.union (neg x) y 160 | 161 | neg xs = HS.fromList [ x | x <- universeF, not $ HS.member x xs] 162 | 163 | x <=> y = HS.fromList 164 | [ z 165 | | z <- universeF 166 | , HS.member z x <=> HS.member z y 167 | ] 168 | -------------------------------------------------------------------------------- /src/Algebra/Heyting/Free.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE Safe #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | module Algebra.Heyting.Free ( 9 | Free (..), 10 | liftFree, 11 | lowerFree, 12 | retractFree, 13 | substFree, 14 | toExpr, 15 | ) where 16 | 17 | import Algebra.Heyting 18 | import Algebra.Lattice 19 | import Algebra.PartialOrd 20 | 21 | import Control.Applicative (liftA2) 22 | import Control.Monad (ap) 23 | import Data.Data (Data, Typeable) 24 | import GHC.Generics (Generic, Generic1) 25 | import Math.NumberTheory.Logarithms (intLog2) 26 | 27 | import qualified Algebra.Heyting.Free.Expr as E 28 | import qualified Test.QuickCheck as QC 29 | 30 | -- $setup 31 | -- >>> import Algebra.Lattice 32 | -- >>> import Algebra.PartialOrd 33 | -- >>> import Algebra.Heyting 34 | 35 | ------------------------------------------------------------------------------- 36 | -- Free 37 | ------------------------------------------------------------------------------- 38 | 39 | -- | Free Heyting algebra. 40 | -- 41 | -- Note: `Eq` and `PartialOrd` instances aren't structural. 42 | -- 43 | -- >>> Top == (Var 'x' ==> Var 'x') 44 | -- True 45 | -- 46 | -- >>> Var 'x' == Var 'y' 47 | -- False 48 | -- 49 | -- You can test for taulogogies: 50 | -- 51 | -- >>> leq Top $ (Var 'A' /\ Var 'B' ==> Var 'C') <=> (Var 'A' ==> Var 'B' ==> Var 'C') 52 | -- True 53 | -- 54 | -- >>> leq Top $ (Var 'A' /\ neg (Var 'A')) <=> Bottom 55 | -- True 56 | -- 57 | -- >>> leq Top $ (Var 'A' \/ neg (Var 'A')) <=> Top 58 | -- False 59 | -- 60 | data Free a 61 | = Var a 62 | | Bottom 63 | | Top 64 | | Free a :/\: Free a 65 | | Free a :\/: Free a 66 | | Free a :=>: Free a 67 | deriving (Show, Functor, Foldable, Traversable, Generic, Generic1, Data, Typeable) 68 | 69 | infixr 6 :/\: 70 | infixr 5 :\/: 71 | infixr 4 :=>: 72 | 73 | liftFree :: a -> Free a 74 | liftFree = Var 75 | 76 | substFree :: Free a -> (a -> Free b) -> Free b 77 | substFree z k = go z where 78 | go (Var x) = k x 79 | go Bottom = Bottom 80 | go Top = Top 81 | go (x :/\: y) = go x /\ go y 82 | go (x :\/: y) = go x \/ go y 83 | go (x :=>: y) = go x ==> go y 84 | 85 | retractFree :: Heyting a => Free a -> a 86 | retractFree = lowerFree id 87 | 88 | lowerFree :: Heyting b => (a -> b) -> Free a -> b 89 | lowerFree f = go where 90 | go (Var x) = f x 91 | go Bottom = bottom 92 | go Top = top 93 | go (x :/\: y) = go x /\ go y 94 | go (x :\/: y) = go x \/ go y 95 | go (x :=>: y) = go x ==> go y 96 | 97 | toExpr :: Free a -> E.Expr a 98 | toExpr (Var a) = E.Var a 99 | toExpr Bottom = E.Bottom 100 | toExpr Top = E.Top 101 | toExpr (x :/\: y) = toExpr x E.:/\: toExpr y 102 | toExpr (x :\/: y) = toExpr x E.:\/: toExpr y 103 | toExpr (x :=>: y) = toExpr x E.:=>: toExpr y 104 | 105 | ------------------------------------------------------------------------------- 106 | -- Monad 107 | ------------------------------------------------------------------------------- 108 | 109 | instance Applicative Free where 110 | pure = liftFree 111 | (<*>) = ap 112 | 113 | instance Monad Free where 114 | return = pure 115 | (>>=) = substFree 116 | 117 | ------------------------------------------------------------------------------- 118 | -- Instances 119 | ------------------------------------------------------------------------------- 120 | 121 | -- instances do small local optimisations. 122 | 123 | instance Lattice (Free a) where 124 | Top /\ y = y 125 | Bottom /\ _ = Bottom 126 | x /\ Top = x 127 | _ /\ Bottom = Bottom 128 | x /\ y = x :/\: y 129 | 130 | Top \/ _ = Top 131 | Bottom \/ y = y 132 | _ \/ Top = Top 133 | x \/ Bottom = x 134 | x \/ y = x :\/: y 135 | 136 | instance BoundedJoinSemiLattice (Free a) where 137 | bottom = Bottom 138 | 139 | instance BoundedMeetSemiLattice (Free a) where 140 | top = Top 141 | 142 | instance Heyting (Free a) where 143 | Bottom ==> _ = Top 144 | Top ==> y = y 145 | _ ==> Top = Top 146 | x ==> y = x :=>: y 147 | 148 | instance Ord a => Eq (Free a) where 149 | x == y = E.proofSearch (toExpr (x <=> y)) 150 | 151 | instance Ord a => PartialOrd (Free a) where 152 | leq x y = E.proofSearch (toExpr (x ==> y)) 153 | 154 | ------------------------------------------------------------------------------- 155 | -- Other instances 156 | ------------------------------------------------------------------------------- 157 | 158 | instance QC.Arbitrary a => QC.Arbitrary (Free a) where 159 | arbitrary = QC.sized arb where 160 | arb n | n <= 0 = prim 161 | | otherwise = QC.oneof (prim : compound) 162 | where 163 | arb' = arb (sc n) 164 | arb'' = arb (sc (sc n)) -- make domains be smaller. 165 | 166 | sc = intLog2 . max 1 167 | 168 | compound = 169 | [ liftA2 (:/\:) arb' arb' 170 | , liftA2 (:\/:) arb' arb' 171 | , liftA2 (:=>:) arb'' arb' 172 | ] 173 | 174 | prim = QC.frequency 175 | [ (20, Var <$> QC.arbitrary) 176 | , (1, pure Bottom) 177 | , (2, pure Top) 178 | ] 179 | 180 | shrink (Var c) = Top : map Var (QC.shrink c) 181 | shrink Bottom = [] 182 | shrink Top = [Bottom] 183 | shrink (x :/\: y) = x : y : map (uncurry (:/\:)) (QC.shrink (x, y)) 184 | shrink (x :\/: y) = x : y : map (uncurry (:\/:)) (QC.shrink (x, y)) 185 | shrink (x :=>: y) = x : y : map (uncurry (:=>:)) (QC.shrink (x, y)) 186 | -------------------------------------------------------------------------------- /src/Algebra/Heyting/Free/Expr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE Safe #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | module Algebra.Heyting.Free.Expr ( 9 | Expr (..), 10 | proofSearch, 11 | ) where 12 | 13 | import Control.Monad (ap) 14 | import Control.Monad.Trans.State (State, evalState, get, put) 15 | import Data.Data (Data, Typeable) 16 | import Data.Set (Set) 17 | import GHC.Generics (Generic, Generic1) 18 | 19 | import qualified Data.Set as Set 20 | 21 | ------------------------------------------------------------------------------- 22 | -- Expr 23 | ------------------------------------------------------------------------------- 24 | 25 | -- | Heyting algebra expression. 26 | -- 27 | -- /Note:/ this type doesn't have 'Algebra.Heyting.Heyting' instance, 28 | -- as its 'Eq' and 'Ord' are structural. 29 | -- 30 | data Expr a 31 | = Var a 32 | | Bottom 33 | | Top 34 | | Expr a :/\: Expr a 35 | | Expr a :\/: Expr a 36 | | Expr a :=>: Expr a 37 | deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Generic1, Data, Typeable) 38 | 39 | infixr 6 :/\: 40 | infixr 5 :\/: 41 | infixr 4 :=>: 42 | 43 | instance Applicative Expr where 44 | pure = Var 45 | (<*>) = ap 46 | 47 | instance Monad Expr where 48 | return = pure 49 | 50 | Var x >>= k = k x 51 | Bottom >>= _ = Bottom 52 | Top >>= _ = Top 53 | (x :/\: y) >>= k = (x >>= k) :/\: (y >>= k) 54 | (x :\/: y) >>= k = (x >>= k) :\/: (y >>= k) 55 | (x :=>: y) >>= k = (x >>= k) :=>: (y >>= k) 56 | 57 | ------------------------------------------------------------------------------- 58 | -- LJT proof search 59 | ------------------------------------------------------------------------------- 60 | 61 | -- | Decide whether @x :: 'Expr' a@ is provable. 62 | -- 63 | -- /Note:/ this doesn't construct a proof term, but merely returns a 'Bool'. 64 | -- 65 | proofSearch :: forall a. Ord a => Expr a -> Bool 66 | proofSearch tyGoal = evalState (emptyCtx |- fmap R tyGoal) 0 67 | where 68 | freshVar = do 69 | n <- get 70 | put (n + 1) 71 | return (L n) 72 | 73 | infix 4 |- 74 | infixr 3 .&& 75 | 76 | (.&&) :: Monad m => m Bool -> m Bool -> m Bool 77 | x .&& y = do 78 | x' <- x 79 | if x' 80 | then y 81 | else return False 82 | 83 | (|-) :: Ctx a -> Expr (Am a) -> State Int Bool 84 | 85 | -- Ctx ats ai ii xs |- _ 86 | -- | traceShow (length ats, length ai, length ii, length xs) False 87 | -- = return False 88 | 89 | -- T-R 90 | _ctx |- Top 91 | = return True 92 | 93 | -- T-L 94 | Ctx ats ai ii (Top : ctx) |- ty 95 | = Ctx ats ai ii ctx |- ty 96 | 97 | -- F-L 98 | Ctx _ _ _ (Bottom : _ctx) |- _ty 99 | = return True 100 | 101 | -- Id-atoms 102 | Ctx ats _ai _ii [] |- Var a 103 | | Set.member a ats 104 | = return True 105 | 106 | -- Id 107 | Ctx _ats _ai _ii (x : _ctx) |- ty 108 | | x == ty 109 | = return True 110 | 111 | -- Move atoms to atoms part of context 112 | Ctx ats ai ii (Var a : ctx) |- ty 113 | = Ctx (Set.insert a ats) ai ii ctx |- ty 114 | 115 | -- =>-R 116 | Ctx ats ai ii ctx |- (a :=>: b) 117 | = Ctx ats ai ii (a : ctx) |- b 118 | 119 | -- /\-L 120 | Ctx ats ai ii ((x :/\: y) : ctx) |- ty 121 | = Ctx ats ai ii (x : y : ctx) |- ty 122 | 123 | -- =>-L-extra (Top) 124 | -- 125 | -- \Gamma, C |- G 126 | -- -------------------------- 127 | -- \Gamma, 1 -> C |- G 128 | -- 129 | Ctx ats ai ii ((Top :=>: c) : ctx) |- ty 130 | = Ctx ats ai ii (c : ctx) |- ty 131 | 132 | -- =>-L-extra (Bottom) 133 | -- 134 | -- \Gamma |- G 135 | -- -------------------------- 136 | -- \Gamma, 0 -> C |- G 137 | -- 138 | Ctx ats ai ii ((Bottom :=>: _) : ctx) |- ty 139 | = Ctx ats ai ii ctx |- ty 140 | 141 | -- =>-L2 (Conj) 142 | -- 143 | -- \Gamma, A -> (B -> C) |- G 144 | -- -------------------------- 145 | -- \Gamma, (A /\ B) -> C |- G 146 | -- 147 | Ctx ats ai ii ((a :/\: b :=>: c) : ctx) |- ty 148 | = Ctx ats ai ii ((a :=>: b :=>: c) : ctx) |- ty 149 | 150 | -- =>-L3 (Disj) 151 | -- 152 | -- \Gamma, A -> C, B -> C |- G 153 | -- --------------------------- 154 | -- \Gamma, (A \/ B) -> C |- G 155 | -- 156 | -- or with fresh var: (P = A \/ B, but an atom) 157 | -- 158 | -- \Gamma, A -> P, B -> P, P -> C |- G 159 | -- ----------------------------------- 160 | -- \Gamma, (A \/ B) -> C |- G 161 | -- 162 | Ctx ats ai ii ((a :\/: b :=>: c) : ctx) |- ty = do 163 | p <- Var <$> freshVar 164 | Ctx ats ai ii ((p :=>: c) : (a :=>: p) : (b :=>: p) : ctx) |- ty 165 | 166 | -- =>-L4 preparation 167 | -- 168 | -- \Gamma, B -> C, A |- B \Gamma, C |- G 169 | -- ------------------------------------------ 170 | -- \Gamma, (A -> B) -> C |- G 171 | -- 172 | Ctx ats ai ii (((a :=>: b) :=>: c) : ctx) |- ty 173 | = Ctx ats ai (Set.insert (ImplImpl a b c) ii) ctx |- ty 174 | 175 | -- =>-L1 preparation 176 | -- 177 | -- \Gamma, X, B |- G 178 | -- ---------------------- 179 | -- \Gamma, X, X -> B |- G 180 | -- 181 | Ctx ats ai ii ((Var x :=>: b) : ctx) |- ty 182 | = Ctx ats (Set.insert (AtomImpl x b) ai) ii ctx |- ty 183 | 184 | -- These two rules, (\/-L) and (/\-R), are pushed to the last, as they branch. 185 | 186 | -- \/-L 187 | Ctx ats ai ii ((x :\/: y) : ctx) |- ty 188 | = Ctx ats ai ii (x : ctx) |- ty 189 | .&& Ctx ats ai ii (y : ctx) |- ty 190 | 191 | -- /\-R 192 | ctx |- (a :/\: b) 193 | = ctx |- a 194 | .&& ctx |- b 195 | 196 | -- Last rules 197 | Ctx ats ai ii [] |- ty 198 | -- L1 completion 199 | | ((y, ai') : _) <- match 200 | = Ctx ats ai' ii [y] |- ty 201 | 202 | -- \/-R and =>-L4 203 | | not (null rest) = iter rest 204 | where 205 | match = 206 | [ (y, Set.delete ai' ai) 207 | | ai'@(AtomImpl x y) <- Set.toList ai 208 | , x `Set.member` ats 209 | ] 210 | 211 | -- try in order 212 | iter [] = return False 213 | iter (Right (ctx', ty') : rest') = do 214 | res <- ctx' |- ty' 215 | if res 216 | then return True 217 | else iter rest' 218 | 219 | iter (Left (ctxa, a, ctxb, b) : rest') = do 220 | res <- ctxa |- a .&& ctxb |- b 221 | if res 222 | then return True 223 | else iter rest' 224 | 225 | rest = disj ++ implImpl 226 | 227 | -- =>-L4 228 | implImpl = 229 | [ Left (Ctx ats ai ii' [x, y :=>: z], y, Ctx ats ai ii' [z], ty) 230 | | entry@(ImplImpl x y z) <- Set.toList ii 231 | , let ii' = Set.delete entry ii 232 | ] 233 | 234 | -- \/-R 235 | disj = case ty of 236 | a :\/: b -> 237 | [ Right (Ctx ats ai ii [], a) 238 | , Right (Ctx ats ai ii [], b) 239 | ] 240 | _ -> [] 241 | 242 | Ctx _ _ _ [] |- (_ :\/: _) 243 | = error "panic! @proofSearch should be matched before" 244 | 245 | Ctx _ _ _ [] |- Var _ 246 | = return False 247 | 248 | Ctx _ _ _ [] |- Bottom 249 | = return False 250 | 251 | ------------------------------------------------------------------------------- 252 | -- Context 253 | ------------------------------------------------------------------------------- 254 | 255 | data Am a 256 | = L !Int 257 | | R a 258 | deriving (Eq, Ord, Show) 259 | 260 | data Ctx a = Ctx 261 | { ctxAtoms :: Set (Am a) 262 | , ctxAtomImpl :: Set (AtomImpl a) 263 | , ctxImplImpl :: Set (ImplImpl a) 264 | , ctxHypothesis :: [Expr (Am a)] 265 | } 266 | deriving Show 267 | 268 | emptyCtx :: Ctx l 269 | emptyCtx = Ctx Set.empty Set.empty Set.empty [] 270 | 271 | -- [[ AtomImpl a b ]] = a => b 272 | data AtomImpl a = AtomImpl (Am a) (Expr (Am a)) 273 | deriving (Eq, Ord, Show) 274 | 275 | -- [[ ImplImpl a b c ]] = (a ==> b) ==> c 276 | data ImplImpl a = ImplImpl !(Expr (Am a)) !(Expr (Am a)) !(Expr (Am a)) 277 | deriving (Eq, Ord, Show) 278 | -------------------------------------------------------------------------------- /src/Algebra/Lattice.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE Safe #-} 7 | ---------------------------------------------------------------------------- 8 | -- | 9 | -- Module : Algebra.Lattice 10 | -- Copyright : (C) 2010-2015 Maximilian Bolingbroke, 2015-2019 Oleg Grenrus 11 | -- License : BSD-3-Clause (see the file LICENSE) 12 | -- 13 | -- Maintainer : Oleg Grenrus 14 | -- 15 | -- In mathematics, a lattice is a partially ordered set in which every 16 | -- two elements have a unique supremum (also called a least upper bound 17 | -- or @join@) and a unique infimum (also called a greatest lower bound or 18 | -- @meet@). 19 | -- 20 | -- In this module lattices are defined using 'meet' and 'join' operators, 21 | -- as it's constructive one. 22 | -- 23 | ---------------------------------------------------------------------------- 24 | module Algebra.Lattice ( 25 | -- * Unbounded lattices 26 | Lattice (..), 27 | joinLeq, joins1, meetLeq, meets1, 28 | 29 | -- * Bounded lattices 30 | BoundedJoinSemiLattice(..), BoundedMeetSemiLattice(..), 31 | joins, meets, 32 | fromBool, 33 | BoundedLattice, 34 | 35 | -- * Monoid wrappers 36 | Meet(..), Join(..), 37 | 38 | -- * Fixed points of chains in lattices 39 | lfp, lfpFrom, unsafeLfp, 40 | gfp, gfpFrom, unsafeGfp, 41 | ) where 42 | 43 | import qualified Algebra.PartialOrd as PO 44 | 45 | import Control.Applicative (Const (..)) 46 | import Control.Monad.Zip (MonadZip (..)) 47 | import Data.Data (Data, Typeable) 48 | import Data.Foldable1 (Foldable1 (..)) 49 | import Data.Functor.Identity (Identity (..)) 50 | import Data.Hashable (Hashable (..)) 51 | import Data.Proxy (Proxy (..)) 52 | import Data.Semigroup (All (..), Any (..), Endo (..), Semigroup (..)) 53 | import Data.Tagged (Tagged (..)) 54 | import Data.Universe.Class (Finite (..), Universe (..)) 55 | import Data.Void (Void) 56 | import GHC.Generics (Generic) 57 | 58 | import qualified Data.HashMap.Lazy as HM 59 | import qualified Data.HashSet as HS 60 | import qualified Data.IntMap as IM 61 | import qualified Data.IntSet as IS 62 | import qualified Data.Map as Map 63 | import qualified Data.Set as Set 64 | import qualified Test.QuickCheck as QC 65 | 66 | #if MIN_VERSION_base(4,18,0) 67 | import Data.Tuple (Solo (MkSolo)) 68 | #elif MIN_VERSION_base(4,16,0) 69 | import Data.Tuple (Solo (Solo)) 70 | #define MkSolo Solo 71 | #elif MIN_VERSION_base(4,15,0) 72 | import GHC.Tuple (Solo (Solo)) 73 | #define MkSolo Solo 74 | #else 75 | import Data.Tuple.Solo (Solo (MkSolo)) 76 | #endif 77 | 78 | infixr 6 /\ -- This comment needed because of CPP 79 | infixr 5 \/ 80 | 81 | -- | An algebraic structure with joins and meets. 82 | -- 83 | -- See and . 84 | -- 85 | -- 'Lattice' is very symmetric, which is seen from the laws: 86 | -- 87 | -- /Associativity/ 88 | -- 89 | -- @ 90 | -- x '\/' (y '\/' z) ≡ (x '\/' y) '\/' z 91 | -- x '/\' (y '/\' z) ≡ (x '/\' y) '/\' z 92 | -- @ 93 | -- 94 | -- /Commutativity/ 95 | -- 96 | -- @ 97 | -- x '\/' y ≡ y '\/' x 98 | -- x '/\' y ≡ y '/\' x 99 | -- @ 100 | -- 101 | -- /Idempotency/ 102 | -- 103 | -- @ 104 | -- x '\/' x ≡ x 105 | -- x '/\' x ≡ x 106 | -- @ 107 | -- 108 | -- /Absorption/ 109 | -- 110 | -- @ 111 | -- a '\/' (a '/\' b) ≡ a 112 | -- a '/\' (a '\/' b) ≡ a 113 | -- @ 114 | class Lattice a where 115 | -- | join 116 | (\/) :: a -> a -> a 117 | 118 | -- | meet 119 | (/\) :: a -> a -> a 120 | 121 | -- | The partial ordering induced by the join-semilattice structure 122 | joinLeq :: (Eq a, Lattice a) => a -> a -> Bool 123 | joinLeq x y = (x \/ y) == y 124 | 125 | meetLeq :: (Eq a, Lattice a) => a -> a -> Bool 126 | meetLeq x y = (x /\ y) == x 127 | 128 | -- | A join-semilattice with an identity element 'bottom' for '\/'. 129 | -- 130 | -- /Laws/ 131 | -- 132 | -- @ 133 | -- x '\/' 'bottom' ≡ x 134 | -- @ 135 | -- 136 | -- /Corollary/ 137 | -- 138 | -- @ 139 | -- x '/\' 'bottom' 140 | -- ≡⟨ identity ⟩ 141 | -- (x '/\' 'bottom') '\/' 'bottom' 142 | -- ≡⟨ absorption ⟩ 143 | -- 'bottom' 144 | -- @ 145 | class Lattice a => BoundedJoinSemiLattice a where 146 | bottom :: a 147 | 148 | -- | The join of a list of join-semilattice elements 149 | joins :: (BoundedJoinSemiLattice a, Foldable f) => f a -> a 150 | joins = getJoin . foldMap Join 151 | 152 | -- | The join of at a list of join-semilattice elements (of length at least one) 153 | joins1 :: (Lattice a, Foldable1 f) => f a -> a 154 | joins1 = getJoin . foldMap1 Join 155 | 156 | -- | A meet-semilattice with an identity element 'top' for '/\'. 157 | -- 158 | -- /Laws/ 159 | -- 160 | -- @ 161 | -- x '/\' 'top' ≡ x 162 | -- @ 163 | -- 164 | -- /Corollary/ 165 | -- 166 | -- @ 167 | -- x '\/' 'top' 168 | -- ≡⟨ identity ⟩ 169 | -- (x '\/' 'top') '/\' 'top' 170 | -- ≡⟨ absorption ⟩ 171 | -- 'top' 172 | -- @ 173 | -- 174 | class Lattice a => BoundedMeetSemiLattice a where 175 | top :: a 176 | 177 | -- | The meet of a list of meet-semilattice elements 178 | meets :: (BoundedMeetSemiLattice a, Foldable f) => f a -> a 179 | meets = getMeet . foldMap Meet 180 | -- 181 | -- | The meet of at a list of meet-semilattice elements (of length at least one) 182 | meets1 :: (Lattice a, Foldable1 f) => f a -> a 183 | meets1 = getMeet . foldMap1 Meet 184 | 185 | type BoundedLattice a = (BoundedMeetSemiLattice a, BoundedJoinSemiLattice a) 186 | 187 | -- | 'True' to 'top' and 'False' to 'bottom' 188 | fromBool :: BoundedLattice a => Bool -> a 189 | fromBool True = top 190 | fromBool False = bottom 191 | 192 | -- 193 | -- Sets 194 | -- 195 | 196 | instance Ord a => Lattice (Set.Set a) where 197 | (\/) = Set.union 198 | (/\) = Set.intersection 199 | 200 | instance Ord a => BoundedJoinSemiLattice (Set.Set a) where 201 | bottom = Set.empty 202 | 203 | instance (Ord a, Finite a) => BoundedMeetSemiLattice (Set.Set a) where 204 | top = Set.fromList universeF 205 | 206 | -- 207 | -- IntSets 208 | -- 209 | 210 | instance Lattice IS.IntSet where 211 | (\/) = IS.union 212 | (/\) = IS.intersection 213 | 214 | instance BoundedJoinSemiLattice IS.IntSet where 215 | bottom = IS.empty 216 | 217 | -- 218 | -- HashSet 219 | -- 220 | 221 | 222 | instance (Eq a, Hashable a) => Lattice (HS.HashSet a) where 223 | (\/) = HS.union 224 | (/\) = HS.intersection 225 | 226 | instance (Eq a, Hashable a) => BoundedJoinSemiLattice (HS.HashSet a) where 227 | bottom = HS.empty 228 | 229 | instance (Eq a, Hashable a, Finite a) => BoundedMeetSemiLattice (HS.HashSet a) where 230 | top = HS.fromList universeF 231 | 232 | -- 233 | -- Maps 234 | -- 235 | 236 | instance (Ord k, Lattice v) => Lattice (Map.Map k v) where 237 | (\/) = Map.unionWith (\/) 238 | (/\) = Map.intersectionWith (/\) 239 | 240 | instance (Ord k, Lattice v) => BoundedJoinSemiLattice (Map.Map k v) where 241 | bottom = Map.empty 242 | 243 | instance (Ord k, Finite k, BoundedMeetSemiLattice v) => BoundedMeetSemiLattice (Map.Map k v) where 244 | top = Map.fromList (universeF `zip` repeat top) 245 | 246 | -- 247 | -- IntMaps 248 | -- 249 | 250 | instance Lattice v => Lattice (IM.IntMap v) where 251 | (\/) = IM.unionWith (\/) 252 | (/\) = IM.intersectionWith (/\) 253 | 254 | instance Lattice v => BoundedJoinSemiLattice (IM.IntMap v) where 255 | bottom = IM.empty 256 | 257 | -- 258 | -- HashMaps 259 | -- 260 | 261 | instance (Eq k, Hashable k, Lattice v) => BoundedJoinSemiLattice (HM.HashMap k v) where 262 | bottom = HM.empty 263 | 264 | instance (Eq k, Hashable k, Lattice v) => Lattice (HM.HashMap k v) where 265 | (\/) = HM.unionWith (\/) 266 | (/\) = HM.intersectionWith (/\) 267 | 268 | instance (Eq k, Hashable k, Finite k, BoundedMeetSemiLattice v) => BoundedMeetSemiLattice (HM.HashMap k v) where 269 | top = HM.fromList (universeF `zip` repeat top) 270 | 271 | -- 272 | -- Functions 273 | -- 274 | 275 | instance Lattice v => Lattice (k -> v) where 276 | f \/ g = \x -> f x \/ g x 277 | f /\ g = \x -> f x /\ g x 278 | 279 | instance BoundedJoinSemiLattice v => BoundedJoinSemiLattice (k -> v) where 280 | bottom = const bottom 281 | 282 | instance BoundedMeetSemiLattice v => BoundedMeetSemiLattice (k -> v) where 283 | top = const top 284 | 285 | -- 286 | -- Unit 287 | -- 288 | 289 | 290 | instance Lattice () where 291 | _ \/ _ = () 292 | _ /\ _ = () 293 | 294 | instance BoundedJoinSemiLattice () where 295 | bottom = () 296 | 297 | instance BoundedMeetSemiLattice () where 298 | top = () 299 | 300 | -- 301 | -- Tuples 302 | -- 303 | 304 | instance (Lattice a, Lattice b) => Lattice (a, b) where 305 | (x1, y1) \/ (x2, y2) = (x1 \/ x2, y1 \/ y2) 306 | (x1, y1) /\ (x2, y2) = (x1 /\ x2, y1 /\ y2) 307 | 308 | instance (BoundedJoinSemiLattice a, BoundedJoinSemiLattice b) => BoundedJoinSemiLattice (a, b) where 309 | bottom = (bottom, bottom) 310 | 311 | instance (BoundedMeetSemiLattice a, BoundedMeetSemiLattice b) => BoundedMeetSemiLattice (a, b) where 312 | top = (top, top) 313 | 314 | -- 315 | -- Either 316 | -- 317 | 318 | -- | Ordinal sum. 319 | -- 320 | -- @since 2.1 321 | instance (Lattice a, Lattice b) => Lattice (Either a b) where 322 | Right x \/ Right y = Right (x \/ y) 323 | u@(Right _) \/ _ = u 324 | _ \/ u@(Right _) = u 325 | Left x \/ Left y = Left (x \/ y) 326 | 327 | Left x /\ Left y = Left (x /\ y) 328 | l@(Left _) /\ _ = l 329 | _ /\ l@(Left _) = l 330 | Right x /\ Right y = Right (x /\ y) 331 | 332 | -- | @since 2.1 333 | instance (BoundedJoinSemiLattice a, Lattice b) => BoundedJoinSemiLattice (Either a b) where 334 | bottom = Left bottom 335 | 336 | -- | @since 2.1 337 | instance (Lattice a, BoundedMeetSemiLattice b) => BoundedMeetSemiLattice (Either a b) where 338 | top = Right top 339 | 340 | -- 341 | -- Bools 342 | -- 343 | 344 | instance Lattice Bool where 345 | (\/) = (||) 346 | (/\) = (&&) 347 | 348 | instance BoundedJoinSemiLattice Bool where 349 | bottom = False 350 | 351 | instance BoundedMeetSemiLattice Bool where 352 | top = True 353 | 354 | --- Monoids 355 | 356 | -- | Monoid wrapper for join-'Lattice' 357 | newtype Join a = Join { getJoin :: a } 358 | deriving (Eq, Ord, Read, Show, Bounded, Typeable, Data, Generic) 359 | 360 | instance Lattice a => Semigroup (Join a) where 361 | Join a <> Join b = Join (a \/ b) 362 | 363 | instance BoundedJoinSemiLattice a => Monoid (Join a) where 364 | mempty = Join bottom 365 | Join a `mappend` Join b = Join (a \/ b) 366 | 367 | instance (Eq a, Lattice a) => PO.PartialOrd (Join a) where 368 | leq (Join a) (Join b) = joinLeq a b 369 | 370 | instance Functor Join where 371 | fmap f (Join x) = Join (f x) 372 | 373 | instance Applicative Join where 374 | pure = Join 375 | Join f <*> Join x = Join (f x) 376 | _ *> x = x 377 | 378 | instance Monad Join where 379 | return = pure 380 | Join m >>= f = f m 381 | (>>) = (*>) 382 | 383 | instance MonadZip Join where 384 | mzip (Join x) (Join y) = Join (x, y) 385 | 386 | instance Universe a => Universe (Join a) where 387 | universe = fmap Join universe 388 | 389 | instance Finite a => Finite (Join a) where 390 | universeF = fmap Join universeF 391 | 392 | -- | Monoid wrapper for meet-'Lattice' 393 | newtype Meet a = Meet { getMeet :: a } 394 | deriving (Eq, Ord, Read, Show, Bounded, Typeable, Data, Generic) 395 | 396 | instance Lattice a => Semigroup (Meet a) where 397 | Meet a <> Meet b = Meet (a /\ b) 398 | 399 | instance BoundedMeetSemiLattice a => Monoid (Meet a) where 400 | mempty = Meet top 401 | Meet a `mappend` Meet b = Meet (a /\ b) 402 | 403 | instance (Eq a, Lattice a) => PO.PartialOrd (Meet a) where 404 | leq (Meet a) (Meet b) = meetLeq a b 405 | 406 | instance Functor Meet where 407 | fmap f (Meet x) = Meet (f x) 408 | 409 | instance Applicative Meet where 410 | pure = Meet 411 | Meet f <*> Meet x = Meet (f x) 412 | _ *> x = x 413 | 414 | instance Monad Meet where 415 | return = pure 416 | Meet m >>= f = f m 417 | (>>) = (*>) 418 | 419 | instance MonadZip Meet where 420 | mzip (Meet x) (Meet y) = Meet (x, y) 421 | 422 | instance Universe a => Universe (Meet a) where 423 | universe = fmap Meet universe 424 | 425 | instance Finite a => Finite (Meet a) where 426 | universeF = fmap Meet universeF 427 | 428 | -- All 429 | 430 | instance Lattice All where 431 | All a \/ All b = All $ a \/ b 432 | All a /\ All b = All $ a /\ b 433 | 434 | instance BoundedJoinSemiLattice All where 435 | bottom = All False 436 | 437 | instance BoundedMeetSemiLattice All where 438 | top = All True 439 | 440 | -- Any 441 | instance Lattice Any where 442 | Any a \/ Any b = Any $ a \/ b 443 | Any a /\ Any b = Any $ a /\ b 444 | 445 | instance BoundedJoinSemiLattice Any where 446 | bottom = Any False 447 | 448 | instance BoundedMeetSemiLattice Any where 449 | top = Any True 450 | 451 | -- Endo 452 | instance Lattice a => Lattice (Endo a) where 453 | Endo a \/ Endo b = Endo $ a \/ b 454 | Endo a /\ Endo b = Endo $ a /\ b 455 | 456 | instance BoundedJoinSemiLattice a => BoundedJoinSemiLattice (Endo a) where 457 | bottom = Endo bottom 458 | 459 | instance BoundedMeetSemiLattice a => BoundedMeetSemiLattice (Endo a) where 460 | top = Endo top 461 | 462 | -- Tagged 463 | 464 | instance Lattice a => Lattice (Tagged t a) where 465 | Tagged a \/ Tagged b = Tagged $ a \/ b 466 | Tagged a /\ Tagged b = Tagged $ a /\ b 467 | 468 | instance BoundedJoinSemiLattice a => BoundedJoinSemiLattice (Tagged t a) where 469 | bottom = Tagged bottom 470 | 471 | instance BoundedMeetSemiLattice a => BoundedMeetSemiLattice (Tagged t a) where 472 | top = Tagged top 473 | 474 | -- Proxy 475 | instance Lattice (Proxy a) where 476 | _ \/ _ = Proxy 477 | _ /\ _ = Proxy 478 | 479 | instance BoundedJoinSemiLattice (Proxy a) where 480 | bottom = Proxy 481 | 482 | instance BoundedMeetSemiLattice (Proxy a) where 483 | top = Proxy 484 | 485 | -- Identity 486 | 487 | instance Lattice a => Lattice (Identity a) where 488 | Identity a \/ Identity b = Identity (a \/ b) 489 | Identity a /\ Identity b = Identity (a /\ b) 490 | 491 | instance BoundedMeetSemiLattice a => BoundedMeetSemiLattice (Identity a) where 492 | top = Identity top 493 | 494 | instance BoundedJoinSemiLattice a => BoundedJoinSemiLattice (Identity a) where 495 | bottom = Identity bottom 496 | 497 | -- Const 498 | instance Lattice a => Lattice (Const a b) where 499 | Const a \/ Const b = Const (a \/ b) 500 | Const a /\ Const b = Const (a /\ b) 501 | 502 | instance BoundedJoinSemiLattice a => BoundedJoinSemiLattice (Const a b) where 503 | bottom = Const bottom 504 | 505 | instance BoundedMeetSemiLattice a => BoundedMeetSemiLattice (Const a b) where 506 | top = Const top 507 | 508 | ------------------------------------------------------------------------------- 509 | -- Void 510 | ------------------------------------------------------------------------------- 511 | 512 | instance Lattice Void where 513 | a \/ _ = a 514 | a /\ _ = a 515 | 516 | ------------------------------------------------------------------------------- 517 | -- QuickCheck 518 | ------------------------------------------------------------------------------- 519 | 520 | instance Lattice QC.Property where 521 | (\/) = (QC..||.) 522 | (/\) = (QC..&&.) 523 | 524 | instance BoundedJoinSemiLattice QC.Property where bottom = QC.property False 525 | instance BoundedMeetSemiLattice QC.Property where top = QC.property True 526 | 527 | ------------------------------------------------------------------------------- 528 | -- OneTuple 529 | ------------------------------------------------------------------------------- 530 | 531 | -- | @since 2.0.3 532 | instance Lattice a => Lattice (Solo a) where 533 | MkSolo a \/ MkSolo b = MkSolo (a \/ b) 534 | MkSolo a /\ MkSolo b = MkSolo (a /\ b) 535 | 536 | -- | @since 2.0.3 537 | instance BoundedMeetSemiLattice a => BoundedMeetSemiLattice (Solo a) where 538 | top = MkSolo top 539 | 540 | -- | @since 2.0.3 541 | instance BoundedJoinSemiLattice a => BoundedJoinSemiLattice (Solo a) where 542 | bottom = MkSolo bottom 543 | 544 | ------------------------------------------------------------------------------- 545 | -- Theorems 546 | ------------------------------------------------------------------------------- 547 | 548 | -- | Implementation of Kleene fixed-point theorem . 549 | -- Assumes that the function is monotone and does not check if that is correct. 550 | {-# INLINE unsafeLfp #-} 551 | unsafeLfp :: (Eq a, BoundedJoinSemiLattice a) => (a -> a) -> a 552 | unsafeLfp = PO.unsafeLfpFrom bottom 553 | 554 | -- | Implementation of Kleene fixed-point theorem . 555 | -- Forces the function to be monotone. 556 | {-# INLINE lfp #-} 557 | lfp :: (Eq a, BoundedJoinSemiLattice a) => (a -> a) -> a 558 | lfp = lfpFrom bottom 559 | 560 | -- | Implementation of Kleene fixed-point theorem . 561 | -- Forces the function to be monotone. 562 | {-# INLINE lfpFrom #-} 563 | lfpFrom :: (Eq a, BoundedJoinSemiLattice a) => a -> (a -> a) -> a 564 | lfpFrom init_x f = PO.unsafeLfpFrom init_x (\x -> f x \/ x) 565 | 566 | 567 | -- | Implementation of Kleene fixed-point theorem . 568 | -- Assumes that the function is antinone and does not check if that is correct. 569 | {-# INLINE unsafeGfp #-} 570 | unsafeGfp :: (Eq a, BoundedMeetSemiLattice a) => (a -> a) -> a 571 | unsafeGfp = PO.unsafeGfpFrom top 572 | 573 | -- | Implementation of Kleene fixed-point theorem . 574 | -- Forces the function to be antinone. 575 | {-# INLINE gfp #-} 576 | gfp :: (Eq a, BoundedMeetSemiLattice a) => (a -> a) -> a 577 | gfp = gfpFrom top 578 | 579 | -- | Implementation of Kleene fixed-point theorem . 580 | -- Forces the function to be antinone. 581 | {-# INLINE gfpFrom #-} 582 | gfpFrom :: (Eq a, BoundedMeetSemiLattice a) => a -> (a -> a) -> a 583 | gfpFrom init_x f = PO.unsafeGfpFrom init_x (\x -> f x /\ x) 584 | -------------------------------------------------------------------------------- /src/Algebra/Lattice/Divisibility.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE Safe #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | ---------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Algebra.Lattice.Divisibility 13 | -- Copyright : (C) 2010-2015 Maximilian Bolingbroke, 2015-2019 Oleg Grenrus 14 | -- License : BSD-3-Clause (see the file LICENSE) 15 | -- 16 | -- Maintainer : Oleg Grenrus 17 | -- 18 | ---------------------------------------------------------------------------- 19 | module Algebra.Lattice.Divisibility ( 20 | Divisibility(..) 21 | ) where 22 | 23 | import Algebra.Lattice 24 | import Algebra.PartialOrd 25 | 26 | import Control.DeepSeq (NFData (..)) 27 | import Control.Monad (ap) 28 | import Data.Data (Data, Typeable) 29 | import Data.Hashable (Hashable (..)) 30 | import Data.Universe.Class (Finite (..), Universe (..)) 31 | import Data.Universe.Helpers (Natural, Tagged, retag) 32 | import GHC.Generics (Generic, Generic1) 33 | 34 | import qualified Test.QuickCheck as QC 35 | 36 | -- 37 | -- Divisibility 38 | -- 39 | 40 | -- | A divisibility lattice. @'join' = 'lcm'@, @'meet' = 'gcd'@. 41 | newtype Divisibility a = Divisibility { getDivisibility :: a } 42 | deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic, Functor, Foldable, Traversable 43 | , Generic1 44 | ) 45 | 46 | instance Applicative Divisibility where 47 | pure = return 48 | (<*>) = ap 49 | 50 | instance Monad Divisibility where 51 | return = Divisibility 52 | Divisibility x >>= f = f x 53 | 54 | instance NFData a => NFData (Divisibility a) where 55 | rnf (Divisibility a) = rnf a 56 | 57 | instance Hashable a => Hashable (Divisibility a) 58 | 59 | instance Integral a => Lattice (Divisibility a) where 60 | Divisibility x \/ Divisibility y = Divisibility (lcm x y) 61 | 62 | Divisibility x /\ Divisibility y = Divisibility (gcd x y) 63 | 64 | instance Integral a => BoundedJoinSemiLattice (Divisibility a) where 65 | bottom = Divisibility 1 66 | 67 | instance (Eq a, Integral a) => PartialOrd (Divisibility a) where 68 | leq (Divisibility a) (Divisibility b) = b `mod` a == 0 69 | 70 | instance Universe a => Universe (Divisibility a) where 71 | universe = map Divisibility universe 72 | instance Finite a => Finite (Divisibility a) where 73 | universeF = map Divisibility universeF 74 | cardinality = retag (cardinality :: Tagged a Natural) 75 | 76 | instance (QC.Arbitrary a, Num a, Ord a) => QC.Arbitrary (Divisibility a) where 77 | arbitrary = divisibility <$> QC.arbitrary 78 | shrink d = filter ( QC.CoArbitrary (Divisibility a) where 81 | coarbitrary = QC.coarbitrary . getDivisibility 82 | 83 | instance QC.Function a => QC.Function (Divisibility a) where 84 | function = QC.functionMap getDivisibility Divisibility 85 | 86 | divisibility :: (Ord a, Num a) => a -> Divisibility a 87 | divisibility x | x < (-1) = Divisibility (abs x) 88 | | x < 1 = Divisibility 1 89 | | otherwise = Divisibility x 90 | -------------------------------------------------------------------------------- /src/Algebra/Lattice/Dropped.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE Safe #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | ---------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Algebra.Lattice.Dropped 13 | -- Copyright : (C) 2010-2015 Maximilian Bolingbroke, 2015-2019 Oleg Grenrus 14 | -- License : BSD-3-Clause (see the file LICENSE) 15 | -- 16 | -- Maintainer : Oleg Grenrus 17 | -- 18 | ---------------------------------------------------------------------------- 19 | module Algebra.Lattice.Dropped ( 20 | Dropped(..) 21 | , retractDropped 22 | , foldDropped 23 | ) where 24 | 25 | import Algebra.Lattice 26 | import Algebra.PartialOrd 27 | 28 | import Control.DeepSeq (NFData (..)) 29 | import Control.Monad (ap) 30 | import Data.Data (Data, Typeable) 31 | import Data.Hashable (Hashable (..)) 32 | import Data.Universe.Class (Finite (..), Universe (..)) 33 | import Data.Universe.Helpers (Natural, Tagged, retag) 34 | import GHC.Generics (Generic, Generic1) 35 | 36 | import qualified Test.QuickCheck as QC 37 | 38 | -- 39 | -- Dropped 40 | -- 41 | 42 | -- | Graft a distinct top onto an otherwise unbounded lattice. 43 | -- As a bonus, the top will be an absorbing element for the join. 44 | data Dropped a = Drop a 45 | | Top 46 | deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic, Functor, Foldable, Traversable 47 | , Generic1 48 | ) 49 | 50 | instance Applicative Dropped where 51 | pure = return 52 | (<*>) = ap 53 | 54 | instance Monad Dropped where 55 | return = Drop 56 | Top >>= _ = Top 57 | Drop x >>= f = f x 58 | 59 | instance NFData a => NFData (Dropped a) where 60 | rnf Top = () 61 | rnf (Drop a) = rnf a 62 | 63 | instance Hashable a => Hashable (Dropped a) 64 | 65 | instance PartialOrd a => PartialOrd (Dropped a) where 66 | leq _ Top = True 67 | leq Top _ = False 68 | leq (Drop x) (Drop y) = leq x y 69 | comparable Top _ = True 70 | comparable _ Top = True 71 | comparable (Drop x) (Drop y) = comparable x y 72 | 73 | instance Lattice a => Lattice (Dropped a) where 74 | Top \/ _ = Top 75 | _ \/ Top = Top 76 | Drop x \/ Drop y = Drop (x \/ y) 77 | 78 | Top /\ drop_y = drop_y 79 | drop_x /\ Top = drop_x 80 | Drop x /\ Drop y = Drop (x /\ y) 81 | 82 | instance BoundedJoinSemiLattice a => BoundedJoinSemiLattice (Dropped a) where 83 | bottom = Drop bottom 84 | 85 | instance Lattice a => BoundedMeetSemiLattice (Dropped a) where 86 | top = Top 87 | 88 | -- | Interpret @'Dropped' a@ using the 'BoundedMeetSemiLattice' of @a@. 89 | retractDropped :: BoundedMeetSemiLattice a => Dropped a -> a 90 | retractDropped = foldDropped top id 91 | 92 | -- | Similar to @'maybe'@, but for @'Dropped'@ type. 93 | foldDropped :: b -> (a -> b) -> Dropped a -> b 94 | foldDropped _ f (Drop x) = f x 95 | foldDropped y _ Top = y 96 | 97 | instance Universe a => Universe (Dropped a) where 98 | universe = Top : map Drop universe 99 | instance Finite a => Finite (Dropped a) where 100 | universeF = Top : map Drop universeF 101 | cardinality = fmap succ (retag (cardinality :: Tagged a Natural)) 102 | 103 | instance QC.Arbitrary a => QC.Arbitrary (Dropped a) where 104 | arbitrary = QC.frequency 105 | [ (1, pure Top) 106 | , (9, Drop <$> QC.arbitrary) 107 | ] 108 | 109 | shrink Top = [] 110 | shrink (Drop x) = Top : map Drop (QC.shrink x) 111 | 112 | instance QC.CoArbitrary a => QC.CoArbitrary (Dropped a) where 113 | coarbitrary Top = QC.variant (0 :: Int) 114 | coarbitrary (Drop x) = QC.variant (1 :: Int) . QC.coarbitrary x 115 | 116 | instance QC.Function a => QC.Function (Dropped a) where 117 | function = QC.functionMap fromDropped toDropped where 118 | fromDropped = foldDropped Nothing Just 119 | toDropped = maybe Top Drop 120 | -------------------------------------------------------------------------------- /src/Algebra/Lattice/Free.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE Safe #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | module Algebra.Lattice.Free ( 9 | Free (..), 10 | liftFree, 11 | lowerFree, 12 | substFree, 13 | retractFree, 14 | toExpr, 15 | ) where 16 | 17 | import Algebra.Lattice 18 | import Algebra.PartialOrd 19 | 20 | import Control.Applicative (liftA2) 21 | import Control.Monad (ap) 22 | import Data.Data (Data, Typeable) 23 | import GHC.Generics (Generic, Generic1) 24 | import Math.NumberTheory.Logarithms (intLog2) 25 | 26 | import qualified Algebra.Heyting.Free.Expr as E 27 | import qualified Test.QuickCheck as QC 28 | 29 | -- $setup 30 | -- >>> import Algebra.Lattice 31 | 32 | ------------------------------------------------------------------------------- 33 | -- Free 34 | ------------------------------------------------------------------------------- 35 | 36 | -- | Free distributive lattice. 37 | -- 38 | -- `Eq` and `PartialOrd` instances aren't structural. 39 | -- 40 | -- >>> (Var 'x' /\ Var 'y') == (Var 'y' /\ Var 'x' /\ Var 'x') 41 | -- True 42 | -- 43 | -- >>> Var 'x' == Var 'y' 44 | -- False 45 | -- 46 | -- This is /distributive/ lattice. 47 | -- 48 | -- >>> import Algebra.Lattice.M3 -- non distributive lattice 49 | -- >>> let x = M3a; y = M3b; z = M3c 50 | -- >>> let lhs = Var x \/ (Var y /\ Var z) 51 | -- >>> let rhs = (Var x \/ Var y) /\ (Var x \/ Var z) 52 | -- 53 | -- 'Free' is distributive so 54 | -- 55 | -- >>> lhs == rhs 56 | -- True 57 | -- 58 | -- but when retracted, values are inequal 59 | -- 60 | -- >>> retractFree lhs == retractFree rhs 61 | -- False 62 | -- 63 | -- >>> (retractFree lhs, retractFree rhs) 64 | -- (M3a,M3i) 65 | -- 66 | data Free a 67 | = Var a 68 | | Free a :/\: Free a 69 | | Free a :\/: Free a 70 | deriving (Show, Functor, Foldable, Traversable, Generic, Generic1, Data, Typeable) 71 | 72 | infixr 6 :/\: 73 | infixr 5 :\/: 74 | 75 | liftFree :: a -> Free a 76 | liftFree = Var 77 | 78 | retractFree :: Lattice a => Free a -> a 79 | retractFree = lowerFree id 80 | 81 | substFree :: Free a -> (a -> Free b) -> Free b 82 | substFree z k = go z where 83 | go (Var x) = k x 84 | go (x :/\: y) = go x /\ go y 85 | go (x :\/: y) = go x \/ go y 86 | 87 | lowerFree :: Lattice b => (a -> b) -> Free a -> b 88 | lowerFree f = go where 89 | go (Var x) = f x 90 | go (x :/\: y) = go x /\ go y 91 | go (x :\/: y) = go x \/ go y 92 | 93 | toExpr :: Free a -> E.Expr a 94 | toExpr (Var a) = E.Var a 95 | toExpr (x :/\: y) = toExpr x E.:/\: toExpr y 96 | toExpr (x :\/: y) = toExpr x E.:\/: toExpr y 97 | 98 | ------------------------------------------------------------------------------- 99 | -- Monad 100 | ------------------------------------------------------------------------------- 101 | 102 | instance Applicative Free where 103 | pure = liftFree 104 | (<*>) = ap 105 | 106 | instance Monad Free where 107 | return = pure 108 | (>>=) = substFree 109 | 110 | ------------------------------------------------------------------------------- 111 | -- Instances 112 | ------------------------------------------------------------------------------- 113 | 114 | instance Lattice (Free a) where 115 | x /\ y = x :/\: y 116 | x \/ y = x :\/: y 117 | 118 | instance Ord a => Eq (Free a) where 119 | (==) = partialOrdEq 120 | 121 | instance Ord a => PartialOrd (Free a) where 122 | leq x y = E.proofSearch (toExpr x E.:=>: toExpr y) 123 | 124 | ------------------------------------------------------------------------------- 125 | -- Other instances 126 | ------------------------------------------------------------------------------- 127 | 128 | instance QC.Arbitrary a => QC.Arbitrary (Free a) where 129 | arbitrary = QC.sized arb where 130 | arb n | n <= 0 = prim 131 | | otherwise = QC.oneof (prim : compound) 132 | where 133 | arb' = arb (intLog2 (max 1 n)) 134 | 135 | compound = 136 | [ liftA2 (:/\:) arb' arb' 137 | , liftA2 (:\/:) arb' arb' 138 | ] 139 | 140 | prim = Var <$> QC.arbitrary 141 | 142 | shrink (Var c) = map Var (QC.shrink c) 143 | shrink (x :/\: y) = x : y : map (uncurry (:/\:)) (QC.shrink (x, y)) 144 | shrink (x :\/: y) = x : y : map (uncurry (:\/:)) (QC.shrink (x, y)) 145 | -------------------------------------------------------------------------------- /src/Algebra/Lattice/Free/Final.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE Safe #-} 4 | 5 | ---------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Algebra.Lattice.Free 8 | -- License : BSD-3-Clause (see the file LICENSE) 9 | -- 10 | -- Maintainer : Oleg Grenrus 11 | -- 12 | ---------------------------------------------------------------------------- 13 | 14 | module Algebra.Lattice.Free.Final ( 15 | -- * Free Lattice 16 | FLattice, 17 | liftFLattice, 18 | lowerFLattice, 19 | retractFLattice, 20 | -- * Free BoundedLattice 21 | FBoundedLattice, 22 | liftFBoundedLattice, 23 | lowerFBoundedLattice, 24 | retractFBoundedLattice, 25 | ) where 26 | 27 | import Algebra.Lattice 28 | 29 | import Data.Universe.Class (Finite (..), Universe (..)) 30 | 31 | ------------------------------------------------------------------------------- 32 | -- Lattice 33 | ------------------------------------------------------------------------------- 34 | 35 | newtype FLattice a = FLattice 36 | { lowerFLattice :: forall b. Lattice b => 37 | (a -> b) -> b 38 | } 39 | 40 | instance Functor FLattice where 41 | fmap f (FLattice g) = FLattice (\inj -> g (inj . f)) 42 | a <$ FLattice f = FLattice (\inj -> f (const (inj a))) 43 | 44 | liftFLattice :: a -> FLattice a 45 | liftFLattice a = FLattice (\inj -> inj a) 46 | 47 | retractFLattice :: Lattice a => FLattice a -> a 48 | retractFLattice a = lowerFLattice a id 49 | 50 | instance Lattice (FLattice a) where 51 | FLattice f \/ FLattice g = FLattice (\inj -> f inj \/ g inj) 52 | FLattice f /\ FLattice g = FLattice (\inj -> f inj /\ g inj) 53 | 54 | 55 | instance BoundedJoinSemiLattice a => 56 | BoundedJoinSemiLattice (FLattice a) where 57 | bottom = FLattice (\inj -> inj bottom) 58 | 59 | instance BoundedMeetSemiLattice a => 60 | BoundedMeetSemiLattice (FLattice a) where 61 | top = FLattice (\inj -> inj top) 62 | 63 | instance Universe a => Universe (FLattice a) where 64 | universe = fmap liftFLattice universe 65 | 66 | instance Finite a => Finite (FLattice a) where 67 | universeF = fmap liftFLattice universeF 68 | 69 | ------------------------------------------------------------------------------- 70 | -- BoundedLattice 71 | ------------------------------------------------------------------------------- 72 | 73 | newtype FBoundedLattice a = FBoundedLattice 74 | { lowerFBoundedLattice :: forall b. BoundedLattice b => 75 | (a -> b) -> b 76 | } 77 | 78 | instance Functor FBoundedLattice where 79 | fmap f (FBoundedLattice g) = FBoundedLattice (\inj -> g (inj . f)) 80 | a <$ FBoundedLattice f = FBoundedLattice (\inj -> f (const (inj a))) 81 | 82 | liftFBoundedLattice :: a -> FBoundedLattice a 83 | liftFBoundedLattice a = FBoundedLattice (\inj -> inj a) 84 | 85 | retractFBoundedLattice :: BoundedLattice a => FBoundedLattice a -> a 86 | retractFBoundedLattice a = lowerFBoundedLattice a id 87 | 88 | instance Lattice (FBoundedLattice a) where 89 | FBoundedLattice f \/ FBoundedLattice g = FBoundedLattice (\inj -> f inj \/ g inj) 90 | FBoundedLattice f /\ FBoundedLattice g = FBoundedLattice (\inj -> f inj /\ g inj) 91 | 92 | 93 | instance BoundedJoinSemiLattice (FBoundedLattice a) where 94 | bottom = FBoundedLattice (\_ -> bottom) 95 | 96 | instance BoundedMeetSemiLattice (FBoundedLattice a) where 97 | top = FBoundedLattice (\_ -> top) 98 | 99 | instance Universe a => Universe (FBoundedLattice a) where 100 | universe = fmap liftFBoundedLattice universe 101 | 102 | instance Finite a => Finite (FBoundedLattice a) where 103 | universeF = fmap liftFBoundedLattice universeF 104 | -------------------------------------------------------------------------------- /src/Algebra/Lattice/Levitated.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE Safe #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | ---------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Algebra.Lattice.Levitated 13 | -- Copyright : (C) 2010-2015 Maximilian Bolingbroke, 2015-2019 Oleg Grenrus 14 | -- License : BSD-3-Clause (see the file LICENSE) 15 | -- 16 | -- Maintainer : Oleg Grenrus 17 | -- 18 | ---------------------------------------------------------------------------- 19 | module Algebra.Lattice.Levitated ( 20 | Levitated(..) 21 | , retractLevitated 22 | , foldLevitated 23 | ) where 24 | 25 | import Algebra.Lattice 26 | import Algebra.PartialOrd 27 | 28 | import Control.DeepSeq (NFData (..)) 29 | import Control.Monad (ap) 30 | import Data.Data (Data, Typeable) 31 | import Data.Hashable (Hashable (..)) 32 | import Data.Universe.Class (Finite (..), Universe (..)) 33 | import Data.Universe.Helpers (Natural, Tagged, retag) 34 | import GHC.Generics (Generic, Generic1) 35 | 36 | import qualified Test.QuickCheck as QC 37 | 38 | -- 39 | -- Levitated 40 | -- 41 | 42 | -- | Graft a distinct top and bottom onto an otherwise unbounded lattice. 43 | -- The top is the absorbing element for the join, and the bottom is the absorbing 44 | -- element for the meet. 45 | data Levitated a = Bottom 46 | | Levitate a 47 | | Top 48 | deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic, Functor, Foldable, Traversable 49 | , Generic1 50 | ) 51 | 52 | instance Applicative Levitated where 53 | pure = return 54 | (<*>) = ap 55 | 56 | instance Monad Levitated where 57 | return = Levitate 58 | Top >>= _ = Top 59 | Bottom >>= _ = Bottom 60 | Levitate x >>= f = f x 61 | 62 | instance NFData a => NFData (Levitated a) where 63 | rnf Top = () 64 | rnf Bottom = () 65 | rnf (Levitate a) = rnf a 66 | 67 | instance Hashable a => Hashable (Levitated a) 68 | 69 | instance PartialOrd a => PartialOrd (Levitated a) where 70 | leq _ Top = True 71 | leq Top _ = False 72 | leq Bottom _ = True 73 | leq _ Bottom = False 74 | leq (Levitate x) (Levitate y) = leq x y 75 | comparable Top _ = True 76 | comparable _ Top = True 77 | comparable Bottom _ = True 78 | comparable _ Bottom = True 79 | comparable (Levitate x) (Levitate y) = comparable x y 80 | 81 | instance Lattice a => Lattice (Levitated a) where 82 | Top \/ _ = Top 83 | _ \/ Top = Top 84 | Levitate x \/ Levitate y = Levitate (x \/ y) 85 | Bottom \/ lev_y = lev_y 86 | lev_x \/ Bottom = lev_x 87 | 88 | Top /\ lev_y = lev_y 89 | lev_x /\ Top = lev_x 90 | Levitate x /\ Levitate y = Levitate (x /\ y) 91 | Bottom /\ _ = Bottom 92 | _ /\ Bottom = Bottom 93 | 94 | instance Lattice a => BoundedJoinSemiLattice (Levitated a) where 95 | bottom = Bottom 96 | 97 | instance Lattice a => BoundedMeetSemiLattice (Levitated a) where 98 | top = Top 99 | 100 | -- | Interpret @'Levitated' a@ using the 'BoundedLattice' of @a@. 101 | retractLevitated :: (BoundedMeetSemiLattice a, BoundedJoinSemiLattice a) => Levitated a -> a 102 | retractLevitated = foldLevitated bottom id top 103 | 104 | -- | Fold 'Levitated'. 105 | foldLevitated :: b -> (a -> b) -> b -> Levitated a -> b 106 | foldLevitated b _ _ Bottom = b 107 | foldLevitated _ f _ (Levitate x) = f x 108 | foldLevitated _ _ t Top = t 109 | 110 | instance Universe a => Universe (Levitated a) where 111 | universe = Top : Bottom : map Levitate universe 112 | instance Finite a => Finite (Levitated a) where 113 | universeF = Top : Bottom : map Levitate universeF 114 | cardinality = fmap (2 +) (retag (cardinality :: Tagged a Natural)) 115 | 116 | instance QC.Arbitrary a => QC.Arbitrary (Levitated a) where 117 | arbitrary = QC.frequency 118 | [ (1, pure Top) 119 | , (1, pure Bottom) 120 | , (9, Levitate <$> QC.arbitrary) 121 | ] 122 | 123 | shrink Top = [] 124 | shrink Bottom = [] 125 | shrink (Levitate x) = Top : Bottom : map Levitate (QC.shrink x) 126 | 127 | instance QC.CoArbitrary a => QC.CoArbitrary (Levitated a) where 128 | coarbitrary Top = QC.variant (0 :: Int) 129 | coarbitrary Bottom = QC.variant (0 :: Int) 130 | coarbitrary (Levitate x) = QC.variant (0 :: Int) . QC.coarbitrary x 131 | 132 | instance QC.Function a => QC.Function (Levitated a) where 133 | function = QC.functionMap fromLevitated toLevitated where 134 | fromLevitated Top = Left True 135 | fromLevitated Bottom = Left False 136 | fromLevitated (Levitate x) = Right x 137 | 138 | toLevitated (Left True) = Top 139 | toLevitated (Left False) = Bottom 140 | toLevitated (Right x) = Levitate x 141 | -------------------------------------------------------------------------------- /src/Algebra/Lattice/Lexicographic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE Safe #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | ---------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Algebra.Lattice.Lexicographic 13 | -- Copyright : (C) 2010-2015 Maximilian Bolingbroke, 2015-2019 Oleg Grenrus 14 | -- License : BSD-3-Clause (see the file LICENSE) 15 | -- 16 | -- Maintainer : Oleg Grenrus 17 | -- 18 | ---------------------------------------------------------------------------- 19 | module Algebra.Lattice.Lexicographic ( 20 | Lexicographic(..) 21 | ) where 22 | 23 | import Algebra.Lattice 24 | import Algebra.PartialOrd 25 | 26 | import Control.DeepSeq (NFData (..)) 27 | import Control.Monad (ap, liftM2) 28 | import Data.Data (Data, Typeable) 29 | import Data.Hashable (Hashable (..)) 30 | import Data.Universe.Class (Finite (..), Universe (..)) 31 | import Data.Universe.Helpers (Natural, Tagged, retag) 32 | import GHC.Generics (Generic, Generic1) 33 | 34 | import qualified Test.QuickCheck as QC 35 | 36 | -- 37 | -- Lexicographic 38 | -- 39 | 40 | -- | A pair lattice with a lexicographic ordering. This means in 41 | -- a join the second component of the resulting pair is the second 42 | -- component of the pair with the larger first component. If the 43 | -- first components are equal, then the second components will be 44 | -- joined. The meet is similar only it prefers the smaller first 45 | -- component. 46 | -- 47 | -- An application of this type is versioning. For example, a 48 | -- Last-Writer-Wins register would look like 49 | -- @'Lexicographic' ('Algebra.Lattice.Ordered.Ordered' Timestamp) v@ where the lattice 50 | -- structure handles the, presumably rare, case of matching 51 | -- @Timestamp@s. Typically this is done in an arbitary, but 52 | -- deterministic manner. 53 | data Lexicographic k v = Lexicographic !k !v 54 | deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic, Functor, Foldable, Traversable 55 | , Generic1 56 | ) 57 | 58 | instance BoundedJoinSemiLattice k => Applicative (Lexicographic k) where 59 | pure = return 60 | (<*>) = ap 61 | 62 | -- Essentially the Writer monad. 63 | instance BoundedJoinSemiLattice k => Monad (Lexicographic k) where 64 | return = Lexicographic bottom 65 | Lexicographic k v >>= f = 66 | case f v of 67 | Lexicographic k' v' -> Lexicographic (k \/ k') v' 68 | 69 | instance (NFData k, NFData v) => NFData (Lexicographic k v) where 70 | rnf (Lexicographic k v) = rnf k `seq` rnf v 71 | 72 | instance (Hashable k, Hashable v) => Hashable (Lexicographic k v) 73 | 74 | -- Why we have 'bottom', and not @v1 \\/ v2@ in the @otherwise@ clause? 75 | -- 76 | -- For example what is the join of @(2, 1)@ and @(3, 2)@ 77 | -- in lexicographic divisibility divisibility lattice. 78 | -- 79 | -- With @v1 \\/ v2@, we get the upper bound, but not least! 80 | -- 81 | -- @ 82 | -- (2, 1) `leq` (6, 2) 83 | -- (3, 2) `leq` (6, 2) 84 | -- @ 85 | -- 86 | -- But @(6, 1) `leq` (6, 2)@, and 87 | -- 88 | -- @ 89 | -- (2, 1) `leq` (6, 1) 90 | -- (3, 2) `leq` (6, 1) 91 | -- @ 92 | -- 93 | instance (PartialOrd k, Lattice k, BoundedJoinSemiLattice v, BoundedMeetSemiLattice v) => Lattice (Lexicographic k v) where 94 | l@(Lexicographic k1 v1) \/ r@(Lexicographic k2 v2) 95 | | k1 == k2 = Lexicographic k1 (v1 \/ v2) 96 | | k1 `leq` k2 = r 97 | | k2 `leq` k1 = l 98 | | otherwise = Lexicographic (k1 \/ k2) bottom 99 | 100 | l@(Lexicographic k1 v1) /\ r@(Lexicographic k2 v2) 101 | | k1 == k2 = Lexicographic k1 (v1 /\ v2) 102 | | k1 `leq` k2 = l 103 | | k2 `leq` k1 = r 104 | | otherwise = Lexicographic (k1 /\ k2) top 105 | 106 | instance (PartialOrd k, BoundedJoinSemiLattice k, BoundedJoinSemiLattice v, BoundedMeetSemiLattice v) => BoundedJoinSemiLattice (Lexicographic k v) where 107 | bottom = Lexicographic bottom bottom 108 | 109 | instance (PartialOrd k, BoundedMeetSemiLattice k, BoundedJoinSemiLattice v, BoundedMeetSemiLattice v) => BoundedMeetSemiLattice (Lexicographic k v) where 110 | top = Lexicographic top top 111 | 112 | instance (PartialOrd k, PartialOrd v) => PartialOrd (Lexicographic k v) where 113 | Lexicographic k1 v1 `leq` Lexicographic k2 v2 114 | | k1 == k2 = v1 `leq` v2 115 | | k1 `leq` k2 = True 116 | | otherwise = False -- Incomparable or k2 `leq` k1 117 | comparable (Lexicographic k1 v1) (Lexicographic k2 v2) 118 | | k1 == k2 = comparable v1 v2 119 | | otherwise = comparable k1 k2 120 | 121 | instance (Universe k, Universe v) => Universe (Lexicographic k v) where 122 | universe = map (uncurry Lexicographic) universe 123 | instance (Finite k, Finite v) => Finite (Lexicographic k v) where 124 | universeF = map (uncurry Lexicographic) universeF 125 | cardinality = liftM2 (*) 126 | (retag (cardinality :: Tagged k Natural)) 127 | (retag (cardinality :: Tagged v Natural)) 128 | 129 | instance (QC.Arbitrary k, QC.Arbitrary v) => QC.Arbitrary (Lexicographic k v) where 130 | arbitrary = uncurry Lexicographic <$> QC.arbitrary 131 | shrink (Lexicographic k v) = uncurry Lexicographic <$> QC.shrink (k, v) 132 | 133 | instance (QC.CoArbitrary k, QC.CoArbitrary v) => QC.CoArbitrary (Lexicographic k v) where 134 | coarbitrary (Lexicographic k v) = QC.coarbitrary (k, v) 135 | 136 | instance (QC.Function k, QC.Function v) => QC.Function (Lexicographic k v) where 137 | function = QC.functionMap (\(Lexicographic k v) -> (k,v)) (uncurry Lexicographic) 138 | -------------------------------------------------------------------------------- /src/Algebra/Lattice/Lifted.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE Safe #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | ---------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Algebra.Lattice.Lifted 13 | -- Copyright : (C) 2010-2015 Maximilian Bolingbroke, 2015-2019 Oleg Grenrus 14 | -- License : BSD-3-Clause (see the file LICENSE) 15 | -- 16 | -- Maintainer : Oleg Grenrus 17 | -- 18 | ---------------------------------------------------------------------------- 19 | module Algebra.Lattice.Lifted ( 20 | Lifted(..) 21 | , retractLifted 22 | , foldLifted 23 | ) where 24 | 25 | import Algebra.Lattice 26 | import Algebra.PartialOrd 27 | 28 | import Control.DeepSeq (NFData (..)) 29 | import Control.Monad (ap) 30 | import Data.Data (Data, Typeable) 31 | import Data.Hashable (Hashable (..)) 32 | import Data.Universe.Class (Finite (..), Universe (..)) 33 | import Data.Universe.Helpers (Natural, Tagged, retag) 34 | import GHC.Generics (Generic, Generic1) 35 | 36 | import qualified Test.QuickCheck as QC 37 | 38 | -- 39 | -- Lifted 40 | -- 41 | 42 | -- | Graft a distinct bottom onto an otherwise unbounded lattice. 43 | -- As a bonus, the bottom will be an absorbing element for the meet. 44 | data Lifted a = Bottom 45 | | Lift a 46 | deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic, Functor, Foldable, Traversable 47 | , Generic1 48 | ) 49 | 50 | instance Applicative Lifted where 51 | pure = return 52 | (<*>) = ap 53 | 54 | instance Monad Lifted where 55 | return = Lift 56 | Bottom >>= _ = Bottom 57 | Lift x >>= f = f x 58 | 59 | instance NFData a => NFData (Lifted a) where 60 | rnf Bottom = () 61 | rnf (Lift a) = rnf a 62 | 63 | instance Hashable a => Hashable (Lifted a) 64 | 65 | instance PartialOrd a => PartialOrd (Lifted a) where 66 | leq Bottom _ = True 67 | leq _ Bottom = False 68 | leq (Lift x) (Lift y) = leq x y 69 | comparable Bottom _ = True 70 | comparable _ Bottom = True 71 | comparable (Lift x) (Lift y) = comparable x y 72 | 73 | instance Lattice a => Lattice (Lifted a) where 74 | Lift x \/ Lift y = Lift (x \/ y) 75 | Bottom \/ lift_y = lift_y 76 | lift_x \/ Bottom = lift_x 77 | 78 | Lift x /\ Lift y = Lift (x /\ y) 79 | Bottom /\ _ = Bottom 80 | _ /\ Bottom = Bottom 81 | 82 | instance Lattice a => BoundedJoinSemiLattice (Lifted a) where 83 | bottom = Bottom 84 | 85 | instance BoundedMeetSemiLattice a => BoundedMeetSemiLattice (Lifted a) where 86 | top = Lift top 87 | 88 | -- | Interpret @'Lifted' a@ using the 'BoundedJoinSemiLattice' of @a@. 89 | retractLifted :: BoundedJoinSemiLattice a => Lifted a -> a 90 | retractLifted = foldLifted bottom id 91 | 92 | -- | Similar to @'maybe'@, but for @'Lifted'@ type. 93 | foldLifted :: b -> (a -> b) -> Lifted a -> b 94 | foldLifted _ f (Lift x) = f x 95 | foldLifted y _ Bottom = y 96 | 97 | instance Universe a => Universe (Lifted a) where 98 | universe = Bottom : map Lift universe 99 | instance Finite a => Finite (Lifted a) where 100 | universeF = Bottom : map Lift universeF 101 | cardinality = fmap succ (retag (cardinality :: Tagged a Natural)) 102 | 103 | instance QC.Arbitrary a => QC.Arbitrary (Lifted a) where 104 | arbitrary = QC.frequency 105 | [ (1, pure Bottom) 106 | , (9, Lift <$> QC.arbitrary) 107 | ] 108 | shrink Bottom = [] 109 | shrink (Lift x) = Bottom : map Lift (QC.shrink x) 110 | 111 | instance QC.CoArbitrary a => QC.CoArbitrary (Lifted a) where 112 | coarbitrary Bottom = QC.variant (0 :: Int) 113 | coarbitrary (Lift x) = QC.variant (1 :: Int) . QC.coarbitrary x 114 | 115 | instance QC.Function a => QC.Function (Lifted a) where 116 | function = QC.functionMap fromLifted toLifted where 117 | fromLifted = foldLifted Nothing Just 118 | toLifted = maybe Bottom Lift 119 | -------------------------------------------------------------------------------- /src/Algebra/Lattice/M2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE Safe #-} 4 | ---------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Algebra.Lattice.M2 7 | -- Copyright : (C) 2019 Oleg Grenrus 8 | -- License : BSD-3-Clause (see the file LICENSE) 9 | -- 10 | -- Maintainer : Oleg Grenrus 11 | -- 12 | ---------------------------------------------------------------------------- 13 | module Algebra.Lattice.M2 ( 14 | M2 (..), 15 | toSetBool, 16 | fromSetBool, 17 | ) where 18 | 19 | import Control.DeepSeq (NFData (..)) 20 | import Data.Data (Data, Typeable) 21 | import Data.Hashable (Hashable (..)) 22 | import Data.Universe.Class (Finite (..), Universe (..)) 23 | import GHC.Generics (Generic) 24 | 25 | import qualified Test.QuickCheck as QC 26 | 27 | import Algebra.Heyting 28 | import Algebra.Lattice 29 | import Algebra.PartialOrd 30 | 31 | import Data.Set (Set) 32 | import qualified Data.Set as Set 33 | 34 | -- | \(M_2\) is isomorphic to \(\mathcal{P}\{\mathbb{B}\}\), i.e. powerset of 'Bool'. 35 | -- 36 | -- <> 37 | -- 38 | data M2 = M2o | M2a | M2b | M2i 39 | deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) 40 | 41 | instance PartialOrd M2 where 42 | M2o `leq` _ = True 43 | _ `leq` M2i = True 44 | M2a `leq` M2a = True 45 | M2b `leq` M2b = True 46 | _ `leq` _ = False 47 | 48 | instance Lattice M2 where 49 | M2o \/ y = y 50 | M2i \/ _ = M2i 51 | x \/ M2o = x 52 | _ \/ M2i = M2i 53 | M2a \/ M2a = M2a 54 | M2b \/ M2b = M2b 55 | _ \/ _ = M2i 56 | 57 | M2o /\ _ = M2o 58 | M2i /\ y = y 59 | _ /\ M2o = M2o 60 | x /\ M2i = x 61 | M2a /\ M2a = M2a 62 | M2b /\ M2b = M2b 63 | _ /\ _ = M2o 64 | 65 | instance BoundedJoinSemiLattice M2 where 66 | bottom = M2o 67 | 68 | instance BoundedMeetSemiLattice M2 where 69 | top = M2i 70 | 71 | instance Heyting M2 where 72 | M2o ==> _ = M2i 73 | M2i ==> x = x 74 | 75 | M2a ==> M2o = M2b 76 | M2a ==> M2a = M2i 77 | M2a ==> M2b = M2b 78 | M2a ==> M2i = M2i 79 | 80 | M2b ==> M2o = M2a 81 | M2b ==> M2a = M2a 82 | M2b ==> M2b = M2i 83 | M2b ==> M2i = M2i 84 | 85 | neg M2o = M2i 86 | neg M2a = M2b 87 | neg M2b = M2a 88 | neg M2i = M2o 89 | 90 | toSetBool :: M2 -> Set Bool 91 | toSetBool M2o = mempty 92 | toSetBool M2a = Set.singleton False 93 | toSetBool M2b = Set.singleton True 94 | toSetBool M2i = Set.fromList [True, False] 95 | 96 | fromSetBool :: Set Bool -> M2 97 | fromSetBool x = case Set.toList x of 98 | [False,True] -> M2i 99 | [False] -> M2a 100 | [True] -> M2b 101 | _ -> M2o 102 | 103 | instance QC.Arbitrary M2 where 104 | arbitrary = QC.arbitraryBoundedEnum 105 | shrink x | x == minBound = [] 106 | | otherwise = [minBound .. pred x] 107 | 108 | instance QC.CoArbitrary M2 where 109 | coarbitrary = QC.coarbitraryEnum 110 | 111 | instance QC.Function M2 where 112 | function = QC.functionBoundedEnum 113 | 114 | instance Universe M2 where universe = [minBound .. maxBound] 115 | instance Finite M2 where cardinality = 4 116 | 117 | instance NFData M2 where 118 | rnf x = x `seq` () 119 | 120 | instance Hashable M2 where 121 | hashWithSalt salt = hashWithSalt salt . fromEnum 122 | -------------------------------------------------------------------------------- /src/Algebra/Lattice/M3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE Safe #-} 4 | ---------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Algebra.Lattice.M3 7 | -- Copyright : (C) 2019 Oleg Grenrus 8 | -- License : BSD-3-Clause (see the file LICENSE) 9 | -- 10 | -- Maintainer : Oleg Grenrus 11 | -- 12 | ---------------------------------------------------------------------------- 13 | module Algebra.Lattice.M3 ( 14 | M3 (..), 15 | ) where 16 | 17 | import Control.DeepSeq (NFData (..)) 18 | import Data.Data (Data, Typeable) 19 | import Data.Hashable (Hashable (..)) 20 | import Data.Universe.Class (Finite (..), Universe (..)) 21 | import GHC.Generics (Generic) 22 | 23 | import qualified Test.QuickCheck as QC 24 | 25 | import Algebra.Lattice 26 | import Algebra.PartialOrd 27 | 28 | -- | \(M_3\), is smallest non-distributive, yet modular lattice. 29 | -- 30 | -- <> 31 | -- 32 | data M3 = M3o | M3a | M3b | M3c | M3i 33 | deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) 34 | 35 | instance PartialOrd M3 where 36 | M3o `leq` _ = True 37 | _ `leq` M3i = True 38 | M3a `leq` M3a = True 39 | M3b `leq` M3b = True 40 | M3c `leq` M3c = True 41 | _ `leq` _ = False 42 | 43 | instance Lattice M3 where 44 | M3o \/ y = y 45 | M3i \/ _ = M3i 46 | x \/ M3o = x 47 | _ \/ M3i = M3i 48 | M3a \/ M3a = M3a 49 | M3b \/ M3b = M3b 50 | M3c \/ M3c = M3c 51 | _ \/ _ = M3i 52 | 53 | M3o /\ _ = M3o 54 | M3i /\ y = y 55 | _ /\ M3o = M3o 56 | x /\ M3i = x 57 | M3a /\ M3a = M3a 58 | M3b /\ M3b = M3b 59 | M3c /\ M3c = M3c 60 | _ /\ _ = M3o 61 | 62 | instance BoundedJoinSemiLattice M3 where 63 | bottom = M3o 64 | 65 | instance BoundedMeetSemiLattice M3 where 66 | top = M3i 67 | 68 | instance QC.Arbitrary M3 where 69 | arbitrary = QC.arbitraryBoundedEnum 70 | shrink x | x == minBound = [] 71 | | otherwise = [minBound .. pred x] 72 | 73 | instance QC.CoArbitrary M3 where 74 | coarbitrary = QC.coarbitraryEnum 75 | 76 | instance QC.Function M3 where 77 | function = QC.functionBoundedEnum 78 | 79 | instance Universe M3 where universe = [minBound .. maxBound] 80 | instance Finite M3 where cardinality = 5 81 | 82 | instance NFData M3 where 83 | rnf x = x `seq` () 84 | 85 | instance Hashable M3 where 86 | hashWithSalt salt = hashWithSalt salt . fromEnum 87 | -------------------------------------------------------------------------------- /src/Algebra/Lattice/N5.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE Safe #-} 4 | ---------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Algebra.Lattice.N5 7 | -- Copyright : (C) 2019 Oleg Grenrus 8 | -- License : BSD-3-Clause (see the file LICENSE) 9 | -- 10 | -- Maintainer : Oleg Grenrus 11 | -- 12 | ---------------------------------------------------------------------------- 13 | module Algebra.Lattice.N5 ( 14 | N5 (..), 15 | ) where 16 | 17 | import Control.DeepSeq (NFData (..)) 18 | import Data.Data (Data, Typeable) 19 | import Data.Hashable (Hashable (..)) 20 | import Data.Universe.Class (Finite (..), Universe (..)) 21 | import GHC.Generics (Generic) 22 | 23 | import qualified Test.QuickCheck as QC 24 | 25 | import Algebra.Lattice 26 | import Algebra.PartialOrd 27 | 28 | -- | \(N_5\), is smallest non-modular (and non-distributive) lattice. 29 | -- 30 | -- <> 31 | -- 32 | data N5 = N5o | N5a | N5b | N5c | N5i 33 | deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) 34 | 35 | instance PartialOrd N5 where 36 | N5o `leq` _ = True 37 | _ `leq` N5i = True 38 | N5a `leq` N5a = True 39 | N5b `leq` N5a = True 40 | N5b `leq` N5b = True 41 | N5c `leq` N5c = True 42 | _ `leq` _ = False 43 | 44 | instance Lattice N5 where 45 | N5o \/ y = y 46 | N5i \/ _ = N5i 47 | x \/ N5o = x 48 | _ \/ N5i = N5i 49 | N5a \/ N5a = N5a 50 | N5a \/ N5b = N5a 51 | N5b \/ N5a = N5a 52 | N5b \/ N5b = N5b 53 | N5c \/ N5c = N5c 54 | _ \/ _ = N5i 55 | 56 | N5o /\ _ = N5o 57 | N5i /\ y = y 58 | _ /\ N5o = N5o 59 | x /\ N5i = x 60 | N5a /\ N5a = N5a 61 | N5b /\ N5b = N5b 62 | N5a /\ N5b = N5b 63 | N5b /\ N5a = N5b 64 | N5c /\ N5c = N5c 65 | _ /\ _ = N5o 66 | 67 | instance BoundedJoinSemiLattice N5 where 68 | bottom = N5o 69 | 70 | instance BoundedMeetSemiLattice N5 where 71 | top = N5i 72 | 73 | instance QC.Arbitrary N5 where 74 | arbitrary = QC.arbitraryBoundedEnum 75 | shrink x | x == minBound = [] 76 | | otherwise = [minBound .. pred x] 77 | 78 | instance QC.CoArbitrary N5 where 79 | coarbitrary = QC.coarbitraryEnum 80 | 81 | instance QC.Function N5 where 82 | function = QC.functionBoundedEnum 83 | 84 | instance Universe N5 where universe = [minBound .. maxBound] 85 | instance Finite N5 where cardinality = 5 86 | 87 | instance NFData N5 where 88 | rnf x = x `seq` () 89 | 90 | instance Hashable N5 where 91 | hashWithSalt salt = hashWithSalt salt . fromEnum 92 | -------------------------------------------------------------------------------- /src/Algebra/Lattice/Op.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE Safe #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | ---------------------------------------------------------------------------- 10 | -- | 11 | -- Module : Algebra.Lattice.Op 12 | -- Copyright : (C) 2010-2015 Maximilian Bolingbroke, 2015-2019 Oleg Grenrus 13 | -- License : BSD-3-Clause (see the file LICENSE) 14 | -- 15 | -- Maintainer : Oleg Grenrus 16 | -- 17 | ---------------------------------------------------------------------------- 18 | module Algebra.Lattice.Op ( 19 | Op(..) 20 | ) where 21 | 22 | import Algebra.Lattice 23 | import Algebra.PartialOrd 24 | 25 | import Control.DeepSeq (NFData (..)) 26 | import Control.Monad (ap) 27 | import Data.Data (Data, Typeable) 28 | import Data.Hashable (Hashable (..)) 29 | import Data.Universe.Class (Finite (..), Universe (..)) 30 | import GHC.Generics (Generic, Generic1) 31 | 32 | import qualified Test.QuickCheck as QC 33 | 34 | -- 35 | -- Op 36 | -- 37 | 38 | -- | The opposite lattice of a given lattice. That is, switch 39 | -- meets and joins. 40 | newtype Op a = Op { getOp :: a } 41 | deriving ( Eq, Show, Read, Data, Typeable, Generic, Functor, Foldable, Traversable 42 | , Generic1 43 | ) 44 | 45 | instance Ord a => Ord (Op a) where 46 | compare (Op a) (Op b) = compare b a 47 | 48 | instance Applicative Op where 49 | pure = return 50 | (<*>) = ap 51 | 52 | instance Monad Op where 53 | return = Op 54 | Op x >>= f = f x 55 | 56 | instance NFData a => NFData (Op a) where 57 | rnf (Op a) = rnf a 58 | 59 | instance Hashable a => Hashable (Op a) 60 | 61 | instance Lattice a => Lattice (Op a) where 62 | Op x \/ Op y = Op (x /\ y) 63 | Op x /\ Op y = Op (x \/ y) 64 | 65 | instance BoundedMeetSemiLattice a => BoundedJoinSemiLattice (Op a) where 66 | bottom = Op top 67 | 68 | instance BoundedJoinSemiLattice a => BoundedMeetSemiLattice (Op a) where 69 | top = Op bottom 70 | 71 | instance PartialOrd a => PartialOrd (Op a) where 72 | Op a `leq` Op b = b `leq` a -- Note swap. 73 | comparable (Op a) (Op b) = comparable a b 74 | 75 | instance Universe a => Universe (Op a) where 76 | universe = map Op universe 77 | instance Finite a => Finite (Op a) where 78 | universeF = map Op universeF 79 | 80 | instance QC.Arbitrary a => QC.Arbitrary (Op a) where 81 | arbitrary = Op <$> QC.arbitrary 82 | shrink = QC.shrinkMap getOp Op 83 | 84 | instance QC.CoArbitrary a => QC.CoArbitrary (Op a) where 85 | coarbitrary = QC.coarbitrary . getOp 86 | 87 | instance QC.Function a => QC.Function (Op a) where 88 | function = QC.functionMap getOp Op 89 | -------------------------------------------------------------------------------- /src/Algebra/Lattice/Ordered.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE Safe #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | ---------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Algebra.Lattice.Ordered 13 | -- Copyright : (C) 2010-2015 Maximilian Bolingbroke, 2015-2019 Oleg Grenrus 14 | -- License : BSD-3-Clause (see the file LICENSE) 15 | -- 16 | -- Maintainer : Oleg Grenrus 17 | -- 18 | ---------------------------------------------------------------------------- 19 | module Algebra.Lattice.Ordered ( 20 | Ordered(..) 21 | ) where 22 | 23 | import Algebra.Heyting 24 | import Algebra.Lattice 25 | import Algebra.PartialOrd 26 | 27 | import Control.DeepSeq (NFData (..)) 28 | import Control.Monad (ap) 29 | import Data.Data (Data, Typeable) 30 | import Data.Hashable (Hashable (..)) 31 | import Data.Universe.Class (Finite (..), Universe (..)) 32 | import Data.Universe.Helpers (Natural, Tagged, retag) 33 | import GHC.Generics (Generic, Generic1) 34 | 35 | import qualified Test.QuickCheck as QC 36 | 37 | -- 38 | -- Ordered 39 | -- 40 | 41 | -- | A total order gives rise to a lattice. Join is 42 | -- 'max', meet is 'min'. 43 | newtype Ordered a = Ordered { getOrdered :: a } 44 | deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic, Functor, Foldable, Traversable 45 | , Generic1 46 | ) 47 | 48 | instance Applicative Ordered where 49 | pure = return 50 | (<*>) = ap 51 | 52 | instance Monad Ordered where 53 | return = Ordered 54 | Ordered x >>= f = f x 55 | 56 | instance NFData a => NFData (Ordered a) where 57 | rnf (Ordered a) = rnf a 58 | 59 | instance Hashable a => Hashable (Ordered a) 60 | 61 | instance Ord a => Lattice (Ordered a) where 62 | Ordered x \/ Ordered y = Ordered (max x y) 63 | Ordered x /\ Ordered y = Ordered (min x y) 64 | 65 | instance (Ord a, Bounded a) => BoundedJoinSemiLattice (Ordered a) where 66 | bottom = Ordered minBound 67 | 68 | instance (Ord a, Bounded a) => BoundedMeetSemiLattice (Ordered a) where 69 | top = Ordered maxBound 70 | 71 | -- | This is interesting logic, as it satisfies both de Morgan laws; 72 | -- but isn't Boolean: i.e. law of exluded middle doesn't hold. 73 | -- 74 | -- Negation "smashes" value into 'minBound' or 'maxBound'. 75 | instance (Ord a, Bounded a) => Heyting (Ordered a) where 76 | x ==> y | x > y = y 77 | | otherwise = top 78 | 79 | instance Ord a => PartialOrd (Ordered a) where 80 | leq = (<=) 81 | comparable _ _ = True 82 | 83 | instance Universe a => Universe (Ordered a) where 84 | universe = map Ordered universe 85 | instance Finite a => Finite (Ordered a) where 86 | universeF = map Ordered universeF 87 | cardinality = retag (cardinality :: Tagged a Natural) 88 | 89 | instance QC.Arbitrary a => QC.Arbitrary (Ordered a) where 90 | arbitrary = Ordered <$> QC.arbitrary 91 | shrink = QC.shrinkMap Ordered getOrdered 92 | 93 | instance QC.CoArbitrary a => QC.CoArbitrary (Ordered a) where 94 | coarbitrary = QC.coarbitrary . getOrdered 95 | 96 | instance QC.Function a => QC.Function (Ordered a) where 97 | function = QC.functionMap getOrdered Ordered 98 | -------------------------------------------------------------------------------- /src/Algebra/Lattice/Unicode.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides Unicode variants of the operators. 2 | -- 3 | -- Unfortunately, ⊤, ⊥, and ¬ don't fit into Haskell lexical structure well. 4 | -- 5 | module Algebra.Lattice.Unicode where 6 | 7 | import Algebra.Heyting 8 | import Algebra.Lattice 9 | 10 | infixr 6 ∧ 11 | infixr 5 ∨ 12 | infixr 4 ⟹ 13 | infix 4 ⟺ 14 | 15 | -- | Meet, alias for '/\'. 16 | (∧) :: Lattice a => a -> a -> a 17 | (∧) = (/\) 18 | 19 | -- | Join, alias for '\/'. 20 | (∨) :: Lattice a => a -> a -> a 21 | (∨) = (\/) 22 | 23 | -- | Implication, alias for '==>'. 24 | (⟹) :: Heyting a => a -> a -> a 25 | (⟹) = (==>) 26 | 27 | -- | Equivalence, alias for '<=>'. 28 | (⟺) :: Heyting a => a -> a -> a 29 | (⟺) = (<=>) 30 | -------------------------------------------------------------------------------- /src/Algebra/Lattice/Wide.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE Safe #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | ---------------------------------------------------------------------------- 10 | -- | 11 | -- Module : Algebra.Lattice.Wide 12 | -- Copyright : (C) 2010-2015 Maximilian Bolingbroke, 2015-2019 Oleg Grenrus 13 | -- License : BSD-3-Clause (see the file LICENSE) 14 | -- 15 | -- Maintainer : Oleg Grenrus 16 | -- 17 | ---------------------------------------------------------------------------- 18 | module Algebra.Lattice.Wide ( 19 | Wide(..) 20 | ) where 21 | 22 | import Algebra.Lattice 23 | import Algebra.PartialOrd 24 | 25 | import Control.DeepSeq (NFData (..)) 26 | import Control.Monad (ap) 27 | import Data.Data (Data, Typeable) 28 | import Data.Hashable (Hashable (..)) 29 | import Data.Universe.Class (Finite (..), Universe (..)) 30 | import Data.Universe.Helpers (Natural, Tagged, retag) 31 | import GHC.Generics (Generic, Generic1) 32 | 33 | import qualified Test.QuickCheck as QC 34 | 35 | -- 36 | -- Wide 37 | -- 38 | 39 | -- | Graft a distinct top and bottom onto any type. 40 | -- The 'Top' is identity for '/\' and the absorbing element for '\/'. 41 | -- The 'Bottom' is the identity for '\/' and and the absorbing element for '/\'. 42 | -- Two 'Middle' values join to top, unless they are equal. 43 | -- 44 | -- <> 45 | -- 46 | data Wide a 47 | = Top 48 | | Middle a 49 | | Bottom 50 | deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic, Functor, Foldable, Traversable 51 | , Generic1 52 | ) 53 | 54 | instance Applicative Wide where 55 | pure = return 56 | (<*>) = ap 57 | 58 | instance Monad Wide where 59 | return = Middle 60 | Top >>= _ = Top 61 | Bottom >>= _ = Bottom 62 | Middle x >>= f = f x 63 | 64 | instance NFData a => NFData (Wide a) where 65 | rnf Top = () 66 | rnf Bottom = () 67 | rnf (Middle a) = rnf a 68 | 69 | instance Hashable a => Hashable (Wide a) 70 | 71 | instance Eq a => Lattice (Wide a) where 72 | Top \/ _ = Top 73 | Bottom \/ x = x 74 | Middle _ \/ Top = Top 75 | Middle x \/ Bottom = Middle x 76 | Middle x \/ Middle y = if x == y then Middle x else Top 77 | 78 | Bottom /\ _ = Bottom 79 | Top /\ x = x 80 | Middle _ /\ Bottom = Bottom 81 | Middle x /\ Top = Middle x 82 | Middle x /\ Middle y = if x == y then Middle x else Bottom 83 | 84 | instance Eq a => BoundedJoinSemiLattice (Wide a) where 85 | bottom = Bottom 86 | 87 | instance Eq a => BoundedMeetSemiLattice (Wide a) where 88 | top = Top 89 | 90 | instance Eq a => PartialOrd (Wide a) where 91 | leq Bottom _ = True 92 | leq Top Bottom = False 93 | leq Top (Middle _) = False 94 | leq Top Top = True 95 | leq (Middle _) Bottom = False 96 | leq (Middle _) Top = True 97 | leq (Middle x) (Middle y) = x == y 98 | 99 | comparable Bottom _ = True 100 | comparable Top _ = True 101 | comparable (Middle _) Bottom = True 102 | comparable (Middle _) Top = True 103 | comparable (Middle x) (Middle y) = x == y 104 | 105 | instance Universe a => Universe (Wide a) where 106 | universe = Top : Bottom : map Middle universe 107 | instance Finite a => Finite (Wide a) where 108 | universeF = Top : Bottom : map Middle universeF 109 | cardinality = fmap (2 +) (retag (cardinality :: Tagged a Natural)) 110 | 111 | instance QC.Arbitrary a => QC.Arbitrary (Wide a) where 112 | arbitrary = QC.frequency 113 | [ (1, pure Top) 114 | , (1, pure Bottom) 115 | , (9, Middle <$> QC.arbitrary) 116 | ] 117 | 118 | shrink Top = [] 119 | shrink Bottom = [] 120 | shrink (Middle x) = Top : Bottom : map Middle (QC.shrink x) 121 | 122 | instance QC.CoArbitrary a => QC.CoArbitrary (Wide a) where 123 | coarbitrary Top = QC.variant (0 :: Int) 124 | coarbitrary Bottom = QC.variant (0 :: Int) 125 | coarbitrary (Middle x) = QC.variant (0 :: Int) . QC.coarbitrary x 126 | 127 | instance QC.Function a => QC.Function (Wide a) where 128 | function = QC.functionMap fromWide toWide where 129 | fromWide Top = Left True 130 | fromWide Bottom = Left False 131 | fromWide (Middle x) = Right x 132 | 133 | toWide (Left True) = Top 134 | toWide (Left False) = Bottom 135 | toWide (Right x) = Middle x 136 | -------------------------------------------------------------------------------- /src/Algebra/Lattice/ZeroHalfOne.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE Safe #-} 4 | ---------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Algebra.Lattice.ZeroHalfOne 7 | -- Copyright : (C) 2019 Oleg Grenrus 8 | -- License : BSD-3-Clause (see the file LICENSE) 9 | -- 10 | -- Maintainer : Oleg Grenrus 11 | -- 12 | ---------------------------------------------------------------------------- 13 | module Algebra.Lattice.ZeroHalfOne ( 14 | ZeroHalfOne (..), 15 | ) where 16 | 17 | import Control.DeepSeq (NFData (..)) 18 | import Data.Data (Data, Typeable) 19 | import Data.Hashable (Hashable (..)) 20 | import Data.Universe.Class (Finite (..), Universe (..)) 21 | import GHC.Generics (Generic) 22 | 23 | import qualified Test.QuickCheck as QC 24 | 25 | import Algebra.Heyting 26 | import Algebra.Lattice 27 | import Algebra.PartialOrd 28 | 29 | -- | The simplest Heyting algebra that is not already a Boolean algebra is the 30 | -- totally ordered set \(\{ 0, \frac{1}{2}, 1 \}\). 31 | -- 32 | data ZeroHalfOne = Zero | Half | One 33 | deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) 34 | 35 | instance PartialOrd ZeroHalfOne where 36 | leq = (<=) 37 | 38 | instance Lattice ZeroHalfOne where 39 | (\/) = max 40 | (/\) = min 41 | 42 | instance BoundedJoinSemiLattice ZeroHalfOne where 43 | bottom = Zero 44 | 45 | instance BoundedMeetSemiLattice ZeroHalfOne where 46 | top = One 47 | 48 | -- | Not boolean: @'neg' 'Half' '\/' 'Half' = 'Half' /= 'One'@ 49 | instance Heyting ZeroHalfOne where 50 | Zero ==> _ = One 51 | One ==> x = x 52 | Half ==> Zero = Zero 53 | Half ==> _ = One 54 | 55 | neg Zero = One 56 | neg One = Zero 57 | neg Half = Zero 58 | 59 | instance QC.Arbitrary ZeroHalfOne where 60 | arbitrary = QC.arbitraryBoundedEnum 61 | shrink x | x == minBound = [] 62 | | otherwise = [minBound .. pred x] 63 | 64 | instance QC.CoArbitrary ZeroHalfOne where 65 | coarbitrary = QC.coarbitraryEnum 66 | 67 | instance QC.Function ZeroHalfOne where 68 | function = QC.functionBoundedEnum 69 | 70 | instance Universe ZeroHalfOne where universe = [minBound .. maxBound] 71 | instance Finite ZeroHalfOne where cardinality = 3 72 | 73 | instance NFData ZeroHalfOne where 74 | rnf x = x `seq` () 75 | 76 | instance Hashable ZeroHalfOne where 77 | hashWithSalt salt = hashWithSalt salt . fromEnum 78 | -------------------------------------------------------------------------------- /src/Algebra/PartialOrd.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | ---------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Algebra.PartialOrd 5 | -- Copyright : (C) 2010-2015 Maximilian Bolingbroke, 2015-2019 Oleg Grenrus 6 | -- License : BSD-3-Clause (see the file LICENSE) 7 | -- 8 | -- Maintainer : Oleg Grenrus 9 | -- 10 | ---------------------------------------------------------------------------- 11 | module Algebra.PartialOrd ( 12 | -- * Partial orderings 13 | PartialOrd(..), 14 | partialOrdEq, 15 | 16 | -- * Fixed points of chains in partial orders 17 | lfpFrom, unsafeLfpFrom, 18 | gfpFrom, unsafeGfpFrom 19 | ) where 20 | 21 | import Data.Foldable (Foldable (..)) 22 | import Data.Hashable (Hashable (..)) 23 | import qualified Data.HashMap.Lazy as HM 24 | import qualified Data.HashSet as HS 25 | import qualified Data.IntMap as IM 26 | import qualified Data.IntSet as IS 27 | import qualified Data.List as L 28 | import qualified Data.Map as Map 29 | import Data.Monoid (All (..), Any (..)) 30 | import qualified Data.Set as Set 31 | import Data.Void (Void) 32 | 33 | -- | A partial ordering on sets 34 | -- () is a set equipped 35 | -- with a binary relation, `leq`, that obeys the following laws 36 | -- 37 | -- @ 38 | -- Reflexive: a ``leq`` a 39 | -- Antisymmetric: a ``leq`` b && b ``leq`` a ==> a == b 40 | -- Transitive: a ``leq`` b && b ``leq`` c ==> a ``leq`` c 41 | -- @ 42 | -- 43 | -- Two elements of the set are said to be `comparable` when they are are 44 | -- ordered with respect to the `leq` relation. So 45 | -- 46 | -- @ 47 | -- `comparable` a b ==> a ``leq`` b || b ``leq`` a 48 | -- @ 49 | -- 50 | -- If `comparable` always returns true then the relation `leq` defines a 51 | -- total ordering (and an `Ord` instance may be defined). Any `Ord` instance is 52 | -- trivially an instance of `PartialOrd`. 'Algebra.Lattice.Ordered' provides a 53 | -- convenient wrapper to satisfy 'PartialOrd' given 'Ord'. 54 | -- 55 | -- As an example consider the partial ordering on sets induced by set 56 | -- inclusion. Then for sets `a` and `b`, 57 | -- 58 | -- @ 59 | -- a ``leq`` b 60 | -- @ 61 | -- 62 | -- is true when `a` is a subset of `b`. Two sets are `comparable` if one is a 63 | -- subset of the other. Concretely 64 | -- 65 | -- @ 66 | -- a = {1, 2, 3} 67 | -- b = {1, 3, 4} 68 | -- c = {1, 2} 69 | -- 70 | -- a ``leq`` a = `True` 71 | -- a ``leq`` b = `False` 72 | -- a ``leq`` c = `False` 73 | -- b ``leq`` a = `False` 74 | -- b ``leq`` b = `True` 75 | -- b ``leq`` c = `False` 76 | -- c ``leq`` a = `True` 77 | -- c ``leq`` b = `False` 78 | -- c ``leq`` c = `True` 79 | -- 80 | -- `comparable` a b = `False` 81 | -- `comparable` a c = `True` 82 | -- `comparable` b c = `False` 83 | -- @ 84 | class Eq a => PartialOrd a where 85 | -- | The relation that induces the partial ordering 86 | leq :: a -> a -> Bool 87 | 88 | -- | Whether two elements are ordered with respect to the relation. A 89 | -- default implementation is given by 90 | -- 91 | -- @ 92 | -- 'comparable' x y = 'leq' x y '||' 'leq' y x 93 | -- @ 94 | comparable :: a -> a -> Bool 95 | comparable x y = leq x y || leq y x 96 | 97 | -- | The equality relation induced by the partial-order structure. It satisfies 98 | -- the laws of an equivalence relation: 99 | -- @ 100 | -- Reflexive: a == a 101 | -- Symmetric: a == b ==> b == a 102 | -- Transitive: a == b && b == c ==> a == c 103 | -- @ 104 | partialOrdEq :: PartialOrd a => a -> a -> Bool 105 | partialOrdEq x y = leq x y && leq y x 106 | 107 | instance PartialOrd () where 108 | leq _ _ = True 109 | 110 | -- | @since 2 111 | instance PartialOrd Bool where 112 | leq = (<=) 113 | 114 | instance PartialOrd Any where 115 | leq = (<=) 116 | 117 | instance PartialOrd All where 118 | leq = (<=) 119 | 120 | instance PartialOrd Void where 121 | leq _ _ = True 122 | 123 | -- | @'leq' = 'Data.List.isSequenceOf'@. 124 | instance Eq a => PartialOrd [a] where 125 | leq = L.isSubsequenceOf 126 | 127 | instance Ord a => PartialOrd (Set.Set a) where 128 | leq = Set.isSubsetOf 129 | 130 | instance PartialOrd IS.IntSet where 131 | leq = IS.isSubsetOf 132 | 133 | instance (Eq k, Hashable k) => PartialOrd (HS.HashSet k) where 134 | leq a b = HS.null (HS.difference a b) 135 | 136 | instance (Ord k, PartialOrd v) => PartialOrd (Map.Map k v) where 137 | leq = Map.isSubmapOfBy leq 138 | 139 | instance PartialOrd v => PartialOrd (IM.IntMap v) where 140 | leq = IM.isSubmapOfBy leq 141 | 142 | instance (Eq k, Hashable k, PartialOrd v) => PartialOrd (HM.HashMap k v) where 143 | x `leq` y = {- wish: HM.isSubmapOfBy leq -} 144 | HM.null (HM.difference x y) && getAll (fold $ HM.intersectionWith (\vx vy -> All (vx `leq` vy)) x y) 145 | 146 | instance (PartialOrd a, PartialOrd b) => PartialOrd (a, b) where 147 | -- NB: *not* a lexical ordering. This is because for some component partial orders, lexical 148 | -- ordering is incompatible with the transitivity axiom we require for the derived partial order 149 | (x1, y1) `leq` (x2, y2) = x1 `leq` x2 && y1 `leq` y2 150 | 151 | -- | Ordinal sum. 152 | -- 153 | -- @since 2.1 154 | instance (PartialOrd a, PartialOrd b) => PartialOrd (Either a b) where 155 | leq (Right x) (Right y) = leq x y 156 | leq (Right _) _ = False 157 | leq _ (Right _) = True 158 | leq (Left x) (Left y) = leq x y 159 | 160 | comparable (Right x) (Right y) = comparable x y 161 | comparable (Right _) _ = True 162 | comparable _ (Right _) = True 163 | comparable (Left x) (Left y) = comparable x y 164 | 165 | -- | Least point of a partially ordered monotone function. Checks that the function is monotone. 166 | lfpFrom :: PartialOrd a => a -> (a -> a) -> a 167 | lfpFrom = lfpFrom' leq 168 | 169 | -- | Least point of a partially ordered monotone function. Does not checks that the function is monotone. 170 | unsafeLfpFrom :: Eq a => a -> (a -> a) -> a 171 | unsafeLfpFrom = lfpFrom' (\_ _ -> True) 172 | 173 | {-# INLINE lfpFrom' #-} 174 | lfpFrom' :: Eq a => (a -> a -> Bool) -> a -> (a -> a) -> a 175 | lfpFrom' check init_x f = go init_x 176 | where go x | x' == x = x 177 | | x `check` x' = go x' 178 | | otherwise = error "lfpFrom: non-monotone function" 179 | where x' = f x 180 | 181 | 182 | -- | Greatest fixed point of a partially ordered antinone function. Checks that the function is antinone. 183 | {-# INLINE gfpFrom #-} 184 | gfpFrom :: PartialOrd a => a -> (a -> a) -> a 185 | gfpFrom = gfpFrom' leq 186 | 187 | -- | Greatest fixed point of a partially ordered antinone function. Does not check that the function is antinone. 188 | {-# INLINE unsafeGfpFrom #-} 189 | unsafeGfpFrom :: Eq a => a -> (a -> a) -> a 190 | unsafeGfpFrom = gfpFrom' (\_ _ -> True) 191 | 192 | {-# INLINE gfpFrom' #-} 193 | gfpFrom' :: Eq a => (a -> a -> Bool) -> a -> (a -> a) -> a 194 | gfpFrom' check init_x f = go init_x 195 | where go x | x' == x = x 196 | | x' `check` x = go x' 197 | | otherwise = error "gfpFrom: non-antinone function" 198 | where x' = f x 199 | -------------------------------------------------------------------------------- /src/Algebra/PartialOrd/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | ---------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Algebra.PartialOrd.Instances 6 | -- Copyright : (C) 2010-2015 Maximilian Bolingbroke, 2015 Oleg Grenrus 7 | -- License : BSD-3-Clause (see the file LICENSE) 8 | -- 9 | -- Maintainer : Oleg Grenrus 10 | -- 11 | -- This module re-exports orphan instances from 'Data.Universe.Instances.Eq' 12 | -- module, and @(PartialOrd v, Finite k) => PartialOrd (k -> v)@ instance. 13 | ---------------------------------------------------------------------------- 14 | module Algebra.PartialOrd.Instances () where 15 | 16 | import Algebra.PartialOrd (PartialOrd (..)) 17 | import Data.Monoid (Endo (..)) 18 | import Data.Universe.Class (Finite (..)) 19 | import Data.Universe.Instances.Eq () 20 | 21 | -- | @Eq (k -> v)@ is from 'Data.Universe.Instances.Eq' 22 | instance (PartialOrd v, Finite k) => PartialOrd (k -> v) where 23 | f `leq` g = all (\k -> f k `leq` g k) universeF 24 | 25 | instance (PartialOrd v, Finite v) => PartialOrd (Endo v) where 26 | Endo f `leq` Endo g = f `leq` g 27 | 28 | 29 | -------------------------------------------------------------------------------- /test/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | module Main (main) where 8 | 9 | import Control.Monad (ap, guard) 10 | import Data.Int (Int8) 11 | import Data.List (genericLength, nub) 12 | import Data.Maybe (isJust, listToMaybe) 13 | import Data.Semigroup (All, Any, Endo (..), (<>)) 14 | import Data.Typeable (Typeable, typeOf) 15 | import Data.Universe.Class (Finite (..), Universe (..)) 16 | import Data.Universe.Helpers (Natural, Tagged (..)) 17 | import Test.QuickCheck 18 | (Arbitrary (..), Property, discard, label, (=/=), (===)) 19 | import Test.QuickCheck.Function 20 | import Test.Tasty 21 | import Test.Tasty.QuickCheck (testProperty) 22 | 23 | import qualified Test.QuickCheck as QC 24 | 25 | import Algebra.Heyting 26 | import Algebra.Lattice 27 | import Algebra.PartialOrd 28 | 29 | import Algebra.Lattice.M2 (M2 (..)) 30 | import Algebra.Lattice.M3 (M3 (..)) 31 | import Algebra.Lattice.N5 (N5 (..)) 32 | import Algebra.Lattice.ZeroHalfOne (ZeroHalfOne (..)) 33 | 34 | import qualified Algebra.Heyting.Free as HF 35 | import qualified Algebra.Lattice.Divisibility as Div 36 | import qualified Algebra.Lattice.Dropped as D 37 | import qualified Algebra.Lattice.Free as F 38 | import qualified Algebra.Lattice.Levitated as L 39 | import qualified Algebra.Lattice.Lexicographic as LO 40 | import qualified Algebra.Lattice.Lifted as U 41 | import qualified Algebra.Lattice.Op as Op 42 | import qualified Algebra.Lattice.Ordered as O 43 | import qualified Algebra.Lattice.Wide as W 44 | 45 | import Data.HashMap.Lazy (HashMap) 46 | import Data.HashSet (HashSet) 47 | import Data.IntMap (IntMap) 48 | import Data.IntSet (IntSet) 49 | import Data.Map (Map) 50 | import Data.Set (Set) 51 | 52 | import Algebra.PartialOrd.Instances () 53 | import Data.Universe.Instances.Eq () 54 | import Data.Universe.Instances.Ord () 55 | import Data.Universe.Instances.Show () 56 | import Test.QuickCheck.Instances () 57 | 58 | -- For old GHC to work 59 | data Proxy (a :: *) = Proxy 60 | data Proxy1 (a :: * -> *) = Proxy1 61 | 62 | main :: IO () 63 | main = defaultMain tests 64 | 65 | tests :: TestTree 66 | tests = testGroup "Tests" 67 | [ allLatticeLaws (LBounded Partial Modular) (Proxy :: Proxy M3) -- non distributive lattice! 68 | , allLatticeLaws (LHeyting Partial IsBoolean) (Proxy :: Proxy M2) -- M2 69 | , allLatticeLaws (LHeyting Partial IsBoolean) (Proxy :: Proxy (Set Bool)) -- isomorphic to M2 70 | , allLatticeLaws (LBounded Partial NonModular) (Proxy :: Proxy N5) 71 | , allLatticeLaws (LHeyting Total IsBoolean) (Proxy :: Proxy ()) 72 | , allLatticeLaws (LHeyting Total IsBoolean) (Proxy :: Proxy Bool) 73 | , allLatticeLaws (LHeyting Total DeMorgan) (Proxy :: Proxy ZeroHalfOne) 74 | , allLatticeLaws (LNormal Partial Distributive) (Proxy :: Proxy (Map Int (O.Ordered Int))) 75 | , allLatticeLaws (LNormal Partial Distributive) (Proxy :: Proxy (IntMap (O.Ordered Int))) 76 | , allLatticeLaws (LNormal Partial Distributive) (Proxy :: Proxy (HashMap Int (O.Ordered Int))) 77 | , allLatticeLaws (LHeyting Partial IsBoolean) (Proxy :: Proxy (Set Int8)) 78 | , allLatticeLaws (LHeyting Partial IsBoolean) (Proxy :: Proxy (HashSet Int8)) 79 | , allLatticeLaws (LBoundedJoin Partial Distributive) (Proxy :: Proxy (Set Int)) 80 | , allLatticeLaws (LBoundedJoin Partial Distributive) (Proxy :: Proxy IntSet) 81 | , allLatticeLaws (LBoundedJoin Partial Distributive) (Proxy :: Proxy (HashSet Int)) 82 | , allLatticeLaws (LHeyting Total DeMorgan) (Proxy :: Proxy (O.Ordered Int8)) 83 | , allLatticeLaws (LBoundedJoin Partial Distributive) (Proxy :: Proxy (Div.Divisibility Int)) 84 | , allLatticeLaws (LNormal Total Distributive) (Proxy :: Proxy (LO.Lexicographic (O.Ordered Int) (O.Ordered Int))) 85 | , allLatticeLaws (LBounded Partial Modular) (Proxy :: Proxy (W.Wide Int)) 86 | , allLatticeLaws (LBounded Partial NonModular) (Proxy :: Proxy (LO.Lexicographic (Set Bool) (Set Bool))) 87 | , allLatticeLaws (LBounded Partial NonModular) (Proxy :: Proxy (LO.Lexicographic M2 M2)) -- non distributive! 88 | 89 | 90 | , allLatticeLaws LNotLattice (Proxy :: Proxy String) 91 | 92 | , allLatticeLaws (LBounded Partial Modular) (Proxy :: Proxy (M2, M2)) 93 | , allLatticeLaws (LBounded Partial Distributive) (Proxy :: Proxy (Either M2 M2)) 94 | , allLatticeLaws (LBounded Partial NonModular) (Proxy :: Proxy (Either M3 N5)) -- non modular, though it takes QC time to find 95 | 96 | , allLatticeLaws (LHeyting Total IsBoolean) (Proxy :: Proxy All) 97 | , allLatticeLaws (LHeyting Total IsBoolean) (Proxy :: Proxy Any) 98 | , allLatticeLaws (LHeyting Partial IsBoolean) (Proxy :: Proxy (Endo Bool)) -- note: it's partial! 99 | , allLatticeLaws (LBounded Partial Modular) (Proxy :: Proxy (Endo M3)) 100 | 101 | , allLatticeLaws (LHeyting Partial IsBoolean) (Proxy :: Proxy (Int8 -> Bool)) 102 | , allLatticeLaws (LHeyting Partial IsBoolean) (Proxy :: Proxy (Int8 -> M2)) 103 | , allLatticeLaws (LBounded Partial Modular) (Proxy :: Proxy (Int8 -> M3)) 104 | 105 | , allLatticeLaws (LNormal Partial Distributive) (Proxy :: Proxy (F.Free Int8)) 106 | , allLatticeLaws (LHeyting Partial NonBoolean) (Proxy :: Proxy (HF.Free Var)) 107 | 108 | , allLatticeLaws (LBoundedMeet Total Distributive) (Proxy :: Proxy (D.Dropped (O.Ordered Int))) 109 | , allLatticeLaws (LBounded Total Distributive) (Proxy :: Proxy (L.Levitated (O.Ordered Int))) 110 | , allLatticeLaws (LBoundedJoin Total Distributive) (Proxy :: Proxy (U.Lifted (O.Ordered Int))) 111 | , allLatticeLaws (LNormal Total Distributive ) (Proxy :: Proxy (Op.Op (O.Ordered Int))) 112 | 113 | , testProperty "Lexicographic M2 M2 contains M3" $ QC.property $ 114 | isJust searchM3LexM2 115 | 116 | , monadLaws "Dropped" (Proxy1 :: Proxy1 D.Dropped) 117 | , monadLaws "Levitated" (Proxy1 :: Proxy1 L.Levitated) 118 | , monadLaws "Lexicographic" (Proxy1 :: Proxy1 (LO.Lexicographic Bool)) 119 | , monadLaws "Lifted" (Proxy1 :: Proxy1 U.Lifted) 120 | , monadLaws "Op" (Proxy1 :: Proxy1 Op.Op) 121 | , monadLaws "Ordered" (Proxy1 :: Proxy1 O.Ordered) 122 | , monadLaws "Wide" (Proxy1 :: Proxy1 W.Wide) 123 | , monadLaws "Heyting.Free" (Proxy1 :: Proxy1 HF.Free) 124 | 125 | , finiteLaws (Proxy :: Proxy M2) 126 | , finiteLaws (Proxy :: Proxy M3) 127 | , finiteLaws (Proxy :: Proxy N5) 128 | , finiteLaws (Proxy :: Proxy ZeroHalfOne) 129 | 130 | , finiteLaws (Proxy :: Proxy OInt8) 131 | , finiteLaws (Proxy :: Proxy (Div.Divisibility Int8)) 132 | , finiteLaws (Proxy :: Proxy (W.Wide Int8)) 133 | , finiteLaws (Proxy :: Proxy (D.Dropped OInt8)) 134 | , finiteLaws (Proxy :: Proxy (L.Levitated OInt8)) 135 | , finiteLaws (Proxy :: Proxy (U.Lifted OInt8)) 136 | , finiteLaws (Proxy :: Proxy (LO.Lexicographic OInt8 OInt8)) 137 | ] 138 | 139 | type OInt8 = O.Ordered Int8 140 | 141 | ------------------------------------------------------------------------------- 142 | -- Monad laws 143 | ------------------------------------------------------------------------------- 144 | 145 | monadLaws :: forall (m :: * -> *). ( Monad m 146 | , Arbitrary (m Int) 147 | , Eq (m Int) 148 | , Show (m Int) 149 | , Arbitrary (m (Fun Int Int)) 150 | , Show (m (Fun Int Int))) 151 | => String 152 | -> Proxy1 m 153 | -> TestTree 154 | monadLaws name _ = testGroup ("Monad laws: " <> name) 155 | [ testProperty "left identity" leftIdentityProp 156 | , testProperty "right identity" rightIdentityProp 157 | , testProperty "composition" compositionProp 158 | , testProperty "Applicative pure" pureProp 159 | , testProperty "Applicative ap" apProp 160 | ] 161 | where 162 | leftIdentityProp :: Int -> Fun Int (m Int) -> Property 163 | leftIdentityProp x (Fun _ k) = (return x >>= k) === k x 164 | 165 | rightIdentityProp :: m Int -> Property 166 | rightIdentityProp m = (m >>= return) === m 167 | 168 | compositionProp :: m Int -> Fun Int (m Int) -> Fun Int (m Int) -> Property 169 | compositionProp m (Fun _ k) (Fun _ h) = (m >>= (\x -> k x >>= h)) === ((m >>= k) >>= h) 170 | 171 | pureProp :: Int -> Property 172 | pureProp x = pure x === (return x :: m Int) 173 | 174 | apProp :: m (Fun Int Int) -> m Int -> Property 175 | apProp f x = (f' <*> x) === ap f' x 176 | where f' = apply <$> f 177 | {-# NOINLINE monadLaws #-} 178 | 179 | ------------------------------------------------------------------------------- 180 | -- Partial ord laws 181 | ------------------------------------------------------------------------------- 182 | 183 | data IsTotal a where 184 | Total :: Ord a => IsTotal a 185 | Partial :: PartialOrd a => IsTotal a 186 | 187 | partialOrdLaws 188 | :: forall a. (Eq a, Show a, Arbitrary a, PartialOrd a) 189 | => IsTotal a 190 | -> Proxy a 191 | -> TestTree 192 | partialOrdLaws total _ = testGroup "PartialOrd" $ 193 | [ testProperty "reflexive" reflProp 194 | , testProperty "anti-symmetric" antiSymProp 195 | , testProperty "transitive" transitiveProp 196 | ] ++ case total of 197 | Partial -> [] 198 | Total -> 199 | [ testProperty "total" totalProp 200 | , testProperty "leq/compare agree" leqCompareProp 201 | ] 202 | where 203 | reflProp :: a -> Property 204 | reflProp x = QC.property $ leq x x 205 | 206 | antiSymProp :: a -> a -> Property 207 | antiSymProp x y 208 | | leq x y && leq y x = label "same" $ x === y 209 | | otherwise = label "diff" $ x =/= y 210 | 211 | transitiveProp :: a -> a -> a -> Property 212 | transitiveProp x y z = case p of 213 | [] -> label "non-related" $ QC.property True 214 | ((x', _, z') : _) -> label "related" $ QC.property $ leq x' z' 215 | where 216 | p = [ (x', y', z') 217 | | (x', y', z') <- [(x,y,z),(y,x,z),(z,y,x),(y,z,x),(z,x,y),(x,z,y)] 218 | , leq x' y' 219 | , leq y' z' 220 | ] 221 | 222 | totalProp :: a -> a -> Property 223 | totalProp x y = QC.property $ leq x y || leq y x 224 | 225 | leqCompareProp :: Ord a => a -> a -> Property 226 | leqCompareProp x y = agree (leq x y) (leq y x) (compare x y) 227 | where 228 | agree True True = (=== EQ) 229 | agree True False = (=== LT) 230 | agree False True = (=== GT) 231 | agree False False = discard 232 | {-# NOINLINE partialOrdLaws #-} 233 | 234 | ------------------------------------------------------------------------------- 235 | -- Lattice 236 | ------------------------------------------------------------------------------- 237 | 238 | -- | Lattice Kind 239 | data LKind a where 240 | LNotLattice :: LKind a 241 | LNormal :: Lattice a => IsTotal a -> Distr -> LKind a 242 | LBoundedMeet :: BoundedMeetSemiLattice a => IsTotal a -> Distr -> LKind a 243 | LBoundedJoin :: BoundedJoinSemiLattice a => IsTotal a -> Distr -> LKind a 244 | LBounded :: BoundedLattice a => IsTotal a -> Distr -> LKind a 245 | LHeyting :: Heyting a => IsTotal a -> IsBoolean -> LKind a 246 | 247 | data Distr 248 | = NonModular 249 | | Modular 250 | | Distributive 251 | deriving (Eq, Ord) 252 | 253 | data IsBoolean 254 | = NonBoolean 255 | | DeMorgan 256 | | IsBoolean 257 | deriving (Eq, Ord) 258 | 259 | allLatticeLaws 260 | :: forall a. (Eq a, Show a, Arbitrary a, Typeable a, PartialOrd a) 261 | => LKind a 262 | -> Proxy a 263 | -> TestTree 264 | allLatticeLaws ki pr = case ki of 265 | LNotLattice -> testGroup name $ 266 | [partialOrdLaws Partial pr] 267 | LNormal t d -> testGroup name $ 268 | partialOrdLaws t pr : allLatticeLaws' d pr 269 | LBoundedMeet t d -> testGroup name $ 270 | partialOrdLaws t pr : allLatticeLaws' d pr ++ 271 | [ boundedMeetLaws pr ] 272 | LBoundedJoin t d -> testGroup name $ 273 | partialOrdLaws t pr : allLatticeLaws' d pr ++ 274 | [ boundedJoinLaws pr ] 275 | LBounded t d -> testGroup name $ 276 | partialOrdLaws t pr : allLatticeLaws' d pr ++ 277 | [ boundedMeetLaws pr 278 | , boundedJoinLaws pr 279 | ] 280 | LHeyting t b -> testGroup name $ 281 | partialOrdLaws t pr : allLatticeLaws' Distributive pr ++ 282 | [ boundedMeetLaws pr 283 | , boundedJoinLaws pr 284 | , heytingLaws pr 285 | ] ++ 286 | [ deMorganLaws pr | b >= DeMorgan ] ++ 287 | [ booleanLaws pr | b >= IsBoolean ] 288 | where 289 | name = show (typeOf (undefined :: a)) 290 | {-# NOINLINE allLatticeLaws #-} 291 | 292 | allLatticeLaws' 293 | :: forall a. (Eq a, Show a, Arbitrary a, Lattice a, PartialOrd a) 294 | => Distr 295 | -> Proxy a 296 | -> [TestTree] 297 | allLatticeLaws' distr pr = 298 | [ latticeLaws pr ] ++ 299 | [ modularLaws pr | distr >= Modular ] ++ 300 | [ distributiveLaws pr | distr >= Distributive ] 301 | 302 | ------------------------------------------------------------------------------- 303 | -- Lattice laws 304 | ------------------------------------------------------------------------------- 305 | 306 | latticeLaws 307 | :: forall a. (Eq a, Show a, Arbitrary a, Lattice a, PartialOrd a) 308 | => Proxy a 309 | -> TestTree 310 | latticeLaws _ = testGroup "Lattice" 311 | [ testProperty "leq = joinLeq" joinLeqProp 312 | , testProperty "leq = meetLeq" meetLeqProp 313 | , testProperty "meet is lower bound" meetLower 314 | , testProperty "join is upper bound" joinUpper 315 | , testProperty "meet commutes" meetComm 316 | , testProperty "join commute" joinComm 317 | , testProperty "meet associative" meetAssoc 318 | , testProperty "join associative" joinAssoc 319 | , testProperty "absorbtion 1" meetAbsorb 320 | , testProperty "absorbtion 2" joinAbsorb 321 | , testProperty "meet idempontent" meetIdemp 322 | , testProperty "join idempontent" joinIdemp 323 | , testProperty "comparableDef" comparableDef 324 | ] 325 | where 326 | joinLeqProp :: a -> a -> Property 327 | joinLeqProp x y = leq x y === joinLeq x y 328 | 329 | meetLeqProp :: a -> a -> Property 330 | meetLeqProp x y = leq x y === meetLeq x y 331 | 332 | meetLower :: a -> a -> Property 333 | meetLower x y = (m `leq` x) QC..&&. (m `leq` y) 334 | where 335 | m = x /\ y 336 | 337 | joinUpper :: a -> a -> Property 338 | joinUpper x y = (x `leq` j) QC..&&. (y `leq` j) 339 | where 340 | j = x \/ y 341 | 342 | meetComm :: a -> a -> Property 343 | meetComm x y = x /\ y === y /\ x 344 | 345 | joinComm :: a -> a -> Property 346 | joinComm x y = x \/ y === y \/ x 347 | 348 | meetAssoc :: a -> a -> a -> Property 349 | meetAssoc x y z = x /\ (y /\ z) === (x /\ y) /\ z 350 | 351 | joinAssoc :: a -> a -> a -> Property 352 | joinAssoc x y z = x \/ (y \/ z) === (x \/ y) \/ z 353 | 354 | meetAbsorb :: a -> a -> Property 355 | meetAbsorb x y = x /\ (x \/ y) === x 356 | 357 | joinAbsorb :: a -> a -> Property 358 | joinAbsorb x y = x \/ (x /\ y) === x 359 | 360 | meetIdemp :: a -> Property 361 | meetIdemp x = x /\ x === x 362 | 363 | joinIdemp :: a -> Property 364 | joinIdemp x = x \/ x === x 365 | 366 | comparableDef :: a -> a -> Property 367 | comparableDef x y = (leq x y || leq y x) === comparable x y 368 | {-# NOINLINE latticeLaws #-} 369 | 370 | ------------------------------------------------------------------------------- 371 | -- Modular 372 | ------------------------------------------------------------------------------- 373 | 374 | modularLaws 375 | :: forall a. (Eq a, Show a, Arbitrary a, Lattice a, PartialOrd a) 376 | => Proxy a 377 | -> TestTree 378 | modularLaws _ = testGroup "Modular" 379 | [ testProperty "(y ∧ (x ∨ z)) ∨ z = (y ∨ z) ∧ (x ∨ z)" modularProp 380 | ] 381 | where 382 | modularProp :: a -> a -> a -> Property 383 | modularProp x y z = lhs === rhs where 384 | lhs = (y /\ (x \/ z)) \/ z 385 | rhs = (y \/ z) /\ (x \/ z) 386 | {-# NOINLINE modularLaws #-} 387 | 388 | ------------------------------------------------------------------------------- 389 | -- Distributive 390 | ------------------------------------------------------------------------------- 391 | 392 | distributiveLaws 393 | :: forall a. (Eq a, Show a, Arbitrary a, Lattice a, PartialOrd a) 394 | => Proxy a 395 | -> TestTree 396 | distributiveLaws _ = testGroup "Distributive" 397 | [ testProperty "x ∧ (y ∨ z) = (x ∧ y) ∨ (x ∧ z)" distrProp 398 | , testProperty "x ∨ (y ∧ z) = (x ∨ y) ∧ (x ∨ z)" distr2Prop 399 | ] 400 | where 401 | distrProp :: a -> a -> a -> Property 402 | distrProp x y z = lhs === rhs where 403 | lhs = x /\ (y \/ z) 404 | rhs = (x /\ y) \/ (x /\ z) 405 | 406 | distr2Prop :: a -> a -> a -> Property 407 | distr2Prop x y z = lhs === rhs where 408 | lhs = x \/ (y /\ z) 409 | rhs = (x \/ y) /\ (x \/ z) 410 | {-# NOINLINE distributiveLaws #-} 411 | 412 | ------------------------------------------------------------------------------- 413 | -- Bounded lattice laws 414 | ------------------------------------------------------------------------------- 415 | 416 | boundedMeetLaws 417 | :: forall a. (Eq a, Show a, Arbitrary a, BoundedMeetSemiLattice a) 418 | => Proxy a 419 | -> TestTree 420 | boundedMeetLaws _ = testGroup "BoundedMeetSemiLattice" 421 | [ testProperty "top /\\ x = x" identityLeftProp 422 | , testProperty "x /\\ top = x" identityRightProp 423 | , testProperty "top \\/ x = top" annihilationLeftProp 424 | , testProperty "x \\/ top = top" annihilationRightProp 425 | ] 426 | where 427 | identityLeftProp :: a -> Property 428 | identityLeftProp x = lhs === rhs where 429 | lhs = top /\ x 430 | rhs = x 431 | 432 | identityRightProp :: a -> Property 433 | identityRightProp x = lhs === rhs where 434 | lhs = x /\ top 435 | rhs = x 436 | 437 | annihilationLeftProp :: a -> Property 438 | annihilationLeftProp x = lhs === rhs where 439 | lhs = top \/ x 440 | rhs = top 441 | 442 | annihilationRightProp :: a -> Property 443 | annihilationRightProp x = lhs === rhs where 444 | lhs = x \/ top 445 | rhs = top 446 | {-# NOINLINE boundedMeetLaws #-} 447 | 448 | boundedJoinLaws 449 | :: forall a. (Eq a, Show a, Arbitrary a, BoundedJoinSemiLattice a) 450 | => Proxy a 451 | -> TestTree 452 | boundedJoinLaws _ = testGroup "BoundedJoinSemiLattice" 453 | [ testProperty "bottom \\/ x = x" identityLeftProp 454 | , testProperty "x \\/ bottom = x" identityRightProp 455 | , testProperty "bottom /\\ x = bottom" annihilationLeftProp 456 | , testProperty "x /\\ bottom = bottom" annihilationRightProp 457 | ] 458 | where 459 | identityLeftProp :: a -> Property 460 | identityLeftProp x = lhs === rhs where 461 | lhs = bottom \/ x 462 | rhs = x 463 | 464 | identityRightProp :: a -> Property 465 | identityRightProp x = lhs === rhs where 466 | lhs = x \/ bottom 467 | rhs = x 468 | 469 | annihilationLeftProp :: a -> Property 470 | annihilationLeftProp x = lhs === rhs where 471 | lhs = bottom /\ x 472 | rhs = bottom 473 | 474 | annihilationRightProp :: a -> Property 475 | annihilationRightProp x = lhs === rhs where 476 | lhs = x /\ bottom 477 | rhs = bottom 478 | {-# NOINLINE boundedJoinLaws #-} 479 | 480 | ------------------------------------------------------------------------------- 481 | -- Heyting laws 482 | ------------------------------------------------------------------------------- 483 | 484 | heytingLaws 485 | :: forall a. (Eq a, Show a, Arbitrary a, Heyting a, Typeable a) 486 | => Proxy a 487 | -> TestTree 488 | heytingLaws _ = testGroup "Heyting" 489 | [ testProperty "neg default" negDefaultProp 490 | , testProperty "<=> default" equivDefaultProp 491 | , testProperty "x ==> x = top" idIsTopProp 492 | , testProperty "a /\\ (a ==> b) = a /\\ b" andDomainProp 493 | , testProperty "b /\\ (a ==> b) = b" andCodomainProp 494 | , testProperty "a ==> (b /\\ c) = (a ==> b) /\\ (a ==> c)" implDistrProp 495 | , testProperty "de Morgan 1" deMorganProp1 496 | , testProperty "weak de Morgan 2" deMorganProp2weak 497 | ] 498 | where 499 | negDefaultProp :: a -> Property 500 | negDefaultProp x = lhs === rhs where 501 | lhs = neg x 502 | rhs = x ==> bottom 503 | 504 | equivDefaultProp :: a -> a -> Property 505 | equivDefaultProp x y = lhs === rhs where 506 | lhs = x <=> y 507 | rhs = (x ==> y) /\ (y ==> x) 508 | 509 | idIsTopProp :: a -> Property 510 | idIsTopProp x = lhs === rhs where 511 | lhs = x ==> x 512 | rhs = top 513 | 514 | andDomainProp :: a -> a -> Property 515 | andDomainProp x y = lhs === rhs where 516 | lhs = x /\ (x ==> y) 517 | rhs = x /\ y 518 | 519 | andCodomainProp :: a -> a -> Property 520 | andCodomainProp x y = lhs === rhs where 521 | lhs = y /\ (x ==> y) 522 | rhs = y 523 | 524 | implDistrProp :: a -> a -> a -> Property 525 | implDistrProp x y z 526 | | typeOf (undefined :: a) == typeOf (undefined :: HF.Free Var) 527 | = QC.mapSize (min 16) $ implDistrProp' x y z 528 | | otherwise 529 | = implDistrProp' x y z 530 | 531 | implDistrProp' :: a -> a -> a -> Property 532 | implDistrProp' x y z = lhs === rhs where 533 | lhs = x ==> (y /\ z) 534 | rhs = (x ==> y) /\ (x ==> z) 535 | 536 | deMorganProp1 :: a -> a -> Property 537 | deMorganProp1 x y = lhs === rhs where 538 | lhs = neg (x \/ y) 539 | rhs = neg x /\ neg y 540 | 541 | deMorganProp2weak :: a -> a -> Property 542 | deMorganProp2weak x y = lhs === rhs where 543 | lhs = neg (x /\ y) 544 | rhs = neg (neg (neg x \/ neg y)) 545 | {-# NOINLINE heytingLaws #-} 546 | 547 | ------------------------------------------------------------------------------- 548 | -- De morgan 549 | ------------------------------------------------------------------------------- 550 | 551 | deMorganLaws 552 | :: forall a. (Eq a, Show a, Arbitrary a, Heyting a) 553 | => Proxy a 554 | -> TestTree 555 | deMorganLaws _ = testGroup "de Morgan" 556 | [ testProperty "de Morgan 2" deMorganProp2 557 | ] 558 | where 559 | deMorganProp2 :: a -> a -> Property 560 | deMorganProp2 x y = lhs === rhs where 561 | lhs = neg (x /\ y) 562 | rhs = neg x \/ neg y 563 | {-# NOINLINE deMorganLaws #-} 564 | 565 | ------------------------------------------------------------------------------- 566 | -- Boolean laws 567 | ------------------------------------------------------------------------------- 568 | 569 | booleanLaws 570 | :: forall a. (Eq a, Show a, Arbitrary a, Heyting a) 571 | => Proxy a 572 | -> TestTree 573 | booleanLaws _ = testGroup "Boolean" 574 | [ testProperty "LEM: neg x \\/ x = top" lemProp 575 | , testProperty "DN: neg (neg x) = x" dnProp 576 | ] 577 | where 578 | lemProp :: a -> Property 579 | lemProp x = lhs === rhs where 580 | lhs = neg x \/ x 581 | rhs = top 582 | 583 | -- every element is regular, i.e. either of following equivalend conditions hold: 584 | -- * neg (neg x) = x 585 | -- * x = neg y, for some y in H -- I don't know example of this 586 | dnProp :: a -> Property 587 | dnProp x = lhs === rhs where 588 | lhs = neg (neg x) 589 | rhs = x 590 | {-# NOINLINE booleanLaws #-} 591 | 592 | ------------------------------------------------------------------------------- 593 | -- Universe / Finite laws 594 | ------------------------------------------------------------------------------- 595 | 596 | finiteLaws 597 | :: forall a. (Eq a, Show a, Arbitrary a, Typeable a, Finite a) 598 | => Proxy a 599 | -> TestTree 600 | finiteLaws _ = testGroup name 601 | [ testProperty "elem x universe" elemProp 602 | , testProperty "length pfx = length (nub pfx)" prefixProp 603 | 604 | , testProperty "elem x universeF" elemFProp 605 | , testProperty "length (filter (== x) universeF) = 1" singleProp 606 | , testProperty "cardinality = Tagged (genericLength universeF)" cardinalityProp 607 | ] 608 | where 609 | name = show (typeOf (undefined :: a)) 610 | 611 | elemProp :: a -> Property 612 | elemProp x = QC.property $ elem x universe 613 | 614 | elemFProp :: a -> Property 615 | elemFProp x = QC.property $ elem x universeF 616 | 617 | prefixProp :: Int -> Property 618 | prefixProp n = 619 | let pfx = take n (universe :: [a]) 620 | in QC.counterexample (show pfx) $ length pfx === length (nub pfx) 621 | 622 | singleProp :: a -> Property 623 | singleProp x = length (filter (== x) universeF) === 1 624 | 625 | cardinalityProp :: Property 626 | cardinalityProp = cardinality === (Tagged (genericLength (universeF :: [a])) :: Tagged a Natural) 627 | {-# NOINLINE finiteLaws #-} 628 | 629 | ------------------------------------------------------------------------------- 630 | -- Lexicographic M2 search 631 | ------------------------------------------------------------------------------- 632 | 633 | searchM3 :: (Eq a, PartialOrd a, Lattice a) => [a] -> Maybe (a,a,a,a,a) 634 | searchM3 xs = listToMaybe $ do 635 | x0 <- xs 636 | xa <- xs 637 | guard (xa `notElem` [x0]) 638 | guard (x0 `leq` xa) 639 | xb <- xs 640 | guard (xb `notElem` [x0,xa]) 641 | guard (x0 `leq` xb) 642 | guard (not $ comparable xa xb) 643 | xc <- xs 644 | guard (xc `notElem` [x0,xa,xb]) 645 | guard (x0 `leq` xc) 646 | guard (not $ comparable xa xc) 647 | guard (not $ comparable xb xc) 648 | x1 <- xs 649 | guard (x1 `notElem` [x0,xa,xb,xc]) 650 | guard (x0 `leq` x1) 651 | guard (xa `leq` x1) 652 | guard (xb `leq` x1) 653 | guard (xc `leq` x1) 654 | 655 | -- homomorphism 656 | let f M3o = x1 657 | f M3a = xa 658 | f M3b = xb 659 | f M3c = xc 660 | f M3i = x1 661 | 662 | ma <- [minBound .. maxBound] 663 | mb <- [minBound .. maxBound] 664 | guard (f (ma /\ mb) == f ma /\ f mb) 665 | guard (f (ma \/ mb) == f ma \/ f mb) 666 | 667 | return (x0,xa,xb,xc,x1) 668 | 669 | type L2 = LO.Lexicographic M2 M2 670 | 671 | searchM3LexM2 :: Maybe (L2,L2,L2,L2,L2) 672 | searchM3LexM2 = searchM3 xs 673 | where 674 | xs = [ LO.Lexicographic x y | x <- ys, y <- ys ] 675 | ys = [minBound .. maxBound] 676 | 677 | ------------------------------------------------------------------------------- 678 | -- Variable (for Free) 679 | ------------------------------------------------------------------------------- 680 | 681 | -- | The less variables we have, the quicker tests will be :) 682 | data Var = A | B | C | D 683 | deriving (Eq, Ord, Show, Enum, Bounded, Typeable) 684 | 685 | instance Arbitrary Var where 686 | arbitrary = QC.arbitraryBoundedEnum 687 | 688 | shrink A = [] 689 | shrink x = [ minBound .. pred x ] 690 | -------------------------------------------------------------------------------- /wide.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskellari/lattices/ddae50f63f7d221e84c95784ebc11f1f9c428ed7/wide.png --------------------------------------------------------------------------------