├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── example └── example.hs ├── gaia.cabal ├── src └── Math │ ├── Gaia.hs │ └── Gaia │ ├── Bool.hs │ ├── Category.hs │ ├── Double.hs │ ├── Finite.hs │ ├── Float.hs │ ├── Int.hs │ ├── Integer.hs │ ├── Prelude.hs │ └── Rational.hs ├── stack.yaml └── test └── test.hs /.travis.yml: -------------------------------------------------------------------------------- 1 | # see https://docs.haskellstack.org/en/stable/GUIDE/#travis-with-caching 2 | # Copy these contents into the root directory of your Github project in a file 3 | # named .travis.yml 4 | 5 | # Use new container infrastructure to enable caching 6 | sudo: false 7 | 8 | # Choose a lightweight base image; we provide our own build tools. 9 | language: c 10 | 11 | # Caching so the next build will be fast too. 12 | cache: 13 | directories: 14 | - $HOME/.ghc 15 | - $HOME/.cabal 16 | - $HOME/.stack 17 | 18 | # The different configurations we want to test. We have BUILD=cabal which uses 19 | # cabal-install, and BUILD=stack which uses Stack. More documentation on each 20 | # of those below. 21 | # 22 | # We set the compiler values here to tell Travis to use a different 23 | # cache file per set of arguments. 24 | # 25 | # If you need to have different apt packages for each combination in the 26 | # matrix, you can use a line such as: 27 | # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} 28 | matrix: 29 | include: 30 | # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: 31 | # https://github.com/hvr/multi-ghc-travis 32 | - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7 33 | compiler: ": #GHC 7.10.3" 34 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 35 | - env: BUILD=cabal GHCVER=8.0.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 36 | compiler: ": #GHC 8.0.1" 37 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 38 | 39 | # Build with the newest GHC and cabal-install. This is an accepted failure, 40 | # see below. 41 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 42 | compiler: ": #GHC HEAD" 43 | addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 44 | 45 | # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS 46 | # variable, such as using --stack-yaml to point to a different file. 47 | - env: BUILD=stack ARGS="" 48 | compiler: ": #stack default" 49 | addons: {apt: {packages: [ghc-8.0.1], sources: [hvr-ghc]}} 50 | 51 | - env: BUILD=stack ARGS="--resolver lts-6" 52 | compiler: ": #stack 8.0.1" 53 | addons: {apt: {packages: [ghc-8.0.1], sources: [hvr-ghc]}} 54 | 55 | # Nightly builds are allowed to fail 56 | - env: BUILD=stack ARGS="--resolver nightly" 57 | compiler: ": #stack nightly" 58 | addons: {apt: {packages: [libgmp,libgmp-dev]}} 59 | 60 | # Build on OS X in addition to Linux 61 | - env: BUILD=stack ARGS="" 62 | compiler: ": #stack default osx" 63 | os: osx 64 | 65 | - env: BUILD=stack ARGS="--resolver lts-7" 66 | compiler: ": #stack 8.0.1 osx" 67 | os: osx 68 | 69 | - env: BUILD=stack ARGS="--resolver nightly" 70 | compiler: ": #stack nightly osx" 71 | os: osx 72 | 73 | allow_failures: 74 | - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7 75 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 76 | - env: BUILD=stack ARGS="--resolver nightly" 77 | 78 | before_install: 79 | # Using compiler above sets CC to an invalid value, so unset it 80 | - unset CC 81 | 82 | # We want to always allow newer versions of packages when building on GHC HEAD 83 | - CABALARGS="" 84 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 85 | 86 | # Download and unpack the stack executable 87 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 88 | - mkdir -p ~/.local/bin 89 | - | 90 | if [ `uname` = "Darwin" ] 91 | then 92 | travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 93 | else 94 | travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 95 | fi 96 | 97 | # Use the more reliable S3 mirror of Hackage 98 | mkdir -p $HOME/.cabal 99 | echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config 100 | echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config 101 | 102 | if [ "$CABALVER" != "1.16" ] 103 | then 104 | echo 'jobs: $ncpus' >> $HOME/.cabal/config 105 | fi 106 | 107 | # Get the list of packages from the stack.yaml file 108 | - PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 109 | 110 | install: 111 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 112 | - if [ -f configure.ac ]; then autoreconf -i; fi 113 | - | 114 | set -ex 115 | case "$BUILD" in 116 | stack) 117 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 118 | ;; 119 | cabal) 120 | cabal --version 121 | travis_retry cabal update 122 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 123 | ;; 124 | esac 125 | set +ex 126 | 127 | script: 128 | - | 129 | set -ex 130 | case "$BUILD" in 131 | stack) 132 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps 133 | ;; 134 | cabal) 135 | cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 136 | 137 | ORIGDIR=$(pwd) 138 | for dir in $PACKAGES 139 | do 140 | cd $dir 141 | cabal check || [ "$CABALVER" == "1.16" ] 142 | cabal sdist 143 | PKGVER=$(cabal info . | awk '{print $2;exit}') 144 | SRC_TGZ=$PKGVER.tar.gz 145 | cd dist 146 | tar zxfv "$SRC_TGZ" 147 | cd "$PKGVER" 148 | cabal configure --enable-tests 149 | cabal build 150 | cd $ORIGDIR 151 | done 152 | ;; 153 | esac 154 | set +ex 155 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Samuel Schlesinger (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Samuel Schlesinger nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Gaia 2 | 3 | This library is meant to act as a logical basis for algebraic computation in Haskell, 4 | and as such it offers many classes which are named in such a way that you can translate 5 | between mathematical notation and Haskell notation as uniformly as possible. This is 6 | done in a way that emphasizes user provided constraints: 7 | 8 | ```Haskell 9 | 10 | class Magma a where mul :: a -> a -> a 11 | class Magma a => Idempotent a 12 | class Magma a => Commutative a 13 | class Magma a => Associative a 14 | class Magma a => Unital a where unit :: a 15 | class Magma a => Invertible a where inv :: a -> a -> a 16 | 17 | ``` 18 | 19 | These are accumulated in composite constraints and the notations which 20 | refer to what these composite constraints define: 21 | 22 | ```Haskell 23 | 24 | type Semigroup a = Associative a 25 | type Monoid a = (Unital a, Semigroup a) 26 | type Group a = (Invertible a, Monoid a) 27 | type Abelian c a = (Commutative a, c a) 28 | 29 | ``` 30 | 31 | In this way you can specify what structure your algorithm processes, and then define it only using 32 | those operations. When you've specified a process like that, it's as general as it can be, 33 | and then you can operate over arbitrary data types and use facilities like rewrite rules and 34 | specialization to achieve the efficiency you would have gotten if you had written the code 35 | monotypically. 36 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example/example.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude hiding (Num(..), (++)) 4 | import Data.Array.IArray 5 | import Data.Array () 6 | import Math.Gaia 7 | import Math.Gaia.Int 8 | import Math.Gaia.Float 9 | import Math.Gaia.Bool 10 | import Math.Gaia.Integer 11 | 12 | identity :: (Distributive x, IArray array x) 13 | => Int -> array (Int, Int) x 14 | 15 | identity n = array ((1, 1), (n, n)) [ if i == j then ((i, j), one) else ((i, j), zero) 16 | | i <- [1..n], j <- [1..n] ] 17 | 18 | matmul :: (Distributive x, IArray array x) 19 | => array (Int, Int) x -> array (Int, Int) x -> array (Int, Int) x 20 | 21 | matmul a b = let 22 | ((1, 1), (aw, ah)) = bounds a 23 | ((1, 1), (bw, bh)) = bounds b 24 | in if aw /= bh 25 | then error "cmaaaahn" 26 | else accumArray (+) zero ((1, 1), (bw, ah)) 27 | [ (ind, a ! ind * b ! ind) 28 | | x <- [1..bw], y <- [1..ah], k <- [1..aw] 29 | , let ind = (x, y) ] 30 | 31 | main = do 32 | let e = (identity 10 :: Array (Int, Int) Integer) 33 | print "heh" 34 | -------------------------------------------------------------------------------- /gaia.cabal: -------------------------------------------------------------------------------- 1 | name: gaia 2 | version: 0.1.0.0 3 | synopsis: Initial project template from stack 4 | description: Please see README.md 5 | homepage: https://github.com/SamuelSchlesinger/gaia#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Samuel Schlesinger 9 | maintainer: sgschlesinger at gmail dot com 10 | copyright: (c) 2016-2018 Samuel Schlesinger 11 | category: Web 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Math.Gaia, 19 | Math.Gaia.Prelude, 20 | Math.Gaia.Int, 21 | Math.Gaia.Integer, 22 | Math.Gaia.Double, 23 | Math.Gaia.Float, 24 | Math.Gaia.Bool, 25 | Math.Gaia.Finite, 26 | Math.Gaia.Category, 27 | Math.Gaia.Rational 28 | 29 | build-depends: base >= 4.7 && < 5, 30 | protolude, 31 | constraints 32 | default-language: Haskell2010 33 | default-extensions: 34 | NoImplicitPrelude, 35 | UnicodeSyntax, 36 | BangPatterns, 37 | BinaryLiterals, 38 | DeriveFoldable, 39 | DeriveFunctor, 40 | DeriveGeneric, 41 | DeriveTraversable, 42 | DisambiguateRecordFields, 43 | EmptyCase, 44 | FlexibleContexts, 45 | FlexibleInstances, 46 | FunctionalDependencies, 47 | GADTSyntax, 48 | InstanceSigs, 49 | KindSignatures, 50 | LambdaCase, 51 | MonadComprehensions, 52 | MultiParamTypeClasses, 53 | MultiWayIf, 54 | NegativeLiterals, 55 | OverloadedStrings, 56 | ParallelListComp, 57 | PartialTypeSignatures, 58 | PatternSynonyms, 59 | RankNTypes, 60 | RecordWildCards, 61 | RecursiveDo, 62 | ScopedTypeVariables, 63 | TupleSections, 64 | TypeFamilies, 65 | TypeOperators 66 | 67 | 68 | executable example 69 | default-language: 70 | Haskell2010 71 | hs-source-dirs: 72 | example 73 | main-is: 74 | example.hs 75 | build-depends: 76 | base >= 4.7 && < 5, 77 | gaia, 78 | array 79 | default-extensions: 80 | NoImplicitPrelude, 81 | UnicodeSyntax, 82 | BangPatterns, 83 | BinaryLiterals, 84 | DeriveFoldable, 85 | DeriveFunctor, 86 | DeriveGeneric, 87 | DeriveTraversable, 88 | DisambiguateRecordFields, 89 | EmptyCase, 90 | FlexibleContexts, 91 | FlexibleInstances, 92 | FunctionalDependencies, 93 | GADTSyntax, 94 | InstanceSigs, 95 | KindSignatures, 96 | LambdaCase, 97 | MonadComprehensions, 98 | MultiParamTypeClasses 99 | 100 | test-suite test 101 | default-language: 102 | Haskell2010 103 | type: 104 | exitcode-stdio-1.0 105 | hs-source-dirs: 106 | test 107 | main-is: 108 | test.hs 109 | build-depends: 110 | base >= 4.7 && < 5, 111 | protolude, 112 | tasty, 113 | HUnit, 114 | tasty-hunit, 115 | smallcheck, 116 | tasty-smallcheck, 117 | QuickCheck, 118 | tasty-quickcheck, 119 | gaia 120 | default-extensions: 121 | NoImplicitPrelude, 122 | UnicodeSyntax, 123 | BangPatterns, 124 | BinaryLiterals, 125 | DeriveFoldable, 126 | DeriveFunctor, 127 | DeriveGeneric, 128 | DeriveTraversable, 129 | DisambiguateRecordFields, 130 | EmptyCase, 131 | FlexibleContexts, 132 | FlexibleInstances, 133 | FunctionalDependencies, 134 | GADTSyntax, 135 | InstanceSigs, 136 | KindSignatures, 137 | LambdaCase, 138 | MonadComprehensions, 139 | MultiParamTypeClasses, 140 | MultiWayIf, 141 | NegativeLiterals, 142 | OverloadedStrings, 143 | ParallelListComp, 144 | PartialTypeSignatures, 145 | PatternSynonyms, 146 | RankNTypes, 147 | RecordWildCards, 148 | RecursiveDo, 149 | ScopedTypeVariables, 150 | TupleSections, 151 | TypeFamilies, 152 | TypeOperators 153 | 154 | source-repository head 155 | type: git 156 | location: https://github.com/SamuelSchlesinger/gaia 157 | -------------------------------------------------------------------------------- /src/Math/Gaia.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds, NoImplicitPrelude, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, FlexibleInstances, LiberalTypeSynonyms, FunctionalDependencies #-} 2 | {-# OPTIONS_GHC -O3 #-} 3 | module Math.Gaia 4 | ( 5 | Magma(..) 6 | , Idempotent(..) 7 | , Commutative(..) 8 | , Associative(..) 9 | , Unital(..) 10 | , Invertible(..) 11 | , Homomorphic(..) 12 | , Isomorphic(..) 13 | , Semigroup(..) 14 | , Monoid(..) 15 | , Group(..) 16 | , Abelian(..) 17 | , (<>) 18 | , (++) 19 | , empty 20 | , Distributive(..) 21 | , Semiring(..) 22 | , Ring(..) 23 | , Exponential(..) 24 | , Division(..) 25 | , Field(..) 26 | , IntegralDomain(..) 27 | , Decidable(..) 28 | , Ordered(..) 29 | , (+) 30 | , (*) 31 | , (-) 32 | , (/) 33 | , exp 34 | , POrdering(..) 35 | , POrd(..) 36 | , ord2pord 37 | , Topped(..) 38 | , Bottomed(..) 39 | , PBounded(..) 40 | , Semilattice(..) 41 | , Lattice(..) 42 | , Negated(..) 43 | , negate 44 | ) where 45 | 46 | import Data.Coerce 47 | import Prelude hiding ((+), (*), (-), (/), exp, negate, Monoid(..), div, mod, (++)) 48 | 49 | -- | Grown out of the flames, the magma 50 | class Magma a where mul :: a -> a -> a 51 | instance Magma a => Magma (x -> a) where 52 | (f `mul` g) x = f x `mul` g x 53 | instance Magma [a] where 54 | [] `mul` g = g 55 | (x : xs) `mul` g = x : xs `mul` g 56 | 57 | class Magma a => Idempotent a 58 | instance Magma a => Idempotent (x -> a) 59 | 60 | class Magma a => Commutative a 61 | instance Commutative a => Commutative (x -> a) 62 | 63 | class Magma a => Associative a 64 | instance Associative a => Associative (x -> a) 65 | instance Associative [a] 66 | 67 | class Magma a => Unital a where unit :: a 68 | instance Unital a => Unital (x -> a) where unit _ = unit 69 | instance Unital [a] where unit = [] 70 | 71 | class Magma a => Invertible a where inv :: a -> a 72 | instance Invertible a => Invertible (x -> a) where inv f x = inv (f x) 73 | 74 | class (Magma a, Magma b) => Homomorphic a b where hom :: a -> b 75 | instance Homomorphic a b => Homomorphic (x -> a) (x -> b) where 76 | hom f x = hom (f x) 77 | 78 | class (Magma a, Magma b) => Isomorphic a b where 79 | iso :: (a -> b, b -> a) 80 | 81 | instance Magma a => Homomorphic a a where hom a = a 82 | 83 | type Semigroup a = Associative a 84 | type Monoid a = (Unital a, Semigroup a) 85 | type Group a = (Invertible a, Monoid a) 86 | type Abelian c a = (Commutative a, c a) 87 | 88 | (<>) :: Semigroup a => a -> a -> a 89 | a <> b = a `mul` b 90 | 91 | (++) :: Monoid a => a -> a -> a 92 | a ++ b = a <> b 93 | 94 | empty :: Monoid a => a 95 | empty = unit 96 | 97 | class ( 98 | Coercible a (Add a) 99 | , Coercible a (Mul a) 100 | , Monoid (Mul a) 101 | , Monoid (Add a) 102 | ) => Distributive a where 103 | type Mul a 104 | type Add a 105 | one :: a 106 | one = coerce (unit :: Mul a) 107 | zero :: a 108 | zero = coerce (unit :: Add a) 109 | 110 | instance Distributive a => Distributive (x -> a) where 111 | type Mul (x -> a) = x -> Mul a 112 | type Add (x -> a) = x -> Add a 113 | 114 | type Semiring a = (Distributive a, Commutative (Add a)) 115 | type Exponential a = (Semiring a, Homomorphic (Add a) (Mul a)) 116 | type Logarithmic a = (Semiring a, Homomorphic (Mul a) (Add a)) 117 | type Ring a = (Semiring a, Group (Add a)) 118 | type Division a = (Ring a, Group (Mul a)) 119 | type Field a = (Division a, Commutative (Mul a)) 120 | type Ordered c a = (Ord a, c a) 121 | type POrdered c a = (POrd a, c a) 122 | type Decidable c a = (Eq a, c a) 123 | class Distributive a => IntegralDomain a where 124 | div :: a -> a -> a 125 | mod :: a -> a -> a 126 | 127 | instance IntegralDomain a => IntegralDomain (x -> a) where 128 | div f g x = div (f x) (g x) 129 | mod f g x = mod (f x) (g x) 130 | 131 | infixr 7 * 132 | (*) :: Distributive a => a -> a -> a 133 | (x :: a) * y = coerce ((coerce x `mul` coerce y) :: Mul a) :: a 134 | 135 | infixr 6 + 136 | (+) :: Distributive a => a -> a -> a 137 | (x :: a) + y = coerce ((coerce x `mul` coerce y) :: Add a) :: a 138 | 139 | infixr 6 - 140 | (-) :: Ring a => a -> a -> a 141 | (x :: a) - y = coerce ((coerce x `mul` inv (coerce y)) :: Add a) :: a 142 | 143 | infixr 7 / 144 | (/) :: Division a => a -> a -> a 145 | (x :: a) / y = coerce ((coerce x `mul` inv (coerce y)) :: Mul a) :: a 146 | 147 | exp :: Exponential a => a -> a 148 | exp (x :: a) = coerce (hom (coerce x :: Add a) :: Mul a) :: a 149 | 150 | log :: Logarithmic a => a -> a 151 | log (x :: a) = coerce (hom (coerce x :: Mul a) :: Add a) :: a 152 | 153 | -- | Equal to, Less than, Greater than, Not comparable to 154 | data POrdering = PEQ | PLT | PGT | PNC 155 | class POrd s where pcompare :: s -> s -> POrdering 156 | class POrd s => Topped s where top :: s 157 | class POrd s => Bottomed s where bottom :: s 158 | 159 | type Semilattice s = (Abelian Semigroup s, Idempotent s) 160 | type PBounded s = (Topped s, Bottomed s) 161 | 162 | class ( 163 | Coercible s (Sup s) 164 | , Coercible s (Inf s) 165 | , Semilattice (Sup s) 166 | , Semilattice (Inf s) 167 | , POrd s 168 | ) => Lattice s where 169 | type family Inf s 170 | type family Sup s 171 | (/\) :: s -> s -> s 172 | (/\) = coerce (mul :: Sup s -> Sup s -> Sup s) 173 | (\/) :: s -> s -> s 174 | (\/) = coerce (mul :: Inf s -> Inf s -> Inf s) 175 | 176 | type Negated s = (Lattice s, Isomorphic (Inf s) (Sup s)) 177 | 178 | negate :: Negated s => s -> s 179 | negate (a :: s) = coerce (fst iso (coerce a :: Inf s) :: Sup s) :: s 180 | 181 | ord2pord :: Ordering -> POrdering 182 | ord2pord EQ = PEQ 183 | ord2pord LT = PLT 184 | ord2pord GT = PGT 185 | 186 | -- | A Premodule is simply the Constraints 187 | -- listed below. 188 | type Premodule r m = (Distributive m, Semiring r, Homomorphic r m, Semigroup m, Commutative m) 189 | 190 | -- | A Semimodule is a Premodule where the action is distributive 191 | class ( 192 | Premodule r m 193 | , Monoid m 194 | , Semiring r 195 | ) => Semimodule r m 196 | 197 | instance Semimodule r m => Semimodule (x -> r) (x -> m) 198 | 199 | -- A Module is a Semimodule where m is a group and r is a ring 200 | type Module r m = (Ring r, Group m, Semimodule r m) 201 | 202 | infixr 6 .+ 203 | (.+) :: Premodule r m => r -> m -> m 204 | r .+ m = hom r + m 205 | 206 | infixr 7 .* 207 | (.*) :: Premodule r m => r -> m -> m 208 | r .* m = hom r * m 209 | 210 | infixr 6 .- 211 | (.-) :: (Premodule r m, Commutative (Add m), Invertible (Add m)) => r -> m -> m 212 | r .- m = hom r - m 213 | 214 | infixr 7 ./ 215 | (./) :: (Premodule r m, Commutative (Mul m), Invertible (Mul m), Commutative (Add m), Invertible (Add m)) => r -> m -> m 216 | r ./ m = hom r / m 217 | 218 | class Metric r m where 219 | d :: m -> m -> r 220 | 221 | instance Metric r m => Metric (x -> r) (x -> m) where 222 | d f g x = d (f x) (g x) 223 | 224 | class ( 225 | Metric r m 226 | , Module r m 227 | ) => Normed r m where 228 | norm :: m -> r 229 | 230 | instance Normed r m => Normed (x -> r) (x -> m) where 231 | norm f x = norm (f x) 232 | 233 | class Normed r m => Inner r m where 234 | (<.>) :: m -> m -> r 235 | -------------------------------------------------------------------------------- /src/Math/Gaia/Bool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | 3 | module Math.Gaia.Bool 4 | ( 5 | Bool(..) 6 | , And(..) 7 | , Or(..) 8 | , Xor(..) 9 | ) where 10 | 11 | import qualified Prelude as P 12 | import Prelude (($), Bool(..)) 13 | import Math.Gaia 14 | 15 | newtype And = And Bool 16 | newtype Or = Or Bool 17 | newtype Xor = Xor Bool 18 | 19 | instance Magma And where 20 | And a `mul` And b = And (a P.&& b) 21 | 22 | instance Magma Or where 23 | Or a `mul` Or b = Or (a P.|| b) 24 | 25 | instance Magma Xor where 26 | Xor True `mul` Xor True = Xor False 27 | Xor False `mul` Xor False = Xor False 28 | _ `mul` _ = Xor True 29 | 30 | instance Associative And 31 | instance Associative Or 32 | instance Associative Xor 33 | 34 | instance Commutative And 35 | instance Commutative Or 36 | instance Commutative Xor 37 | 38 | instance Idempotent Or 39 | instance Idempotent And 40 | 41 | instance Unital Or where unit = Or False 42 | instance Unital And where unit = And True 43 | instance Unital Xor where unit = Xor False 44 | 45 | instance Invertible Xor where inv a = a 46 | 47 | instance Homomorphic Or And where hom (Or x) = And (P.not x) 48 | 49 | instance Homomorphic And Or where hom (And x) = Or (P.not x) 50 | 51 | instance Isomorphic And Or where iso = (hom, hom) 52 | instance Isomorphic Or And where iso = (hom, hom) 53 | 54 | instance POrd Bool where 55 | pcompare True True = PEQ 56 | pcompare True False = PGT 57 | pcompare False True = PLT 58 | pcompare False False = PEQ 59 | 60 | instance Distributive Bool where 61 | type Mul Bool = And 62 | type Add Bool = Xor 63 | 64 | instance Lattice Bool where 65 | type Inf Bool = Or 66 | type Sup Bool = And 67 | -------------------------------------------------------------------------------- /src/Math/Gaia/Category.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | TypeInType 3 | , PolyKinds 4 | , DataKinds 5 | , ConstraintKinds 6 | , TypeFamilies 7 | , TypeOperators 8 | , RankNTypes 9 | , FlexibleInstances 10 | , FlexibleContexts 11 | , NoImplicitPrelude 12 | , GADTs 13 | , AllowAmbiguousTypes 14 | , UndecidableInstances 15 | , UndecidableSuperClasses #-} 16 | 17 | module Math.Gaia.Category 18 | ( 19 | Hom(..) 20 | , Quiver(..) 21 | , Category(..) 22 | , Groupoid(..) 23 | , Monoidal(..) 24 | , Arrow(..) 25 | ) where 26 | 27 | import Data.Kind 28 | import Data.Constraint 29 | import Data.Constraint.Forall 30 | 31 | -- | Abstraction 32 | 33 | data family Hom :: k -> k -> Type 34 | 35 | class Vacuous x 36 | instance Vacuous x 37 | 38 | class Hom ~ hom => Quiver hom where 39 | (~>) :: hom i j -> hom j k -> hom i k 40 | (<~) :: hom j k -> hom i j -> hom i k 41 | f <~ g = g ~> f 42 | f ~> g = g <~ f 43 | 44 | class Quiver hom => Category hom where 45 | id :: hom i i 46 | 47 | (.) :: Category hom => hom j k -> hom i j -> hom i k 48 | (.) = (<~) 49 | 50 | (>>>) :: Category hom => hom i j -> hom j k -> hom i k 51 | (>>>) = (~>) 52 | 53 | (<<<) :: Category hom => hom i j -> hom k i -> hom k j 54 | (<<<) = (.) 55 | 56 | class Category hom => Groupoid hom where 57 | inv :: hom i j -> hom j i 58 | 59 | (/) :: Groupoid hom => hom i j -> hom l j -> hom i l 60 | f / g = f ~> inv g 61 | 62 | class (Category (Dom f), Category (Cod f)) => Functor (f :: i -> j) where 63 | type Dom f :: i -> i -> Type 64 | type Cod f :: j -> j -> Type 65 | fmap :: Dom f a b -> Cod f (f a) (f b) 66 | 67 | class Quiver hom => Monoidal (hom :: k -> k -> Type) where 68 | type (a :: k) <*> (b :: k) :: k 69 | type I :: k 70 | associator :: (hom ((a <*> b) <*> c) (a <*> (b <*> c)), hom (a <*> (b <*> c)) ((a <*> b) <*> c)) 71 | lunitor :: (hom (I <*> a) a, hom a (I <*> a)) 72 | runitor :: (hom (a <*> I) a, hom a (a <*> I)) 73 | 74 | class Monoidal hom => Arrow hom where 75 | first :: hom a b -> hom (a <*> x) (b <*> x) 76 | second :: hom a b -> hom (x <*> a) (x <*> b) 77 | (***) :: hom a b -> hom x y -> hom (a <*> x) (b <*> y) 78 | (&&&) :: hom a x -> hom a y -> hom a (x <*> y) 79 | 80 | ---------------------------------------------------------- 81 | 82 | -- | Concretion 83 | 84 | newtype instance Hom x y 85 | = Fun (x -> y) 86 | 87 | newtype instance Hom (f :: k -> j) (g :: k -> j) 88 | = Nat (forall (x :: k). Hom (f x) (g x)) 89 | 90 | newtype instance Hom x y 91 | = Con (x :- y) 92 | 93 | instance Quiver (Hom :: j -> j -> Type) => Quiver (Hom :: (k -> j) -> (k -> j) -> Type) where 94 | Nat f ~> Nat g = Nat (f ~> g) 95 | 96 | instance Category (Hom :: j -> j -> Type) => Category (Hom :: (k -> j) -> (k -> j) -> Type) where 97 | id = Nat id 98 | 99 | 100 | -------------------------------------------------------------------------------- /src/Math/Gaia/Double.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-} 2 | 3 | module Math.Gaia.Double where 4 | 5 | import Math.Gaia 6 | import Protolude (Double(..), ($), (>), (<), (>=), (<=), (==)) 7 | import qualified Protolude as P 8 | 9 | newtype AddDouble = AddDouble Double 10 | newtype MulDouble = MulDouble Double 11 | 12 | instance Magma AddDouble where 13 | AddDouble a `mul` AddDouble b = AddDouble (a P.+ b) 14 | 15 | instance Magma MulDouble where 16 | MulDouble a `mul` MulDouble b = MulDouble (a P.* b) 17 | 18 | instance Associative AddDouble 19 | instance Associative MulDouble 20 | 21 | instance Commutative AddDouble 22 | instance Commutative MulDouble 23 | 24 | instance Unital AddDouble where 25 | unit = AddDouble 0 26 | 27 | instance Unital MulDouble where 28 | unit = MulDouble 1 29 | 30 | instance Homomorphic AddDouble AddDouble where 31 | hom x = x 32 | 33 | instance Invertible AddDouble where 34 | inv (AddDouble a) = AddDouble $ P.negate a 35 | 36 | instance Distributive Double where 37 | type Add Double = AddDouble 38 | type Mul Double = MulDouble 39 | 40 | newtype InfDouble = InfDouble Double 41 | newtype SupDouble = SupDouble Double 42 | 43 | instance Magma InfDouble where 44 | InfDouble a `mul` InfDouble b = InfDouble (if a <= b then a else b) 45 | 46 | instance Magma SupDouble where 47 | SupDouble a `mul` SupDouble b = SupDouble (if a >= b then a else b) 48 | 49 | instance Associative InfDouble 50 | instance Associative SupDouble 51 | 52 | instance Commutative SupDouble 53 | instance Commutative InfDouble 54 | 55 | instance Idempotent SupDouble 56 | instance Idempotent InfDouble 57 | 58 | instance Homomorphic SupDouble InfDouble where hom (SupDouble a) = InfDouble (-a) 59 | instance Homomorphic InfDouble SupDouble where hom (InfDouble a) = SupDouble (-a) 60 | 61 | instance POrd Double where 62 | pcompare n m = if n > m then PGT else if n == m then PEQ else PLT 63 | 64 | instance Lattice Double where 65 | type Inf Double = InfDouble 66 | type Sup Double = SupDouble 67 | -------------------------------------------------------------------------------- /src/Math/Gaia/Finite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, PolyKinds, GADTs, FlexibleContexts, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances, ConstraintKinds, StandaloneDeriving #-} 2 | 3 | module Math.Gaia.Finite 4 | ( 5 | Mod(..) 6 | , AddMod(..) 7 | , MulMod(..) 8 | , Prime(..) 9 | , RootOf(..) 10 | ) where 11 | 12 | import Prelude hiding ((+), (-), (*), (/), exp, div, mod, Monoid(..), negate) 13 | import GHC.TypeLits 14 | import Data.Proxy 15 | import Data.Coerce 16 | import Data.Kind (Type) 17 | import Data.Type.Equality 18 | import Math.Gaia 19 | 20 | {-# SPECIALIZE (+) :: (IntegralDomain z, Homomorphic Integer z, KnownNat n) => z `Mod` n -> z `Mod` n -> z `Mod` n #-} 21 | {-# SPECIALIZE (*) :: (IntegralDomain z, Homomorphic Integer z, KnownNat n) => z `Mod` n -> z `Mod` n -> z `Mod` n #-} 22 | 23 | data Mod :: Type -> Nat -> Type where 24 | Mod :: !z -> Mod z n 25 | 26 | deriving instance Show z => Show (Mod z n) 27 | 28 | instance ( 29 | Eq z 30 | , IntegralDomain z 31 | , Homomorphic Integer z 32 | , KnownNat n 33 | ) => Eq (Mod z n) where 34 | {-# INLINE (==) #-} 35 | Mod x == Mod y = x `mod` hom (natVal (Proxy :: Proxy n)) == x `mod` hom (natVal (Proxy :: Proxy n)) 36 | 37 | instance ( 38 | Ord z 39 | , IntegralDomain z 40 | , Homomorphic Integer z 41 | , KnownNat n 42 | ) => Ord (Mod z n) where 43 | {-# INLINE compare #-} 44 | compare (Mod x) (Mod y) = compare (x `mod` (hom (natVal (Proxy :: Proxy n)) :: z)) 45 | (y `mod` (hom (natVal (Proxy :: Proxy n)) :: z)) 46 | 47 | newtype AddMod z n = AddMod (Mod z n) 48 | 49 | instance (IntegralDomain z, KnownNat n, Homomorphic Integer z) => Magma (AddMod z n) where 50 | mul (AddMod (Mod a)) (AddMod (Mod b)) = AddMod $ Mod ((a + b) `mod` (hom (natVal (Proxy :: Proxy n)) :: z)) 51 | 52 | 53 | instance ( 54 | IntegralDomain z 55 | , KnownNat n 56 | , Homomorphic Integer z 57 | ) => Associative (MulMod z n) 58 | 59 | instance ( 60 | IntegralDomain z 61 | , KnownNat n 62 | , Homomorphic Integer z 63 | ) => Associative (AddMod z n) 64 | 65 | instance ( 66 | IntegralDomain z 67 | , KnownNat n 68 | , Homomorphic Integer z 69 | ) => Unital (AddMod z n) where 70 | {-# INLINE unit #-} 71 | unit = AddMod $ (Mod (hom (1 :: Integer)) :: Mod z n) 72 | 73 | instance ( 74 | IntegralDomain z 75 | , KnownNat n 76 | , Homomorphic Integer z 77 | ) => Unital (MulMod z n) where 78 | {-# INLINE unit #-} 79 | unit = MulMod $ (Mod (hom (1 :: Integer)) :: Mod z n) 80 | 81 | newtype MulMod z n = MulMod (Mod z n) 82 | 83 | instance ( 84 | IntegralDomain z 85 | , KnownNat n 86 | , Homomorphic Integer z 87 | ) => Magma (MulMod z n) where 88 | mul (MulMod (Mod a)) (MulMod (Mod b)) = MulMod $ Mod ((a * b) `mod` (hom (natVal (Proxy :: Proxy n)) :: z)) 89 | 90 | 91 | instance ( 92 | IntegralDomain z 93 | , KnownNat n 94 | , Homomorphic Integer z 95 | ) => Distributive (Mod z n) where 96 | type Add (Mod z n) = AddMod z n 97 | type Mul (Mod z n) = MulMod z n 98 | 99 | instance ( 100 | Ord z 101 | , IntegralDomain z 102 | , KnownNat n 103 | , Homomorphic Integer z 104 | ) => POrd (Mod z n) where 105 | pcompare a b = ord2pord $ compare a b 106 | 107 | type family If (c :: Bool) (a :: k) (b :: k) :: k where 108 | If True a b = a 109 | If False a b = b 110 | 111 | -- | This doesn't work for small numbers or something 112 | type family IsPrime (n :: Nat) (m :: Nat) (k :: Nat) :: Bool where 113 | IsPrime n 1 k = True 114 | IsPrime n m 1 = IsPrime n (m - 1) (m - 2) 115 | IsPrime n m k = If (k * m == n) False (IsPrime n m (k - 1)) 116 | 117 | type Prime n = IsPrime n (n - 1) (n - 2) ~ True 118 | 119 | type family IsRootOf (n :: Nat) (m :: Nat) (p :: Nat) :: Bool where 120 | IsRootOf n m p = If (n == m) True (If (n <=? m) False (IsRootOf n (m * p) p)) 121 | 122 | type RootOf n p = IsRootOf n p p 123 | 124 | 125 | 126 | -------------------------------------------------------------------------------- /src/Math/Gaia/Float.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-} 2 | 3 | module Math.Gaia.Float 4 | ( 5 | Float(..) 6 | , AddFloat(..) 7 | , MulFloat(..) 8 | ) where 9 | 10 | import Math.Gaia 11 | import Protolude (Float(..), ($), (>), (<), (>=), (<=), (==)) 12 | import qualified Protolude as P 13 | 14 | newtype AddFloat = AddFloat Float 15 | newtype MulFloat = MulFloat Float 16 | 17 | instance Magma AddFloat where 18 | AddFloat a `mul` AddFloat b = AddFloat (a P.+ b) 19 | 20 | instance Magma MulFloat where 21 | MulFloat a `mul` MulFloat b = MulFloat (a P.* b) 22 | 23 | instance Associative AddFloat 24 | instance Associative MulFloat 25 | 26 | instance Commutative AddFloat 27 | instance Commutative MulFloat 28 | 29 | instance Unital AddFloat where 30 | unit = AddFloat 0 31 | 32 | instance Unital MulFloat where 33 | unit = MulFloat 1 34 | 35 | instance Homomorphic AddFloat AddFloat where 36 | hom x = x 37 | 38 | instance Homomorphic AddFloat MulFloat where 39 | hom (AddFloat x) = MulFloat (P.exp x) 40 | 41 | instance Homomorphic MulFloat AddFloat where 42 | hom (MulFloat x) = AddFloat (P.log x) 43 | 44 | instance Isomorphic AddFloat MulFloat where 45 | iso = (\(AddFloat x) -> MulFloat (P.exp x), \(MulFloat x) -> AddFloat (P.log x)) 46 | 47 | instance Isomorphic MulFloat AddFloat where 48 | iso = let (a, b) = iso in (b, a) 49 | 50 | instance Invertible AddFloat where 51 | inv (AddFloat a) = AddFloat $ P.negate a 52 | 53 | instance Distributive Float where 54 | type Add Float = AddFloat 55 | type Mul Float = MulFloat 56 | 57 | newtype InfFloat = InfFloat Float 58 | newtype SupFloat = SupFloat Float 59 | 60 | instance Magma InfFloat where 61 | InfFloat a `mul` InfFloat b = InfFloat (if a <= b then a else b) 62 | 63 | instance Magma SupFloat where 64 | SupFloat a `mul` SupFloat b = SupFloat (if a >= b then a else b) 65 | 66 | instance Associative InfFloat 67 | instance Associative SupFloat 68 | 69 | instance Commutative SupFloat 70 | instance Commutative InfFloat 71 | 72 | instance Idempotent SupFloat 73 | instance Idempotent InfFloat 74 | 75 | instance Homomorphic SupFloat InfFloat where hom (SupFloat a) = InfFloat (-a) 76 | instance Homomorphic InfFloat SupFloat where hom (InfFloat a) = SupFloat (-a) 77 | 78 | instance POrd Float where 79 | pcompare n m = if n > m then PGT else if n == m then PEQ else PLT 80 | 81 | instance Lattice Float where 82 | type Inf Float = InfFloat 83 | type Sup Float = SupFloat 84 | -------------------------------------------------------------------------------- /src/Math/Gaia/Int.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-} 2 | 3 | module Math.Gaia.Int where 4 | 5 | import Math.Gaia 6 | import Protolude (Int(..), ($), (>), (<), (>=), (<=), (==)) 7 | import qualified Protolude as P 8 | 9 | newtype AddInt = AddInt Int 10 | newtype MulInt = MulInt Int 11 | 12 | instance Homomorphic AddInt MulInt where 13 | hom (AddInt n) = MulInt (2 P.^ n) 14 | 15 | instance Magma AddInt where 16 | AddInt a `mul` AddInt b = AddInt (a P.+ b) 17 | 18 | instance Magma MulInt where 19 | MulInt a `mul` MulInt b = MulInt (a P.* b) 20 | 21 | instance Associative AddInt 22 | instance Associative MulInt 23 | 24 | instance Commutative AddInt 25 | instance Commutative MulInt 26 | 27 | instance Unital AddInt where 28 | unit = AddInt 0 29 | 30 | instance Unital MulInt where 31 | unit = MulInt 1 32 | 33 | instance Homomorphic AddInt AddInt where 34 | hom x = x 35 | 36 | instance Invertible AddInt where 37 | inv (AddInt a) = AddInt $ P.negate a 38 | 39 | instance Distributive Int where 40 | type Add Int = AddInt 41 | type Mul Int = MulInt 42 | 43 | instance IntegralDomain Int where 44 | div = P.div 45 | mod = P.mod 46 | 47 | newtype InfInt = InfInt Int 48 | newtype SupInt = SupInt Int 49 | 50 | instance Magma InfInt where 51 | InfInt a `mul` InfInt b = InfInt (if a <= b then a else b) 52 | 53 | instance Magma SupInt where 54 | SupInt a `mul` SupInt b = SupInt (if a >= b then a else b) 55 | 56 | instance Associative InfInt 57 | instance Associative SupInt 58 | 59 | instance Commutative SupInt 60 | instance Commutative InfInt 61 | 62 | instance Idempotent SupInt 63 | instance Idempotent InfInt 64 | 65 | instance Homomorphic SupInt InfInt where hom (SupInt a) = InfInt (-a) 66 | instance Homomorphic InfInt SupInt where hom (InfInt a) = SupInt (-a) 67 | 68 | 69 | instance Isomorphic SupInt InfInt where iso = (hom, hom) 70 | instance Isomorphic InfInt SupInt where iso = (hom, hom) 71 | 72 | instance POrd Int where 73 | pcompare n m = if n > m then PGT else if n == m then PEQ else PLT 74 | 75 | instance Lattice Int where 76 | type Inf Int = InfInt 77 | type Sup Int = SupInt 78 | -------------------------------------------------------------------------------- /src/Math/Gaia/Integer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-} 2 | 3 | module Math.Gaia.Integer 4 | ( 5 | Integer(..) 6 | , AddInteger(..) 7 | , MulInteger(..) 8 | , lengthZ 9 | ) where 10 | 11 | import Math.Gaia 12 | import Protolude (Integer(..), ($), (>), (<), (>=), (<=), (==)) 13 | import Data.Coerce 14 | import qualified Protolude as P 15 | 16 | newtype AddInteger = AddInteger Integer 17 | newtype MulInteger = MulInteger Integer 18 | 19 | instance Homomorphic AddInteger MulInteger where 20 | hom (AddInteger n) = MulInteger (2 P.^ n) 21 | 22 | instance Homomorphic [a] AddInteger where 23 | hom [] = AddInteger 0 24 | hom (x : xs) = AddInteger 1 `mul` hom xs 25 | 26 | lengthZ :: [a] -> Integer 27 | lengthZ x = coerce $ (hom x :: AddInteger) 28 | 29 | instance Magma AddInteger where 30 | AddInteger a `mul` AddInteger b = AddInteger (a P.+ b) 31 | 32 | instance Magma MulInteger where 33 | MulInteger a `mul` MulInteger b = MulInteger (a P.* b) 34 | 35 | instance Associative AddInteger 36 | instance Associative MulInteger 37 | 38 | instance Commutative AddInteger 39 | instance Commutative MulInteger 40 | 41 | instance Unital AddInteger where 42 | unit = AddInteger 0 43 | 44 | instance Unital MulInteger where 45 | unit = MulInteger 1 46 | 47 | instance Homomorphic AddInteger AddInteger where 48 | hom x = x 49 | 50 | instance Invertible AddInteger where 51 | inv (AddInteger a) = AddInteger $ P.negate a 52 | 53 | instance Distributive Integer where 54 | type Add Integer = AddInteger 55 | type Mul Integer = MulInteger 56 | 57 | instance IntegralDomain Integer where 58 | div = P.div 59 | mod = P.mod 60 | 61 | newtype InfInteger = InfInteger Integer 62 | newtype SupInteger = SupInteger Integer 63 | 64 | instance Isomorphic InfInteger SupInteger where 65 | iso = (\(InfInteger x) -> SupInteger (P.negate x), \(SupInteger x) -> InfInteger (P.negate x)) 66 | 67 | instance Isomorphic SupInteger InfInteger where 68 | iso = let (a, b) = iso in (b, a) 69 | 70 | instance Magma InfInteger where 71 | InfInteger a `mul` InfInteger b = InfInteger (if a <= b then a else b) 72 | 73 | instance Magma SupInteger where 74 | SupInteger a `mul` SupInteger b = SupInteger (if a >= b then a else b) 75 | 76 | instance Associative InfInteger 77 | instance Associative SupInteger 78 | 79 | instance Commutative SupInteger 80 | instance Commutative InfInteger 81 | 82 | instance Idempotent SupInteger 83 | instance Idempotent InfInteger 84 | 85 | instance Homomorphic SupInteger InfInteger where hom (SupInteger a) = InfInteger (-a) 86 | instance Homomorphic InfInteger SupInteger where hom (InfInteger a) = SupInteger (-a) 87 | 88 | instance POrd Integer where 89 | pcompare n m = if n > m then PGT else if n == m then PEQ else PLT 90 | 91 | instance Lattice Integer where 92 | type Inf Integer = InfInteger 93 | type Sup Integer = SupInteger 94 | -------------------------------------------------------------------------------- /src/Math/Gaia/Prelude.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | module Math.Gaia.Prelude (module X) where 4 | 5 | import Protolude as X hiding 6 | ( Semiring(..) 7 | , (+) 8 | , (-) 9 | , (*) 10 | , (/) 11 | -- , cancel 12 | , zero 13 | , one 14 | , negate 15 | , div 16 | , mod 17 | , abs 18 | , infinity 19 | , exp 20 | , first 21 | , second 22 | ) 23 | 24 | import Math.Gaia as X hiding 25 | ( (<>) 26 | , (++) 27 | , empty 28 | , Semigroup 29 | , Monoid 30 | ) 31 | 32 | import Math.Gaia.Int as X 33 | import Math.Gaia.Integer as X 34 | import Math.Gaia.Float as X 35 | import Math.Gaia.Double as X 36 | -- TODO 37 | -- import Math.Gaia.Vector as X 38 | import Math.Gaia.Bool as X 39 | import Math.Gaia.Finite as X 40 | -- Not fit for consumption by public 41 | -- import Math.Gaia.Category as X 42 | 43 | -------------------------------------------------------------------------------- /src/Math/Gaia/Rational.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-} 2 | 3 | module Math.Gaia.Rational where 4 | 5 | import Math.Gaia 6 | import Protolude (Rational(..), ($), (>), (<), (>=), (<=), (==)) 7 | import qualified Protolude as P 8 | 9 | newtype AddRational = AddRational Rational 10 | newtype MulRational = MulRational Rational 11 | 12 | instance Magma AddRational where 13 | AddRational a `mul` AddRational b = AddRational (a P.+ b) 14 | 15 | instance Magma MulRational where 16 | MulRational a `mul` MulRational b = MulRational (a P.* b) 17 | 18 | instance Associative AddRational 19 | instance Associative MulRational 20 | 21 | instance Commutative AddRational 22 | instance Commutative MulRational 23 | 24 | instance Unital AddRational where 25 | unit = AddRational 0 26 | 27 | instance Unital MulRational where 28 | unit = MulRational 1 29 | 30 | instance Homomorphic AddRational AddRational where 31 | hom x = x 32 | 33 | instance Invertible AddRational where 34 | inv (AddRational a) = AddRational $ P.negate a 35 | 36 | instance Invertible MulRational where 37 | inv (MulRational a) = MulRational $ P.recip a 38 | 39 | instance Distributive Rational where 40 | type Add Rational = AddRational 41 | type Mul Rational = MulRational 42 | 43 | newtype InfRational = InfRational Rational 44 | newtype SupRational = SupRational Rational 45 | 46 | instance Magma InfRational where 47 | InfRational a `mul` InfRational b = InfRational (if a <= b then a else b) 48 | 49 | instance Magma SupRational where 50 | SupRational a `mul` SupRational b = SupRational (if a >= b then a else b) 51 | 52 | instance Associative InfRational 53 | instance Associative SupRational 54 | 55 | instance Commutative SupRational 56 | instance Commutative InfRational 57 | 58 | instance Idempotent SupRational 59 | instance Idempotent InfRational 60 | 61 | instance Homomorphic SupRational InfRational where hom (SupRational a) = InfRational (-a) 62 | instance Homomorphic InfRational SupRational where hom (InfRational a) = SupRational (-a) 63 | 64 | instance POrd Rational where 65 | pcompare n m = if n > m then PGT else if n == m then PEQ else PLT 66 | 67 | instance Lattice Rational where 68 | type Inf Rational = InfRational 69 | type Sup Rational = SupRational 70 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-7.2 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.2" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /test/test.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | module Main where 4 | 5 | import Protolude hiding ((+),(-),(*),(/),zero,one,negate) 6 | 7 | import Test.Tasty (TestName, TestTree, testGroup, defaultMain) 8 | import Test.Tasty.QuickCheck 9 | 10 | import Math.Gaia 11 | import Math.Gaia.Int() 12 | import Math.Gaia.Integer() 13 | import Math.Gaia.Double() 14 | import Math.Gaia.Float() 15 | import Math.Gaia.Bool() 16 | import Math.Gaia.Rational() 17 | 18 | data LawArity a = 19 | Unary (a -> Bool) | 20 | Binary (a -> a -> Bool) | 21 | Ternary (a -> a -> a -> Bool) | 22 | Ornary (a -> a -> a -> a -> Bool) 23 | 24 | type Law a = (TestName, (LawArity a)) 25 | 26 | testLawOf :: 27 | ( Arbitrary a 28 | , Show a 29 | ) => 30 | [a] -> Law a -> TestTree 31 | testLawOf _ (name, Unary f) = testProperty name f 32 | testLawOf _ (name, Binary f) = testProperty name f 33 | testLawOf _ (name, Ternary f) = testProperty name f 34 | testLawOf _ (name, Ornary f) = testProperty name f 35 | 36 | tests :: TestTree 37 | tests = testGroup "everything" $ 38 | [ testGroup "Int" $ testLawOf ([]::[Int]) <$> lawsIntegral 39 | , testGroup "Integer" $ testLawOf ([]::[Integer]) <$> lawsIntegral 40 | , testGroup "Float" $ testLawOf ([]::[Float]) <$> lawsFloat 41 | , testGroup "Double" $ testLawOf ([]::[Double]) <$> lawsFloat 42 | , testGroup "Rational" $ testLawOf ([]::[Rational]) <$> lawsRational 43 | ] 44 | 45 | main :: IO () 46 | main = defaultMain tests 47 | 48 | lawsIntegral :: 49 | ( Eq a 50 | , Distributive a 51 | , Invertible (Add a) 52 | , Commutative (Add a) 53 | , Lattice a 54 | , Isomorphic (Inf a) (Sup a) 55 | ) => 56 | [Law a] 57 | lawsIntegral = 58 | [ ("associative: a + (b + c) == (a + b) + c", Ternary (\a b c -> a + (b + c) == (a + b) + c)) 59 | , ("left zero: zero + a = a", Unary (\a -> zero + a == a)) 60 | , ("right zero: a + zero = a", Unary (\a -> a + zero == a)) 61 | , ("left one: one * a == a", Unary (\a -> one * a == a)) 62 | , ("right one: a * one == a", Unary (\a -> a * one == a)) 63 | , ("commutative: a + b == b + a", Binary (\a b -> a + b == b + a)) 64 | , ("commutative: a * b == b * a", Binary (\a b -> a * b == b * a)) 65 | , ("associative: (a * b) * c == a * (b * c)", Ternary (\a b c -> (a * b) * c == a * (b * c))) 66 | , ("left annihilative: a * zero == zero", Unary (\a -> a * zero == zero)) 67 | , ("right annihilative: zero * a == zero", Unary (\a -> zero * a == zero)) 68 | , ("left distributive: a * (b + c) == a * b + a * c", Ternary (\a b c -> a * (b + c) == a * b + a * c)) 69 | , ("right distributive: (a + b) * c == a * c + b * c", Ternary (\a b c -> (a + b) * c == a * c + b * c)) 70 | , ("right minus1: (a + b) - b = a", Binary (\a b -> (a + b) - b == a)) 71 | , ("right minus2: a + (b - b) = a", Binary (\a b -> a + (b - b) == a)) 72 | , ("negate minus: a + negate b == a - b", Binary (\a b -> a + negate b == a - b)) 73 | , ("left inverse: negate a + a == zero", Unary (\a -> negate a + a == zero)) 74 | , ("right inverse: a + negate a == zero", Unary (\a -> a + negate a == zero)) 75 | ] 76 | 77 | lawsFloat :: 78 | ( Eq a 79 | , Distributive a 80 | , Invertible (Add a) 81 | , Commutative (Add a) 82 | ) => 83 | [Law a] 84 | lawsFloat = 85 | [ ("left zero: zero + a = a", Unary (\a -> zero + a == a)) 86 | , ("right zero: a + zero = a", Unary (\a -> a + zero == a)) 87 | , ("left one: one * a == a", Unary (\a -> one * a == a)) 88 | , ("right one: a * one == a", Unary (\a -> a * one == a)) 89 | , ("commutative: a + b == b + a", Binary (\a b -> a + b == b + a)) 90 | , ("commutative: a * b == b * a", Binary (\a b -> a * b == b * a)) 91 | , ("left annihilative: a * zero == zero", Unary (\a -> a * zero == zero)) 92 | , ("right annihilative: zero * a == zero", Unary (\a -> zero * a == zero)) 93 | , ("right minus2: a + (b - b) = a", Binary (\a b -> a + (b - b) == a)) 94 | ] 95 | 96 | lawsRational :: 97 | ( Eq a 98 | , Distributive a 99 | , Invertible (Add a) 100 | , Commutative (Add a) 101 | ) => 102 | [Law a] 103 | lawsRational = 104 | [ ("associative: a + (b + c) == (a + b) + c", Ternary (\a b c -> a + (b + c) == (a + b) + c)) 105 | , ("left zero: zero + a = a", Unary (\a -> zero + a == a)) 106 | , ("right zero: a + zero = a", Unary (\a -> a + zero == a)) 107 | , ("left one: one * a == a", Unary (\a -> one * a == a)) 108 | , ("right one: a * one == a", Unary (\a -> a * one == a)) 109 | , ("commutative: a + b == b + a", Binary (\a b -> a + b == b + a)) 110 | , ("commutative: a * b == b * a", Binary (\a b -> a * b == b * a)) 111 | , ("associative: (a * b) * c == a * (b * c)", Ternary (\a b c -> (a * b) * c == a * (b * c))) 112 | , ("left annihilative: a * zero == zero", Unary (\a -> a * zero == zero)) 113 | , ("right annihilative: zero * a == zero", Unary (\a -> zero * a == zero)) 114 | , ("left distributive: a * (b + c) == a * b + a * c", Ternary (\a b c -> a * (b + c) == a * b + a * c)) 115 | , ("right distributive: (a + b) * c == a * c + b * c", Ternary (\a b c -> (a + b) * c == a * c + b * c)) 116 | , ("right minus1: (a + b) - b = a", Binary (\a b -> (a + b) - b == a)) 117 | , ("right minus2: a + (b - b) = a", Binary (\a b -> a + (b - b) == a)) 118 | ] 119 | --------------------------------------------------------------------------------