algebra-3.1/0000755000000000000000000000000012072477456011156 5ustar0000000000000000algebra-3.1/.ghci0000644000000000000000000000012512072477456012067 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h algebra-3.1/.gitignore0000644000000000000000000000001412072477456013141 0ustar0000000000000000_darcs dist algebra-3.1/.travis.yml0000644000000000000000000000033412072477456013267 0ustar0000000000000000language: haskell notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313algebra\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" algebra-3.1/.vim.custom0000644000000000000000000000137712072477456013273 0ustar0000000000000000" Add the following to your .vimrc to automatically load this on startup " if filereadable(".vim.custom") " so .vim.custom " endif function StripTrailingWhitespace() let myline=line(".") let mycolumn = col(".") silent %s/ *$// call cursor(myline, mycolumn) endfunction " enable syntax highlighting syntax on " search for the tags file anywhere between here and / set tags=TAGS;/ " highlight tabs and trailing spaces set listchars=tab:‗‗,trail:‗ set list " f2 runs hasktags map :exec ":!hasktags -x -c --ignore src" " strip trailing whitespace before saving " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() " rebuild hasktags after saving au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" algebra-3.1/algebra.cabal0000644000000000000000000000653312072477456013546 0ustar0000000000000000name: algebra category: Math, Algebra version: 3.1 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: experimental homepage: http://github.com/ekmett/algebra/ bug-reports: http://github.com/ekmett/algebra/issues copyright: Copyright (C) 2011 Edward A. Kmett synopsis: Constructive abstract algebra description: Constructive abstract algebra build-type: Simple extra-source-files: .ghci .gitignore .vim.custom .travis.yml README.markdown CHANGELOG.markdown source-repository head type: git location: git://github.com/ekmett/algebra.git library hs-source-dirs: src other-extensions: TypeOperators MultiParamTypeClasses FlexibleInstances FlexibleContexts MultiParamTypeClasses BangPatterns ScopedTypeVariables UndecidableInstances PatternGuards DeriveDataTypeable RebindableSyntax GeneralizedNewtypeDeriving build-depends: array >= 0.3.0.2 && < 0.5, base == 4.*, distributive >= 0.2.2, transformers >= 0.2 && < 0.4, tagged >= 0.4.2, categories >= 1.0, containers >= 0.3 && < 0.6, keys >= 3, mtl >= 2.0.1 && < 2.2, nats >= 0.1, semigroups >= 0.9, semigroupoids >= 3, representable-functors >= 3, representable-tries >= 3, void >= 0.5.5.1 exposed-modules: Numeric.Additive.Class Numeric.Additive.Group Numeric.Algebra Numeric.Algebra.Class Numeric.Algebra.Commutative Numeric.Algebra.Complex Numeric.Algebra.Complex.Class Numeric.Algebra.Distinguished.Class Numeric.Algebra.Division Numeric.Algebra.Dual Numeric.Algebra.Dual.Class Numeric.Algebra.Factorable Numeric.Algebra.Hopf Numeric.Algebra.Hyperbolic Numeric.Algebra.Idempotent Numeric.Algebra.Incidence Numeric.Algebra.Involutive Numeric.Algebra.Quaternion Numeric.Algebra.Quaternion.Class Numeric.Algebra.Unital Numeric.Band.Class Numeric.Band.Rectangular Numeric.Coalgebra.Categorical Numeric.Coalgebra.Dual Numeric.Coalgebra.Geometric Numeric.Coalgebra.Hyperbolic Numeric.Coalgebra.Hyperbolic.Class Numeric.Coalgebra.Quaternion Numeric.Coalgebra.Incidence Numeric.Coalgebra.Trigonometric Numeric.Coalgebra.Trigonometric.Class Numeric.Covector Numeric.Decidable.Associates Numeric.Decidable.Units Numeric.Decidable.Zero Numeric.Dioid.Class Numeric.Exp Numeric.Field.Class Numeric.Log Numeric.Map Numeric.Module.Class Numeric.Module.Representable Numeric.Order.Additive Numeric.Order.Class Numeric.Order.LocallyFinite Numeric.Partial.Group Numeric.Partial.Monoid Numeric.Partial.Semigroup Numeric.Quadrance.Class Numeric.Rig.Characteristic Numeric.Rig.Class Numeric.Rig.Ordered Numeric.Ring.Class Numeric.Ring.Division Numeric.Ring.Endomorphism Numeric.Ring.Local Numeric.Ring.Opposite Numeric.Ring.Rng Numeric.Rng.Class Numeric.Rng.Zero Numeric.Semiring.Integral Numeric.Semiring.Involutive ghc-options: -Wall algebra-3.1/CHANGELOG.markdown0000644000000000000000000000004012072477456014203 0ustar00000000000000003.0.2 ----- * Started CHANGELOG algebra-3.1/LICENSE0000644000000000000000000000265312072477456012171 0ustar0000000000000000Copyright 2011 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. algebra-3.1/README.markdown0000644000000000000000000000063412072477456013662 0ustar0000000000000000algebra ========== [![Build Status](https://secure.travis-ci.org/ekmett/algebra.png?branch=master)](http://travis-ci.org/ekmett/algebra) This is a package for exploring constructive abstract algebra in Haskell. Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett algebra-3.1/Setup.lhs0000644000000000000000000000016512072477456012770 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain algebra-3.1/src/0000755000000000000000000000000012072477456011745 5ustar0000000000000000algebra-3.1/src/Numeric/0000755000000000000000000000000012072477456013347 5ustar0000000000000000algebra-3.1/src/Numeric/Algebra.hs0000644000000000000000000000716212072477456015246 0ustar0000000000000000module Numeric.Algebra ( -- * Additive -- ** additive semigroups Additive(..) , sum1 -- ** additive Abelian semigroups , Abelian -- ** additive idempotent semigroups , Idempotent , sinnum1pIdempotent , sinnumIdempotent -- ** partitionable additive semigroups , Partitionable(..) -- ** additive monoids , Monoidal(..) , sum -- ** additive groups , Group(..) -- * Multiplicative -- ** multiplicative semigroups , Multiplicative(..) , product1 -- ** commutative multiplicative semigroups , Commutative -- ** multiplicative monoids , Unital(..) , product -- ** idempotent multiplicative semigroups , Band , pow1pBand , powBand -- ** multiplicative groups , Division(..) -- ** factorable multiplicative semigroups , Factorable(..) -- ** involutive multiplicative semigroups , InvolutiveMultiplication(..) , TriviallyInvolutive -- * Ring-Structures -- ** Semirings , Semiring , InvolutiveSemiring , Dioid -- ** Rngs , Rng -- ** Rigs , Rig(..) -- * Rings , Ring(..) -- ** Division Rings , LocalRing , DivisionRing , Field -- * Modules , LeftModule(..) , RightModule(..) , Module -- * Algebras -- ** associative algebras over (non-commutative) semirings , Algebra(..) , Coalgebra(..) -- ** unital algebras , UnitalAlgebra(..) , CounitalCoalgebra(..) , Bialgebra -- ** involutive algebras , InvolutiveAlgebra(..) , InvolutiveCoalgebra(..) , InvolutiveBialgebra , TriviallyInvolutiveAlgebra , TriviallyInvolutiveCoalgebra , TriviallyInvolutiveBialgebra -- ** idempotent algebras , IdempotentAlgebra , IdempotentBialgebra -- ** commutative algebras , CommutativeAlgebra , CommutativeBialgebra , CocommutativeCoalgebra -- ** division algebras , DivisionAlgebra(..) -- ** Hopf alegebras , HopfAlgebra(..) -- * Ring Properties -- ** Characteristic , Characteristic(..) , charInt, charWord -- ** Order , Order(..) , OrderedRig , AdditiveOrder , LocallyFiniteOrder , DecidableZero , DecidableUnits , DecidableAssociates -- * Natural numbers , Natural , Whole(toNatural) -- * Representable Additive , addRep, sinnum1pRep -- * Representable Monoidal , zeroRep, sinnumRep -- * Representable Group , negateRep, minusRep, subtractRep, timesRep -- * Representable Multiplicative (via Algebra) , mulRep -- * Representable Unital (via UnitalAlgebra) , oneRep -- * Representable Rig (via Algebra) , fromNaturalRep -- * Representable Ring (via Algebra) , fromIntegerRep -- * Norm , Quadrance(..) -- * Covectors , Covector(..) -- ** Covectors as linear functionals , counitM , unitM , comultM , multM , invM , coinvM , antipodeM , convolveM , memoM ) where import Prelude () import Numeric.Additive.Class import Numeric.Additive.Group import Numeric.Algebra.Class import Numeric.Algebra.Involutive import Numeric.Algebra.Idempotent import Numeric.Algebra.Commutative import Numeric.Algebra.Division import Numeric.Algebra.Factorable import Numeric.Algebra.Unital import Numeric.Algebra.Hopf import Numeric.Covector import Numeric.Decidable.Units import Numeric.Decidable.Associates import Numeric.Decidable.Zero import Numeric.Dioid.Class import Numeric.Module.Representable import Numeric.Natural.Internal import Numeric.Order.Class import Numeric.Order.Additive import Numeric.Order.LocallyFinite import Numeric.Quadrance.Class import Numeric.Rig.Class import Numeric.Rig.Characteristic import Numeric.Rig.Ordered import Numeric.Rng.Class import Numeric.Ring.Class import Numeric.Ring.Local import Numeric.Ring.Division import Numeric.Field.Class algebra-3.1/src/Numeric/Covector.hs0000644000000000000000000001106512072477456015472 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} module Numeric.Covector ( Covector(..) , ($*) -- * Covectors as linear functionals , counitM , unitM , comultM , multM , invM , coinvM , antipodeM , convolveM , memoM ) where import Numeric.Additive.Class import Numeric.Additive.Group import Numeric.Algebra.Class import Numeric.Algebra.Unital import Numeric.Algebra.Idempotent import Numeric.Algebra.Involutive import Numeric.Algebra.Commutative import Numeric.Algebra.Hopf import Numeric.Rig.Class import Numeric.Ring.Class import Control.Applicative import Control.Monad import Data.Key import Data.Functor.Representable.Trie import Data.Functor.Plus hiding (zero) import qualified Data.Functor.Plus as Plus import Data.Functor.Bind import qualified Prelude import Prelude hiding ((+),(-),negate,subtract,replicate,(*)) -- | Linear functionals from elements of an (infinite) free module to a scalar -- f $* (x + y) = (f $* x) + (f $* y) -- f $* (a .* x) = a * (f $* x) newtype Covector r a = Covector ((a -> r) -> r) infixr 0 $* ($*) :: Indexable m => Covector r (Key m) -> m r -> r Covector f $* m = f (index m) instance Functor (Covector r) where fmap f m = Covector $ \k -> m $* k . f instance Apply (Covector r) where mf <.> ma = Covector $ \k -> mf $* \f -> ma $* k . f instance Applicative (Covector r) where pure a = Covector $ \k -> k a mf <*> ma = Covector $ \k -> mf $* \f -> ma $* k . f instance Bind (Covector r) where m >>- f = Covector $ \k -> m $* \a -> f a $* k instance Monad (Covector r) where return a = Covector $ \k -> k a m >>= f = Covector $ \k -> m $* \a -> f a $* k instance Additive r => Alt (Covector r) where Covector m Covector n = Covector $ m + n instance Monoidal r => Plus (Covector r) where zero = Covector zero instance Monoidal r => Alternative (Covector r) where Covector m <|> Covector n = Covector $ m + n empty = Covector zero instance Monoidal r => MonadPlus (Covector r) where Covector m `mplus` Covector n = Covector $ m + n mzero = Covector zero instance Additive r => Additive (Covector r a) where Covector m + Covector n = Covector $ m + n sinnum1p n (Covector m) = Covector $ sinnum1p n m instance Coalgebra r m => Multiplicative (Covector r m) where Covector f * Covector g = Covector $ \k -> f (\m -> g (comult k m)) instance (Commutative m, Coalgebra r m) => Commutative (Covector r m) instance Coalgebra r m => Semiring (Covector r m) instance CounitalCoalgebra r m => Unital (Covector r m) where one = Covector counit instance (Rig r, CounitalCoalgebra r m) => Rig (Covector r m) instance (Ring r, CounitalCoalgebra r m) => Ring (Covector r m) instance Idempotent r => Idempotent (Covector r a) instance (Idempotent r, IdempotentCoalgebra r a) => Band (Covector r a) multM :: Coalgebra r c => c -> c -> Covector r c multM a b = Covector $ \k -> comult k a b unitM :: CounitalCoalgebra r c => Covector r c unitM = Covector counit comultM :: Algebra r a => a -> Covector r (a,a) comultM c = Covector $ \k -> mult (curry k) c counitM :: UnitalAlgebra r a => a -> Covector r () counitM a = Covector $ \k -> unit (k ()) a convolveM :: (Algebra r c, Coalgebra r a) => (c -> Covector r a) -> (c -> Covector r a) -> c -> Covector r a convolveM f g c = do (c1,c2) <- comultM c a1 <- f c1 a2 <- g c2 multM a1 a2 invM :: InvolutiveAlgebra r h => h -> Covector r h invM = Covector . flip inv coinvM :: InvolutiveCoalgebra r h => h -> Covector r h coinvM = Covector . flip coinv -- | convolveM antipodeM return = convolveM return antipodeM = comultM >=> uncurry joinM antipodeM :: HopfAlgebra r h => h -> Covector r h antipodeM = Covector . flip antipode memoM :: HasTrie a => a -> Covector s a memoM = Covector . flip memo -- TODO: we can also build up the augmentation ideal instance Monoidal s => Monoidal (Covector s a) where zero = Covector zero sinnum n (Covector m) = Covector (sinnum n m) instance Abelian s => Abelian (Covector s a) instance Group s => Group (Covector s a) where Covector m - Covector n = Covector $ m - n negate (Covector m) = Covector $ negate m subtract (Covector m) (Covector n) = Covector $ subtract m n times n (Covector m) = Covector $ times n m instance Coalgebra r m => LeftModule (Covector r m) (Covector r m) where (.*) = (*) instance LeftModule r s => LeftModule r (Covector s m) where s .* m = Covector $ \k -> s .* (m $* k) instance Coalgebra r m => RightModule (Covector r m) (Covector r m) where (*.) = (*) instance RightModule r s => RightModule r (Covector s m) where m *. s = Covector $ \k -> (m $* k) *. s algebra-3.1/src/Numeric/Exp.hs0000644000000000000000000000153712072477456014445 0ustar0000000000000000module Numeric.Exp ( Exp(..) ) where import Data.Function (on) import Numeric.Algebra import Prelude hiding ((+),(-),negate,replicate,subtract) newtype Exp r = Exp { runExp :: r } instance Additive r => Multiplicative (Exp r) where Exp a * Exp b = Exp (a + b) productWith1 f = Exp . sumWith1 (runExp . f) pow1p (Exp m) n = Exp (sinnum1p n m) instance Monoidal r => Unital (Exp r) where one = Exp zero pow (Exp m) n = Exp (sinnum n m) productWith f = Exp . sumWith (runExp . f) instance Group r => Division (Exp r) where Exp a / Exp b = Exp (a - b) recip (Exp a) = Exp (negate a) Exp a \\ Exp b = Exp (subtract a b) Exp m ^ n = Exp (times n m) instance Abelian r => Commutative (Exp r) instance Idempotent r => Band (Exp r) instance Partitionable r => Factorable (Exp r) where factorWith f = partitionWith (f `on` Exp) . runExp algebra-3.1/src/Numeric/Log.hs0000644000000000000000000000233712072477456014431 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} module Numeric.Log ( Log(..) ) where import Data.Function (on) import Numeric.Algebra import Prelude hiding ((*),(^),(/),recip,negate,subtract) newtype Log r = Log { runLog :: r } instance Multiplicative r => Additive (Log r) where Log a + Log b = Log (a * b) sumWith1 f = Log . productWith1 (runLog . f) sinnum1p n (Log m) = Log (pow1p m n) instance Unital r => LeftModule Natural (Log r) where n .* Log m = Log (pow m n) instance Unital r => RightModule Natural (Log r) where Log m *. n = Log (pow m n) instance Unital r => Monoidal (Log r) where zero = Log one sinnum n (Log m) = Log (pow m n) sumWith f = Log . productWith (runLog . f) instance Division r => LeftModule Integer (Log r) where n .* Log m = Log (m ^ n) instance Division r => RightModule Integer (Log r) where Log m *. n = Log (m ^ n) instance Division r => Group (Log r) where Log a - Log b = Log (a / b) negate (Log a) = Log (recip a) subtract (Log a) (Log b) = Log (a \\ b) times n (Log m) = Log (m ^ n) instance Commutative r => Abelian (Log r) instance Band r => Idempotent (Log r) instance Factorable r => Partitionable (Log r) where partitionWith f = factorWith (f `on` Log) . runLog algebra-3.1/src/Numeric/Map.hs0000644000000000000000000002141712072477456014425 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-} module Numeric.Map ( Map(..) , ($@) , multMap , unitMap , memoMap , comultMap , counitMap , invMap , coinvMap , antipodeMap , convolveMap ) where import Control.Applicative import Control.Arrow import Control.Categorical.Bifunctor import Control.Category import Control.Category.Associative import Control.Category.Braided import Control.Category.Cartesian import Control.Category.Cartesian.Closed import Control.Category.Distributive import qualified Control.Category.Monoidal as C import Control.Category.Monoidal (Id) import Control.Monad import Control.Monad.Reader.Class import Data.Key import Data.Functor.Representable import Data.Functor.Representable.Trie import Data.Functor.Bind import Data.Functor.Plus hiding (zero) import qualified Data.Functor.Plus as Plus import Data.Semigroupoid import Data.Void import Numeric.Algebra import Prelude hiding ((*), (+), negate, subtract,(-), recip, (/), foldr, sum, product, replicate, concat, (.), id, curry, uncurry, fst, snd) -- | linear maps from elements of a free module to another free module over r -- -- > f $# x + y = (f $# x) + (f $# y) -- > f $# (r .* x) = r .* (f $# x) -- -- -- @Map r b a@ represents a linear mapping from a free module with basis @a@ over @r@ to a free module with basis @b@ over @r@. -- -- Note well the reversed direction of the arrow, due to the contravariance of change of basis! -- -- This way enables we can employ arbitrary pure functions as linear maps by lifting them using `arr`, or build them -- by using the monad instance for Map r b. As a consequence Map is an instance of, well, almost everything. infixr 0 $# newtype Map r b a = Map ((a -> r) -> b -> r) ($#) :: (Indexable v, Representable w) => Map r (Key w) (Key v) -> v r -> w r ($#) (Map m) = tabulate . m . index infixr 0 $@ -- | extract a linear functional from a linear map ($@) :: Map r b a -> b -> Covector r a m $@ b = Covector $ \k -> (m $# k) b -- NB: due to contravariance (>>>) to get the usual notion of composition! instance Category (Map r) where id = Map id Map f . Map g = Map (g . f) instance Semigroupoid (Map r) where Map f `o` Map g = Map (g . f) instance Functor (Map r b) where fmap f m = Map $ \k -> m $# k . f instance Apply (Map r b) where mf <.> ma = Map $ \k b -> (mf $# \f -> (ma $# k . f) b) b instance Applicative (Map r b) where pure a = Map $ \k _ -> k a mf <*> ma = Map $ \k b -> (mf $# \f -> (ma $# k . f) b) b instance Bind (Map r b) where Map m >>- f = Map $ \k b -> m (\a -> (f a $# k) b) b instance Monad (Map r b) where return a = Map $ \k _ -> k a m >>= f = Map $ \k b -> (m $# \a -> (f a $# k) b) b instance PFunctor (,) (Map r) (Map r) instance QFunctor (,) (Map r) (Map r) instance Bifunctor (,) (Map r) (Map r) (Map r) where bimap m n = Map $ \k (a,c) -> (m $# \b -> (n $# \d -> k (b,d)) c) a instance Associative (Map r) (,) where associate = arr associate disassociate = arr disassociate instance Braided (Map r) (,) where braid = arr braid instance Symmetric (Map r) (,) instance C.Monoidal (Map r) (,) where type Id (Map r) (,) = () idl = arr C.idl idr = arr C.idr coidl = arr C.coidl coidr = arr C.coidr instance Cartesian (Map r) where type Product (Map r) = (,) fst = arr fst snd = arr snd diag = arr diag f &&& g = Map $ \k a -> (f $# \b -> (g $# \c -> k (b,c)) a) a instance CCC (Map r) where type Exp (Map r) = Map r apply = Map $ \k (f,a) -> (f $# k) a curry m = Map $ \k a -> k (Map $ \k' b -> (m $# k') (a, b)) uncurry m = Map $ \k (a, b) -> (m $# (\m' -> (m' $# k) b)) a instance Distributive (Map r) where distribute = Map $ \k (a,p) -> k $ bimap ((,) a) ((,)a) p instance PFunctor Either (Map r) (Map r) instance QFunctor Either (Map r) (Map r) instance Bifunctor Either (Map r) (Map r) (Map r) where bimap m n = Map $ \k -> either (m $# k . Left) (n $# k . Right) instance Associative (Map r) Either where associate = arr associate disassociate = arr disassociate instance Braided (Map r) Either where braid = arr braid instance Symmetric (Map r) Either instance CoCartesian (Map r) where type Sum (Map r) = Either inl = arr inl inr = arr inr codiag = arr codiag m ||| n = Map $ \k -> either (m $# k) (n $# k) instance C.Monoidal (Map r) Either where type Id (Map r) Either = Void idl = arr C.idl idr = arr C.idr coidl = arr C.coidl coidr = arr C.coidr instance Arrow (Map r) where arr f = Map (. f) first m = Map $ \k (a,c) -> (m $# \b -> k (b,c)) a second m = Map $ \k (c,a) -> (m $# \b -> k (c,b)) a m *** n = Map $ \k (a,c) -> (m $# \b -> (n $# \d -> k (b,d)) c) a m &&& n = Map $ \k a -> (m $# \b -> (n $# \c -> k (b,c)) a) a instance ArrowApply (Map r) where app = Map $ \k (f,a) -> (f $# k) a instance MonadReader b (Map r b) where ask = id local f m = Map $ \k -> (m $# k) . f -- While the following typechecks, it isn't correct, -- callCC is non-linear, the internal Map ignores the functional it is given! -- --instance MonadCont (Map r b) where -- callCC f = Map $ \k -> (f $# \a -> Map $ \_ _ -> k a) k -- label :: ((a -> r) -> Map r b a) -> Map r b a -- label f = Map $ \k -> f k $# k -- break :: (a -> r) -> a -> Map r b a instance Monoidal r => ArrowZero (Map r) where zeroArrow = Map zero instance Monoidal r => ArrowPlus (Map r) where Map m <+> Map n = Map $ m + n instance ArrowChoice (Map r) where left m = Map $ \k -> either (m $# k . Left) (k . Right) right m = Map $ \k -> either (k . Left) (m $# k . Right) m +++ n = Map $ \k -> either (m $# k . Left) (n $# k . Right) m ||| n = Map $ \k -> either (m $# k) (n $# k) -- TODO: ArrowLoop? -- TODO: more categories instances for (Map r) & Either to get to precocartesian! instance Additive r => Additive (Map r b a) where Map m + Map n = Map $ m + n sinnum1p n (Map m) = Map $ sinnum1p n m instance Coalgebra r m => Multiplicative (Map r b m) where f * g = Map $ \k b -> (f $# \a -> (g $# comult k a) b) b instance CounitalCoalgebra r m => Unital (Map r b m) where one = Map $ \k _ -> counit k instance Coalgebra r m => Semiring (Map r b m) instance Coalgebra r m => LeftModule (Map r b m) (Map r b m) where (.*) = (*) instance LeftModule r s => LeftModule r (Map s b m) where s .* Map m = Map $ \k b -> s .* m k b instance Coalgebra r m => RightModule (Map r b m) (Map r b m) where (*.) = (*) instance RightModule r s => RightModule r (Map s b m) where Map m *. s = Map $ \k b -> m k b *. s instance Additive r => Alt (Map r b) where Map m Map n = Map $ m + n instance Monoidal r => Plus (Map r b) where zero = Map zero instance Monoidal r => Alternative (Map r b) where Map m <|> Map n = Map $ m + n empty = Map zero instance Monoidal r => MonadPlus (Map r b) where Map m `mplus` Map n = Map $ m + n mzero = Map zero instance Monoidal s => Monoidal (Map s b a) where zero = Map zero sinnum n (Map m) = Map $ sinnum n m instance Abelian s => Abelian (Map s b a) instance Group s => Group (Map s b a) where Map m - Map n = Map $ m - n negate (Map m) = Map $ negate m subtract (Map m) (Map n) = Map $ subtract m n times n (Map m) = Map $ times n m instance (Commutative m, Coalgebra r m) => Commutative (Map r b m) instance (Rig r, CounitalCoalgebra r m) => Rig (Map r b m) instance (Ring r, CounitalCoalgebra r m) => Ring (Map r a m) -- | (inefficiently) combine a linear combination of basis vectors to make a map. -- arrMap :: (Monoidal r, Semiring r) => (b -> [(r, a)]) -> Map r b a -- arrMap f = Map $ \k b -> sum [ r * k a | (r, a) <- f b ] -- | Memoize the results of this linear map memoMap :: HasTrie a => Map r a a memoMap = Map memo comultMap :: Algebra r a => Map r a (a,a) comultMap = Map $ mult . curry multMap :: Coalgebra r c => Map r (c,c) c multMap = Map $ uncurry . comult counitMap :: UnitalAlgebra r a => Map r a () counitMap = Map $ \k -> unit $ k () unitMap :: CounitalCoalgebra r c => Map r () c unitMap = Map $ \k () -> counit k -- | convolution given an associative algebra and coassociative coalgebra convolveMap :: (Algebra r a, Coalgebra r c) => Map r a c -> Map r a c -> Map r a c convolveMap f g = multMap . (f *** g) . comultMap -- convolveMap antipodeMap id = convolveMap id antipodeMap = unit . counit antipodeMap :: HopfAlgebra r h => Map r h h antipodeMap = Map antipode coinvMap :: InvolutiveAlgebra r a => Map r a a coinvMap = Map inv invMap :: InvolutiveCoalgebra r c => Map r c c invMap = Map coinv {- -- ring homomorphism from r -> r^a embedMap :: (Unital m, CounitalCoalgebra r m) => (b -> r) -> Map r b m embedMap f = Map $ \k b -> f b * k one -- if the characteristic of s does not divide the order of a, then s[a] is semisimple -- and if a has a length function, we can build a filtered algebra -- | The augmentation ring homomorphism from r^a -> r augmentMap :: Unital s => Map s b m -> b -> s augmentMap m = m $# const one -} algebra-3.1/src/Numeric/Additive/0000755000000000000000000000000012072477456015100 5ustar0000000000000000algebra-3.1/src/Numeric/Additive/Class.hs0000644000000000000000000001701312072477456016503 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} module Numeric.Additive.Class ( -- * Additive Semigroups Additive(..) , sum1 -- * Additive Abelian semigroups , Abelian -- * Additive Monoids , Idempotent , sinnum1pIdempotent -- * Partitionable semigroups , Partitionable(..) ) where import Data.Int import Data.Word import Data.Foldable hiding (concat) import Data.Semigroup.Foldable import Data.Key import Data.Functor.Representable import Data.Functor.Representable.Trie -- import Data.Foldable hiding (concat) import Numeric.Natural.Internal import Prelude (fmap,(-),Bool(..),($),id,(>>=),fromIntegral,(*),otherwise,quot,maybe,error,even,Maybe(..),(==),(.),($!),Integer,(||),toInteger,Integral) import qualified Prelude import Data.List.NonEmpty (NonEmpty(..), fromList) infixl 6 + -- | -- > (a + b) + c = a + (b + c) -- > sinnum 1 a = a -- > sinnum (2 * n) a = sinnum n a + sinnum n a -- > sinnum (2 * n + 1) a = sinnum n a + sinnum n a + a class Additive r where (+) :: r -> r -> r -- | sinnum1p n r = sinnum (1 + n) r sinnum1p :: Whole n => n -> r -> r sinnum1p y0 x0 = f x0 (1 Prelude.+ y0) where f x y | even y = f (x + x) (y `quot` 2) | y == 1 = x | otherwise = g (x + x) (unsafePred y `quot` 2) x g x y z | even y = g (x + x) (y `quot` 2) z | y == 1 = x + z | otherwise = g (x + x) (unsafePred y `quot` 2) (x + z) sumWith1 :: Foldable1 f => (a -> r) -> f a -> r sumWith1 f = maybe (error "Numeric.Additive.Semigroup.sumWith1: empty structure") id . foldl' mf Nothing where mf Nothing y = Just $! f y mf (Just x) y = Just $! x + f y sum1 :: (Foldable1 f, Additive r) => f r -> r sum1 = sumWith1 id instance Additive r => Additive (b -> r) where f + g = \e -> f e + g e sinnum1p n f e = sinnum1p n (f e) sumWith1 f xs e = sumWith1 (`f` e) xs instance (HasTrie b, Additive r) => Additive (b :->: r) where (+) = zipWith (+) sinnum1p = fmap . sinnum1p sumWith1 f xs = tabulate $ \e -> sumWith1 (\a -> index (f a) e) xs instance Additive Bool where (+) = (||) sinnum1p _ a = a instance Additive Natural where (+) = (Prelude.+) sinnum1p n r = (1 Prelude.+ toNatural n) * r instance Additive Integer where (+) = (Prelude.+) sinnum1p n r = (1 Prelude.+ toInteger n) * r instance Additive Int where (+) = (Prelude.+) sinnum1p n r = fromIntegral (1 Prelude.+ n) * r instance Additive Int8 where (+) = (Prelude.+) sinnum1p n r = fromIntegral (1 Prelude.+ n) * r instance Additive Int16 where (+) = (Prelude.+) sinnum1p n r = fromIntegral (1 Prelude.+ n) * r instance Additive Int32 where (+) = (Prelude.+) sinnum1p n r = fromIntegral (1 Prelude.+ n) * r instance Additive Int64 where (+) = (Prelude.+) sinnum1p n r = fromIntegral (1 Prelude.+ n) * r instance Additive Word where (+) = (Prelude.+) sinnum1p n r = fromIntegral (1 Prelude.+ n) * r instance Additive Word8 where (+) = (Prelude.+) sinnum1p n r = fromIntegral (1 Prelude.+ n) * r instance Additive Word16 where (+) = (Prelude.+) sinnum1p n r = fromIntegral (1 Prelude.+ n) * r instance Additive Word32 where (+) = (Prelude.+) sinnum1p n r = fromIntegral (1 Prelude.+ n) * r instance Additive Word64 where (+) = (Prelude.+) sinnum1p n r = fromIntegral (1 Prelude.+ n) * r instance Additive () where _ + _ = () sinnum1p _ _ = () sumWith1 _ _ = () instance (Additive a, Additive b) => Additive (a,b) where (a,b) + (i,j) = (a + i, b + j) sinnum1p n (a,b) = (sinnum1p n a, sinnum1p n b) instance (Additive a, Additive b, Additive c) => Additive (a,b,c) where (a,b,c) + (i,j,k) = (a + i, b + j, c + k) sinnum1p n (a,b,c) = (sinnum1p n a, sinnum1p n b, sinnum1p n c) instance (Additive a, Additive b, Additive c, Additive d) => Additive (a,b,c,d) where (a,b,c,d) + (i,j,k,l) = (a + i, b + j, c + k, d + l) sinnum1p n (a,b,c,d) = (sinnum1p n a, sinnum1p n b, sinnum1p n c, sinnum1p n d) instance (Additive a, Additive b, Additive c, Additive d, Additive e) => Additive (a,b,c,d,e) where (a,b,c,d,e) + (i,j,k,l,m) = (a + i, b + j, c + k, d + l, e + m) sinnum1p n (a,b,c,d,e) = (sinnum1p n a, sinnum1p n b, sinnum1p n c, sinnum1p n d, sinnum1p n e) concat :: NonEmpty (NonEmpty a) -> NonEmpty a concat m = m >>= id class Additive m => Partitionable m where -- | partitionWith f c returns a list containing f a b for each a b such that a + b = c, partitionWith :: (m -> m -> r) -> m -> NonEmpty r instance Partitionable Bool where partitionWith f False = f False False :| [] partitionWith f True = f False True :| [f True False, f True True] instance Partitionable Natural where partitionWith f n = fromList [ f k (n - k) | k <- [0..n] ] instance Partitionable () where partitionWith f () = f () () :| [] instance (Partitionable a, Partitionable b) => Partitionable (a,b) where partitionWith f (a,b) = concat $ partitionWith (\ax ay -> partitionWith (\bx by -> f (ax,bx) (ay,by)) b) a instance (Partitionable a, Partitionable b, Partitionable c) => Partitionable (a,b,c) where partitionWith f (a,b,c) = concat $ partitionWith (\ax ay -> concat $ partitionWith (\bx by -> partitionWith (\cx cy -> f (ax,bx,cx) (ay,by,cy)) c) b) a instance (Partitionable a, Partitionable b, Partitionable c,Partitionable d ) => Partitionable (a,b,c,d) where partitionWith f (a,b,c,d) = concat $ partitionWith (\ax ay -> concat $ partitionWith (\bx by -> concat $ partitionWith (\cx cy -> partitionWith (\dx dy -> f (ax,bx,cx,dx) (ay,by,cy,dy)) d) c) b) a instance (Partitionable a, Partitionable b, Partitionable c,Partitionable d, Partitionable e) => Partitionable (a,b,c,d,e) where partitionWith f (a,b,c,d,e) = concat $ partitionWith (\ax ay -> concat $ partitionWith (\bx by -> concat $ partitionWith (\cx cy -> concat $ partitionWith (\dx dy -> partitionWith (\ex ey -> f (ax,bx,cx,dx,ex) (ay,by,cy,dy,ey)) e) d) c) b) a -- | an additive abelian semigroup -- -- a + b = b + a class Additive r => Abelian r instance Abelian r => Abelian (e -> r) instance (HasTrie e, Abelian r) => Abelian (e :->: r) instance Abelian () instance Abelian Bool instance Abelian Integer instance Abelian Natural instance Abelian Int instance Abelian Int8 instance Abelian Int16 instance Abelian Int32 instance Abelian Int64 instance Abelian Word instance Abelian Word8 instance Abelian Word16 instance Abelian Word32 instance Abelian Word64 instance (Abelian a, Abelian b) => Abelian (a,b) instance (Abelian a, Abelian b, Abelian c) => Abelian (a,b,c) instance (Abelian a, Abelian b, Abelian c, Abelian d) => Abelian (a,b,c,d) instance (Abelian a, Abelian b, Abelian c, Abelian d, Abelian e) => Abelian (a,b,c,d,e) -- | An additive semigroup with idempotent addition. -- -- > a + a = a -- class Additive r => Idempotent r sinnum1pIdempotent :: Natural -> r -> r sinnum1pIdempotent _ r = r instance Idempotent () instance Idempotent Bool instance Idempotent r => Idempotent (e -> r) instance (HasTrie e, Idempotent r) => Idempotent (e :->: r) instance (Idempotent a, Idempotent b) => Idempotent (a,b) instance (Idempotent a, Idempotent b, Idempotent c) => Idempotent (a,b,c) instance (Idempotent a, Idempotent b, Idempotent c, Idempotent d) => Idempotent (a,b,c,d) instance (Idempotent a, Idempotent b, Idempotent c, Idempotent d, Idempotent e) => Idempotent (a,b,c,d,e) algebra-3.1/src/Numeric/Additive/Group.hs0000644000000000000000000001025512072477456016533 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeOperators #-} module Numeric.Additive.Group ( -- * Additive Groups Group(..) ) where import Data.Int import Data.Word import Data.Key import Data.Functor.Representable.Trie import Prelude hiding ((*), (+), (-), negate, subtract,zipWith) import qualified Prelude import Numeric.Additive.Class import Numeric.Algebra.Class infixl 6 - infixl 7 `times` class (LeftModule Integer r, RightModule Integer r, Monoidal r) => Group r where (-) :: r -> r -> r negate :: r -> r subtract :: r -> r -> r times :: Integral n => n -> r -> r times y0 x0 = case compare y0 0 of LT -> f (negate x0) (Prelude.negate y0) EQ -> zero GT -> f x0 y0 where f x y | even y = f (x + x) (y `quot` 2) | y == 1 = x | otherwise = g (x + x) ((y Prelude.- 1) `quot` 2) x g x y z | even y = g (x + x) (y `quot` 2) z | y == 1 = x + z | otherwise = g (x + x) ((y Prelude.- 1) `quot` 2) (x + z) negate a = zero - a a - b = a + negate b subtract a b = negate a + b instance Group r => Group (e -> r) where f - g = \x -> f x - g x negate f x = negate (f x) subtract f g x = subtract (f x) (g x) times n f e = times n (f e) instance (HasTrie e, Group r) => Group (e :->: r) where (-) = zipWith (-) negate = fmap negate subtract = zipWith subtract times = fmap . times instance Group Integer where (-) = (Prelude.-) negate = Prelude.negate subtract = Prelude.subtract times n r = fromIntegral n * r instance Group Int where (-) = (Prelude.-) negate = Prelude.negate subtract = Prelude.subtract times n r = fromIntegral n * r instance Group Int8 where (-) = (Prelude.-) negate = Prelude.negate subtract = Prelude.subtract times n r = fromIntegral n * r instance Group Int16 where (-) = (Prelude.-) negate = Prelude.negate subtract = Prelude.subtract times n r = fromIntegral n * r instance Group Int32 where (-) = (Prelude.-) negate = Prelude.negate subtract = Prelude.subtract times n r = fromIntegral n * r instance Group Int64 where (-) = (Prelude.-) negate = Prelude.negate subtract = Prelude.subtract times n r = fromIntegral n * r instance Group Word where (-) = (Prelude.-) negate = Prelude.negate subtract = Prelude.subtract times n r = fromIntegral n * r instance Group Word8 where (-) = (Prelude.-) negate = Prelude.negate subtract = Prelude.subtract times n r = fromIntegral n * r instance Group Word16 where (-) = (Prelude.-) negate = Prelude.negate subtract = Prelude.subtract times n r = fromIntegral n * r instance Group Word32 where (-) = (Prelude.-) negate = Prelude.negate subtract = Prelude.subtract times n r = fromIntegral n * r instance Group Word64 where (-) = (Prelude.-) negate = Prelude.negate subtract = Prelude.subtract times n r = fromIntegral n * r instance Group () where _ - _ = () negate _ = () subtract _ _ = () times _ _ = () instance (Group a, Group b) => Group (a,b) where negate (a,b) = (negate a, negate b) (a,b) - (i,j) = (a-i, b-j) subtract (a,b) (i,j) = (subtract a i, subtract b j) times n (a,b) = (times n a,times n b) instance (Group a, Group b, Group c) => Group (a,b,c) where negate (a,b,c) = (negate a, negate b, negate c) (a,b,c) - (i,j,k) = (a-i, b-j, c-k) subtract (a,b,c) (i,j,k) = (subtract a i, subtract b j, subtract c k) times n (a,b,c) = (times n a,times n b, times n c) instance (Group a, Group b, Group c, Group d) => Group (a,b,c,d) where negate (a,b,c,d) = (negate a, negate b, negate c, negate d) (a,b,c,d) - (i,j,k,l) = (a-i, b-j, c-k, d-l) subtract (a,b,c,d) (i,j,k,l) = (subtract a i, subtract b j, subtract c k, subtract d l) times n (a,b,c,d) = (times n a,times n b, times n c, times n d) instance (Group a, Group b, Group c, Group d, Group e) => Group (a,b,c,d,e) where negate (a,b,c,d,e) = (negate a, negate b, negate c, negate d, negate e) (a,b,c,d,e) - (i,j,k,l,m) = (a-i, b-j, c-k, d-l, e-m) subtract (a,b,c,d,e) (i,j,k,l,m) = (subtract a i, subtract b j, subtract c k, subtract d l, subtract e m) times n (a,b,c,d,e) = (times n a,times n b, times n c, times n d, times n e) algebra-3.1/src/Numeric/Algebra/0000755000000000000000000000000012072477456014704 5ustar0000000000000000algebra-3.1/src/Numeric/Algebra/Class.hs0000644000000000000000000004466412072477456016323 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeOperators #-} module Numeric.Algebra.Class ( -- * Multiplicative Semigroups Multiplicative(..) , pow1pIntegral , product1 -- * Semirings , Semiring -- * Left and Right Modules , LeftModule(..) , RightModule(..) , Module -- * Additive Monoids , Monoidal(..) , sum , sinnumIdempotent -- * Associative algebras , Algebra(..) -- * Coassociative coalgebras , Coalgebra(..) ) where import Control.Applicative import Data.Foldable hiding (sum, concat) import Data.Functor.Representable import Data.Functor.Representable.Trie import Data.Int import Data.IntMap (IntMap) import Data.IntSet (IntSet) import Data.Key import Data.Map (Map) import Data.Monoid (mappend) -- import Data.Semigroup.Foldable import Data.Sequence hiding (reverse,index) import Data.Semigroup.Foldable import Data.Set (Set) import Data.Word import Numeric.Additive.Class import Numeric.Natural.Internal import Prelude hiding ((*), (+), negate, subtract,(-), recip, (/), foldr, sum, product, replicate, concat) import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Prelude infixr 8 `pow1p` infixl 7 *, .*, *. -- | A multiplicative semigroup class Multiplicative r where (*) :: r -> r -> r -- class Multiplicative r => PowerAssociative r where -- pow1p x n = pow x (1 + n) pow1p :: Whole n => r -> n -> r pow1p x0 y0 = f x0 (y0 Prelude.+ 1) where f x y | even y = f (x * x) (y `quot` 2) | y == 1 = x | otherwise = g (x * x) ((y Prelude.- 1) `quot` 2) x g x y z | even y = g (x * x) (y `quot` 2) z | y == 1 = x * z | otherwise = g (x * x) ((y Prelude.- 1) `quot` 2) (x * z) -- class PowerAssociative r => Assocative r where productWith1 :: Foldable1 f => (a -> r) -> f a -> r productWith1 f = maybe (error "Numeric.Multiplicative.Semigroup.productWith1: empty structure") id . foldl' mf Nothing where mf Nothing y = Just $! f y mf (Just x) y = Just $! x * f y product1 :: (Foldable1 f, Multiplicative r) => f r -> r product1 = productWith1 id pow1pIntegral :: (Integral r, Integral n) => r -> n -> r pow1pIntegral r n = r ^ (1 Prelude.+ n) instance Multiplicative Bool where (*) = (&&) pow1p m _ = m instance Multiplicative Natural where (*) = (Prelude.*) pow1p = pow1pIntegral instance Multiplicative Integer where (*) = (Prelude.*) pow1p = pow1pIntegral instance Multiplicative Int where (*) = (Prelude.*) pow1p = pow1pIntegral instance Multiplicative Int8 where (*) = (Prelude.*) pow1p = pow1pIntegral instance Multiplicative Int16 where (*) = (Prelude.*) pow1p = pow1pIntegral instance Multiplicative Int32 where (*) = (Prelude.*) pow1p = pow1pIntegral instance Multiplicative Int64 where (*) = (Prelude.*) pow1p = pow1pIntegral instance Multiplicative Word where (*) = (Prelude.*) pow1p = pow1pIntegral instance Multiplicative Word8 where (*) = (Prelude.*) pow1p = pow1pIntegral instance Multiplicative Word16 where (*) = (Prelude.*) pow1p = pow1pIntegral instance Multiplicative Word32 where (*) = (Prelude.*) pow1p = pow1pIntegral instance Multiplicative Word64 where (*) = (Prelude.*) pow1p = pow1pIntegral instance Multiplicative () where _ * _ = () pow1p _ _ = () instance (Multiplicative a, Multiplicative b) => Multiplicative (a,b) where (a,b) * (c,d) = (a * c, b * d) instance (Multiplicative a, Multiplicative b, Multiplicative c) => Multiplicative (a,b,c) where (a,b,c) * (i,j,k) = (a * i, b * j, c * k) instance (Multiplicative a, Multiplicative b, Multiplicative c, Multiplicative d) => Multiplicative (a,b,c,d) where (a,b,c,d) * (i,j,k,l) = (a * i, b * j, c * k, d * l) instance (Multiplicative a, Multiplicative b, Multiplicative c, Multiplicative d, Multiplicative e) => Multiplicative (a,b,c,d,e) where (a,b,c,d,e) * (i,j,k,l,m) = (a * i, b * j, c * k, d * l, e * m) instance Algebra r a => Multiplicative (a -> r) where f * g = mult $ \a b -> f a * g b instance (HasTrie a, Algebra r a) => Multiplicative (a :->: r) where f * g = tabulate $ mult $ \a b -> index f a * index g b -- | A pair of an additive abelian semigroup, and a multiplicative semigroup, with the distributive laws: -- -- > a(b + c) = ab + ac -- left distribution (we are a LeftNearSemiring) -- > (a + b)c = ac + bc -- right distribution (we are a [Right]NearSemiring) -- -- Common notation includes the laws for additive and multiplicative identity in semiring. -- -- If you want that, look at 'Rig' instead. -- -- Ideally we'd use the cyclic definition: -- -- > class (LeftModule r r, RightModule r r, Additive r, Abelian r, Multiplicative r) => Semiring r -- -- to enforce that every semiring r is an r-module over itself, but Haskell doesn't like that. class (Additive r, Abelian r, Multiplicative r) => Semiring r instance Semiring Integer instance Semiring Natural instance Semiring Bool instance Semiring Int instance Semiring Int8 instance Semiring Int16 instance Semiring Int32 instance Semiring Int64 instance Semiring Word instance Semiring Word8 instance Semiring Word16 instance Semiring Word32 instance Semiring Word64 instance Semiring () instance (Semiring a, Semiring b) => Semiring (a, b) instance (Semiring a, Semiring b, Semiring c) => Semiring (a, b, c) instance (Semiring a, Semiring b, Semiring c, Semiring d) => Semiring (a, b, c, d) instance (Semiring a, Semiring b, Semiring c, Semiring d, Semiring e) => Semiring (a, b, c, d, e) instance Algebra r a => Semiring (a -> r) instance (HasTrie a, Algebra r a) => Semiring (a :->: r) -- | An associative algebra built with a free module over a semiring class Semiring r => Algebra r a where mult :: (a -> a -> r) -> a -> r instance Algebra () a where mult _ _ = () -- | The tensor algebra instance Semiring r => Algebra r [a] where mult f = go [] where go ls rrs@(r:rs) = f (reverse ls) rrs + go (r:ls) rs go ls [] = f (reverse ls) [] -- | The tensor algebra instance Semiring r => Algebra r (Seq a) where mult f = go Seq.empty where go ls s = case viewl s of EmptyL -> f ls s r :< rs -> f ls s + go (ls |> r) rs instance Semiring r => Algebra r () where mult f = f () instance (Semiring r, Ord a) => Algebra r (Set a) where mult f = go Set.empty where go ls s = case Set.minView s of Nothing -> f ls s Just (r, rs) -> f ls s + go (Set.insert r ls) rs instance Semiring r => Algebra r IntSet where mult f = go IntSet.empty where go ls s = case IntSet.minView s of Nothing -> f ls s Just (r, rs) -> f ls s + go (IntSet.insert r ls) rs instance (Semiring r, Monoidal r, Ord a, Partitionable b) => Algebra r (Map a b) -- where -- mult f xs = case minViewWithKey xs of -- Nothing -> zero -- Just ((k, r), rs) -> ... instance (Semiring r, Monoidal r, Partitionable a) => Algebra r (IntMap a) instance (Algebra r a, Algebra r b) => Algebra r (a,b) where mult f (a,b) = mult (\a1 a2 -> mult (\b1 b2 -> f (a1,b1) (a2,b2)) b) a instance (Algebra r a, Algebra r b, Algebra r c) => Algebra r (a,b,c) where mult f (a,b,c) = mult (\a1 a2 -> mult (\b1 b2 -> mult (\c1 c2 -> f (a1,b1,c1) (a2,b2,c2)) c) b) a instance (Algebra r a, Algebra r b, Algebra r c, Algebra r d) => Algebra r (a,b,c,d) where mult f (a,b,c,d) = mult (\a1 a2 -> mult (\b1 b2 -> mult (\c1 c2 -> mult (\d1 d2 -> f (a1,b1,c1,d1) (a2,b2,c2,d2)) d) c) b) a instance (Algebra r a, Algebra r b, Algebra r c, Algebra r d, Algebra r e) => Algebra r (a,b,c,d,e) where mult f (a,b,c,d,e) = mult (\a1 a2 -> mult (\b1 b2 -> mult (\c1 c2 -> mult (\d1 d2 -> mult (\e1 e2 -> f (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2)) e) d) c) b) a -- incoherent -- instance (Algebra r b, Algebra r a) => Algebra (b -> r) a where mult f a b = mult (\a1 a2 -> f a1 a2 b) a -- A coassociative coalgebra over a semiring using class Semiring r => Coalgebra r c where comult :: (c -> r) -> c -> c -> r -- | Every coalgebra gives rise to an algebra by vector space duality classically. -- Sadly, it requires vector space duality, which we cannot use constructively. -- The dual argument only relies in the fact that any constructive coalgebra can only inspect a finite number of coefficients, -- which we CAN exploit. instance Algebra r m => Coalgebra r (m -> r) where comult k f g = k (f * g) instance (HasTrie m, Algebra r m) => Coalgebra r (m :->: r) where comult k f g = k (f * g) -- instance Coalgebra () c where comult _ _ _ = () -- instance (Algebra r b, Coalgebra r c) => Coalgebra (b -> r) c where comult f c1 c2 b = comult (`f` b) c1 c2 instance Semiring r => Coalgebra r () where comult = const instance (Coalgebra r a, Coalgebra r b) => Coalgebra r (a, b) where comult f (a1,b1) (a2,b2) = comult (\a -> comult (\b -> f (a,b)) b1 b2) a1 a2 instance (Coalgebra r a, Coalgebra r b, Coalgebra r c) => Coalgebra r (a, b, c) where comult f (a1,b1,c1) (a2,b2,c2) = comult (\a -> comult (\b -> comult (\c -> f (a,b,c)) c1 c2) b1 b2) a1 a2 instance (Coalgebra r a, Coalgebra r b, Coalgebra r c, Coalgebra r d) => Coalgebra r (a, b, c, d) where comult f (a1,b1,c1,d1) (a2,b2,c2,d2) = comult (\a -> comult (\b -> comult (\c -> comult (\d -> f (a,b,c,d)) d1 d2) c1 c2) b1 b2) a1 a2 instance (Coalgebra r a, Coalgebra r b, Coalgebra r c, Coalgebra r d, Coalgebra r e) => Coalgebra r (a, b, c, d, e) where comult f (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = comult (\a -> comult (\b -> comult (\c -> comult (\d -> comult (\e -> f (a,b,c,d,e)) e1 e2) d1 d2) c1 c2) b1 b2) a1 a2 -- | The tensor Hopf algebra instance Semiring r => Coalgebra r [a] where comult f as bs = f (mappend as bs) -- | The tensor Hopf algebra instance Semiring r => Coalgebra r (Seq a) where comult f as bs = f (mappend as bs) -- | the free commutative band coalgebra instance (Semiring r, Ord a) => Coalgebra r (Set a) where comult f as bs = f (Set.union as bs) -- | the free commutative band coalgebra over Int instance Semiring r => Coalgebra r IntSet where comult f as bs = f (IntSet.union as bs) -- | the free commutative coalgebra over a set and a given semigroup instance (Semiring r, Ord a, Additive b) => Coalgebra r (Map a b) where comult f as bs = f (Map.unionWith (+) as bs) -- | the free commutative coalgebra over a set and Int instance (Semiring r, Additive b) => Coalgebra r (IntMap b) where comult f as bs = f (IntMap.unionWith (+) as bs) class (Semiring r, Additive m) => LeftModule r m where (.*) :: r -> m -> m instance LeftModule Natural Bool where 0 .* _ = False _ .* a = a instance LeftModule Natural Natural where (.*) = (*) instance LeftModule Natural Integer where Natural n .* m = n * m instance LeftModule Integer Integer where (.*) = (*) instance LeftModule Natural Int where (.*) = (*) . fromIntegral instance LeftModule Integer Int where (.*) = (*) . fromInteger instance LeftModule Natural Int8 where (.*) = (*) . fromIntegral instance LeftModule Integer Int8 where (.*) = (*) . fromInteger instance LeftModule Natural Int16 where (.*) = (*) . fromIntegral instance LeftModule Integer Int16 where (.*) = (*) . fromInteger instance LeftModule Natural Int32 where (.*) = (*) . fromIntegral instance LeftModule Integer Int32 where (.*) = (*) . fromInteger instance LeftModule Natural Int64 where (.*) = (*) . fromIntegral instance LeftModule Integer Int64 where (.*) = (*) . fromInteger instance LeftModule Natural Word where (.*) = (*) . fromIntegral instance LeftModule Integer Word where (.*) = (*) . fromInteger instance LeftModule Natural Word8 where (.*) = (*) . fromIntegral instance LeftModule Integer Word8 where (.*) = (*) . fromInteger instance LeftModule Natural Word16 where (.*) = (*) . fromIntegral instance LeftModule Integer Word16 where (.*) = (*) . fromInteger instance LeftModule Natural Word32 where (.*) = (*) . fromIntegral instance LeftModule Integer Word32 where (.*) = (*) . fromInteger instance LeftModule Natural Word64 where (.*) = (*) . fromIntegral instance LeftModule Integer Word64 where (.*) = (*) . fromInteger instance Semiring r => LeftModule r () where _ .* _ = () instance LeftModule r m => LeftModule r (e -> m) where (.*) m f e = m .* f e instance (HasTrie e, LeftModule r m) => LeftModule r (e :->: m) where (.*) m f = tabulate $ \e -> m .* index f e instance Additive m => LeftModule () m where _ .* a = a instance (LeftModule r a, LeftModule r b) => LeftModule r (a, b) where n .* (a, b) = (n .* a, n .* b) instance (LeftModule r a, LeftModule r b, LeftModule r c) => LeftModule r (a, b, c) where n .* (a, b, c) = (n .* a, n .* b, n .* c) instance (LeftModule r a, LeftModule r b, LeftModule r c, LeftModule r d) => LeftModule r (a, b, c, d) where n .* (a, b, c, d) = (n .* a, n .* b, n .* c, n .* d) instance (LeftModule r a, LeftModule r b, LeftModule r c, LeftModule r d, LeftModule r e) => LeftModule r (a, b, c, d, e) where n .* (a, b, c, d, e) = (n .* a, n .* b, n .* c, n .* d, n .* e) class (Semiring r, Additive m) => RightModule r m where (*.) :: m -> r -> m instance RightModule Natural Bool where _ *. 0 = False a *. _ = a instance RightModule Natural Natural where (*.) = (*) instance RightModule Natural Integer where n *. Natural m = n * m instance RightModule Integer Integer where (*.) = (*) instance RightModule Natural Int where m *. n = m * fromIntegral n instance RightModule Integer Int where m *. n = m * fromInteger n instance RightModule Natural Int8 where m *. n = m * fromIntegral n instance RightModule Integer Int8 where m *. n = m * fromInteger n instance RightModule Natural Int16 where m *. n = m * fromIntegral n instance RightModule Integer Int16 where m *. n = m * fromInteger n instance RightModule Natural Int32 where m *. n = m * fromIntegral n instance RightModule Integer Int32 where m *. n = m * fromInteger n instance RightModule Natural Int64 where m *. n = m * fromIntegral n instance RightModule Integer Int64 where m *. n = m * fromInteger n instance RightModule Natural Word where m *. n = m * fromIntegral n instance RightModule Integer Word where m *. n = m * fromInteger n instance RightModule Natural Word8 where m *. n = m * fromIntegral n instance RightModule Integer Word8 where m *. n = m * fromInteger n instance RightModule Natural Word16 where m *. n = m * fromIntegral n instance RightModule Integer Word16 where m *. n = m * fromInteger n instance RightModule Natural Word32 where m *. n = m * fromIntegral n instance RightModule Integer Word32 where m *. n = m * fromInteger n instance RightModule Natural Word64 where m *. n = m * fromIntegral n instance RightModule Integer Word64 where m *. n = m * fromInteger n instance Semiring r => RightModule r () where _ *. _ = () instance RightModule r m => RightModule r (e -> m) where (*.) f m e = f e *. m instance (HasTrie e, RightModule r m) => RightModule r (e :->: m) where (*.) f m = tabulate $ \e -> index f e *. m instance Additive m => RightModule () m where (*.) = const instance (RightModule r a, RightModule r b) => RightModule r (a, b) where (a, b) *. n = (a *. n, b *. n) instance (RightModule r a, RightModule r b, RightModule r c) => RightModule r (a, b, c) where (a, b, c) *. n = (a *. n, b *. n, c *. n) instance (RightModule r a, RightModule r b, RightModule r c, RightModule r d) => RightModule r (a, b, c, d) where (a, b, c, d) *. n = (a *. n, b *. n, c *. n, d *. n) instance (RightModule r a, RightModule r b, RightModule r c, RightModule r d, RightModule r e) => RightModule r (a, b, c, d, e) where (a, b, c, d, e) *. n = (a *. n, b *. n, c *. n, d *. n, e *. n) class (LeftModule r m, RightModule r m) => Module r m instance (LeftModule r m, RightModule r m) => Module r m -- | An additive monoid -- -- > zero + a = a = a + zero class (LeftModule Natural m, RightModule Natural m) => Monoidal m where zero :: m sinnum :: Whole n => n -> m -> m sinnum 0 _ = zero sinnum n x0 = f x0 n where f x y | even y = f (x + x) (y `quot` 2) | y == 1 = x | otherwise = g (x + x) (unsafePred y `quot` 2) x g x y z | even y = g (x + x) (y `quot` 2) z | y == 1 = x + z | otherwise = g (x + x) (unsafePred y `quot` 2) (x + z) sumWith :: Foldable f => (a -> m) -> f a -> m sumWith f = foldl' (\b a -> b + f a) zero sum :: (Foldable f, Monoidal m) => f m -> m sum = sumWith id sinnumIdempotent :: (Integral n, Idempotent r, Monoidal r) => n -> r -> r sinnumIdempotent 0 _ = zero sinnumIdempotent _ x = x instance Monoidal Bool where zero = False sinnum 0 _ = False sinnum _ r = r instance Monoidal Natural where zero = 0 sinnum n r = toNatural n * r instance Monoidal Integer where zero = 0 sinnum n r = toInteger n * r instance Monoidal Int where zero = 0 sinnum n r = fromIntegral n * r instance Monoidal Int8 where zero = 0 sinnum n r = fromIntegral n * r instance Monoidal Int16 where zero = 0 sinnum n r = fromIntegral n * r instance Monoidal Int32 where zero = 0 sinnum n r = fromIntegral n * r instance Monoidal Int64 where zero = 0 sinnum n r = fromIntegral n * r instance Monoidal Word where zero = 0 sinnum n r = fromIntegral n * r instance Monoidal Word8 where zero = 0 sinnum n r = fromIntegral n * r instance Monoidal Word16 where zero = 0 sinnum n r = fromIntegral n * r instance Monoidal Word32 where zero = 0 sinnum n r = fromIntegral n * r instance Monoidal Word64 where zero = 0 sinnum n r = fromIntegral n * r instance Monoidal r => Monoidal (e -> r) where zero = const zero sumWith f xs e = sumWith (`f` e) xs sinnum n r e = sinnum n (r e) instance (HasTrie e, Monoidal r) => Monoidal (e :->: r) where zero = pure zero sumWith f xs = tabulate $ \e -> sumWith (\a -> index (f a) e) xs sinnum n r = tabulate $ sinnum n . index r instance Monoidal () where zero = () sinnum _ () = () sumWith _ _ = () instance (Monoidal a, Monoidal b) => Monoidal (a,b) where zero = (zero,zero) sinnum n (a,b) = (sinnum n a, sinnum n b) instance (Monoidal a, Monoidal b, Monoidal c) => Monoidal (a,b,c) where zero = (zero,zero,zero) sinnum n (a,b,c) = (sinnum n a, sinnum n b, sinnum n c) instance (Monoidal a, Monoidal b, Monoidal c, Monoidal d) => Monoidal (a,b,c,d) where zero = (zero,zero,zero,zero) sinnum n (a,b,c,d) = (sinnum n a, sinnum n b, sinnum n c, sinnum n d) instance (Monoidal a, Monoidal b, Monoidal c, Monoidal d, Monoidal e) => Monoidal (a,b,c,d,e) where zero = (zero,zero,zero,zero,zero) sinnum n (a,b,c,d,e) = (sinnum n a, sinnum n b, sinnum n c, sinnum n d, sinnum n e) algebra-3.1/src/Numeric/Algebra/Commutative.hs0000644000000000000000000001120012072477456017527 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances, FlexibleInstances, TypeOperators #-} module Numeric.Algebra.Commutative ( Commutative , CommutativeAlgebra , CocommutativeCoalgebra , CommutativeBialgebra ) where import Data.Functor.Representable.Trie import Data.Int import Data.IntSet (IntSet) import Data.IntMap (IntMap) import Data.Set (Set) import Data.Map (Map) import Data.Word import Numeric.Additive.Class import Numeric.Algebra.Class import Numeric.Algebra.Unital import Numeric.Natural import Prelude (Bool, Ord, Integer) -- | A commutative multiplicative semigroup class Multiplicative r => Commutative r instance Commutative () instance Commutative Bool instance Commutative Integer instance Commutative Int instance Commutative Int8 instance Commutative Int16 instance Commutative Int32 instance Commutative Int64 instance Commutative Natural instance Commutative Word instance Commutative Word8 instance Commutative Word16 instance Commutative Word32 instance Commutative Word64 instance ( Commutative a , Commutative b ) => Commutative (a,b) instance ( Commutative a , Commutative b , Commutative c ) => Commutative (a,b,c) instance ( Commutative a , Commutative b , Commutative c , Commutative d ) => Commutative (a,b,c,d) instance ( Commutative a , Commutative b , Commutative c , Commutative d , Commutative e ) => Commutative (a,b,c,d,e) instance CommutativeAlgebra r a => Commutative (a -> r) instance ( HasTrie a , CommutativeAlgebra r a ) => Commutative (a :->: r) class Algebra r a => CommutativeAlgebra r a instance ( Commutative r , Semiring r ) => CommutativeAlgebra r () instance ( CommutativeAlgebra r a , CommutativeAlgebra r b ) => CommutativeAlgebra r (a,b) instance ( CommutativeAlgebra r a , CommutativeAlgebra r b , CommutativeAlgebra r c ) => CommutativeAlgebra r (a,b,c) instance ( CommutativeAlgebra r a , CommutativeAlgebra r b , CommutativeAlgebra r c , CommutativeAlgebra r d ) => CommutativeAlgebra r (a,b,c,d) instance ( CommutativeAlgebra r a , CommutativeAlgebra r b , CommutativeAlgebra r c , CommutativeAlgebra r d , CommutativeAlgebra r e ) => CommutativeAlgebra r (a,b,c,d,e) instance ( Commutative r , Semiring r , Ord a ) => CommutativeAlgebra r (Set a) instance (Commutative r , Semiring r ) => CommutativeAlgebra r IntSet instance (Commutative r , Monoidal r , Semiring r , Ord a , Abelian b , Partitionable b ) => CommutativeAlgebra r (Map a b) instance ( Commutative r , Monoidal r , Semiring r , Abelian b , Partitionable b ) => CommutativeAlgebra r (IntMap b) class Coalgebra r c => CocommutativeCoalgebra r c instance CommutativeAlgebra r m => CocommutativeCoalgebra r (m -> r) instance ( HasTrie m , CommutativeAlgebra r m ) => CocommutativeCoalgebra r (m :->: r) instance (Commutative r, Semiring r) => CocommutativeCoalgebra r () instance ( CocommutativeCoalgebra r a , CocommutativeCoalgebra r b ) => CocommutativeCoalgebra r (a,b) instance ( CocommutativeCoalgebra r a , CocommutativeCoalgebra r b , CocommutativeCoalgebra r c ) => CocommutativeCoalgebra r (a,b,c) instance ( CocommutativeCoalgebra r a , CocommutativeCoalgebra r b , CocommutativeCoalgebra r c , CocommutativeCoalgebra r d ) => CocommutativeCoalgebra r (a,b,c,d) instance ( CocommutativeCoalgebra r a , CocommutativeCoalgebra r b , CocommutativeCoalgebra r c , CocommutativeCoalgebra r d , CocommutativeCoalgebra r e ) => CocommutativeCoalgebra r (a,b,c,d,e) instance ( Commutative r , Semiring r , Ord a) => CocommutativeCoalgebra r (Set a) instance ( Commutative r , Semiring r ) => CocommutativeCoalgebra r IntSet instance ( Commutative r , Semiring r , Ord a , Abelian b ) => CocommutativeCoalgebra r (Map a b) instance ( Commutative r , Semiring r , Abelian b ) => CocommutativeCoalgebra r (IntMap b) class ( Bialgebra r h , CommutativeAlgebra r h , CocommutativeCoalgebra r h ) => CommutativeBialgebra r h instance ( Bialgebra r h , CommutativeAlgebra r h , CocommutativeCoalgebra r h ) => CommutativeBialgebra r h algebra-3.1/src/Numeric/Algebra/Complex.hs0000644000000000000000000001544212072477456016655 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses , FlexibleInstances , TypeFamilies , UndecidableInstances , DeriveDataTypeable , TypeOperators #-} module Numeric.Algebra.Complex ( Distinguished(..) , Complicated(..) , ComplexBasis(..) , Complex(..) , realPart , imagPart , uncomplicate ) where import Control.Applicative import Control.Monad.Reader.Class import Data.Data import Data.Distributive import Data.Functor.Bind import Data.Functor.Representable import Data.Functor.Representable.Trie import Data.Foldable import Data.Ix hiding (index) import Data.Key import Data.Semigroup import Data.Semigroup.Traversable import Data.Semigroup.Foldable import Data.Traversable import Numeric.Algebra import Numeric.Algebra.Distinguished.Class import Numeric.Algebra.Complex.Class import Numeric.Algebra.Quaternion.Class import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger,recip) -- complex basis data ComplexBasis = E | I deriving (Eq,Ord,Show,Read,Enum,Ix,Bounded,Data,Typeable) data Complex a = Complex a a deriving (Eq,Show,Read,Data,Typeable) realPart :: (Representable f, Key f ~ ComplexBasis) => f a -> a realPart f = index f E imagPart :: (Representable f, Key f ~ ComplexBasis) => f a -> a imagPart f = index f I instance Distinguished ComplexBasis where e = E instance Complicated ComplexBasis where i = I instance Rig r => Distinguished (Complex r) where e = Complex one zero instance Rig r => Complicated (Complex r) where i = Complex zero one instance Rig r => Distinguished (ComplexBasis -> r) where e E = one e _ = zero instance Rig r => Complicated (ComplexBasis -> r) where i I = one i _ = zero instance Rig r => Distinguished (ComplexBasis :->: r) where e = Trie e instance Rig r => Complicated (ComplexBasis :->: r) where i = Trie i type instance Key Complex = ComplexBasis instance Representable Complex where tabulate f = Complex (f E) (f I) instance Indexable Complex where index (Complex a _ ) E = a index (Complex _ b ) I = b instance Lookup Complex where lookup = lookupDefault instance Adjustable Complex where adjust f E (Complex a b) = Complex (f a) b adjust f I (Complex a b) = Complex a (f b) instance Distributive Complex where distribute = distributeRep instance Functor Complex where fmap f (Complex a b) = Complex (f a) (f b) instance Zip Complex where zipWith f (Complex a1 b1) (Complex a2 b2) = Complex (f a1 a2) (f b1 b2) instance ZipWithKey Complex where zipWithKey f (Complex a1 b1) (Complex a2 b2) = Complex (f E a1 a2) (f I b1 b2) instance Keyed Complex where mapWithKey = mapWithKeyRep instance Apply Complex where (<.>) = apRep instance Applicative Complex where pure = pureRep (<*>) = apRep instance Bind Complex where (>>-) = bindRep instance Monad Complex where return = pureRep (>>=) = bindRep instance MonadReader ComplexBasis Complex where ask = askRep local = localRep instance Foldable Complex where foldMap f (Complex a b) = f a `mappend` f b instance FoldableWithKey Complex where foldMapWithKey f (Complex a b) = f E a `mappend` f I b instance Traversable Complex where traverse f (Complex a b) = Complex <$> f a <*> f b instance TraversableWithKey Complex where traverseWithKey f (Complex a b) = Complex <$> f E a <*> f I b instance Foldable1 Complex where foldMap1 f (Complex a b) = f a <> f b instance FoldableWithKey1 Complex where foldMapWithKey1 f (Complex a b) = f E a <> f I b instance Traversable1 Complex where traverse1 f (Complex a b) = Complex <$> f a <.> f b instance TraversableWithKey1 Complex where traverseWithKey1 f (Complex a b) = Complex <$> f E a <.> f I b instance HasTrie ComplexBasis where type BaseTrie ComplexBasis = Complex embedKey = id projectKey = id instance Additive r => Additive (Complex r) where (+) = addRep sinnum1p = sinnum1pRep instance LeftModule r s => LeftModule r (Complex s) where r .* Complex a b = Complex (r .* a) (r .* b) instance RightModule r s => RightModule r (Complex s) where Complex a b *. r = Complex (a *. r) (b *. r) instance Monoidal r => Monoidal (Complex r) where zero = zeroRep sinnum = sinnumRep instance Group r => Group (Complex r) where (-) = minusRep negate = negateRep subtract = subtractRep times = timesRep instance Abelian r => Abelian (Complex r) instance Idempotent r => Idempotent (Complex r) instance Partitionable r => Partitionable (Complex r) where partitionWith f (Complex a b) = id =<< partitionWith (\a1 a2 -> partitionWith (\b1 b2 -> f (Complex a1 b1) (Complex a2 b2)) b) a instance Rng k => Algebra k ComplexBasis where mult f = f' where fe = f E E - f I I fi = f E I + f I E f' E = fe f' I = fi instance Rng k => UnitalAlgebra k ComplexBasis where unit x E = x unit _ _ = zero -- the trivial coalgebra instance Rng k => Coalgebra k ComplexBasis where comult f E E = f E comult f I I = f I comult _ _ _ = zero instance Rng k => CounitalCoalgebra k ComplexBasis where counit f = f E + f I instance Rng k => Bialgebra k ComplexBasis instance (InvolutiveSemiring k, Rng k) => InvolutiveAlgebra k ComplexBasis where inv f = f' where afe = adjoint (f E) nfi = negate (f I) f' E = afe f' I = nfi instance (InvolutiveSemiring k, Rng k) => InvolutiveCoalgebra k ComplexBasis where coinv = inv instance (InvolutiveSemiring k, Rng k) => HopfAlgebra k ComplexBasis where antipode = inv instance (Commutative r, Rng r) => Multiplicative (Complex r) where (*) = mulRep instance (TriviallyInvolutive r, Rng r) => Commutative (Complex r) instance (Commutative r, Rng r) => Semiring (Complex r) instance (Commutative r, Ring r) => Unital (Complex r) where one = oneRep instance (Commutative r, Ring r) => Rig (Complex r) where fromNatural n = Complex (fromNatural n) zero instance (Commutative r, Ring r) => Ring (Complex r) where fromInteger n = Complex (fromInteger n) zero instance (Commutative r, Rng r) => LeftModule (Complex r) (Complex r) where (.*) = (*) instance (Commutative r, Rng r) => RightModule (Complex r) (Complex r) where (*.) = (*) instance (Commutative r, Rng r, InvolutiveMultiplication r) => InvolutiveMultiplication (Complex r) where adjoint (Complex a b) = Complex (adjoint a) (negate b) instance (Commutative r, Rng r, InvolutiveSemiring r) => InvolutiveSemiring (Complex r) instance (Commutative r, Rng r, InvolutiveSemiring r) => Quadrance r (Complex r) where quadrance n = realPart $ adjoint n * n instance (Commutative r, InvolutiveSemiring r, DivisionRing r) => Division (Complex r) where recip q@(Complex a b) = Complex (qq \\ a) (qq \\ b) where qq = quadrance q -- | half of the Cayley-Dickson quaternion isomorphism uncomplicate :: Hamiltonian q => ComplexBasis -> ComplexBasis -> q uncomplicate E E = e uncomplicate I E = i uncomplicate E I = j uncomplicate I I = k algebra-3.1/src/Numeric/Algebra/Division.hs0000644000000000000000000000422312072477456017025 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} module Numeric.Algebra.Division ( Division(..) , DivisionAlgebra(..) ) where import Prelude hiding ((*), recip, (/),(^)) import Numeric.Algebra.Class import Numeric.Algebra.Unital infixr 8 ^ infixl 7 /, \\ -- A multiplicative group class Unital r => Division r where recip :: r -> r (/) :: r -> r -> r (\\) :: r -> r -> r (^) :: Integral n => r -> n -> r recip a = one / a a / b = a * recip b a \\ b = recip a * b x0 ^ y0 = case compare y0 0 of LT -> f (recip x0) (negate y0) EQ -> one GT -> f x0 y0 where f x y | even y = f (x * x) (y `quot` 2) | y == 1 = x | otherwise = g (x * x) ((y - 1) `quot` 2) x g x y z | even y = g (x * x) (y `quot` 2) z | y == 1 = x * z | otherwise = g (x * x) ((y - 1) `quot` 2) (x * z) instance Division () where _ / _ = () recip _ = () _ \\ _ = () _ ^ _ = () instance (Division a, Division b) => Division (a,b) where recip (a,b) = (recip a, recip b) (a,b) / (i,j) = (a/i,b/j) (a,b) \\ (i,j) = (a\\i,b\\j) (a,b) ^ n = (a^n,b^n) instance (Division a, Division b, Division c) => Division (a,b,c) where recip (a,b,c) = (recip a, recip b, recip c) (a,b,c) / (i,j,k) = (a/i,b/j,c/k) (a,b,c) \\ (i,j,k) = (a\\i,b\\j,c\\k) (a,b,c) ^ n = (a^n,b^n,c^n) instance (Division a, Division b, Division c, Division d) => Division (a,b,c,d) where recip (a,b,c,d) = (recip a, recip b, recip c, recip d) (a,b,c,d) / (i,j,k,l) = (a/i,b/j,c/k,d/l) (a,b,c,d) \\ (i,j,k,l) = (a\\i,b\\j,c\\k,d\\l) (a,b,c,d) ^ n = (a^n,b^n,c^n,d^n) instance (Division a, Division b, Division c, Division d, Division e) => Division (a,b,c,d,e) where recip (a,b,c,d,e) = (recip a, recip b, recip c, recip d, recip e) (a,b,c,d,e) / (i,j,k,l,m) = (a/i,b/j,c/k,d/l,e/m) (a,b,c,d,e) \\ (i,j,k,l,m) = (a\\i,b\\j,c\\k,d\\l,e\\m) (a,b,c,d,e) ^ n = (a^n,b^n,c^n,d^n,e^n) class UnitalAlgebra r a => DivisionAlgebra r a where recipriocal :: (a -> r) -> a -> r -- recipriocal f = one `over` f instance (Unital r, DivisionAlgebra r a) => Division (a -> r) where recip = recipriocal algebra-3.1/src/Numeric/Algebra/Dual.hs0000644000000000000000000001347712072477456016141 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies, UndecidableInstances, DeriveDataTypeable #-} module Numeric.Algebra.Dual ( Distinguished(..) , Infinitesimal(..) , DualBasis(..) , Dual(..) ) where import Control.Applicative import Control.Monad.Reader.Class import Data.Data import Data.Distributive import Data.Functor.Bind import Data.Functor.Representable import Data.Functor.Representable.Trie import Data.Foldable import Data.Ix import Data.Key import Data.Semigroup hiding (Dual) import Data.Semigroup.Traversable import Data.Semigroup.Foldable import Data.Traversable import Numeric.Algebra import Numeric.Algebra.Distinguished.Class import Numeric.Algebra.Dual.Class import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger,recip) -- | dual number basis, D^2 = 0. D /= 0. data DualBasis = E | D deriving (Eq,Ord,Show,Read,Enum,Ix,Bounded,Data,Typeable) data Dual a = Dual a a deriving (Eq,Show,Read,Data,Typeable) instance Distinguished DualBasis where e = E instance Infinitesimal DualBasis where d = D instance Rig r => Distinguished (Dual r) where e = Dual one zero instance Rig r => Infinitesimal (Dual r) where d = Dual zero one instance Rig r => Distinguished (DualBasis -> r) where e E = one e _ = zero instance Rig r => Infinitesimal (DualBasis -> r) where d D = one d _ = zero type instance Key Dual = DualBasis instance Representable Dual where tabulate f = Dual (f E) (f D) instance Indexable Dual where index (Dual a _ ) E = a index (Dual _ b ) D = b instance Lookup Dual where lookup = lookupDefault instance Adjustable Dual where adjust f E (Dual a b) = Dual (f a) b adjust f D (Dual a b) = Dual a (f b) instance Distributive Dual where distribute = distributeRep instance Functor Dual where fmap f (Dual a b) = Dual (f a) (f b) instance Zip Dual where zipWith f (Dual a1 b1) (Dual a2 b2) = Dual (f a1 a2) (f b1 b2) instance ZipWithKey Dual where zipWithKey f (Dual a1 b1) (Dual a2 b2) = Dual (f E a1 a2) (f D b1 b2) instance Keyed Dual where mapWithKey = mapWithKeyRep instance Apply Dual where (<.>) = apRep instance Applicative Dual where pure = pureRep (<*>) = apRep instance Bind Dual where (>>-) = bindRep instance Monad Dual where return = pureRep (>>=) = bindRep instance MonadReader DualBasis Dual where ask = askRep local = localRep instance Foldable Dual where foldMap f (Dual a b) = f a `mappend` f b instance FoldableWithKey Dual where foldMapWithKey f (Dual a b) = f E a `mappend` f D b instance Traversable Dual where traverse f (Dual a b) = Dual <$> f a <*> f b instance TraversableWithKey Dual where traverseWithKey f (Dual a b) = Dual <$> f E a <*> f D b instance Foldable1 Dual where foldMap1 f (Dual a b) = f a <> f b instance FoldableWithKey1 Dual where foldMapWithKey1 f (Dual a b) = f E a <> f D b instance Traversable1 Dual where traverse1 f (Dual a b) = Dual <$> f a <.> f b instance TraversableWithKey1 Dual where traverseWithKey1 f (Dual a b) = Dual <$> f E a <.> f D b instance HasTrie DualBasis where type BaseTrie DualBasis = Dual embedKey = id projectKey = id instance Additive r => Additive (Dual r) where (+) = addRep sinnum1p = sinnum1pRep instance LeftModule r s => LeftModule r (Dual s) where r .* Dual a b = Dual (r .* a) (r .* b) instance RightModule r s => RightModule r (Dual s) where Dual a b *. r = Dual (a *. r) (b *. r) instance Monoidal r => Monoidal (Dual r) where zero = zeroRep sinnum = sinnumRep instance Group r => Group (Dual r) where (-) = minusRep negate = negateRep subtract = subtractRep times = timesRep instance Abelian r => Abelian (Dual r) instance Idempotent r => Idempotent (Dual r) instance Partitionable r => Partitionable (Dual r) where partitionWith f (Dual a b) = id =<< partitionWith (\a1 a2 -> partitionWith (\b1 b2 -> f (Dual a1 b1) (Dual a2 b2)) b) a instance Rng k => Algebra k DualBasis where mult f = f' where fe = f E E fd = f E D + f D E f' E = fe f' D = fd instance Rng k => UnitalAlgebra k DualBasis where unit x E = x unit _ _ = zero -- the trivial coalgebra instance Rng k => Coalgebra k DualBasis where comult f E E = f E comult f D D = f D comult _ _ _ = zero instance Rng k => CounitalCoalgebra k DualBasis where counit f = f E + f D instance Rng k => Bialgebra k DualBasis instance (InvolutiveSemiring k, Rng k) => InvolutiveAlgebra k DualBasis where inv f = f' where afe = adjoint (f E) nfd = negate (f D) f' E = afe f' D = nfd instance (InvolutiveSemiring k, Rng k) => InvolutiveCoalgebra k DualBasis where coinv = inv instance (InvolutiveSemiring k, Rng k) => HopfAlgebra k DualBasis where antipode = inv instance (Commutative r, Rng r) => Multiplicative (Dual r) where (*) = mulRep instance (TriviallyInvolutive r, Rng r) => Commutative (Dual r) instance (Commutative r, Rng r) => Semiring (Dual r) instance (Commutative r, Ring r) => Unital (Dual r) where one = oneRep instance (Commutative r, Ring r) => Rig (Dual r) where fromNatural n = Dual (fromNatural n) zero instance (Commutative r, Ring r) => Ring (Dual r) where fromInteger n = Dual (fromInteger n) zero instance (Commutative r, Rng r) => LeftModule (Dual r) (Dual r) where (.*) = (*) instance (Commutative r, Rng r) => RightModule (Dual r) (Dual r) where (*.) = (*) instance (Commutative r, Rng r, InvolutiveSemiring r) => InvolutiveMultiplication (Dual r) where adjoint (Dual a b) = Dual (adjoint a) (negate b) instance (Commutative r, Rng r, InvolutiveSemiring r) => InvolutiveSemiring (Dual r) instance (Commutative r, Rng r, InvolutiveSemiring r) => Quadrance r (Dual r) where quadrance n = case adjoint n * n of Dual a _ -> a instance (Commutative r, InvolutiveSemiring r, DivisionRing r) => Division (Dual r) where recip q@(Dual a b) = Dual (qq \\ a) (qq \\ b) where qq = quadrance q algebra-3.1/src/Numeric/Algebra/Factorable.hs0000644000000000000000000000410012072477456017275 0ustar0000000000000000module Numeric.Algebra.Factorable ( -- * Factorable Multiplicative Semigroups Factorable(..) ) where import Data.List.NonEmpty import Numeric.Algebra.Class (Multiplicative(..)) import Prelude hiding (concat) -- | `factorWith f c` returns a non-empty list containing `f a b` for all `a, b` such that `a * b = c`. -- -- Results of factorWith f 0 are undefined and may result in either an error or an infinite list. class Multiplicative m => Factorable m where factorWith :: (m -> m -> r) -> m -> NonEmpty r instance Factorable Bool where factorWith f False = f False False :| [f False True, f True False] factorWith f True = f True True :| [] instance Factorable () where factorWith f () = f () () :| [] concat :: NonEmpty (NonEmpty a) -> NonEmpty a concat m = m >>= id instance (Factorable a, Factorable b) => Factorable (a,b) where factorWith f (a,b) = concat $ factorWith (\ax ay -> factorWith (\bx by -> f (ax,bx) (ay,by)) b) a instance (Factorable a, Factorable b, Factorable c) => Factorable (a,b,c) where factorWith f (a,b,c) = concat $ factorWith (\ax ay -> concat $ factorWith (\bx by -> factorWith (\cx cy -> f (ax,bx,cx) (ay,by,cy)) c) b) a instance (Factorable a, Factorable b, Factorable c,Factorable d ) => Factorable (a,b,c,d) where factorWith f (a,b,c,d) = concat $ factorWith (\ax ay -> concat $ factorWith (\bx by -> concat $ factorWith (\cx cy -> factorWith (\dx dy -> f (ax,bx,cx,dx) (ay,by,cy,dy)) d) c) b) a instance (Factorable a, Factorable b, Factorable c,Factorable d, Factorable e) => Factorable (a,b,c,d,e) where factorWith f (a,b,c,d,e) = concat $ factorWith (\ax ay -> concat $ factorWith (\bx by -> concat $ factorWith (\cx cy -> concat $ factorWith (\dx dy -> factorWith (\ex ey -> f (ax,bx,cx,dx,ex) (ay,by,cy,dy,ey)) e) d) c) b) a algebra-3.1/src/Numeric/Algebra/Hopf.hs0000644000000000000000000000314312072477456016135 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} module Numeric.Algebra.Hopf ( HopfAlgebra(..) ) where import Numeric.Algebra.Unital -- | A HopfAlgebra algebra on a semiring, where the module is free. -- -- When @antipode . antipode = id@ and antipode is an antihomomorphism then we are an InvolutiveBialgebra with @inv = antipode@ as well class Bialgebra r h => HopfAlgebra r h where -- > convolve id antipode = convolve antipode id = unit . counit antipode :: (h -> r) -> h -> r -- incoherent -- instance (UnitalAlgebra r a, HopfAlgebra r h) => HopfAlgebra (a -> r) h where antipode f h a = antipode (`f` a) h -- instance HopfAlgebra () h where antipode = id -- TODO: check this -- instance InvolutiveSemiring r => HopfAlgebra r () where antipode = adjoint instance (HopfAlgebra r a, HopfAlgebra r b) => HopfAlgebra r (a, b) where antipode f (a,b) = antipode (\a' -> antipode (\b' -> f (a',b')) b) a instance (HopfAlgebra r a, HopfAlgebra r b, HopfAlgebra r c) => HopfAlgebra r (a, b, c) where antipode f (a,b,c) = antipode (\a' -> antipode (\b' -> antipode (\c' -> f (a',b',c')) c) b) a instance (HopfAlgebra r a, HopfAlgebra r b, HopfAlgebra r c, HopfAlgebra r d) => HopfAlgebra r (a, b, c, d) where antipode f (a,b,c,d) = antipode (\a' -> antipode (\b' -> antipode (\c' -> antipode (\d' -> f (a',b',c',d')) d) c) b) a instance (HopfAlgebra r a, HopfAlgebra r b, HopfAlgebra r c, HopfAlgebra r d, HopfAlgebra r e) => HopfAlgebra r (a, b, c, d, e) where antipode f (a,b,c,d,e) = antipode (\a' -> antipode (\b' -> antipode (\c' -> antipode (\d' -> antipode (\e' -> f (a',b',c',d',e')) e) d) c) b) a algebra-3.1/src/Numeric/Algebra/Hyperbolic.hs0000644000000000000000000001454412072477456017350 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies, UndecidableInstances, DeriveDataTypeable #-} module Numeric.Algebra.Hyperbolic ( Hyperbolic(..) , HyperBasis'(..) , Hyper'(..) ) where import Control.Applicative import Control.Monad.Reader.Class import Data.Data import Data.Distributive import Data.Functor.Bind import Data.Functor.Representable import Data.Functor.Representable.Trie import Data.Foldable import Data.Ix import Data.Key import Data.Semigroup.Traversable import Data.Semigroup.Foldable import Data.Semigroup import Data.Traversable import Numeric.Algebra import Numeric.Coalgebra.Hyperbolic.Class import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger) -- the dual hyperbolic basis data HyperBasis' = Cosh' | Sinh' deriving (Eq,Ord,Show,Read,Enum,Ix,Bounded,Data,Typeable) data Hyper' a = Hyper' a a deriving (Eq,Show,Read,Data,Typeable) instance Hyperbolic HyperBasis' where cosh = Cosh' sinh = Sinh' instance Rig r => Hyperbolic (Hyper' r) where cosh = Hyper' one zero sinh = Hyper' zero one instance Rig r => Hyperbolic (HyperBasis' -> r) where cosh Sinh' = zero cosh Cosh' = one sinh Sinh' = one sinh Cosh' = zero type instance Key Hyper' = HyperBasis' instance Representable Hyper' where tabulate f = Hyper' (f Cosh') (f Sinh') instance Indexable Hyper' where index (Hyper' a _ ) Cosh' = a index (Hyper' _ b ) Sinh' = b instance Lookup Hyper' where lookup = lookupDefault instance Adjustable Hyper' where adjust f Cosh' (Hyper' a b) = Hyper' (f a) b adjust f Sinh' (Hyper' a b) = Hyper' a (f b) instance Distributive Hyper' where distribute = distributeRep instance Functor Hyper' where fmap f (Hyper' a b) = Hyper' (f a) (f b) instance Zip Hyper' where zipWith f (Hyper' a1 b1) (Hyper' a2 b2) = Hyper' (f a1 a2) (f b1 b2) instance ZipWithKey Hyper' where zipWithKey f (Hyper' a1 b1) (Hyper' a2 b2) = Hyper' (f Cosh' a1 a2) (f Sinh' b1 b2) instance Keyed Hyper' where mapWithKey = mapWithKeyRep instance Apply Hyper' where (<.>) = apRep instance Applicative Hyper' where pure = pureRep (<*>) = apRep instance Bind Hyper' where (>>-) = bindRep instance Monad Hyper' where return = pureRep (>>=) = bindRep instance MonadReader HyperBasis' Hyper' where ask = askRep local = localRep instance Foldable Hyper' where foldMap f (Hyper' a b) = f a `mappend` f b instance FoldableWithKey Hyper' where foldMapWithKey f (Hyper' a b) = f Cosh' a `mappend` f Sinh' b instance Traversable Hyper' where traverse f (Hyper' a b) = Hyper' <$> f a <*> f b instance TraversableWithKey Hyper' where traverseWithKey f (Hyper' a b) = Hyper' <$> f Cosh' a <*> f Sinh' b instance Foldable1 Hyper' where foldMap1 f (Hyper' a b) = f a <> f b instance FoldableWithKey1 Hyper' where foldMapWithKey1 f (Hyper' a b) = f Cosh' a <> f Sinh' b instance Traversable1 Hyper' where traverse1 f (Hyper' a b) = Hyper' <$> f a <.> f b instance TraversableWithKey1 Hyper' where traverseWithKey1 f (Hyper' a b) = Hyper' <$> f Cosh' a <.> f Sinh' b instance HasTrie HyperBasis' where type BaseTrie HyperBasis' = Hyper' embedKey = id projectKey = id instance Additive r => Additive (Hyper' r) where (+) = addRep sinnum1p = sinnum1pRep instance LeftModule r s => LeftModule r (Hyper' s) where r .* Hyper' a b = Hyper' (r .* a) (r .* b) instance RightModule r s => RightModule r (Hyper' s) where Hyper' a b *. r = Hyper' (a *. r) (b *. r) instance Monoidal r => Monoidal (Hyper' r) where zero = zeroRep sinnum = sinnumRep instance Group r => Group (Hyper' r) where (-) = minusRep negate = negateRep subtract = subtractRep times = timesRep instance Abelian r => Abelian (Hyper' r) instance Idempotent r => Idempotent (Hyper' r) instance Partitionable r => Partitionable (Hyper' r) where partitionWith f (Hyper' a b) = id =<< partitionWith (\a1 a2 -> partitionWith (\b1 b2 -> f (Hyper' a1 b1) (Hyper' a2 b2)) b) a -- the dual hyperbolic trigonometric algebra instance (Commutative k, Semiring k) => Algebra k HyperBasis' where mult f = f' where fs = f Sinh' Cosh' + f Cosh' Sinh' fc = f Cosh' Cosh' + f Sinh' Sinh' f' Sinh' = fs f' Cosh' = fc instance (Commutative k, Monoidal k, Semiring k) => UnitalAlgebra k HyperBasis' where unit _ Sinh' = zero unit x Cosh' = x -- the diagonal coalgebra instance (Commutative k, Monoidal k, Semiring k) => Coalgebra k HyperBasis' where comult f = f' where fs = f Sinh' fc = f Cosh' f' Sinh' Sinh' = fs f' Sinh' Cosh' = zero f' Cosh' Sinh' = zero f' Cosh' Cosh' = fc instance (Commutative k, Monoidal k, Semiring k) => CounitalCoalgebra k HyperBasis' where counit f = f Cosh' + f Sinh' instance (Commutative k, Monoidal k, Semiring k) => Bialgebra k HyperBasis' instance (Commutative k, Group k, InvolutiveSemiring k) => InvolutiveAlgebra k HyperBasis' where inv f = f' where afc = adjoint (f Cosh') nfs = negate (f Sinh') f' Cosh' = afc f' Sinh' = nfs instance (Commutative k, Group k, InvolutiveSemiring k) => InvolutiveCoalgebra k HyperBasis' where coinv = inv instance (Commutative k, Group k, InvolutiveSemiring k) => HopfAlgebra k HyperBasis' where antipode = inv instance (Commutative k, Semiring k) => Multiplicative (Hyper' k) where (*) = mulRep instance (Commutative k, Semiring k) => Commutative (Hyper' k) instance (Commutative k, Semiring k) => Semiring (Hyper' k) instance (Commutative k, Rig k) => Unital (Hyper' k) where one = Hyper' one zero instance (Commutative r, Rig r) => Rig (Hyper' r) where fromNatural n = Hyper' (fromNatural n) zero instance (Commutative r, Ring r) => Ring (Hyper' r) where fromInteger n = Hyper' (fromInteger n) zero instance (Commutative r, Semiring r) => LeftModule (Hyper' r) (Hyper' r) where (.*) = (*) instance (Commutative r, Semiring r) => RightModule (Hyper' r) (Hyper' r) where (*.) = (*) instance (Commutative r, InvolutiveSemiring r, Rng r) => InvolutiveMultiplication (Hyper' r) where adjoint (Hyper' a b) = Hyper' (adjoint a) (negate b) instance (Commutative r, InvolutiveSemiring r, Rng r) => InvolutiveSemiring (Hyper' r) instance (Commutative r, InvolutiveSemiring r, Rng r) => Quadrance r (Hyper' r) where quadrance n = case adjoint n * n of Hyper' a _ -> a instance (Commutative r, InvolutiveSemiring r, DivisionRing r) => Division (Hyper' r) where recip q@(Hyper' a b) = Hyper' (qq \\ a) (qq \\ b) where qq = quadrance q algebra-3.1/src/Numeric/Algebra/Idempotent.hs0000644000000000000000000000513512072477456017354 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} module Numeric.Algebra.Idempotent ( Band , pow1pBand , powBand -- * Idempotent algebras , IdempotentAlgebra , IdempotentCoalgebra , IdempotentBialgebra ) where import Numeric.Algebra.Class import Numeric.Algebra.Unital import Numeric.Natural import Data.Set (Set) import Data.IntSet (IntSet) -- | An multiplicative semigroup with idempotent multiplication. -- -- > a * a = a class Multiplicative r => Band r pow1pBand :: Whole n => r -> n -> r pow1pBand r _ = r powBand :: (Unital r, Whole n) => r -> n -> r powBand _ 0 = one powBand r _ = r instance Band () instance Band Bool instance (Band a, Band b) => Band (a,b) instance (Band a, Band b, Band c) => Band (a,b,c) instance (Band a, Band b, Band c, Band d) => Band (a,b,c,d) instance (Band a, Band b, Band c, Band d, Band e) => Band (a,b,c,d,e) -- idempotent algebra class Algebra r a => IdempotentAlgebra r a instance (Semiring r, Band r, Ord a) => IdempotentAlgebra r (Set a) instance (Semiring r, Band r) => IdempotentAlgebra r IntSet instance (Semiring r, Band r) => IdempotentAlgebra r () instance (IdempotentAlgebra r a, IdempotentAlgebra r b) => IdempotentAlgebra r (a,b) instance (IdempotentAlgebra r a, IdempotentAlgebra r b, IdempotentAlgebra r c) => IdempotentAlgebra r (a,b,c) instance (IdempotentAlgebra r a, IdempotentAlgebra r b, IdempotentAlgebra r c, IdempotentAlgebra r d) => IdempotentAlgebra r (a,b,c,d) instance (IdempotentAlgebra r a, IdempotentAlgebra r b, IdempotentAlgebra r c, IdempotentAlgebra r d, IdempotentAlgebra r e) => IdempotentAlgebra r (a,b,c,d,e) -- idempotent coalgebra class Coalgebra r c => IdempotentCoalgebra r c instance (Semiring r, Band r, Ord c) => IdempotentCoalgebra r (Set c) instance (Semiring r, Band r) => IdempotentCoalgebra r IntSet instance (Semiring r, Band r) => IdempotentCoalgebra r () instance (IdempotentCoalgebra r a, IdempotentCoalgebra r b) => IdempotentCoalgebra r (a,b) instance (IdempotentCoalgebra r a, IdempotentCoalgebra r b, IdempotentCoalgebra r c) => IdempotentCoalgebra r (a,b,c) instance (IdempotentCoalgebra r a, IdempotentCoalgebra r b, IdempotentCoalgebra r c, IdempotentCoalgebra r d) => IdempotentCoalgebra r (a,b,c,d) instance (IdempotentCoalgebra r a, IdempotentCoalgebra r b, IdempotentCoalgebra r c, IdempotentCoalgebra r d, IdempotentCoalgebra r e) => IdempotentCoalgebra r (a,b,c,d,e) -- idempotent bialgebra class (Bialgebra r h, IdempotentAlgebra r h, IdempotentCoalgebra r h) => IdempotentBialgebra r h instance (Bialgebra r h, IdempotentAlgebra r h, IdempotentCoalgebra r h) => IdempotentBialgebra r h algebra-3.1/src/Numeric/Algebra/Incidence.hs0000644000000000000000000000205612072477456017124 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses , FlexibleInstances , UndecidableInstances , DeriveDataTypeable #-} module Numeric.Algebra.Incidence ( Interval(..) , zeta , moebius ) where import Data.Data import Numeric.Algebra.Class import Numeric.Algebra.Unital import Numeric.Algebra.Commutative import Numeric.Ring.Class import Numeric.Order.Class import Numeric.Order.LocallyFinite -- the basis for an incidence algebra data Interval a = Interval a a deriving (Eq,Ord,Show,Read,Data,Typeable) instance (Commutative r, Monoidal r, Semiring r, LocallyFiniteOrder a) => Algebra r (Interval a) where mult f (Interval a c) = sumWith (\b -> f (Interval a b) (Interval b c)) $ range a c instance (Commutative r, Monoidal r, Semiring r, LocallyFiniteOrder a) => UnitalAlgebra r (Interval a) where unit r (Interval a b) | a ~~ b = r | otherwise = zero zeta :: Unital r => Interval a -> r zeta = const one moebius :: (Ring r, LocallyFiniteOrder a) => Interval a -> r moebius (Interval a b) = moebiusInversion a b algebra-3.1/src/Numeric/Algebra/Involutive.hs0000644000000000000000000002512612072477456017412 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeOperators #-} module Numeric.Algebra.Involutive ( -- * Involution InvolutiveMultiplication(..) , InvolutiveSemiring -- * Involutive Algebras , InvolutiveAlgebra(..) , InvolutiveCoalgebra(..) , InvolutiveBialgebra -- * Trivial Involution , TriviallyInvolutive , TriviallyInvolutiveAlgebra , TriviallyInvolutiveCoalgebra , TriviallyInvolutiveBialgebra ) where import Numeric.Algebra.Class import Numeric.Algebra.Commutative import Numeric.Algebra.Unital import Data.Int import Data.Functor.Representable import Data.Functor.Representable.Trie import Data.Key import Data.Word import Numeric.Natural.Internal -- | An semigroup with involution -- -- > adjoint a * adjoint b = adjoint (b * a) class Multiplicative r => InvolutiveMultiplication r where adjoint :: r -> r instance InvolutiveMultiplication Int where adjoint = id instance InvolutiveMultiplication Integer where adjoint = id instance InvolutiveMultiplication Int8 where adjoint = id instance InvolutiveMultiplication Int16 where adjoint = id instance InvolutiveMultiplication Int32 where adjoint = id instance InvolutiveMultiplication Int64 where adjoint = id instance InvolutiveMultiplication Bool where adjoint = id instance InvolutiveMultiplication Word where adjoint = id instance InvolutiveMultiplication Natural where adjoint = id instance InvolutiveMultiplication Word8 where adjoint = id instance InvolutiveMultiplication Word16 where adjoint = id instance InvolutiveMultiplication Word32 where adjoint = id instance InvolutiveMultiplication Word64 where adjoint = id instance InvolutiveMultiplication () where adjoint = id instance ( InvolutiveMultiplication a , InvolutiveMultiplication b ) => InvolutiveMultiplication (a,b) where adjoint (a,b) = (adjoint a, adjoint b) instance ( InvolutiveMultiplication a , InvolutiveMultiplication b , InvolutiveMultiplication c ) => InvolutiveMultiplication (a,b,c) where adjoint (a,b,c) = (adjoint a, adjoint b, adjoint c) instance ( InvolutiveMultiplication a , InvolutiveMultiplication b , InvolutiveMultiplication c , InvolutiveMultiplication d ) => InvolutiveMultiplication (a,b,c,d) where adjoint (a,b,c,d) = (adjoint a, adjoint b, adjoint c, adjoint d) instance ( InvolutiveMultiplication a , InvolutiveMultiplication b , InvolutiveMultiplication c , InvolutiveMultiplication d , InvolutiveMultiplication e ) => InvolutiveMultiplication (a,b,c,d,e) where adjoint (a,b,c,d,e) = (adjoint a, adjoint b, adjoint c, adjoint d, adjoint e) instance InvolutiveAlgebra r h => InvolutiveMultiplication (h -> r) where adjoint = inv instance (HasTrie h, InvolutiveAlgebra r h) => InvolutiveMultiplication (h :->: r) where adjoint = tabulate . inv . index -- | adjoint (x + y) = adjoint x + adjoint y class (Semiring r, InvolutiveMultiplication r) => InvolutiveSemiring r instance InvolutiveSemiring () instance InvolutiveSemiring Bool instance InvolutiveSemiring Integer instance InvolutiveSemiring Int instance InvolutiveSemiring Int8 instance InvolutiveSemiring Int16 instance InvolutiveSemiring Int32 instance InvolutiveSemiring Int64 instance InvolutiveSemiring Natural instance InvolutiveSemiring Word instance InvolutiveSemiring Word8 instance InvolutiveSemiring Word16 instance InvolutiveSemiring Word32 instance InvolutiveSemiring Word64 instance ( InvolutiveSemiring a , InvolutiveSemiring b ) => InvolutiveSemiring (a, b) instance ( InvolutiveSemiring a , InvolutiveSemiring b , InvolutiveSemiring c ) => InvolutiveSemiring (a, b, c) instance ( InvolutiveSemiring a , InvolutiveSemiring b , InvolutiveSemiring c , InvolutiveSemiring d ) => InvolutiveSemiring (a, b, c, d) instance ( InvolutiveSemiring a , InvolutiveSemiring b , InvolutiveSemiring c , InvolutiveSemiring d , InvolutiveSemiring e ) => InvolutiveSemiring (a, b, c, d, e) -- | -- > adjoint = id class ( Commutative r , InvolutiveMultiplication r ) => TriviallyInvolutive r instance TriviallyInvolutive Bool instance TriviallyInvolutive Int instance TriviallyInvolutive Integer instance TriviallyInvolutive Int8 instance TriviallyInvolutive Int16 instance TriviallyInvolutive Int32 instance TriviallyInvolutive Int64 instance TriviallyInvolutive Word instance TriviallyInvolutive Natural instance TriviallyInvolutive Word8 instance TriviallyInvolutive Word16 instance TriviallyInvolutive Word32 instance TriviallyInvolutive Word64 instance TriviallyInvolutive () instance ( TriviallyInvolutive a , TriviallyInvolutive b ) => TriviallyInvolutive (a,b) instance ( TriviallyInvolutive a , TriviallyInvolutive b , TriviallyInvolutive c ) => TriviallyInvolutive (a,b,c) instance ( TriviallyInvolutive a , TriviallyInvolutive b , TriviallyInvolutive c , TriviallyInvolutive d ) => TriviallyInvolutive (a,b,c,d) instance ( TriviallyInvolutive a , TriviallyInvolutive b , TriviallyInvolutive c , TriviallyInvolutive d , TriviallyInvolutive e ) => TriviallyInvolutive (a,b,c,d,e) instance ( TriviallyInvolutive r , TriviallyInvolutiveAlgebra r a ) => TriviallyInvolutive (a -> r) instance ( HasTrie a , TriviallyInvolutive r , TriviallyInvolutiveAlgebra r a ) => TriviallyInvolutive (a :->: r) -- inv is an associative algebra homomorphism class (InvolutiveSemiring r, Algebra r a) => InvolutiveAlgebra r a where inv :: (a -> r) -> a -> r instance InvolutiveSemiring r => InvolutiveAlgebra r () where inv = (adjoint .) instance ( InvolutiveAlgebra r a , InvolutiveAlgebra r b ) => InvolutiveAlgebra r (a, b) where inv f (a,b) = inv (\a' -> inv (\b' -> f (a',b')) b) a instance ( InvolutiveAlgebra r a , InvolutiveAlgebra r b , InvolutiveAlgebra r c ) => InvolutiveAlgebra r (a, b, c) where inv f (a,b,c) = inv (\a' -> inv (\b' -> inv (\c' -> f (a',b',c')) c) b) a instance ( InvolutiveAlgebra r a , InvolutiveAlgebra r b , InvolutiveAlgebra r c , InvolutiveAlgebra r d ) => InvolutiveAlgebra r (a, b, c, d) where inv f (a,b,c,d) = inv (\a' -> inv (\b' -> inv (\c' -> inv (\d' -> f (a',b',c',d')) d) c) b) a instance ( InvolutiveAlgebra r a , InvolutiveAlgebra r b , InvolutiveAlgebra r c , InvolutiveAlgebra r d , InvolutiveAlgebra r e ) => InvolutiveAlgebra r (a, b, c, d, e) where inv f (a,b,c,d,e) = inv (\a' -> inv (\b' -> inv (\c' -> inv (\d' -> inv (\e' -> f (a',b',c',d',e')) e) d) c) b) a class ( CommutativeAlgebra r a , TriviallyInvolutive r , InvolutiveAlgebra r a ) => TriviallyInvolutiveAlgebra r a instance ( TriviallyInvolutive r , InvolutiveSemiring r ) => TriviallyInvolutiveAlgebra r () instance ( TriviallyInvolutiveAlgebra r a , TriviallyInvolutiveAlgebra r b ) => TriviallyInvolutiveAlgebra r (a, b) where instance (TriviallyInvolutiveAlgebra r a , TriviallyInvolutiveAlgebra r b , TriviallyInvolutiveAlgebra r c ) => TriviallyInvolutiveAlgebra r (a, b, c) where instance ( TriviallyInvolutiveAlgebra r a , TriviallyInvolutiveAlgebra r b , TriviallyInvolutiveAlgebra r c , TriviallyInvolutiveAlgebra r d ) => TriviallyInvolutiveAlgebra r (a, b, c, d) instance ( TriviallyInvolutiveAlgebra r a , TriviallyInvolutiveAlgebra r b , TriviallyInvolutiveAlgebra r c , TriviallyInvolutiveAlgebra r d , TriviallyInvolutiveAlgebra r e ) => TriviallyInvolutiveAlgebra r (a, b, c, d, e) class ( InvolutiveSemiring r , Coalgebra r c ) => InvolutiveCoalgebra r c where coinv :: (c -> r) -> c -> r instance InvolutiveSemiring r => InvolutiveCoalgebra r () where coinv f c = adjoint (f c) instance ( InvolutiveCoalgebra r a , InvolutiveCoalgebra r b ) => InvolutiveCoalgebra r (a, b) where coinv f (a,b) = coinv (\a' -> coinv (\b' -> f (a',b')) b) a instance ( InvolutiveCoalgebra r a , InvolutiveCoalgebra r b , InvolutiveCoalgebra r c ) => InvolutiveCoalgebra r (a, b, c) where coinv f (a,b,c) = coinv (\a' -> coinv (\b' -> coinv (\c' -> f (a',b',c')) c) b) a instance ( InvolutiveCoalgebra r a , InvolutiveCoalgebra r b , InvolutiveCoalgebra r c , InvolutiveCoalgebra r d ) => InvolutiveCoalgebra r (a, b, c, d) where coinv f (a,b,c,d) = coinv (\a' -> coinv (\b' -> coinv (\c' -> coinv (\d' -> f (a',b',c',d')) d) c) b) a instance ( InvolutiveCoalgebra r a , InvolutiveCoalgebra r b , InvolutiveCoalgebra r c , InvolutiveCoalgebra r d , InvolutiveCoalgebra r e ) => InvolutiveCoalgebra r (a, b, c, d, e) where coinv f (a,b,c,d,e) = coinv (\a' -> coinv (\b' -> coinv (\c' -> coinv (\d' -> coinv (\e' -> f (a',b',c',d',e')) e) d) c) b) a class ( CocommutativeCoalgebra r a , TriviallyInvolutive r , InvolutiveCoalgebra r a ) => TriviallyInvolutiveCoalgebra r a instance ( TriviallyInvolutive r , InvolutiveSemiring r ) => TriviallyInvolutiveCoalgebra r () instance ( TriviallyInvolutiveCoalgebra r a , TriviallyInvolutiveCoalgebra r b ) => TriviallyInvolutiveCoalgebra r (a, b) instance ( TriviallyInvolutiveCoalgebra r a , TriviallyInvolutiveCoalgebra r b , TriviallyInvolutiveCoalgebra r c ) => TriviallyInvolutiveCoalgebra r (a, b, c) instance ( TriviallyInvolutiveCoalgebra r a , TriviallyInvolutiveCoalgebra r b , TriviallyInvolutiveCoalgebra r c , TriviallyInvolutiveCoalgebra r d ) => TriviallyInvolutiveCoalgebra r (a, b, c, d) instance ( TriviallyInvolutiveCoalgebra r a , TriviallyInvolutiveCoalgebra r b , TriviallyInvolutiveCoalgebra r c , TriviallyInvolutiveCoalgebra r d , TriviallyInvolutiveCoalgebra r e ) => TriviallyInvolutiveCoalgebra r (a, b, c, d, e) class ( Bialgebra r h , InvolutiveAlgebra r h , InvolutiveCoalgebra r h ) => InvolutiveBialgebra r h instance ( Bialgebra r h , InvolutiveAlgebra r h , InvolutiveCoalgebra r h ) => InvolutiveBialgebra r h class ( InvolutiveBialgebra r h , TriviallyInvolutiveAlgebra r h , TriviallyInvolutiveCoalgebra r h ) => TriviallyInvolutiveBialgebra r h instance ( InvolutiveBialgebra r h , TriviallyInvolutiveAlgebra r h , TriviallyInvolutiveCoalgebra r h ) => TriviallyInvolutiveBialgebra r h algebra-3.1/src/Numeric/Algebra/Quaternion.hs0000644000000000000000000002262412072477456017373 0ustar0000000000000000{-# LANGUAGE FlexibleInstances , MultiParamTypeClasses , TypeFamilies , UndecidableInstances , DeriveDataTypeable , TypeOperators #-} module Numeric.Algebra.Quaternion ( Distinguished(..) , Complicated(..) , Hamiltonian(..) , QuaternionBasis(..) , Quaternion(..) , complicate , vectorPart , scalarPart ) where import Control.Applicative import Control.Monad.Reader.Class import Data.Ix hiding (index) import Data.Key import Data.Data import Data.Distributive import Data.Functor.Bind import Data.Functor.Representable import Data.Functor.Representable.Trie import Data.Foldable import Data.Traversable import Data.Semigroup import Data.Semigroup.Traversable import Data.Semigroup.Foldable import Numeric.Algebra import Numeric.Algebra.Distinguished.Class import Numeric.Algebra.Complex.Class import Numeric.Algebra.Quaternion.Class import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger) instance Distinguished QuaternionBasis where e = E instance Complicated QuaternionBasis where i = I instance Hamiltonian QuaternionBasis where j = J k = K instance Rig r => Distinguished (Quaternion r) where e = Quaternion one zero zero zero instance Rig r => Complicated (Quaternion r) where i = Quaternion zero one zero zero instance Rig r => Hamiltonian (Quaternion r) where j = Quaternion zero zero one zero k = Quaternion one zero zero one instance Rig r => Distinguished (QuaternionBasis :->: r) where e = Trie e instance Rig r => Complicated (QuaternionBasis :->: r) where i = Trie i instance Rig r => Hamiltonian (QuaternionBasis :->: r) where j = Trie j k = Trie k instance Rig r => Distinguished (QuaternionBasis -> r) where e E = one e _ = zero instance Rig r => Complicated (QuaternionBasis -> r) where i I = one i _ = zero instance Rig r => Hamiltonian (QuaternionBasis -> r) where j J = one j _ = zero k K = one k _ = zero -- quaternion basis data QuaternionBasis = E | I | J | K deriving (Eq,Ord,Enum,Read,Show,Bounded,Ix,Data,Typeable) data Quaternion a = Quaternion a a a a deriving (Eq,Show,Read,Data,Typeable) type instance Key Quaternion = QuaternionBasis instance Representable Quaternion where tabulate f = Quaternion (f E) (f I) (f J) (f K) instance Indexable Quaternion where index (Quaternion a _ _ _) E = a index (Quaternion _ b _ _) I = b index (Quaternion _ _ c _) J = c index (Quaternion _ _ _ d) K = d instance Lookup Quaternion where lookup = lookupDefault instance Adjustable Quaternion where adjust f E (Quaternion a b c d) = Quaternion (f a) b c d adjust f I (Quaternion a b c d) = Quaternion a (f b) c d adjust f J (Quaternion a b c d) = Quaternion a b (f c) d adjust f K (Quaternion a b c d) = Quaternion a b c (f d) instance Distributive Quaternion where distribute = distributeRep instance Functor Quaternion where fmap = fmapRep instance Zip Quaternion where zipWith f (Quaternion a1 b1 c1 d1) (Quaternion a2 b2 c2 d2) = Quaternion (f a1 a2) (f b1 b2) (f c1 c2) (f d1 d2) instance ZipWithKey Quaternion where zipWithKey f (Quaternion a1 b1 c1 d1) (Quaternion a2 b2 c2 d2) = Quaternion (f E a1 a2) (f I b1 b2) (f J c1 c2) (f K d1 d2) instance Keyed Quaternion where mapWithKey = mapWithKeyRep instance Apply Quaternion where (<.>) = apRep instance Applicative Quaternion where pure = pureRep (<*>) = apRep instance Bind Quaternion where (>>-) = bindRep instance Monad Quaternion where return = pureRep (>>=) = bindRep instance MonadReader QuaternionBasis Quaternion where ask = askRep local = localRep instance Foldable Quaternion where foldMap f (Quaternion a b c d) = f a `mappend` f b `mappend` f c `mappend` f d instance FoldableWithKey Quaternion where foldMapWithKey f (Quaternion a b c d) = f E a `mappend` f I b `mappend` f J c `mappend` f K d instance Traversable Quaternion where traverse f (Quaternion a b c d) = Quaternion <$> f a <*> f b <*> f c <*> f d instance TraversableWithKey Quaternion where traverseWithKey f (Quaternion a b c d) = Quaternion <$> f E a <*> f I b <*> f J c <*> f K d instance Foldable1 Quaternion where foldMap1 f (Quaternion a b c d) = f a <> f b <> f c <> f d instance FoldableWithKey1 Quaternion where foldMapWithKey1 f (Quaternion a b c d) = f E a <> f I b <> f J c <> f K d instance Traversable1 Quaternion where traverse1 f (Quaternion a b c d) = Quaternion <$> f a <.> f b <.> f c <.> f d instance TraversableWithKey1 Quaternion where traverseWithKey1 f (Quaternion a b c d) = Quaternion <$> f E a <.> f I b <.> f J c <.> f K d instance HasTrie QuaternionBasis where type BaseTrie QuaternionBasis = Quaternion embedKey = id projectKey = id instance Additive r => Additive (Quaternion r) where (+) = addRep sinnum1p = sinnum1pRep instance LeftModule r s => LeftModule r (Quaternion s) where r .* Quaternion a b c d = Quaternion (r .* a) (r .* b) (r .* c) (r .* d) instance RightModule r s => RightModule r (Quaternion s) where Quaternion a b c d *. r = Quaternion (a *. r) (b *. r) (c *. r) (d *. r) instance Monoidal r => Monoidal (Quaternion r) where zero = zeroRep sinnum = sinnumRep instance Group r => Group (Quaternion r) where (-) = minusRep negate = negateRep subtract = subtractRep times = timesRep instance Abelian r => Abelian (Quaternion r) instance Idempotent r => Idempotent (Quaternion r) instance Partitionable r => Partitionable (Quaternion r) where partitionWith f (Quaternion a b c d) = id =<< partitionWith (\a1 a2 -> id =<< partitionWith (\b1 b2 -> id =<< partitionWith (\c1 c2 -> partitionWith (\d1 d2 -> f (Quaternion a1 b1 c1 d1) (Quaternion a2 b2 c2 d2) ) d) c) b) a -- | the quaternion algebra instance (TriviallyInvolutive r, Rng r) => Algebra r QuaternionBasis where mult f = f' where fe = f E E - (f I I + f J J + f K K) fi = f E I + f I E + f J K - f K J fj = f E J + f J E + f K I - f I K fk = f E K + f K E + f I J - f J I f' E = fe f' I = fi f' J = fj f' K = fk instance (TriviallyInvolutive r, Rng r) => UnitalAlgebra r QuaternionBasis where unit x E = x unit _ _ = zero -- | the trivial diagonal coalgebra instance (TriviallyInvolutive r, Rng r) => Coalgebra r QuaternionBasis where comult f = f' where fe = f E fi = f I fj = f J fk = f K f' E E = fe f' I I = fi f' J J = fj f' K K = fk f' _ _ = zero instance (TriviallyInvolutive r, Rng r) => CounitalCoalgebra r QuaternionBasis where counit f = f E + f I + f J + f K {- -- dual quaternion comultiplication instance (TriviallyInvolutive r, Rng r) => Coalgebra r QuaternionBasis where comult f = f' where fe = f E fi = f I fj = f J fk = f K fe' = negate fe fi' = negate fi fj' = negate fj fk' = negate fk f' E E = fe f' E I = fi f' E J = fj f' E K = fk f' I E = fi f' I I = fe' f' I J = fk f' I K = fj' f' J E = fj f' J I = fk' f' J J = fe' f' J K = fi f' K E = fk f' K I = fj f' K J = fi' f' K K = fe' instance (TriviallyInvolutive r, Rng r) => CounitalCoalgebra r QuaternionBasis where counit f = f E -} instance (TriviallyInvolutive r, Rng r) => Bialgebra r QuaternionBasis instance (TriviallyInvolutive r, InvolutiveSemiring r, Rng r) => InvolutiveAlgebra r QuaternionBasis where inv f E = f E inv f b = negate (f b) instance (TriviallyInvolutive r, InvolutiveSemiring r, Rng r) => InvolutiveCoalgebra r QuaternionBasis where coinv = inv instance (TriviallyInvolutive r, InvolutiveSemiring r, Rng r) => HopfAlgebra r QuaternionBasis where antipode = inv instance (TriviallyInvolutive r, Rng r) => Multiplicative (Quaternion r) where (*) = mulRep instance (TriviallyInvolutive r, Rng r) => Semiring (Quaternion r) instance (TriviallyInvolutive r, Ring r) => Unital (Quaternion r) where one = oneRep instance (TriviallyInvolutive r, Ring r) => Rig (Quaternion r) where fromNatural n = Quaternion (fromNatural n) zero zero zero instance (TriviallyInvolutive r, Ring r) => Ring (Quaternion r) where fromInteger n = Quaternion (fromInteger n) zero zero zero instance ( TriviallyInvolutive r, Rng r) => LeftModule (Quaternion r) (Quaternion r) where (.*) = (*) instance (TriviallyInvolutive r, Rng r) => RightModule (Quaternion r) (Quaternion r) where (*.) = (*) instance (TriviallyInvolutive r, Rng r) => InvolutiveMultiplication (Quaternion r) where -- without trivial involution, multiplication fails associativity, and we'd need to -- support weaker multiplicative properties like Alternative and PowerAssociative adjoint (Quaternion a b c d) = Quaternion a (negate b) (negate c) (negate d) -- | Cayley-Dickson quaternion isomorphism (one way) complicate :: Complicated c => QuaternionBasis -> (c,c) complicate E = (e, e) complicate I = (i, e) complicate J = (e, i) complicate K = (i, i) scalarPart :: (Representable f, Key f ~ QuaternionBasis) => f r -> r scalarPart f = index f E vectorPart :: (Representable f, Key f ~ QuaternionBasis) => f r -> (r,r,r) vectorPart f = (index f I, index f J, index f K) instance (TriviallyInvolutive r, Rng r) => Quadrance r (Quaternion r) where quadrance n = scalarPart (adjoint n * n) instance (TriviallyInvolutive r, Ring r, Division r) => Division (Quaternion r) where recip q@(Quaternion a b c d) = Quaternion (qq \\ a) (qq \\ b) (qq \\ c) (qq \\ d) where qq = quadrance q algebra-3.1/src/Numeric/Algebra/Unital.hs0000644000000000000000000001351612072477456016502 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} module Numeric.Algebra.Unital ( -- * Unital Multiplication (Multiplicative monoid) Unital(..) , product -- * Unital Associative Algebra , UnitalAlgebra(..) -- * Unital Coassociative Coalgebra , CounitalCoalgebra(..) -- * Bialgebra , Bialgebra ) where import Numeric.Algebra.Class import Numeric.Natural.Internal import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Foldable hiding (product) import Data.Int import Data.Word import Prelude hiding ((*), foldr, product) infixr 8 `pow` class Multiplicative r => Unital r where one :: r pow :: Whole n => r -> n -> r pow _ 0 = one pow x0 y0 = f x0 y0 where f x y | even y = f (x * x) (y `quot` 2) | y == 1 = x | otherwise = g (x * x) ((y - 1) `quot` 2) x g x y z | even y = g (x * x) (y `quot` 2) z | y == 1 = x * z | otherwise = g (x * x) ((y - 1) `quot` 2) (x * z) productWith :: Foldable f => (a -> r) -> f a -> r productWith f = foldl' (\b a -> b * f a) one product :: (Foldable f, Unital r) => f r -> r product = productWith id instance Unital Bool where one = True instance Unital Integer where one = 1 instance Unital Int where one = 1 instance Unital Int8 where one = 1 instance Unital Int16 where one = 1 instance Unital Int32 where one = 1 instance Unital Int64 where one = 1 instance Unital Natural where one = 1 instance Unital Word where one = 1 instance Unital Word8 where one = 1 instance Unital Word16 where one = 1 instance Unital Word32 where one = 1 instance Unital Word64 where one = 1 instance Unital () where one = () instance (Unital a, Unital b) => Unital (a,b) where one = (one,one) instance (Unital a, Unital b, Unital c) => Unital (a,b,c) where one = (one,one,one) instance (Unital a, Unital b, Unital c, Unital d) => Unital (a,b,c,d) where one = (one,one,one,one) instance (Unital a, Unital b, Unital c, Unital d, Unital e) => Unital (a,b,c,d,e) where one = (one,one,one,one,one) -- | An associative unital algebra over a semiring, built using a free module class Algebra r a => UnitalAlgebra r a where unit :: r -> a -> r instance (Unital r, UnitalAlgebra r a) => Unital (a -> r) where one = unit one instance Semiring r => UnitalAlgebra r () where unit r () = r -- incoherent -- instance UnitalAlgebra () a where unit _ _ = () -- instance (UnitalAlgebra r a, UnitalAlgebra r b) => UnitalAlgebra (a -> r) b where unit f b a = unit (f a) b instance (UnitalAlgebra r a, UnitalAlgebra r b) => UnitalAlgebra r (a,b) where unit r (a,b) = unit r a * unit r b instance (UnitalAlgebra r a, UnitalAlgebra r b, UnitalAlgebra r c) => UnitalAlgebra r (a,b,c) where unit r (a,b,c) = unit r a * unit r b * unit r c instance (UnitalAlgebra r a, UnitalAlgebra r b, UnitalAlgebra r c, UnitalAlgebra r d) => UnitalAlgebra r (a,b,c,d) where unit r (a,b,c,d) = unit r a * unit r b * unit r c * unit r d instance (UnitalAlgebra r a, UnitalAlgebra r b, UnitalAlgebra r c, UnitalAlgebra r d, UnitalAlgebra r e) => UnitalAlgebra r (a,b,c,d,e) where unit r (a,b,c,d,e) = unit r a * unit r b * unit r c * unit r d * unit r e instance (Monoidal r, Semiring r) => UnitalAlgebra r [a] where unit r [] = r unit _ _ = zero instance (Monoidal r, Semiring r) => UnitalAlgebra r (Seq a) where unit r a | Seq.null a = r | otherwise = zero -- A coassociative counital coalgebra over a semiring, where the module is free class Coalgebra r c => CounitalCoalgebra r c where counit :: (c -> r) -> r instance (Unital r, UnitalAlgebra r m) => CounitalCoalgebra r (m -> r) where counit k = k one -- incoherent -- instance (UnitalAlgebra r a, CounitalCoalgebra r c) => CounitalCoalgebra (a -> r) c where counit k a = counit (`k` a) -- instance CounitalCoalgebra () a where counit _ = () instance Semiring r => CounitalCoalgebra r () where counit f = f () instance (CounitalCoalgebra r a, CounitalCoalgebra r b) => CounitalCoalgebra r (a, b) where counit k = counit $ \a -> counit $ \b -> k (a,b) instance (CounitalCoalgebra r a, CounitalCoalgebra r b, CounitalCoalgebra r c) => CounitalCoalgebra r (a, b, c) where counit k = counit $ \a -> counit $ \b -> counit $ \c -> k (a,b,c) instance (CounitalCoalgebra r a, CounitalCoalgebra r b, CounitalCoalgebra r c, CounitalCoalgebra r d) => CounitalCoalgebra r (a, b, c, d) where counit k = counit $ \a -> counit $ \b -> counit $ \c -> counit $ \d -> k (a,b,c,d) instance (CounitalCoalgebra r a, CounitalCoalgebra r b, CounitalCoalgebra r c, CounitalCoalgebra r d, CounitalCoalgebra r e) => CounitalCoalgebra r (a, b, c, d, e) where counit k = counit $ \a -> counit $ \b -> counit $ \c -> counit $ \d -> counit $ \e -> k (a,b,c,d,e) instance Semiring r => CounitalCoalgebra r [a] where counit k = k [] instance Semiring r => CounitalCoalgebra r (Seq a) where counit k = k (Seq.empty) -- | A bialgebra is both a unital algebra and counital coalgebra -- where the `mult` and `unit` are compatible in some sense with -- the `comult` and `counit`. That is to say that -- 'mult' and 'unit' are a coalgebra homomorphisms or (equivalently) that -- 'comult' and 'counit' are an algebra homomorphisms. class (UnitalAlgebra r a, CounitalCoalgebra r a) => Bialgebra r a -- TODO -- instance (Unital r, Bialgebra r m) => Bialgebra r (m -> r) -- instance Bialgebra () c -- instance (UnitalAlgebra r b, Bialgebra r c) => Bialgebra (b -> r) c instance Semiring r => Bialgebra r () instance (Bialgebra r a, Bialgebra r b) => Bialgebra r (a, b) instance (Bialgebra r a, Bialgebra r b, Bialgebra r c) => Bialgebra r (a, b, c) instance (Bialgebra r a, Bialgebra r b, Bialgebra r c, Bialgebra r d) => Bialgebra r (a, b, c, d) instance (Bialgebra r a, Bialgebra r b, Bialgebra r c, Bialgebra r d, Bialgebra r e) => Bialgebra r (a, b, c, d, e) instance (Monoidal r, Semiring r) => Bialgebra r [a] instance (Monoidal r, Semiring r) => Bialgebra r (Seq a) algebra-3.1/src/Numeric/Algebra/Complex/0000755000000000000000000000000012072477456016313 5ustar0000000000000000algebra-3.1/src/Numeric/Algebra/Complex/Class.hs0000644000000000000000000000044112072477456017713 0ustar0000000000000000module Numeric.Algebra.Complex.Class ( Complicated(..) ) where import Numeric.Algebra.Distinguished.Class import Numeric.Covector import Prelude (return) class Distinguished r => Complicated r where i :: r instance Complicated a => Complicated (Covector r a) where i = return i algebra-3.1/src/Numeric/Algebra/Distinguished/0000755000000000000000000000000012072477456017507 5ustar0000000000000000algebra-3.1/src/Numeric/Algebra/Distinguished/Class.hs0000644000000000000000000000037712072477456021117 0ustar0000000000000000module Numeric.Algebra.Distinguished.Class ( Distinguished(..) ) where import Numeric.Covector -- a basis with a distinguished point class Distinguished t where e :: t instance Distinguished a => Distinguished (Covector r a) where e = return e algebra-3.1/src/Numeric/Algebra/Dual/0000755000000000000000000000000012072477456015571 5ustar0000000000000000algebra-3.1/src/Numeric/Algebra/Dual/Class.hs0000644000000000000000000000041612072477456017173 0ustar0000000000000000module Numeric.Algebra.Dual.Class ( Infinitesimal(..) ) where import Numeric.Algebra.Distinguished.Class import Numeric.Covector class Distinguished t => Infinitesimal t where d :: t instance Infinitesimal a => Infinitesimal (Covector r a) where d = return d algebra-3.1/src/Numeric/Algebra/Quaternion/0000755000000000000000000000000012072477456017031 5ustar0000000000000000algebra-3.1/src/Numeric/Algebra/Quaternion/Class.hs0000644000000000000000000000043412072477456020433 0ustar0000000000000000module Numeric.Algebra.Quaternion.Class ( Hamiltonian(..) ) where import Numeric.Algebra.Complex.Class import Numeric.Covector class Complicated t => Hamiltonian t where j :: t k :: t instance Hamiltonian a => Hamiltonian (Covector r a) where j = return j k = return k algebra-3.1/src/Numeric/Band/0000755000000000000000000000000012072477456014213 5ustar0000000000000000algebra-3.1/src/Numeric/Band/Class.hs0000644000000000000000000000015212072477456015612 0ustar0000000000000000module Numeric.Band.Class ( Band , pow1pBand , powBand ) where import Numeric.Algebra.Idempotent algebra-3.1/src/Numeric/Band/Rectangular.hs0000644000000000000000000000111112072477456017010 0ustar0000000000000000module Numeric.Band.Rectangular ( Rect(..) ) where import Numeric.Algebra.Class import Numeric.Algebra.Idempotent import Data.Semigroupoid -- | a rectangular band is a nowhere commutative semigroup. -- That is to say, if ab = ba then a = b. From this it follows -- classically that aa = a and that such a band is isomorphic -- to the following structure data Rect i j = Rect i j deriving (Eq,Ord,Show,Read) instance Semigroupoid Rect where Rect _ i `o` Rect j _ = Rect j i instance Multiplicative (Rect i j) where Rect i _ * Rect _ j = Rect i j instance Band (Rect i j) algebra-3.1/src/Numeric/Coalgebra/0000755000000000000000000000000012072477456015226 5ustar0000000000000000algebra-3.1/src/Numeric/Coalgebra/Categorical.hs0000644000000000000000000000151512072477456020001 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, PatternGuards #-} module Numeric.Coalgebra.Categorical ( Morphism(..) ) where import Data.Data import Numeric.Partial.Semigroup import Numeric.Partial.Monoid import Numeric.Partial.Group import Numeric.Algebra.Class import Numeric.Algebra.Unital import Numeric.Algebra.Commutative -- the dual categorical algebra newtype Morphism a = Morphism a deriving (Eq,Ord,Show,Read,PartialSemigroup,PartialMonoid,PartialGroup,Data,Typeable) instance (Commutative r, Monoidal r, Semiring r, PartialSemigroup a) => Coalgebra r (Morphism a) where comult f a b | Just c <- padd a b = f c | otherwise = zero instance (Commutative r, Monoidal r, Semiring r, PartialMonoid a) => CounitalCoalgebra r (Morphism a) where counit f = f pzero algebra-3.1/src/Numeric/Coalgebra/Dual.hs0000644000000000000000000001370512072477456016455 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies, UndecidableInstances, DeriveDataTypeable #-} module Numeric.Coalgebra.Dual ( Distinguished(..) , Infinitesimal(..) , DualBasis'(..) , Dual'(..) ) where import Control.Applicative import Control.Monad.Reader.Class import Data.Data import Data.Distributive import Data.Functor.Bind import Data.Functor.Representable import Data.Functor.Representable.Trie import Data.Foldable import Data.Ix import Data.Key import Data.Semigroup.Traversable import Data.Semigroup.Foldable import Data.Semigroup import Data.Traversable import Numeric.Algebra import Numeric.Algebra.Distinguished.Class import Numeric.Algebra.Dual.Class import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger,recip) -- | dual number basis, D^2 = 0. D /= 0. data DualBasis' = E | D deriving (Eq,Ord,Show,Read,Enum,Ix,Bounded,Data,Typeable) data Dual' a = Dual' a a deriving (Eq,Show,Read,Data,Typeable) instance Distinguished DualBasis' where e = E instance Infinitesimal DualBasis' where d = D instance Rig r => Distinguished (Dual' r) where e = Dual' one zero instance Rig r => Infinitesimal (Dual' r) where d = Dual' zero one instance Rig r => Distinguished (DualBasis' -> r) where e E = one e _ = zero instance Rig r => Infinitesimal (DualBasis' -> r) where d D = one d _ = zero type instance Key Dual' = DualBasis' instance Representable Dual' where tabulate f = Dual' (f E) (f D) instance Indexable Dual' where index (Dual' a _ ) E = a index (Dual' _ b ) D = b instance Lookup Dual' where lookup = lookupDefault instance Adjustable Dual' where adjust f E (Dual' a b) = Dual' (f a) b adjust f D (Dual' a b) = Dual' a (f b) instance Distributive Dual' where distribute = distributeRep instance Functor Dual' where fmap f (Dual' a b) = Dual' (f a) (f b) instance Zip Dual' where zipWith f (Dual' a1 b1) (Dual' a2 b2) = Dual' (f a1 a2) (f b1 b2) instance ZipWithKey Dual' where zipWithKey f (Dual' a1 b1) (Dual' a2 b2) = Dual' (f E a1 a2) (f D b1 b2) instance Keyed Dual' where mapWithKey = mapWithKeyRep instance Apply Dual' where (<.>) = apRep instance Applicative Dual' where pure = pureRep (<*>) = apRep instance Bind Dual' where (>>-) = bindRep instance Monad Dual' where return = pureRep (>>=) = bindRep instance MonadReader DualBasis' Dual' where ask = askRep local = localRep instance Foldable Dual' where foldMap f (Dual' a b) = f a `mappend` f b instance FoldableWithKey Dual' where foldMapWithKey f (Dual' a b) = f E a `mappend` f D b instance Traversable Dual' where traverse f (Dual' a b) = Dual' <$> f a <*> f b instance TraversableWithKey Dual' where traverseWithKey f (Dual' a b) = Dual' <$> f E a <*> f D b instance Foldable1 Dual' where foldMap1 f (Dual' a b) = f a <> f b instance FoldableWithKey1 Dual' where foldMapWithKey1 f (Dual' a b) = f E a <> f D b instance Traversable1 Dual' where traverse1 f (Dual' a b) = Dual' <$> f a <.> f b instance TraversableWithKey1 Dual' where traverseWithKey1 f (Dual' a b) = Dual' <$> f E a <.> f D b instance HasTrie DualBasis' where type BaseTrie DualBasis' = Dual' embedKey = id projectKey = id instance Additive r => Additive (Dual' r) where (+) = addRep sinnum1p = sinnum1pRep instance LeftModule r s => LeftModule r (Dual' s) where r .* Dual' a b = Dual' (r .* a) (r .* b) instance RightModule r s => RightModule r (Dual' s) where Dual' a b *. r = Dual' (a *. r) (b *. r) instance Monoidal r => Monoidal (Dual' r) where zero = zeroRep sinnum = sinnumRep instance Group r => Group (Dual' r) where (-) = minusRep negate = negateRep subtract = subtractRep times = timesRep instance Abelian r => Abelian (Dual' r) instance Idempotent r => Idempotent (Dual' r) instance Partitionable r => Partitionable (Dual' r) where partitionWith f (Dual' a b) = id =<< partitionWith (\a1 a2 -> partitionWith (\b1 b2 -> f (Dual' a1 b1) (Dual' a2 b2)) b) a instance Semiring k => Algebra k DualBasis' where mult f = f' where fe = f E E fd = f D D f' E = fe f' D = fd instance Semiring k => UnitalAlgebra k DualBasis' where unit = const -- the trivial coalgebra instance Rng k => Coalgebra k DualBasis' where comult f = f' where fe = f E fd = f D f' E E = fe f' E D = fd f' D E = fd f' D D = zero instance Rng k => CounitalCoalgebra k DualBasis' where counit f = f E instance Rng k => Bialgebra k DualBasis' instance (InvolutiveSemiring k, Rng k) => InvolutiveAlgebra k DualBasis' where inv f = f' where afe = adjoint (f E) nfd = negate (f D) f' E = afe f' D = nfd instance (InvolutiveSemiring k, Rng k) => InvolutiveCoalgebra k DualBasis' where coinv = inv instance (InvolutiveSemiring k, Rng k) => HopfAlgebra k DualBasis' where antipode = inv instance (Commutative r, Rng r) => Multiplicative (Dual' r) where (*) = mulRep instance (TriviallyInvolutive r, Rng r) => Commutative (Dual' r) instance (Commutative r, Rng r) => Semiring (Dual' r) instance (Commutative r, Ring r) => Unital (Dual' r) where one = oneRep instance (Commutative r, Ring r) => Rig (Dual' r) where fromNatural n = Dual' (fromNatural n) zero instance (Commutative r, Ring r) => Ring (Dual' r) where fromInteger n = Dual' (fromInteger n) zero instance (Commutative r, Rng r) => LeftModule (Dual' r) (Dual' r) where (.*) = (*) instance (Commutative r, Rng r) => RightModule (Dual' r) (Dual' r) where (*.) = (*) instance (Commutative r, Rng r, InvolutiveSemiring r) => InvolutiveMultiplication (Dual' r) where adjoint (Dual' a b) = Dual' (adjoint a) (negate b) instance (Commutative r, Rng r, InvolutiveSemiring r) => InvolutiveSemiring (Dual' r) instance (Commutative r, Rng r, InvolutiveSemiring r) => Quadrance r (Dual' r) where quadrance n = case adjoint n * n of Dual' a _ -> a instance (Commutative r, InvolutiveSemiring r, DivisionRing r) => Division (Dual' r) where recip q@(Dual' a b) = Dual' (qq \\ a) (qq \\ b) where qq = quadrance q algebra-3.1/src/Numeric/Coalgebra/Geometric.hs0000644000000000000000000001500712072477456017503 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, BangPatterns, TypeOperators, DeriveDataTypeable, FlexibleInstances, TypeFamilies, PatternGuards, UndecidableInstances, ScopedTypeVariables #-} module Numeric.Coalgebra.Geometric ( -- * Geometric coalgebra primitives BasisCoblade(..) , Comultivector -- * Operations over an eigenbasis , Eigenbasis(..) , Eigenmetric(..) , Euclidean(..) -- * Grade , grade , filterGrade -- * Inversions , reverse , gradeInversion , cliffordConjugate -- * Products , geometric , outer -- * Inner products , contractL , contractR , hestenes , dot , liftProduct ) where import Control.Monad (mfilter) import Data.Bits import Data.Functor.Representable.Trie import Data.Word import Data.Data import Data.Ix import Data.Array.Unboxed import Numeric.Algebra import Prelude hiding ((-),(*),(+),negate,reverse) -- a basis vector for a simple geometric coalgebra with the Euclidean inner product newtype BasisCoblade m = BasisCoblade { runBasisCoblade :: Word64 } deriving ( Eq,Ord,Num,Bits,Enum,Ix,Bounded,Show,Read,Real,Integral , Additive,Abelian,LeftModule Natural,RightModule Natural,Monoidal , Multiplicative,Unital,Commutative , Semiring,Rig , DecidableZero,DecidableAssociates,DecidableUnits ) instance HasTrie (BasisCoblade m) where type BaseTrie (BasisCoblade m) = BaseTrie Word64 embedKey = embedKey . runBasisCoblade projectKey = BasisCoblade . projectKey -- A metric space over an eigenbasis class Eigenbasis m where euclidean :: proxy m -> Bool antiEuclidean :: proxy m -> Bool v :: m -> BasisCoblade m e :: Int -> m -- assuming n /= 0, find the index of the least significant set bit in a basis blade lsb :: BasisCoblade m -> Int lsb n = fromIntegral $ ix ! shiftR ((n .&. (-n)) * 0x07EDD5E59A4E28C2) 58 where -- a 64 bit deBruijn multiplication table ix :: UArray (BasisCoblade m) Word8 ix = listArray (0, 63) [ 63, 0, 58, 1, 59, 47, 53, 2 , 60, 39, 48, 27, 54, 33, 42, 3 , 61, 51, 37, 40, 49, 18, 28, 20 , 55, 30, 34, 11, 43, 14, 22, 4 , 62, 57, 46, 52, 38, 26, 32, 41 , 50, 36, 17, 19, 29, 10, 13, 21 , 56, 45, 25, 31, 35, 16, 9, 12 , 44, 24, 15, 8, 23, 7, 6, 5 ] class (Ring r, Eigenbasis m) => Eigenmetric r m where metric :: m -> r type Comultivector r m = Covector r (BasisCoblade m) -- Euclidean basis, we can work with basis vectors for euclidean spaces of up to 64 dimensions without -- expanding the representation of our basis vectors newtype Euclidean = Euclidean Int deriving ( Eq,Ord,Show,Read,Num,Ix,Enum,Real,Integral , Data,Typeable , Additive,LeftModule Natural,RightModule Natural,Monoidal,Abelian,LeftModule Integer,RightModule Integer,Group , Multiplicative,TriviallyInvolutive,InvolutiveMultiplication,InvolutiveSemiring,Unital,Commutative , Semiring,Rig,Ring ) instance HasTrie Euclidean where type BaseTrie Euclidean = BaseTrie Int embedKey (Euclidean i) = embedKey i projectKey = Euclidean . projectKey instance Eigenbasis Euclidean where euclidean _ = True antiEuclidean _ = False v n = shiftL 1 (fromIntegral n) e = fromIntegral instance Ring r => Eigenmetric r Euclidean where metric _ = one grade :: BasisCoblade m -> Int grade = fromIntegral . count 5 . count 4 . count 3 . count 2 . count 1 . count 0 where count c x = (x .&. mask) + (shiftR x p .&. mask) where p = shiftL 1 c mask = (-1) `div` (shiftL 1 p + 1) m1powTimes :: (Num n, Bits n, Group r) => n -> r -> r m1powTimes n r | (n .&. 1) == 0 = r | otherwise = negate r reorder :: Group r => BasisCoblade m -> BasisCoblade m -> r -> r reorder a0 b = m1powTimes $ go 0 (shiftR a0 1) where go !acc 0 = acc go acc a = go (acc + grade (a .&. b)) (shiftR a 1) -- _k filterGrade :: Monoidal r => BasisCoblade m -> Int -> Comultivector r m filterGrade b k | grade b == k = zero | otherwise = return b instance Eigenmetric r m => Coalgebra r (BasisCoblade m) where comult f n m = scale (n .&. m) $ reorder n m $ f $ xor n m where scale b | euclidean n = id | otherwise = (go one b *) go :: Eigenmetric r m => r -> BasisCoblade m -> r go acc 0 = acc go acc n' | b <- lsb n' , m' <- metric (e b :: m) = go (acc*m') (clearBit n' b) instance Eigenmetric r m => CounitalCoalgebra r (BasisCoblade m) where counit f = f (BasisCoblade zero) -- instance Group r => InvertibleModule r BasisCoblade where -- reversion (A~) is an involution for the outer product reverse :: Group r => BasisCoblade m -> Comultivector r m reverse b = shiftR (g * (g - 1)) 1 `m1powTimes` return b where g = grade b cliffordConjugate :: Group r => BasisCoblade m -> Comultivector r m cliffordConjugate b = shiftR (g * (g + 1)) 1 `m1powTimes` return b where g = grade b -- A^ gradeInversion :: Group r => BasisCoblade m -> Comultivector r m gradeInversion b = grade b `m1powTimes` return b geometric :: Eigenmetric r m => BasisCoblade m -> BasisCoblade m -> Comultivector r m geometric = multM outer :: Eigenmetric r m => BasisCoblade m -> BasisCoblade m -> Comultivector r m outer m n | m .&. n == 0 = geometric m n | otherwise = zero -- A _| B -- grade (A _| B) = grade B - grade A contractL :: Eigenmetric r m => BasisCoblade m -> BasisCoblade m -> Comultivector r m contractL a b | ga Prelude.> gb = zero | otherwise = mfilter (\r -> grade r == gb - ga) (geometric a b) where ga = grade a gb = grade b -- A |_ B -- grade (A |_ B) = grade A - grade B contractR :: Eigenmetric r m => BasisCoblade m -> BasisCoblade m -> Comultivector r m contractR a b | ga Prelude.< gb = zero | otherwise = mfilter (\r -> grade r == ga - gb) (geometric a b) where ga = grade a gb = grade b -- the modified Hestenes' product dot :: Eigenmetric r m => BasisCoblade m -> BasisCoblade m -> Comultivector r m dot a b = mfilter (\r -> grade r == abs(grade a - grade b)) (geometric a b) -- Hestenes' inner product -- if 0 /= grade a <= grade b then -- dot a b = hestenes a b = leftContract a b hestenes :: Eigenmetric r m => BasisCoblade m -> BasisCoblade m -> Comultivector r m hestenes a b | ga == 0 || gb == 0 = zero | otherwise = mfilter (\r -> grade r == abs(ga - gb)) (geometric a b) where ga = grade a gb = grade b liftProduct :: (BasisCoblade m -> BasisCoblade m -> Comultivector r m) -> Comultivector r m -> Comultivector r m -> Comultivector r m liftProduct f ma mb = do a <- ma b <- mb f a b algebra-3.1/src/Numeric/Coalgebra/Hyperbolic.hs0000644000000000000000000001340512072477456017665 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies, UndecidableInstances, DeriveDataTypeable #-} module Numeric.Coalgebra.Hyperbolic ( Hyperbolic(..) , HyperBasis(..) , Hyper(..) ) where import Control.Applicative import Control.Monad.Reader.Class import Data.Data import Data.Distributive import Data.Functor.Bind import Data.Functor.Representable import Data.Functor.Representable.Trie import Data.Foldable import Data.Ix import Data.Key import Data.Semigroup.Traversable import Data.Semigroup.Foldable import Data.Semigroup import Data.Traversable import Numeric.Algebra import Numeric.Coalgebra.Hyperbolic.Class import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger, cosh, sinh) -- complex basis data HyperBasis = Cosh | Sinh deriving (Eq,Ord,Show,Read,Enum,Ix,Bounded,Data,Typeable) data Hyper a = Hyper a a deriving (Eq,Show,Read,Data,Typeable) instance Hyperbolic HyperBasis where cosh = Cosh sinh = Sinh instance Rig r => Hyperbolic (Hyper r) where cosh = Hyper one zero sinh = Hyper zero one instance Rig r => Hyperbolic (HyperBasis -> r) where cosh Sinh = zero cosh Cosh = one sinh Sinh = one sinh Cosh = zero type instance Key Hyper = HyperBasis instance Representable Hyper where tabulate f = Hyper (f Cosh) (f Sinh) instance Indexable Hyper where index (Hyper a _ ) Cosh = a index (Hyper _ b ) Sinh = b instance Lookup Hyper where lookup = lookupDefault instance Adjustable Hyper where adjust f Cosh (Hyper a b) = Hyper (f a) b adjust f Sinh (Hyper a b) = Hyper a (f b) instance Distributive Hyper where distribute = distributeRep instance Functor Hyper where fmap f (Hyper a b) = Hyper (f a) (f b) instance Zip Hyper where zipWith f (Hyper a1 b1) (Hyper a2 b2) = Hyper (f a1 a2) (f b1 b2) instance ZipWithKey Hyper where zipWithKey f (Hyper a1 b1) (Hyper a2 b2) = Hyper (f Cosh a1 a2) (f Sinh b1 b2) instance Keyed Hyper where mapWithKey = mapWithKeyRep instance Apply Hyper where (<.>) = apRep instance Applicative Hyper where pure = pureRep (<*>) = apRep instance Bind Hyper where (>>-) = bindRep instance Monad Hyper where return = pureRep (>>=) = bindRep instance MonadReader HyperBasis Hyper where ask = askRep local = localRep instance Foldable Hyper where foldMap f (Hyper a b) = f a `mappend` f b instance FoldableWithKey Hyper where foldMapWithKey f (Hyper a b) = f Cosh a `mappend` f Sinh b instance Traversable Hyper where traverse f (Hyper a b) = Hyper <$> f a <*> f b instance TraversableWithKey Hyper where traverseWithKey f (Hyper a b) = Hyper <$> f Cosh a <*> f Sinh b instance Foldable1 Hyper where foldMap1 f (Hyper a b) = f a <> f b instance FoldableWithKey1 Hyper where foldMapWithKey1 f (Hyper a b) = f Cosh a <> f Sinh b instance Traversable1 Hyper where traverse1 f (Hyper a b) = Hyper <$> f a <.> f b instance TraversableWithKey1 Hyper where traverseWithKey1 f (Hyper a b) = Hyper <$> f Cosh a <.> f Sinh b instance HasTrie HyperBasis where type BaseTrie HyperBasis = Hyper embedKey = id projectKey = id instance Additive r => Additive (Hyper r) where (+) = addRep sinnum1p = sinnum1pRep instance LeftModule r s => LeftModule r (Hyper s) where r .* Hyper a b = Hyper (r .* a) (r .* b) instance RightModule r s => RightModule r (Hyper s) where Hyper a b *. r = Hyper (a *. r) (b *. r) instance Monoidal r => Monoidal (Hyper r) where zero = zeroRep sinnum = sinnumRep instance Group r => Group (Hyper r) where (-) = minusRep negate = negateRep subtract = subtractRep times = timesRep instance Abelian r => Abelian (Hyper r) instance Idempotent r => Idempotent (Hyper r) instance Partitionable r => Partitionable (Hyper r) where partitionWith f (Hyper a b) = id =<< partitionWith (\a1 a2 -> partitionWith (\b1 b2 -> f (Hyper a1 b1) (Hyper a2 b2)) b) a -- | the trivial diagonal algebra instance Semiring k => Algebra k HyperBasis where mult f = f' where fs = f Sinh Sinh fc = f Cosh Cosh f' Sinh = fs f' Cosh = fc instance Semiring k => UnitalAlgebra k HyperBasis where unit = const -- | the hyperbolic trigonometric coalgebra instance (Commutative k, Semiring k) => Coalgebra k HyperBasis where comult f = f' where fs = f Sinh fc = f Cosh f' Sinh Sinh = fc f' Sinh Cosh = fs f' Cosh Sinh = fs f' Cosh Cosh = fc instance (Commutative k, Semiring k) => CounitalCoalgebra k HyperBasis where counit f = f Cosh instance (Commutative k, Semiring k) => Bialgebra k HyperBasis instance (Commutative k, Group k, InvolutiveSemiring k) => InvolutiveAlgebra k HyperBasis where inv f = f' where afc = adjoint (f Cosh) nfs = negate (f Sinh) f' Cosh = afc f' Sinh = nfs instance (Commutative k, Group k, InvolutiveSemiring k) => InvolutiveCoalgebra k HyperBasis where coinv = inv instance (Commutative k, Group k, InvolutiveSemiring k) => HopfAlgebra k HyperBasis where antipode = inv instance (Commutative k, Semiring k) => Multiplicative (Hyper k) where (*) = mulRep instance (Commutative k, Semiring k) => Commutative (Hyper k) instance (Commutative k, Semiring k) => Semiring (Hyper k) instance (Commutative k, Rig k) => Unital (Hyper k) where one = Hyper one zero instance (Commutative r, Rig r) => Rig (Hyper r) where fromNatural n = Hyper (fromNatural n) zero instance (Commutative r, Ring r) => Ring (Hyper r) where fromInteger n = Hyper (fromInteger n) zero instance (Commutative r, Semiring r) => LeftModule (Hyper r) (Hyper r) where (.*) = (*) instance (Commutative r, Semiring r) => RightModule (Hyper r) (Hyper r) where (*.) = (*) instance (Commutative r, Group r, InvolutiveSemiring r) => InvolutiveMultiplication (Hyper r) where adjoint (Hyper a b) = Hyper (adjoint a) (negate b) instance (Commutative r, Group r, InvolutiveSemiring r) => InvolutiveSemiring (Hyper r) algebra-3.1/src/Numeric/Coalgebra/Incidence.hs0000644000000000000000000000202012072477456017435 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses , FlexibleInstances , UndecidableInstances , DeriveDataTypeable #-} module Numeric.Coalgebra.Incidence ( Interval'(..) , zeta' , moebius' ) where import Data.Data import Numeric.Algebra.Class import Numeric.Algebra.Unital import Numeric.Algebra.Commutative import Numeric.Ring.Class import Numeric.Order.LocallyFinite -- | the dual incidence algebra basis data Interval' a = Interval' a a deriving (Eq,Ord,Show,Read,Data,Typeable) instance (Eq a, Commutative r, Monoidal r, Semiring r) => Coalgebra r (Interval' a) where comult f (Interval' a b) (Interval' b' c) | b == b' = f (Interval' a c) | otherwise = zero instance (Eq a, Bounded a, Commutative r, Monoidal r, Semiring r) => CounitalCoalgebra r (Interval' a) where counit f = f (Interval' minBound maxBound) zeta' :: Unital r => Interval' a -> r zeta' = const one moebius' :: (Ring r, LocallyFiniteOrder a) => Interval' a -> r moebius' (Interval' a b) = moebiusInversion a b algebra-3.1/src/Numeric/Coalgebra/Quaternion.hs0000644000000000000000000002217312072477456017714 0ustar0000000000000000{-# LANGUAGE FlexibleInstances , MultiParamTypeClasses , TypeFamilies , UndecidableInstances , DeriveDataTypeable , TypeOperators #-} module Numeric.Coalgebra.Quaternion ( Distinguished(..) , Complicated(..) , Hamiltonian(..) , QuaternionBasis'(..) , Quaternion'(..) , complicate' , vectorPart' , scalarPart' ) where import Control.Applicative import Control.Monad.Reader.Class import Data.Ix hiding (index) import Data.Key import Data.Data import Data.Distributive import Data.Functor.Bind import Data.Functor.Representable import Data.Functor.Representable.Trie import Data.Foldable import Data.Traversable import Data.Semigroup.Traversable import Data.Semigroup.Foldable import Data.Semigroup import Numeric.Algebra import Numeric.Algebra.Distinguished.Class import Numeric.Algebra.Complex.Class import Numeric.Algebra.Quaternion.Class import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger) instance Distinguished QuaternionBasis' where e = E' instance Complicated QuaternionBasis' where i = I' instance Hamiltonian QuaternionBasis' where j = J' k = K' instance Rig r => Distinguished (Quaternion' r) where e = Quaternion' one zero zero zero instance Rig r => Complicated (Quaternion' r) where i = Quaternion' zero one zero zero instance Rig r => Hamiltonian (Quaternion' r) where j = Quaternion' zero zero one zero k = Quaternion' one zero zero one instance Rig r => Distinguished (QuaternionBasis' :->: r) where e = Trie e instance Rig r => Complicated (QuaternionBasis' :->: r) where i = Trie i instance Rig r => Hamiltonian (QuaternionBasis' :->: r) where j = Trie j k = Trie k instance Rig r => Distinguished (QuaternionBasis' -> r) where e E' = one e _ = zero instance Rig r => Complicated (QuaternionBasis' -> r) where i I' = one i _ = zero instance Rig r => Hamiltonian (QuaternionBasis' -> r) where j J' = one j _ = zero k K' = one k _ = zero -- quaternion basis data QuaternionBasis' = E' | I' | J' | K' deriving (Eq,Ord,Enum,Read,Show,Bounded,Ix,Data,Typeable) data Quaternion' a = Quaternion' a a a a deriving (Eq,Show,Read,Data,Typeable) type instance Key Quaternion' = QuaternionBasis' instance Representable Quaternion' where tabulate f = Quaternion' (f E') (f I') (f J') (f K') instance Indexable Quaternion' where index (Quaternion' a _ _ _) E' = a index (Quaternion' _ b _ _) I' = b index (Quaternion' _ _ c _) J' = c index (Quaternion' _ _ _ d) K' = d instance Lookup Quaternion' where lookup = lookupDefault instance Adjustable Quaternion' where adjust f E' (Quaternion' a b c d) = Quaternion' (f a) b c d adjust f I' (Quaternion' a b c d) = Quaternion' a (f b) c d adjust f J' (Quaternion' a b c d) = Quaternion' a b (f c) d adjust f K' (Quaternion' a b c d) = Quaternion' a b c (f d) instance Distributive Quaternion' where distribute = distributeRep instance Functor Quaternion' where fmap = fmapRep instance Zip Quaternion' where zipWith f (Quaternion' a1 b1 c1 d1) (Quaternion' a2 b2 c2 d2) = Quaternion' (f a1 a2) (f b1 b2) (f c1 c2) (f d1 d2) instance ZipWithKey Quaternion' where zipWithKey f (Quaternion' a1 b1 c1 d1) (Quaternion' a2 b2 c2 d2) = Quaternion' (f E' a1 a2) (f I' b1 b2) (f J' c1 c2) (f K' d1 d2) instance Keyed Quaternion' where mapWithKey = mapWithKeyRep instance Apply Quaternion' where (<.>) = apRep instance Applicative Quaternion' where pure = pureRep (<*>) = apRep instance Bind Quaternion' where (>>-) = bindRep instance Monad Quaternion' where return = pureRep (>>=) = bindRep instance MonadReader QuaternionBasis' Quaternion' where ask = askRep local = localRep instance Foldable Quaternion' where foldMap f (Quaternion' a b c d) = f a `mappend` f b `mappend` f c `mappend` f d instance FoldableWithKey Quaternion' where foldMapWithKey f (Quaternion' a b c d) = f E' a `mappend` f I' b `mappend` f J' c `mappend` f K' d instance Traversable Quaternion' where traverse f (Quaternion' a b c d) = Quaternion' <$> f a <*> f b <*> f c <*> f d instance TraversableWithKey Quaternion' where traverseWithKey f (Quaternion' a b c d) = Quaternion' <$> f E' a <*> f I' b <*> f J' c <*> f K' d instance Foldable1 Quaternion' where foldMap1 f (Quaternion' a b c d) = f a <> f b <> f c <> f d instance FoldableWithKey1 Quaternion' where foldMapWithKey1 f (Quaternion' a b c d) = f E' a <> f I' b <> f J' c <> f K' d instance Traversable1 Quaternion' where traverse1 f (Quaternion' a b c d) = Quaternion' <$> f a <.> f b <.> f c <.> f d instance TraversableWithKey1 Quaternion' where traverseWithKey1 f (Quaternion' a b c d) = Quaternion' <$> f E' a <.> f I' b <.> f J' c <.> f K' d instance HasTrie QuaternionBasis' where type BaseTrie QuaternionBasis' = Quaternion' embedKey = id projectKey = id instance Additive r => Additive (Quaternion' r) where (+) = addRep sinnum1p = sinnum1pRep instance LeftModule r s => LeftModule r (Quaternion' s) where r .* Quaternion' a b c d = Quaternion' (r .* a) (r .* b) (r .* c) (r .* d) instance RightModule r s => RightModule r (Quaternion' s) where Quaternion' a b c d *. r = Quaternion' (a *. r) (b *. r) (c *. r) (d *. r) instance Monoidal r => Monoidal (Quaternion' r) where zero = zeroRep sinnum = sinnumRep instance Group r => Group (Quaternion' r) where (-) = minusRep negate = negateRep subtract = subtractRep times = timesRep instance Abelian r => Abelian (Quaternion' r) instance Idempotent r => Idempotent (Quaternion' r) instance Partitionable r => Partitionable (Quaternion' r) where partitionWith f (Quaternion' a b c d) = id =<< partitionWith (\a1 a2 -> id =<< partitionWith (\b1 b2 -> id =<< partitionWith (\c1 c2 -> partitionWith (\d1 d2 -> f (Quaternion' a1 b1 c1 d1) (Quaternion' a2 b2 c2 d2) ) d) c) b) a -- | the trivial diagonal algebra instance (TriviallyInvolutive r, Semiring r) => Algebra r QuaternionBasis' where mult f = f' where fe = f E' E' fi = f I' I' fj = f J' J' fk = f K' K' f' E' = fe f' I' = fi f' J' = fj f' K' = fk instance (TriviallyInvolutive r, Semiring r) => UnitalAlgebra r QuaternionBasis' where unit = const -- | dual quaternion comultiplication instance (TriviallyInvolutive r, Rng r) => Coalgebra r QuaternionBasis' where comult f = f' where fe = f E' fi = f I' fj = f J' fk = f K' fe' = negate fe fi' = negate fi fj' = negate fj fk' = negate fk f' E' E' = fe f' E' I' = fi f' E' J' = fj f' E' K' = fk f' I' E' = fi f' I' I' = fe' f' I' J' = fk f' I' K' = fj' f' J' E' = fj f' J' I' = fk' f' J' J' = fe' f' J' K' = fi f' K' E' = fk f' K' I' = fj f' K' J' = fi' f' K' K' = fe' instance (TriviallyInvolutive r, Rng r) => CounitalCoalgebra r QuaternionBasis' where counit f = f E' instance (TriviallyInvolutive r, Rng r) => Bialgebra r QuaternionBasis' instance (TriviallyInvolutive r, InvolutiveSemiring r, Rng r) => InvolutiveAlgebra r QuaternionBasis' where inv f E' = f E' inv f b = negate (f b) instance (TriviallyInvolutive r, InvolutiveSemiring r, Rng r) => InvolutiveCoalgebra r QuaternionBasis' where coinv = inv instance (TriviallyInvolutive r, InvolutiveSemiring r, Rng r) => HopfAlgebra r QuaternionBasis' where antipode = inv instance (TriviallyInvolutive r, Semiring r) => Multiplicative (Quaternion' r) where (*) = mulRep instance (TriviallyInvolutive r, Semiring r) => Semiring (Quaternion' r) instance (TriviallyInvolutive r, Ring r) => Unital (Quaternion' r) where one = oneRep instance (TriviallyInvolutive r, Ring r) => Rig (Quaternion' r) where fromNatural n = Quaternion' (fromNatural n) zero zero zero instance (TriviallyInvolutive r, Ring r) => Ring (Quaternion' r) where fromInteger n = Quaternion' (fromInteger n) zero zero zero instance ( TriviallyInvolutive r, Rng r) => LeftModule (Quaternion' r) (Quaternion' r) where (.*) = (*) instance (TriviallyInvolutive r, Rng r) => RightModule (Quaternion' r) (Quaternion' r) where (*.) = (*) instance (TriviallyInvolutive r, Rng r) => InvolutiveMultiplication (Quaternion' r) where -- without trivial involution, multiplication fails associativity, and we'd need to -- support weaker multiplicative properties like Alternative and PowerAssociative adjoint (Quaternion' a b c d) = Quaternion' a (negate b) (negate c) (negate d) -- | Cayley-Dickson quaternion isomorphism (one way) complicate' :: Complicated c => QuaternionBasis' -> (c , c) complicate' E' = (e, e) complicate' I' = (i, e) complicate' J' = (e, i) complicate' K' = (i, i) scalarPart' :: (Representable f, Key f ~ QuaternionBasis') => f r -> r scalarPart' f = index f E' vectorPart' :: (Representable f, Key f ~ QuaternionBasis') => f r -> (r,r,r) vectorPart' f = (index f I', index f J', index f K') instance (TriviallyInvolutive r, Rng r) => Quadrance r (Quaternion' r) where quadrance n = scalarPart' (adjoint n * n) instance (TriviallyInvolutive r, Ring r, Division r) => Division (Quaternion' r) where recip q@(Quaternion' a b c d) = Quaternion' (qq \\ a) (qq \\ b) (qq \\ c) (qq \\ d) where qq = quadrance q algebra-3.1/src/Numeric/Coalgebra/Trigonometric.hs0000644000000000000000000001454712072477456020422 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses , FlexibleInstances , TypeFamilies , UndecidableInstances , DeriveDataTypeable , TypeOperators #-} module Numeric.Coalgebra.Trigonometric ( Trigonometric(..) , TrigBasis(..) , Trig(..) ) where import Control.Applicative import Control.Monad.Reader.Class import Data.Data import Data.Distributive import Data.Functor.Bind import Data.Functor.Representable import Data.Functor.Representable.Trie import Data.Foldable import Data.Ix import Data.Key import Data.Semigroup.Traversable import Data.Semigroup.Foldable import Data.Semigroup import Data.Traversable import Numeric.Algebra import Prelude hiding ((-),(+),(*),negate,subtract, fromInteger, sin, cos) import Numeric.Algebra.Distinguished.Class import Numeric.Algebra.Complex.Class import Numeric.Coalgebra.Trigonometric.Class -- the dual complex basis data TrigBasis = Cos | Sin deriving (Eq,Ord,Show,Read,Enum,Ix,Bounded,Data,Typeable) data Trig a = Trig a a deriving (Eq,Show,Read,Data,Typeable) instance Distinguished TrigBasis where e = Cos instance Complicated TrigBasis where i = Sin instance Trigonometric TrigBasis where cos = Cos sin = Sin instance Rig r => Distinguished (Trig r) where e = Trig one zero instance Rig r => Complicated (Trig r) where i = Trig zero one instance Rig r => Trigonometric (Trig r) where cos = Trig one zero sin = Trig zero one instance Rig r => Distinguished (TrigBasis -> r) where e = cos instance Rig r => Complicated (TrigBasis -> r) where i = sin instance Rig r => Trigonometric (TrigBasis -> r) where cos Sin = zero cos Cos = one sin Sin = one sin Cos = zero instance Rig r => Trigonometric (TrigBasis :->: r) where cos = Trie cos sin = Trie sin instance Rig r => Distinguished (TrigBasis :->: r) where e = Trie e instance Rig r => Complicated (TrigBasis :->: r) where i = Trie i type instance Key Trig = TrigBasis instance Representable Trig where tabulate f = Trig (f Cos) (f Sin) instance Indexable Trig where index (Trig a _ ) Cos = a index (Trig _ b ) Sin = b instance Lookup Trig where lookup = lookupDefault instance Adjustable Trig where adjust f Cos (Trig a b) = Trig (f a) b adjust f Sin (Trig a b) = Trig a (f b) instance Distributive Trig where distribute = distributeRep instance Functor Trig where fmap f (Trig a b) = Trig (f a) (f b) instance Zip Trig where zipWith f (Trig a1 b1) (Trig a2 b2) = Trig (f a1 a2) (f b1 b2) instance ZipWithKey Trig where zipWithKey f (Trig a1 b1) (Trig a2 b2) = Trig (f Cos a1 a2) (f Sin b1 b2) instance Keyed Trig where mapWithKey = mapWithKeyRep instance Apply Trig where (<.>) = apRep instance Applicative Trig where pure = pureRep (<*>) = apRep instance Bind Trig where (>>-) = bindRep instance Monad Trig where return = pureRep (>>=) = bindRep instance MonadReader TrigBasis Trig where ask = askRep local = localRep instance Foldable Trig where foldMap f (Trig a b) = f a `mappend` f b instance FoldableWithKey Trig where foldMapWithKey f (Trig a b) = f Cos a `mappend` f Sin b instance Traversable Trig where traverse f (Trig a b) = Trig <$> f a <*> f b instance TraversableWithKey Trig where traverseWithKey f (Trig a b) = Trig <$> f Cos a <*> f Sin b instance Foldable1 Trig where foldMap1 f (Trig a b) = f a <> f b instance FoldableWithKey1 Trig where foldMapWithKey1 f (Trig a b) = f Cos a <> f Sin b instance Traversable1 Trig where traverse1 f (Trig a b) = Trig <$> f a <.> f b instance TraversableWithKey1 Trig where traverseWithKey1 f (Trig a b) = Trig <$> f Cos a <.> f Sin b instance HasTrie TrigBasis where type BaseTrie TrigBasis = Trig embedKey = id projectKey = id instance Additive r => Additive (Trig r) where (+) = addRep sinnum1p = sinnum1pRep instance LeftModule r s => LeftModule r (Trig s) where r .* Trig a b = Trig (r .* a) (r .* b) instance RightModule r s => RightModule r (Trig s) where Trig a b *. r = Trig (a *. r) (b *. r) instance Monoidal r => Monoidal (Trig r) where zero = zeroRep sinnum = sinnumRep instance Group r => Group (Trig r) where (-) = minusRep negate = negateRep subtract = subtractRep times = timesRep instance Abelian r => Abelian (Trig r) instance Idempotent r => Idempotent (Trig r) instance Partitionable r => Partitionable (Trig r) where partitionWith f (Trig a b) = id =<< partitionWith (\a1 a2 -> partitionWith (\b1 b2 -> f (Trig a1 b1) (Trig a2 b2)) b) a -- the diagonal algebra instance (Commutative k, Rng k) => Algebra k TrigBasis where mult f = f' where fc = f Cos Cos fs = f Sin Sin f' Cos = fc f' Sin = fs -- instance (Commutative k, Rng k) => UnitalAlgebra k TrigBasis where unit = const -- The trigonometric coalgebra instance (Commutative k, Rng k) => Coalgebra k TrigBasis where comult f = f' where fs = f Sin fc = f Cos fc' = negate fc f' Sin Sin = fc' f' Sin Cos = fs f' Cos Sin = fs f' Cos Cos = fc instance (Commutative k, Rng k) => Bialgebra k TrigBasis instance (Commutative k, Group k, InvolutiveSemiring k) => InvolutiveAlgebra k TrigBasis where inv f = f' where afc = adjoint (f Cos) nfs = negate (f Sin) f' Cos = afc f' Sin = nfs instance (Commutative k, Group k, InvolutiveSemiring k) => InvolutiveCoalgebra k TrigBasis where coinv = inv instance (Commutative k, Group k, InvolutiveSemiring k) => HopfAlgebra k TrigBasis where antipode = inv instance (Commutative k, Rng k) => CounitalCoalgebra k TrigBasis where counit f = f Cos instance (Commutative k, Rng k) => Multiplicative (Trig k) where (*) = mulRep instance (Commutative k, Rng k) => Commutative (Trig k) instance (Commutative k, Rng k) => Semiring (Trig k) instance (Commutative k, Ring k) => Unital (Trig k) where one = Trig one zero instance (Commutative r, Ring r) => Rig (Trig r) where fromNatural n = Trig (fromNatural n) zero instance (Commutative r, Ring r) => Ring (Trig r) where fromInteger n = Trig (fromInteger n) zero instance (Commutative r, Rng r) => LeftModule (Trig r) (Trig r) where (.*) = (*) instance (Commutative r, Rng r) => RightModule (Trig r) (Trig r) where (*.) = (*) instance (Commutative r, Rng r, InvolutiveMultiplication r) => InvolutiveMultiplication (Trig r) where adjoint (Trig a b) = Trig (adjoint a) (negate b) instance (Commutative r, Rng r, InvolutiveSemiring r) => InvolutiveSemiring (Trig r) algebra-3.1/src/Numeric/Coalgebra/Hyperbolic/0000755000000000000000000000000012072477456017326 5ustar0000000000000000algebra-3.1/src/Numeric/Coalgebra/Hyperbolic/Class.hs0000644000000000000000000000041612072477456020730 0ustar0000000000000000module Numeric.Coalgebra.Hyperbolic.Class ( Hyperbolic(..) ) where import Prelude (return) import Numeric.Covector class Hyperbolic r where cosh :: r sinh :: r instance Hyperbolic a => Hyperbolic (Covector r a) where cosh = return cosh sinh = return sinh algebra-3.1/src/Numeric/Coalgebra/Trigonometric/0000755000000000000000000000000012072477456020053 5ustar0000000000000000algebra-3.1/src/Numeric/Coalgebra/Trigonometric/Class.hs0000644000000000000000000000042712072477456021457 0ustar0000000000000000module Numeric.Coalgebra.Trigonometric.Class ( Trigonometric(..) ) where import Prelude (return) import Numeric.Covector class Trigonometric r where cos :: r sin :: r instance Trigonometric a => Trigonometric (Covector r a) where cos = return cos sin = return sin algebra-3.1/src/Numeric/Decidable/0000755000000000000000000000000012072477456015203 5ustar0000000000000000algebra-3.1/src/Numeric/Decidable/Associates.hs0000644000000000000000000000506212072477456017640 0ustar0000000000000000module Numeric.Decidable.Associates ( DecidableAssociates(..) , isAssociateIntegral , isAssociateWhole ) where import Data.Function (on) import Data.Int import Data.Word import Numeric.Algebra.Unital import Numeric.Natural.Internal isAssociateIntegral :: (Eq n, Num n) => n -> n -> Bool isAssociateIntegral = (==) `on` abs isAssociateWhole :: Eq n => n -> n -> Bool isAssociateWhole = (==) class Unital r => DecidableAssociates r where -- | b is an associate of a if there exists a unit u such that b = a*u -- -- This relationship is symmetric because if u is a unit, u^-1 exists and is a unit, so -- -- > b*u^-1 = a*u*u^-1 = a isAssociate :: r -> r -> Bool instance DecidableAssociates Bool where isAssociate = (==) instance DecidableAssociates Integer where isAssociate = isAssociateIntegral instance DecidableAssociates Int where isAssociate = isAssociateIntegral instance DecidableAssociates Int8 where isAssociate = isAssociateIntegral instance DecidableAssociates Int16 where isAssociate = isAssociateIntegral instance DecidableAssociates Int32 where isAssociate = isAssociateIntegral instance DecidableAssociates Int64 where isAssociate = isAssociateIntegral instance DecidableAssociates Natural where isAssociate = isAssociateWhole instance DecidableAssociates Word where isAssociate = isAssociateWhole instance DecidableAssociates Word8 where isAssociate = isAssociateWhole instance DecidableAssociates Word16 where isAssociate = isAssociateWhole instance DecidableAssociates Word32 where isAssociate = isAssociateWhole instance DecidableAssociates Word64 where isAssociate = isAssociateWhole instance DecidableAssociates () where isAssociate _ _ = True instance (DecidableAssociates a, DecidableAssociates b) => DecidableAssociates (a, b) where isAssociate (a,b) (i,j) = isAssociate a i && isAssociate b j instance (DecidableAssociates a, DecidableAssociates b, DecidableAssociates c) => DecidableAssociates (a, b, c) where isAssociate (a,b,c) (i,j,k) = isAssociate a i && isAssociate b j && isAssociate c k instance (DecidableAssociates a, DecidableAssociates b, DecidableAssociates c, DecidableAssociates d) => DecidableAssociates (a, b, c, d) where isAssociate (a,b,c,d) (i,j,k,l) = isAssociate a i && isAssociate b j && isAssociate c k && isAssociate d l instance (DecidableAssociates a, DecidableAssociates b, DecidableAssociates c, DecidableAssociates d, DecidableAssociates e) => DecidableAssociates (a, b, c, d, e) where isAssociate (a,b,c,d,e) (i,j,k,l,m) = isAssociate a i && isAssociate b j && isAssociate c k && isAssociate d l && isAssociate e m algebra-3.1/src/Numeric/Decidable/Units.hs0000644000000000000000000000550012072477456016641 0ustar0000000000000000module Numeric.Decidable.Units ( DecidableUnits(..) , recipUnitIntegral , recipUnitWhole ) where import Data.Maybe (isJust) import Data.Int import Data.Word import Numeric.Algebra.Class import Numeric.Algebra.Unital import Numeric.Natural.Internal import Control.Applicative import Prelude hiding ((*)) class Unital r => DecidableUnits r where recipUnit :: r -> Maybe r isUnit :: DecidableUnits r => r -> Bool isUnit = isJust . recipUnit (^?) :: Integral n => r -> n -> Maybe r x0 ^? y0 = case compare y0 0 of LT -> fmap (`f` negate y0) (recipUnit x0) EQ -> Just one GT -> Just (f x0 y0) where f x y | even y = f (x * x) (y `quot` 2) | y == 1 = x | otherwise = g (x * x) ((y - 1) `quot` 2) x g x y z | even y = g (x * x) (y `quot` 2) z | y == 1 = x * z | otherwise = g (x * x) ((y - 1) `quot` 2) (x * z) recipUnitIntegral :: Integral r => r -> Maybe r recipUnitIntegral a@1 = Just a recipUnitIntegral a@(-1) = Just a recipUnitIntegral _ = Nothing recipUnitWhole :: Integral r => r -> Maybe r recipUnitWhole a@1 = Just a recipUnitWhole _ = Nothing instance DecidableUnits Bool where recipUnit False = Nothing recipUnit True = Just True instance DecidableUnits Integer where recipUnit = recipUnitIntegral instance DecidableUnits Int where recipUnit = recipUnitIntegral instance DecidableUnits Int8 where recipUnit = recipUnitIntegral instance DecidableUnits Int16 where recipUnit = recipUnitIntegral instance DecidableUnits Int32 where recipUnit = recipUnitIntegral instance DecidableUnits Int64 where recipUnit = recipUnitIntegral instance DecidableUnits Natural where recipUnit = recipUnitWhole instance DecidableUnits Word where recipUnit = recipUnitWhole instance DecidableUnits Word8 where recipUnit = recipUnitWhole instance DecidableUnits Word16 where recipUnit = recipUnitWhole instance DecidableUnits Word32 where recipUnit = recipUnitWhole instance DecidableUnits Word64 where recipUnit = recipUnitWhole instance DecidableUnits () where recipUnit _ = Just () instance (DecidableUnits a, DecidableUnits b) => DecidableUnits (a, b) where recipUnit (a,b) = (,) <$> recipUnit a <*> recipUnit b instance (DecidableUnits a, DecidableUnits b, DecidableUnits c) => DecidableUnits (a, b, c) where recipUnit (a,b,c) = (,,) <$> recipUnit a <*> recipUnit b <*> recipUnit c instance (DecidableUnits a, DecidableUnits b, DecidableUnits c, DecidableUnits d) => DecidableUnits (a, b, c, d) where recipUnit (a,b,c,d) = (,,,) <$> recipUnit a <*> recipUnit b <*> recipUnit c <*> recipUnit d instance (DecidableUnits a, DecidableUnits b, DecidableUnits c, DecidableUnits d, DecidableUnits e) => DecidableUnits (a, b, c, d, e) where recipUnit (a,b,c,d,e) = (,,,,) <$> recipUnit a <*> recipUnit b <*> recipUnit c <*> recipUnit d <*> recipUnit e algebra-3.1/src/Numeric/Decidable/Zero.hs0000644000000000000000000000305412072477456016460 0ustar0000000000000000module Numeric.Decidable.Zero ( DecidableZero(..) ) where import Numeric.Algebra.Class import Data.Int import Data.Word import Numeric.Natural.Internal class Monoidal r => DecidableZero r where isZero :: r -> Bool instance DecidableZero Bool where isZero = not instance DecidableZero Integer where isZero = (0==) instance DecidableZero Int where isZero = (0==) instance DecidableZero Int8 where isZero = (0==) instance DecidableZero Int16 where isZero = (0==) instance DecidableZero Int32 where isZero = (0==) instance DecidableZero Int64 where isZero = (0==) instance DecidableZero Natural where isZero = (0==) instance DecidableZero Word where isZero = (0==) instance DecidableZero Word8 where isZero = (0==) instance DecidableZero Word16 where isZero = (0==) instance DecidableZero Word32 where isZero = (0==) instance DecidableZero Word64 where isZero = (0==) instance DecidableZero () where isZero _ = True instance (DecidableZero a, DecidableZero b) => DecidableZero (a, b) where isZero (a,b) = isZero a && isZero b instance (DecidableZero a, DecidableZero b, DecidableZero c) => DecidableZero (a, b, c) where isZero (a,b,c) = isZero a && isZero b && isZero c instance (DecidableZero a, DecidableZero b, DecidableZero c, DecidableZero d) => DecidableZero (a, b, c, d) where isZero (a,b,c,d) = isZero a && isZero b && isZero c && isZero d instance (DecidableZero a, DecidableZero b, DecidableZero c, DecidableZero d, DecidableZero e) => DecidableZero (a, b, c, d, e) where isZero (a,b,c,d,e) = isZero a && isZero b && isZero c && isZero d && isZero e algebra-3.1/src/Numeric/Dioid/0000755000000000000000000000000012072477456014377 5ustar0000000000000000algebra-3.1/src/Numeric/Dioid/Class.hs0000644000000000000000000000040112072477456015773 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} module Numeric.Dioid.Class ( Dioid ) where import Numeric.Additive.Class import Numeric.Algebra.Class class (Semiring r, Idempotent r) => Dioid r instance (Semiring r, Idempotent r) => Dioid r algebra-3.1/src/Numeric/Field/0000755000000000000000000000000012072477456014372 5ustar0000000000000000algebra-3.1/src/Numeric/Field/Class.hs0000644000000000000000000000042012072477456015767 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} module Numeric.Field.Class ( Field ) where import Numeric.Ring.Division import Numeric.Algebra.Commutative class (Commutative r, DivisionRing r) => Field r instance (Commutative r, DivisionRing r) => Field r algebra-3.1/src/Numeric/Module/0000755000000000000000000000000012072477456014574 5ustar0000000000000000algebra-3.1/src/Numeric/Module/Class.hs0000644000000000000000000000023112072477456016171 0ustar0000000000000000module Numeric.Module.Class ( -- * Module over semirings LeftModule(..) , RightModule(..) , Module ) where import Numeric.Algebra.Class algebra-3.1/src/Numeric/Module/Representable.hs0000644000000000000000000000475212072477456017733 0ustar0000000000000000{-# LANGUAGE RebindableSyntax, FlexibleContexts #-} module Numeric.Module.Representable ( -- * Representable Additive addRep, sinnum1pRep -- * Representable Monoidal , zeroRep, sinnumRep -- * Representable Group , negateRep, minusRep, subtractRep, timesRep -- * Representable Multiplicative (via Algebra) , mulRep -- * Representable Unital (via UnitalAlgebra) , oneRep -- * Representable Rig (via Algebra) , fromNaturalRep -- * Representable Ring (via Algebra) , fromIntegerRep ) where import Control.Applicative import Data.Functor import Data.Functor.Representable import Data.Key import Numeric.Additive.Class import Numeric.Additive.Group import Numeric.Algebra.Class import Numeric.Algebra.Unital import Numeric.Natural.Internal import Numeric.Rig.Class import Numeric.Ring.Class import Control.Category import Prelude (($), Integral(..),Integer) -- | `Additive.(+)` default definition addRep :: (Zip m, Additive r) => m r -> m r -> m r addRep = zipWith (+) -- | `Additive.sinnum1p` default definition sinnum1pRep :: (Whole n, Functor m, Additive r) => n -> m r -> m r sinnum1pRep = fmap . sinnum1p -- | `Monoidal.zero` default definition zeroRep :: (Applicative m, Monoidal r) => m r zeroRep = pure zero -- | `Monoidal.sinnum` default definition sinnumRep :: (Whole n, Functor m, Monoidal r) => n -> m r -> m r sinnumRep = fmap . sinnum -- | `Group.negate` default definition negateRep :: (Functor m, Group r) => m r -> m r negateRep = fmap negate -- | `Group.(-)` default definition minusRep :: (Zip m, Group r) => m r -> m r -> m r minusRep = zipWith (-) -- | `Group.subtract` default definition subtractRep :: (Zip m, Group r) => m r -> m r -> m r subtractRep = zipWith subtract -- | `Group.times` default definition timesRep :: (Integral n, Functor m, Group r) => n -> m r -> m r timesRep = fmap . times -- | `Multiplicative.(*)` default definition mulRep :: (Representable m, Algebra r (Key m)) => m r -> m r -> m r mulRep m n = tabulate $ mult (\b1 b2 -> index m b1 * index n b2) -- | `Unital.one` default definition oneRep :: (Representable m, Unital r, UnitalAlgebra r (Key m)) => m r oneRep = tabulate $ unit one -- | `Rig.fromNatural` default definition fromNaturalRep :: (UnitalAlgebra r (Key m), Representable m, Rig r) => Natural -> m r fromNaturalRep n = tabulate $ unit (fromNatural n) -- | `Ring.fromInteger` default definition fromIntegerRep :: (UnitalAlgebra r (Key m), Representable m, Ring r) => Integer -> m r fromIntegerRep n = tabulate $ unit (fromInteger n) algebra-3.1/src/Numeric/Order/0000755000000000000000000000000012072477456014422 5ustar0000000000000000algebra-3.1/src/Numeric/Order/Additive.hs0000644000000000000000000000143112072477456016506 0ustar0000000000000000module Numeric.Order.Additive ( AdditiveOrder ) where import Numeric.Natural.Internal import Numeric.Additive.Class import Numeric.Order.Class -- An additive semigroup with a partial order (<=) -- | z + x <= z + y = x <= y = x + z <= y + z class (Additive r, Order r) => AdditiveOrder r instance AdditiveOrder Integer instance AdditiveOrder Natural instance AdditiveOrder Bool instance AdditiveOrder () instance (AdditiveOrder a, AdditiveOrder b) => AdditiveOrder (a,b) instance (AdditiveOrder a, AdditiveOrder b, AdditiveOrder c) => AdditiveOrder (a,b,c) instance (AdditiveOrder a, AdditiveOrder b, AdditiveOrder c, AdditiveOrder d) => AdditiveOrder (a,b,c,d) instance (AdditiveOrder a, AdditiveOrder b, AdditiveOrder c, AdditiveOrder d, AdditiveOrder e) => AdditiveOrder (a,b,c,d,e) algebra-3.1/src/Numeric/Order/Class.hs0000644000000000000000000000411012072477456016017 0ustar0000000000000000module Numeric.Order.Class ( Order(..) , orderOrd ) where import Data.Int import Data.Word import Data.Set import Numeric.Natural.Internal -- a partial order (a, <=) class Order a where (<~) :: a -> a -> Bool a <~ b = maybe False (<= EQ) (order a b) (<) :: a -> a -> Bool a < b = order a b == Just LT (>~) :: a -> a -> Bool a >~ b = b <~ a (>) :: a -> a -> Bool a > b = order a b == Just GT (~~) :: a -> a -> Bool a ~~ b = order a b == Just EQ (/~) :: a -> a -> Bool a /~ b = order a b /= Just EQ order :: a -> a -> Maybe Ordering order a b | a <~ b = Just $ if b <~ a then EQ else LT | b <~ a = Just GT | otherwise = Nothing comparable :: a -> a -> Bool comparable a b = maybe False (const True) (order a b) orderOrd :: Ord a => a -> a -> Maybe Ordering orderOrd a b = Just (compare a b) instance Order Bool where order = orderOrd instance Order Integer where order = orderOrd instance Order Int where order = orderOrd instance Order Int8 where order = orderOrd instance Order Int16 where order = orderOrd instance Order Int32 where order = orderOrd instance Order Int64 where order = orderOrd instance Order Natural where order = orderOrd instance Order Word where order = orderOrd instance Order Word8 where order = orderOrd instance Order Word16 where order = orderOrd instance Order Word32 where order = orderOrd instance Order Word64 where order = orderOrd instance Ord a => Order (Set a) where (<~) = isSubsetOf instance Order () where order _ _ = Just EQ _ <~ _ = True comparable _ _ = True instance (Order a, Order b) => Order (a, b) where (a,b) <~ (i,j) = a <~ i && b <~ j instance (Order a, Order b, Order c) => Order (a, b, c) where (a,b,c) <~ (i,j,k) = a <~ i && b <~ j && c <~ k instance (Order a, Order b, Order c, Order d) => Order (a, b, c, d) where (a,b,c,d) <~ (i,j,k,l) = a <~ i && b <~ j && c <~ k && d <~ l instance (Order a, Order b, Order c, Order d, Order e) => Order (a, b, c, d, e) where (a,b,c,d,e) <~ (i,j,k,l,m) = a <~ i && b <~ j && c <~ k && d <~ l && e <~ m algebra-3.1/src/Numeric/Order/LocallyFinite.hs0000644000000000000000000001550312072477456017520 0ustar0000000000000000module Numeric.Order.LocallyFinite ( LocallyFiniteOrder(..) ) where import Control.Applicative import Numeric.Additive.Class import Numeric.Additive.Group import Numeric.Algebra.Class import Numeric.Algebra.Unital import Numeric.Order.Class import Numeric.Natural.Internal import Numeric.Rig.Class import Numeric.Ring.Class import Data.Int import Data.Bits import Data.Word import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Ix as Ix import Prelude hiding ((*),(+),fromIntegral,(<),negate,(-)) class Order a => LocallyFiniteOrder a where range :: a -> a -> [a] rangeSize :: a -> a -> Natural -- moebiusInversion inversion moebiusInversion :: Ring r => a -> a -> r moebiusInversion x y = case order x y of Just EQ -> one Just LT -> sumWith (\z -> if z < y then moebiusInversion x z else zero) $ range x y _ -> zero instance LocallyFiniteOrder Natural where range = curry Ix.range rangeSize a b | a <= b = Natural (runNatural b - runNatural a + 1) | otherwise = 0 moebiusInversion x y = case compare x y of EQ -> one LT | unsafePred y == x -> negate one _ -> zero instance LocallyFiniteOrder Integer where range = curry Ix.range rangeSize a b | a <= b = Natural (b - a + 1) | otherwise = 0 moebiusInversion x y = case compare x y of EQ -> one LT | y - 1 == x -> negate one _ -> zero instance Ord a => LocallyFiniteOrder (Set a) where range a b | Set.isSubsetOf a b = go a $ Set.toList $ Set.difference b a | otherwise = [] where go _ [] = [] go s (x:xs) = do s' <- [s, Set.insert x s] go s' xs rangeSize a b | Set.isSubsetOf a b = fromNatural $ shiftL 1 $ Set.size b - Set.size a | otherwise = zero moebiusInversion a b | Set.isSubsetOf a b = if (Set.size b - Set.size a) .&. 1 == 0 then one else negate one | otherwise = zero instance LocallyFiniteOrder Bool where range False False = [False] range False True = [False, True] range True False = [] range True True = [True] rangeSize False False = 1 rangeSize False True = 2 rangeSize True False = 0 rangeSize True True = 1 moebiusInversion False False = one moebiusInversion False True = negate one moebiusInversion True False = zero moebiusInversion True True = one instance LocallyFiniteOrder Int where range = curry Ix.range rangeSize a b | a <= b = Natural $ fromIntegral $ b - a + 1 | otherwise = 0 moebiusInversion x y = case compare x y of EQ -> one LT | y - 1 == x -> negate one _ -> zero instance LocallyFiniteOrder Int8 where range = curry Ix.range rangeSize a b | a <= b = Natural $ fromIntegral $ b - a + 1 | otherwise = 0 moebiusInversion x y = case compare x y of EQ -> one LT | y - 1 == x -> negate one _ -> zero instance LocallyFiniteOrder Int16 where range = curry Ix.range rangeSize a b | a <= b = Natural $ fromIntegral $ b - a + 1 | otherwise = 0 moebiusInversion x y = case compare x y of EQ -> one LT | y - 1 == x -> negate one _ -> zero instance LocallyFiniteOrder Int32 where range = curry Ix.range rangeSize a b | a <= b = Natural $ fromIntegral $ b - a + 1 | otherwise = 0 moebiusInversion x y = case compare x y of EQ -> one LT | y - 1 == x -> negate one _ -> zero instance LocallyFiniteOrder Int64 where range = curry Ix.range rangeSize a b | a <= b = Natural $ fromIntegral $ b - a + 1 | otherwise = 0 moebiusInversion x y = case compare x y of EQ -> one LT | y - 1 == x -> negate one _ -> zero instance LocallyFiniteOrder Word where range = curry Ix.range rangeSize a b | a <= b = Natural $ fromIntegral $ b - a + 1 | otherwise = 0 moebiusInversion x y = case compare x y of EQ -> one LT | y - 1 == x -> negate one _ -> zero instance LocallyFiniteOrder Word8 where range = curry Ix.range rangeSize a b | a <= b = Natural $ fromIntegral $ b - a + 1 | otherwise = 0 moebiusInversion x y = case compare x y of EQ -> one LT | y - 1 == x -> negate one _ -> zero instance LocallyFiniteOrder Word16 where range = curry Ix.range rangeSize a b | a <= b = Natural $ fromIntegral $ b - a + 1 | otherwise = 0 moebiusInversion x y = case compare x y of EQ -> one LT | y - 1 == x -> negate one _ -> zero instance LocallyFiniteOrder Word32 where range = curry Ix.range rangeSize a b | a <= b = Natural $ fromIntegral $ b - a + 1 | otherwise = 0 moebiusInversion x y = case compare x y of EQ -> one LT | y - 1 == x -> negate one _ -> zero instance LocallyFiniteOrder Word64 where range = curry Ix.range rangeSize a b | a <= b = Natural $ fromIntegral $ b - a + 1 | otherwise = 0 moebiusInversion x y = case compare x y of EQ -> one LT | y - 1 == x -> negate one _ -> zero instance LocallyFiniteOrder () where range _ _ = [()] rangeSize _ _ = 1 moebiusInversion _ _ = one instance ( LocallyFiniteOrder a , LocallyFiniteOrder b ) => LocallyFiniteOrder (a,b) where range (a,b) (i,j) = (,) <$> range a i <*> range b j rangeSize (a,b) (i,j) = rangeSize a i * rangeSize b j -- TODO: check this against the default definition above moebiusInversion (a,b) (i,j) = moebiusInversion a i * moebiusInversion b j instance ( LocallyFiniteOrder a , LocallyFiniteOrder b , LocallyFiniteOrder c ) => LocallyFiniteOrder (a,b,c) where range (a,b,c) (i,j,k) = (,,) <$> range a i <*> range b j <*> range c k rangeSize (a,b,c) (i,j,k) = rangeSize a i * rangeSize b j * rangeSize c k moebiusInversion (a,b,c) (i,j,k) = moebiusInversion a i * moebiusInversion b j * moebiusInversion c k instance ( LocallyFiniteOrder a , LocallyFiniteOrder b , LocallyFiniteOrder c , LocallyFiniteOrder d ) => LocallyFiniteOrder (a,b,c,d) where range (a,b,c,d) (i,j,k,l) = (,,,) <$> range a i <*> range b j <*> range c k <*> range d l rangeSize (a,b,c,d) (i,j,k,l) = rangeSize a i * rangeSize b j * rangeSize c k * rangeSize d l moebiusInversion (a,b,c,d) (i,j,k,l) = moebiusInversion a i * moebiusInversion b j * moebiusInversion c k * moebiusInversion d l instance ( LocallyFiniteOrder a , LocallyFiniteOrder b , LocallyFiniteOrder c , LocallyFiniteOrder d , LocallyFiniteOrder e ) => LocallyFiniteOrder (a, b, c, d, e) where range (a,b,c,d,e) (i,j,k,l,m) = (,,,,) <$> range a i <*> range b j <*> range c k <*> range d l <*> range e m rangeSize (a,b,c,d,e) (i,j,k,l,m) = rangeSize a i * rangeSize b j * rangeSize c k * rangeSize d l * rangeSize e m moebiusInversion (a,b,c,d,e) (i,j,k,l,m) = moebiusInversion a i * moebiusInversion b j * moebiusInversion c k * moebiusInversion d l * moebiusInversion e m algebra-3.1/src/Numeric/Partial/0000755000000000000000000000000012072477456014743 5ustar0000000000000000algebra-3.1/src/Numeric/Partial/Group.hs0000644000000000000000000000560312072477456016377 0ustar0000000000000000module Numeric.Partial.Group ( PartialGroup(..) ) where import Control.Applicative import Data.Int import Data.Word import Numeric.Partial.Semigroup import Numeric.Partial.Monoid import Numeric.Natural class PartialMonoid a => PartialGroup a where pnegate :: a -> Maybe a pnegate = pminus pzero pminus :: a -> a -> Maybe a pminus a b = padd a =<< pnegate b psubtract :: a -> a -> Maybe a psubtract a b = pnegate a >>= (`padd` b) instance PartialGroup Int where pnegate = Just . negate instance PartialGroup Integer where pnegate = Just . negate instance PartialGroup Int8 where pnegate = Just . negate instance PartialGroup Int16 where pnegate = Just . negate instance PartialGroup Int32 where pnegate = Just . negate instance PartialGroup Int64 where pnegate = Just . negate instance PartialGroup Word where pnegate = Just . negate instance PartialGroup Word8 where pnegate = Just . negate instance PartialGroup Word16 where pnegate = Just . negate instance PartialGroup Word32 where pnegate = Just . negate instance PartialGroup Word64 where pnegate = Just . negate instance PartialGroup Natural where pnegate 0 = Just 0 pnegate _ = Nothing pminus a b | a < b = Nothing | otherwise = Just (a - b) psubtract a b | a > b = Nothing | otherwise = Just (b - a) instance PartialGroup () where pnegate _ = Just () pminus _ _ = Just () psubtract _ _ = Just () instance (PartialGroup a, PartialGroup b) => PartialGroup (a, b) where pnegate (a, b) = (,) <$> pnegate a <*> pnegate b pminus (a, b) (i, j) = (,) <$> pminus a i <*> pminus b j psubtract (a, b) (i, j) = (,) <$> psubtract a i <*> psubtract b j instance (PartialGroup a, PartialGroup b, PartialGroup c) => PartialGroup (a, b, c) where pnegate (a, b, c) = (,,) <$> pnegate a <*> pnegate b <*> pnegate c pminus (a, b, c) (i, j, k) = (,,) <$> pminus a i <*> pminus b j <*> pminus c k psubtract (a, b, c) (i, j, k) = (,,) <$> psubtract a i <*> psubtract b j <*> psubtract c k instance (PartialGroup a, PartialGroup b, PartialGroup c, PartialGroup d) => PartialGroup (a, b, c, d) where pnegate (a, b, c, d) = (,,,) <$> pnegate a <*> pnegate b <*> pnegate c <*> pnegate d pminus (a, b, c, d) (i, j, k, l) = (,,,) <$> pminus a i <*> pminus b j <*> pminus c k <*> pminus d l psubtract (a, b, c, d) (i, j, k, l) = (,,,) <$> psubtract a i <*> psubtract b j <*> psubtract c k <*> psubtract d l instance (PartialGroup a, PartialGroup b, PartialGroup c, PartialGroup d, PartialGroup e) => PartialGroup (a, b, c, d, e) where pnegate (a, b, c, d, e) = (,,,,) <$> pnegate a <*> pnegate b <*> pnegate c <*> pnegate d <*> pnegate e pminus (a, b, c, d, e) (i, j, k, l, m) = (,,,,) <$> pminus a i <*> pminus b j <*> pminus c k <*> pminus d l <*> pminus e m psubtract (a, b, c, d, e) (i, j, k, l, m) = (,,,,) <$> psubtract a i <*> psubtract b j <*> psubtract c k <*> psubtract d l <*> psubtract e m algebra-3.1/src/Numeric/Partial/Monoid.hs0000644000000000000000000000301012072477456016516 0ustar0000000000000000module Numeric.Partial.Monoid ( PartialMonoid(..) ) where import Numeric.Partial.Semigroup import Data.Int import Data.Word import Numeric.Natural.Internal class PartialSemigroup a => PartialMonoid a where pzero :: a instance PartialMonoid Bool where pzero = False instance PartialMonoid Int where pzero = 0 instance PartialMonoid Integer where pzero = 0 instance PartialMonoid Natural where pzero = 0 instance PartialMonoid Int8 where pzero = 0 instance PartialMonoid Int16 where pzero = 0 instance PartialMonoid Int32 where pzero = 0 instance PartialMonoid Int64 where pzero = 0 instance PartialMonoid Word where pzero = 0 instance PartialMonoid Word8 where pzero = 0 instance PartialMonoid Word16 where pzero = 0 instance PartialMonoid Word32 where pzero = 0 instance PartialMonoid Word64 where pzero = 0 instance PartialMonoid () where pzero = () instance PartialSemigroup a => PartialMonoid (Maybe a) where pzero = Nothing instance (PartialMonoid a, PartialMonoid b) => PartialMonoid (a, b) where pzero = (pzero, pzero) instance (PartialMonoid a, PartialMonoid b, PartialMonoid c) => PartialMonoid (a, b, c) where pzero = (pzero, pzero, pzero) instance (PartialMonoid a, PartialMonoid b, PartialMonoid c, PartialMonoid d) => PartialMonoid (a, b, c, d) where pzero = (pzero, pzero, pzero, pzero) instance (PartialMonoid a, PartialMonoid b, PartialMonoid c, PartialMonoid d, PartialMonoid e) => PartialMonoid (a, b, c, d, e) where pzero = (pzero, pzero, pzero, pzero, pzero) algebra-3.1/src/Numeric/Partial/Semigroup.hs0000644000000000000000000000422712072477456017256 0ustar0000000000000000module Numeric.Partial.Semigroup ( PartialSemigroup(..) ) where import Control.Applicative import Data.Word import Data.Int import Numeric.Natural.Internal class PartialSemigroup a where padd :: a -> a -> Maybe a paddNum :: Num a => a -> a -> Maybe a paddNum a b = Just (a + b) instance PartialSemigroup Int where padd = paddNum instance PartialSemigroup Integer where padd = paddNum instance PartialSemigroup Natural where padd = paddNum instance PartialSemigroup Int8 where padd = paddNum instance PartialSemigroup Int16 where padd = paddNum instance PartialSemigroup Int32 where padd = paddNum instance PartialSemigroup Int64 where padd = paddNum instance PartialSemigroup Word where padd = paddNum instance PartialSemigroup Word8 where padd = paddNum instance PartialSemigroup Word16 where padd = paddNum instance PartialSemigroup Word32 where padd = paddNum instance PartialSemigroup Word64 where padd = paddNum instance PartialSemigroup a => PartialSemigroup (Maybe a) where padd ma mb = Just $ do a <- ma b <- mb padd a b instance PartialSemigroup Bool where padd a b = Just (a || b) instance PartialSemigroup () where padd _ _ = Just () instance (PartialSemigroup a, PartialSemigroup b) => PartialSemigroup (a, b) where padd (a,b) (i,j) = (,) <$> padd a i <*> padd b j instance (PartialSemigroup a, PartialSemigroup b, PartialSemigroup c) => PartialSemigroup (a, b, c) where padd (a,b,c) (i,j,k) = (,,) <$> padd a i <*> padd b j <*> padd c k instance (PartialSemigroup a, PartialSemigroup b, PartialSemigroup c, PartialSemigroup d) => PartialSemigroup (a, b, c, d) where padd (a,b,c,d) (i,j,k,l) = (,,,) <$> padd a i <*> padd b j <*> padd c k <*> padd d l instance (PartialSemigroup a, PartialSemigroup b, PartialSemigroup c, PartialSemigroup d, PartialSemigroup e) => PartialSemigroup (a, b, c, d, e) where padd (a,b,c,d,e) (i,j,k,l,m) = (,,,,) <$> padd a i <*> padd b j <*> padd c k <*> padd d l <*> padd e m instance (PartialSemigroup a, PartialSemigroup b) => PartialSemigroup (Either a b) where padd (Left a) (Left b) = Left <$> padd a b padd (Right a) (Right b) = Right <$> padd a b padd _ _ = Nothing algebra-3.1/src/Numeric/Quadrance/0000755000000000000000000000000012072477456015252 5ustar0000000000000000algebra-3.1/src/Numeric/Quadrance/Class.hs0000644000000000000000000000522712072477456016661 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} module Numeric.Quadrance.Class ( Quadrance(..) ) where import Data.Int import Data.Word import Numeric.Additive.Class import Numeric.Algebra.Class import Numeric.Algebra.Unital import Numeric.Rig.Class import Numeric.Natural.Internal import Prelude hiding ((+),(*)) -- a module with a computable squared norm class Additive r => Quadrance r m where quadrance :: m -> r instance Quadrance () a where quadrance _ = () instance Monoidal r => Quadrance r () where quadrance _ = zero instance (Quadrance r a, Quadrance r b) => Quadrance r (a,b) where quadrance (a,b) = quadrance a + quadrance b instance (Quadrance r a, Quadrance r b, Quadrance r c) => Quadrance r (a,b,c) where quadrance (a,b,c) = quadrance a + quadrance b + quadrance c instance (Quadrance r a, Quadrance r b, Quadrance r c, Quadrance r d) => Quadrance r (a,b,c,d) where quadrance (a,b,c,d) = quadrance a + quadrance b + quadrance c + quadrance d instance (Quadrance r a, Quadrance r b, Quadrance r c, Quadrance r d, Quadrance r e) => Quadrance r (a,b,c,d,e) where quadrance (a,b,c,d,e) = quadrance a + quadrance b + quadrance c + quadrance d + quadrance e instance Rig r => Quadrance r Bool where quadrance False = zero quadrance True = one sq :: Multiplicative r => r -> r sq r = r * r instance Rig r => Quadrance r Int where quadrance = fromNatural . Natural . sq . toInteger instance Rig r => Quadrance r Word where quadrance = fromNatural . Natural . sq . toInteger instance Rig r => Quadrance r Natural where quadrance = fromNatural . Natural . sq . toInteger instance Rig r => Quadrance r Integer where quadrance = fromNatural . Natural . fromInteger . sq instance Rig r => Quadrance r Int8 where quadrance = fromNatural . Natural . sq . toInteger instance Rig r => Quadrance r Int16 where quadrance = fromNatural . Natural . sq . toInteger instance Rig r => Quadrance r Int32 where quadrance = fromNatural . Natural . sq . toInteger instance Rig r => Quadrance r Int64 where quadrance = fromNatural . Natural . sq . toInteger instance Rig r => Quadrance r Word8 where quadrance = fromNatural . Natural . sq . toInteger instance Rig r => Quadrance r Word16 where quadrance = fromNatural . Natural . sq . toInteger instance Rig r => Quadrance r Word32 where quadrance = fromNatural . Natural . sq . toInteger instance Rig r => Quadrance r Word64 where quadrance = fromNatural . Natural . sq . toInteger {- instance InvolutiveSemiring r => Quadrance r (Complex r) where quadrance n = e (adjoint n * n) instance InvolutiveSemiring r => Quadrance r (Quaternion r) where quadrance n = e (adjoint n * n) -} algebra-3.1/src/Numeric/Rig/0000755000000000000000000000000012072477456014070 5ustar0000000000000000algebra-3.1/src/Numeric/Rig/Characteristic.hs0000644000000000000000000000534412072477456017362 0ustar0000000000000000module Numeric.Rig.Characteristic ( Characteristic(..) , charInt , charWord ) where import Data.Int import Data.Word import Numeric.Rig.Class import Numeric.Natural.Internal import Prelude hiding ((^)) data Proxy p = Proxy class Rig r => Characteristic r where char :: proxy r -> Natural charInt :: (Integral s, Bounded s) => proxy s -> Natural charInt p = 2 * fromIntegral (maxBound `asProxyTypeOf` p) + 2 asProxyTypeOf :: a -> p a -> a asProxyTypeOf = const charWord :: (Whole s, Bounded s) => proxy s -> Natural charWord p = toNatural (maxBound `asProxyTypeOf` p) + 1 -- | NB: we're using the boolean semiring, not the boolean ring instance Characteristic Bool where char _ = 0 instance Characteristic Integer where char _ = 0 instance Characteristic Natural where char _ = 0 instance Characteristic Int where char = charInt instance Characteristic Int8 where char = charInt instance Characteristic Int16 where char = charInt instance Characteristic Int32 where char = charInt instance Characteristic Int64 where char = charInt instance Characteristic Word where char = charWord instance Characteristic Word8 where char = charWord instance Characteristic Word16 where char = charWord instance Characteristic Word32 where char = charWord instance Characteristic Word64 where char = charWord instance Characteristic () where char _ = 1 instance (Characteristic a, Characteristic b) => Characteristic (a,b) where char p = char (a p) `lcm` char (b p) where a :: proxy (a,b) -> Proxy a a _ = Proxy b :: proxy (a,b) -> Proxy b b _ = Proxy instance (Characteristic a, Characteristic b, Characteristic c) => Characteristic (a,b,c) where char p = char (a p) `lcm` char (b p) `lcm` char (c p) where a :: proxy (a,b,c) -> Proxy a a _ = Proxy b :: proxy (a,b,c) -> Proxy b b _ = Proxy c :: proxy (a,b,c) -> Proxy c c _ = Proxy instance (Characteristic a, Characteristic b, Characteristic c, Characteristic d) => Characteristic (a,b,c,d) where char p = char (a p) `lcm` char (b p) `lcm` char (c p) `lcm` char (d p) where a :: proxy (a,b,c,d) -> Proxy a a _ = Proxy b :: proxy (a,b,c,d) -> Proxy b b _ = Proxy c :: proxy (a,b,c,d) -> Proxy c c _ = Proxy d :: proxy (a,b,c,d) -> Proxy d d _ = Proxy instance (Characteristic a, Characteristic b, Characteristic c, Characteristic d, Characteristic e) => Characteristic (a,b,c,d,e) where char p = char (a p) `lcm` char (b p) `lcm` char (c p) `lcm` char (d p) `lcm` char (e p) where a :: proxy (a,b,c,d,e) -> Proxy a a _ = Proxy b :: proxy (a,b,c,d,e) -> Proxy b b _ = Proxy c :: proxy (a,b,c,d,e) -> Proxy c c _ = Proxy d :: proxy (a,b,c,d,e) -> Proxy d d _ = Proxy e :: proxy (a,b,c,d,e) -> Proxy e e _ = Proxy algebra-3.1/src/Numeric/Rig/Class.hs0000644000000000000000000000346212072477456015476 0ustar0000000000000000module Numeric.Rig.Class ( Rig(..) , fromNaturalNum , fromWhole ) where import Numeric.Algebra.Class import Numeric.Algebra.Unital import Data.Int import Data.Word import Prelude (Integer, Bool, Num(fromInteger),(/=),id,(.)) import Numeric.Natural.Internal fromNaturalNum :: Num r => Natural -> r fromNaturalNum (Natural n) = fromInteger n -- | A Ring without (n)egation class (Semiring r, Unital r, Monoidal r) => Rig r where fromNatural :: Natural -> r fromNatural n = sinnum n one fromWhole :: (Whole n, Rig r) => n -> r fromWhole = fromNatural . toNatural -- TODO: optimize instance Rig Integer where fromNatural = fromNaturalNum instance Rig Natural where fromNatural = id instance Rig Bool where fromNatural = (/=) 0 instance Rig Int where fromNatural = fromNaturalNum instance Rig Int8 where fromNatural = fromNaturalNum instance Rig Int16 where fromNatural = fromNaturalNum instance Rig Int32 where fromNatural = fromNaturalNum instance Rig Int64 where fromNatural = fromNaturalNum instance Rig Word where fromNatural = fromNaturalNum instance Rig Word8 where fromNatural = fromNaturalNum instance Rig Word16 where fromNatural = fromNaturalNum instance Rig Word32 where fromNatural = fromNaturalNum instance Rig Word64 where fromNatural = fromNaturalNum instance Rig () where fromNatural _ = () instance (Rig a, Rig b) => Rig (a, b) where fromNatural n = (fromNatural n, fromNatural n) instance (Rig a, Rig b, Rig c) => Rig (a, b, c) where fromNatural n = (fromNatural n, fromNatural n, fromNatural n) instance (Rig a, Rig b, Rig c, Rig d) => Rig (a, b, c, d) where fromNatural n = (fromNatural n, fromNatural n, fromNatural n, fromNatural n) instance (Rig a, Rig b, Rig c, Rig d, Rig e) => Rig (a, b, c, d, e) where fromNatural n = (fromNatural n, fromNatural n, fromNatural n, fromNatural n, fromNatural n) algebra-3.1/src/Numeric/Rig/Ordered.hs0000644000000000000000000000131412072477456016007 0ustar0000000000000000module Numeric.Rig.Ordered ( OrderedRig ) where import Numeric.Rig.Class import Numeric.Order.Additive import Numeric.Natural.Internal -- x <= y ==> x + z <= y + z -- 0 <= x && y <= z implies xy <= xz -- 0 <= x <= 1 class (AdditiveOrder r, Rig r) => OrderedRig r instance OrderedRig Integer instance OrderedRig Natural instance OrderedRig Bool instance OrderedRig () instance (OrderedRig a, OrderedRig b) => OrderedRig (a, b) instance (OrderedRig a, OrderedRig b, OrderedRig c) => OrderedRig (a, b, c) instance (OrderedRig a, OrderedRig b, OrderedRig c, OrderedRig d) => OrderedRig (a, b, c, d) instance (OrderedRig a, OrderedRig b, OrderedRig c, OrderedRig d, OrderedRig e) => OrderedRig (a, b, c, d, e) algebra-3.1/src/Numeric/Ring/0000755000000000000000000000000012072477456014246 5ustar0000000000000000algebra-3.1/src/Numeric/Ring/Class.hs0000644000000000000000000000331012072477456015644 0ustar0000000000000000module Numeric.Ring.Class ( Ring(..) , fromIntegral ) where import Data.Int import Data.Word import Numeric.Rig.Class import Numeric.Rng.Class import Numeric.Additive.Group import Numeric.Algebra.Unital import qualified Prelude import Prelude (Integral(toInteger), Integer, (.)) class (Rig r, Rng r) => Ring r where fromInteger :: Integer -> r fromInteger n = times n one fromIntegral :: (Integral n, Ring r) => n -> r fromIntegral = fromInteger . toInteger instance Ring Integer where fromInteger = Prelude.fromInteger instance Ring Int where fromInteger = Prelude.fromInteger instance Ring Int8 where fromInteger = Prelude.fromInteger instance Ring Int16 where fromInteger = Prelude.fromInteger instance Ring Int32 where fromInteger = Prelude.fromInteger instance Ring Int64 where fromInteger = Prelude.fromInteger instance Ring Word where fromInteger = Prelude.fromInteger instance Ring Word8 where fromInteger = Prelude.fromInteger instance Ring Word16 where fromInteger = Prelude.fromInteger instance Ring Word32 where fromInteger = Prelude.fromInteger instance Ring Word64 where fromInteger = Prelude.fromInteger instance Ring () where fromInteger _ = () instance (Ring a, Ring b) => Ring (a, b) where fromInteger n = (fromInteger n, fromInteger n) instance (Ring a, Ring b, Ring c) => Ring (a, b, c) where fromInteger n = (fromInteger n, fromInteger n, fromInteger n) instance (Ring a, Ring b, Ring c, Ring d) => Ring (a, b, c, d) where fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n) instance (Ring a, Ring b, Ring c, Ring d, Ring e) => Ring (a, b, c, d, e) where fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n) algebra-3.1/src/Numeric/Ring/Division.hs0000644000000000000000000000041212072477456016363 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} module Numeric.Ring.Division ( DivisionRing ) where import Numeric.Algebra.Division import Numeric.Ring.Class class (Division r, Ring r) => DivisionRing r instance (Division r, Ring r) => DivisionRing r algebra-3.1/src/Numeric/Ring/Endomorphism.hs0000644000000000000000000000412212072477456017245 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} module Numeric.Ring.Endomorphism ( End(..) , toEnd , fromEnd , frobenius ) where import Data.Monoid import Numeric.Algebra import Prelude hiding ((*),(+),(-),negate,subtract) import Data.Proxy -- | The endomorphism ring of an abelian group or the endomorphism semiring of an abelian monoid -- -- http://en.wikipedia.org/wiki/Endomorphism_ring newtype End a = End { appEnd :: a -> a } instance Monoid (End r) where mappend (End a) (End b) = End (a . b) mempty = End id instance Additive r => Additive (End r) where End f + End g = End (f + g) instance Abelian r => Abelian (End r) instance Monoidal r => Monoidal (End r) where zero = End (const zero) instance Group r => Group (End r) where End f - End g = End (f - g) negate (End f) = End (negate f) subtract (End f) (End g) = End (subtract f g) instance Multiplicative (End r) where End f * End g = End (f . g) instance Unital (End r) where one = End id instance (Abelian r, Commutative r) => Commutative (End r) instance (Abelian r, Monoidal r) => Semiring (End r) instance (Abelian r, Monoidal r) => Rig (End r) instance (Abelian r, Group r) => Ring (End r) instance (Monoidal m, Abelian m) => LeftModule (End m) (End m) where End f .* End g = End (f . g) instance (Monoidal m, Abelian m) => RightModule (End m) (End m) where End f *. End g = End (f . g) instance LeftModule r m => LeftModule r (End m) where r .* End f = End (\e -> r .* f e) instance RightModule r m => RightModule r (End m) where End f *. r = End (\e -> f e *. r) -- TODO: Involutive? Invertible? -- instance SimpleAdditiveAbelianGroup r => DivisionRing (End r) where -- ring isomorphism from r to the endomorphism ring of r. toEnd :: Multiplicative r => r -> End r toEnd r = End (*r) -- ring isomorphism from the endormorphism ring of r to r. fromEnd :: Unital r => End r -> r fromEnd (End f) = f one -- the frobenius ring endomorphism (assuming the characteristic is prime) frobenius :: Characteristic r => End r frobenius = End $ \r -> r `pow` char (ofRing r) ofRing :: r -> Proxy r ofRing _ = Proxy algebra-3.1/src/Numeric/Ring/Local.hs0000644000000000000000000000041112072477456015630 0ustar0000000000000000module Numeric.Ring.Local ( LocalRing ) where import Numeric.Ring.Class -- forall x in r, either x or 1 - x is a unit. -- if a finite sum is a unit then so are some of its terms, so the empty sum is not a unit, and one /= zero. class Ring r => LocalRing r algebra-3.1/src/Numeric/Ring/Opposite.hs0000644000000000000000000000615512072477456016413 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} module Numeric.Ring.Opposite ( Opposite(..) ) where import Data.Foldable import Data.Function (on) import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Traversable import Numeric.Algebra import Numeric.Decidable.Associates import Numeric.Decidable.Units import Numeric.Decidable.Zero import Prelude hiding ((-),(+),(*),(/),(^),recip,negate,subtract,replicate) -- | http://en.wikipedia.org/wiki/Opposite_ring newtype Opposite r = Opposite { runOpposite :: r } deriving (Show,Read) instance Eq r => Eq (Opposite r) where (==) = (==) `on` runOpposite instance Ord r => Ord (Opposite r) where compare = compare `on` runOpposite instance Functor Opposite where fmap f (Opposite r) = Opposite (f r) instance Foldable Opposite where foldMap f (Opposite r) = f r instance Traversable Opposite where traverse f (Opposite r) = fmap Opposite (f r) instance Foldable1 Opposite where foldMap1 f (Opposite r) = f r instance Traversable1 Opposite where traverse1 f (Opposite r) = fmap Opposite (f r) instance Additive r => Additive (Opposite r) where Opposite a + Opposite b = Opposite (a + b) sinnum1p n (Opposite a) = Opposite (sinnum1p n a) sumWith1 f = Opposite . sumWith1 (runOpposite . f) instance Monoidal r => Monoidal (Opposite r) where zero = Opposite zero sinnum n (Opposite a) = Opposite (sinnum n a) sumWith f = Opposite . sumWith (runOpposite . f) instance Semiring r => LeftModule (Opposite r) (Opposite r) where (.*) = (*) instance RightModule r s => LeftModule r (Opposite s) where r .* Opposite s = Opposite (s *. r) instance LeftModule r s => RightModule r (Opposite s) where Opposite s *. r = Opposite (r .* s) instance Semiring r => RightModule (Opposite r) (Opposite r) where (*.) = (*) instance Group r => Group (Opposite r) where negate = Opposite . negate . runOpposite Opposite a - Opposite b = Opposite (a - b) subtract (Opposite a) (Opposite b) = Opposite (subtract a b) times n (Opposite a) = Opposite (times n a) instance Abelian r => Abelian (Opposite r) instance DecidableZero r => DecidableZero (Opposite r) where isZero = isZero . runOpposite instance DecidableUnits r => DecidableUnits (Opposite r) where recipUnit = fmap Opposite . recipUnit . runOpposite instance DecidableAssociates r => DecidableAssociates (Opposite r) where isAssociate (Opposite a) (Opposite b) = isAssociate a b instance Multiplicative r => Multiplicative (Opposite r) where Opposite a * Opposite b = Opposite (b * a) pow1p (Opposite a) n = Opposite (pow1p a n) instance Commutative r => Commutative (Opposite r) instance Idempotent r => Idempotent (Opposite r) instance Band r => Band (Opposite r) instance Unital r => Unital (Opposite r) where one = Opposite one pow (Opposite a) n = Opposite (pow a n) instance Division r => Division (Opposite r) where recip = Opposite . recip . runOpposite Opposite a / Opposite b = Opposite (b \\ a) Opposite a \\ Opposite b = Opposite (b / a) Opposite a ^ n = Opposite (a ^ n) instance Semiring r => Semiring (Opposite r) instance Rig r => Rig (Opposite r) instance Ring r => Ring (Opposite r) algebra-3.1/src/Numeric/Ring/Rng.hs0000644000000000000000000000510612072477456015332 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} module Numeric.Ring.Rng ( RngRing(..) , rngRingHom , liftRngHom ) where import Numeric.Algebra import Prelude hiding ((+),(-),(*),(/),replicate,negate,subtract,fromIntegral) -- | The free Ring given a Rng obtained by adjoining Z, such that -- -- > RngRing r = n*1 + r -- -- This ring is commonly denoted r^. data RngRing r = RngRing !Integer r deriving (Show,Read) instance Abelian r => Additive (RngRing r) where RngRing n a + RngRing m b = RngRing (n + m) (a + b) sinnum1p n (RngRing m a) = RngRing ((1 + toInteger n) * m) (sinnum1p n a) instance Abelian r => Abelian (RngRing r) instance (Abelian r, Monoidal r) => LeftModule Natural (RngRing r) where n .* RngRing m a = RngRing (toInteger n * m) (sinnum n a) instance (Abelian r, Monoidal r) => RightModule Natural (RngRing r) where RngRing m a *. n = RngRing (toInteger n * m) (sinnum n a) instance (Abelian r, Monoidal r) => Monoidal (RngRing r) where zero = RngRing 0 zero sinnum n (RngRing m a) = RngRing (toInteger n * m) (sinnum n a) instance (Abelian r, Group r) => LeftModule Integer (RngRing r) where n .* RngRing m a = RngRing (toInteger n * m) (times n a) instance (Abelian r, Group r) => RightModule Integer (RngRing r) where RngRing m a *. n = RngRing (toInteger n * m) (times n a) instance (Abelian r, Group r) => Group (RngRing r) where RngRing n a - RngRing m b = RngRing (n - m) (a - b) negate (RngRing n a) = RngRing (negate n) (negate a) subtract (RngRing n a) (RngRing m b) = RngRing (subtract n m) (subtract a b) times n (RngRing m a) = RngRing (toInteger n * m) (times n a) instance Rng r => Multiplicative (RngRing r) where RngRing n a * RngRing m b = RngRing (n*m) (times n b + times m a + a * b) instance (Commutative r, Rng r) => Commutative (RngRing r) instance Rng s => LeftModule (RngRing s) (RngRing s) where (.*) = (*) instance Rng s => RightModule (RngRing s) (RngRing s) where (*.) = (*) instance Rng r => Unital (RngRing r) where one = RngRing 1 zero instance (Rng r, Division r) => Division (RngRing r) where RngRing n a / RngRing m b = RngRing 0 $ (times n one + a) / (times m one + b) instance Rng r => Semiring (RngRing r) instance Rng r => Rig (RngRing r) instance Rng r => Ring (RngRing r) -- | The rng homomorphism from r to RngRing r rngRingHom :: r -> RngRing r rngRingHom = RngRing 0 -- | given a rng homomorphism from a rng r into a ring s, liftRngHom yields a ring homomorphism from the ring `r^` into `s`. liftRngHom :: Ring s => (r -> s) -> RngRing r -> s liftRngHom g (RngRing n a) = times n one + g a algebra-3.1/src/Numeric/Rng/0000755000000000000000000000000012072477456014075 5ustar0000000000000000algebra-3.1/src/Numeric/Rng/Class.hs0000644000000000000000000000042212072477456015474 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} module Numeric.Rng.Class ( Rng ) where import Numeric.Additive.Group import Numeric.Algebra.Class -- | A Ring without an /i/dentity. class (Group r, Semiring r) => Rng r instance (Group r, Semiring r) => Rng r algebra-3.1/src/Numeric/Rng/Zero.hs0000644000000000000000000000341112072477456015347 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} module Numeric.Rng.Zero ( ZeroRng(..) ) where import Numeric.Algebra import Data.Foldable (toList) import Prelude hiding ((+),(-),negate,subtract,replicate) -- *** The Zero Rng for an Abelian Group, adding the trivial product -- -- > _ * _ = zero -- -- which distributes over (+) -- ZeroRng/runZeroRng witness an additive Abelian group isomorphism to the zero rng. newtype ZeroRng r = ZeroRng { runZeroRng :: r } deriving (Eq,Ord,Show,Read) instance Additive r => Additive (ZeroRng r) where ZeroRng a + ZeroRng b = ZeroRng (a + b) sumWith1 f = ZeroRng . sumWith1 (runZeroRng . f) instance Idempotent r => Idempotent (ZeroRng r) instance Abelian r => Abelian (ZeroRng r) instance Monoidal r => Monoidal (ZeroRng r) where zero = ZeroRng zero sumWith f = ZeroRng . sumWith (runZeroRng . f) sinnum n (ZeroRng a) = ZeroRng (sinnum n a) instance Group r => Group (ZeroRng r) where ZeroRng a - ZeroRng b = ZeroRng (a - b) negate (ZeroRng a) = ZeroRng (negate a) subtract (ZeroRng a) (ZeroRng b) = ZeroRng (subtract a b) times n (ZeroRng a) = ZeroRng (times n a) instance Monoidal r => Multiplicative (ZeroRng r) where _ * _ = zero productWith1 f as = case toList as of [] -> error "productWith1: empty Foldable1" [a] -> f a _ -> zero instance (Monoidal r, Abelian r) => Semiring (ZeroRng r) instance Monoidal r => Commutative (ZeroRng r) instance (Group r, Abelian r) => Rng (ZeroRng r) instance Monoidal r => LeftModule Natural (ZeroRng r) where (.*) = sinnum instance Monoidal r => RightModule Natural (ZeroRng r) where m *. n = sinnum n m instance Group r => LeftModule Integer (ZeroRng r) where (.*) = times instance Group r => RightModule Integer (ZeroRng r) where m *. n = times n m algebra-3.1/src/Numeric/Semiring/0000755000000000000000000000000012072477456015124 5ustar0000000000000000algebra-3.1/src/Numeric/Semiring/Integral.hs0000644000000000000000000000056312072477456017231 0ustar0000000000000000module Numeric.Semiring.Integral ( IntegralSemiring ) where import Numeric.Algebra.Class import Numeric.Natural.Internal -- | An integral semiring has no zero divisors -- -- > a * b = 0 implies a == 0 || b == 0 class (Monoidal r, Semiring r) => IntegralSemiring r instance IntegralSemiring Integer instance IntegralSemiring Natural instance IntegralSemiring Bool algebra-3.1/src/Numeric/Semiring/Involutive.hs0000644000000000000000000000015012072477456017620 0ustar0000000000000000module Numeric.Semiring.Involutive ( InvolutiveSemiring ) where import Numeric.Algebra.Involutive