computational-algebra (empty) → 0.0.1.0
raw patch · 12 files changed
+1168/−0 lines, 12 filesdep +algebradep +basedep +containerssetup-changed
Dependencies added: algebra, base, containers, lens, monomorphic, parsec, tagged
Files
- Algebra/Algorithms/Groebner.hs +143/−0
- Algebra/Algorithms/Groebner/Monomorphic.hs +30/−0
- Algebra/Internal.hs +195/−0
- Algebra/Ring/Noetherian.hs +96/−0
- Algebra/Ring/Polynomial.hs +304/−0
- Algebra/Ring/Polynomial/Monomorphic.hs +124/−0
- Algebra/Ring/Polynomial/Parser.hs +87/−0
- Example.hs +59/−0
- LICENSE +30/−0
- Monomorphic.hs +62/−0
- Setup.hs +2/−0
- computational-algebra.cabal +36/−0
+ Algebra/Algorithms/Groebner.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, GADTs #-}+{-# LANGUAGE MultiParamTypeClasses, NoImplicitPrelude, ParallelListComp #-}+{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeOperators #-}+module Algebra.Algorithms.Groebner where+import Algebra.Internal+import Algebra.Ring.Noetherian+import Algebra.Ring.Polynomial+import Data.List+import Numeric.Algebra+import Prelude hiding (Num (..), recip)++divModPolynomial :: (IsMonomialOrder order, IsPolynomial r n, Field r)+ => OrderedPolynomial r order n -> [OrderedPolynomial r order n] -> ([(OrderedPolynomial r order n, OrderedPolynomial r order n)], OrderedPolynomial r order n)+divModPolynomial f0 fs = loop f0 zero (zip (nub fs) (repeat zero))+ where+ loop p r dic+ | p == zero = (dic, r)+ | otherwise =+ let ltP = toPolynomial $ leadingTerm p+ in case break ((`divs` leadingMonomial p) . leadingMonomial . fst) dic of+ (_, []) -> loop (p - ltP) (r + ltP) dic+ (xs, (g, old):ys) ->+ let q = toPolynomial $ leadingTerm p `tryDiv` leadingTerm g+ dic' = xs ++ (g, old + q) : ys+ in loop (p - (q * g)) r dic'++modPolynomial :: (IsPolynomial r n, Field r, IsMonomialOrder order)+ => OrderedPolynomial r order n+ -> [OrderedPolynomial r order n]+ -> OrderedPolynomial r order n+modPolynomial = (snd .) . divModPolynomial++divPolynomial :: (IsPolynomial r n, Field r, IsMonomialOrder order)+ => OrderedPolynomial r order n+ -> [OrderedPolynomial r order n]+ -> [(OrderedPolynomial r order n, OrderedPolynomial r order n)]+divPolynomial = (fst .) . divModPolynomial++infixl 7 `divPolynomial`+infixl 7 `modPolynomial`+infixl 7 `divModPolynomial`++simpleBuchberger :: (Field k, IsPolynomial k n, IsMonomialOrder order)+ => Ideal (OrderedPolynomial k order n) -> [OrderedPolynomial k order n]+simpleBuchberger ideal =+ let gs = nub $ generators ideal+ in fst $ until (null . snd) (\(ggs, acc) -> let cur = nub $ ggs ++ acc in+ (cur, calc cur)) (gs, calc gs)+ where+ calc acc = [ q | f <- acc, g <- acc, f /= g+ , let q = sPolynomial f g `modPolynomial` acc, q /= zero+ ]++minimizeGroebnerBasis :: (Field k, IsPolynomial k n, IsMonomialOrder order)+ => [OrderedPolynomial k order n] -> [OrderedPolynomial k order n]+minimizeGroebnerBasis = foldr step []+ where+ step x xs = injectCoeff (recip $ leadingCoeff x) * x : filter (not . (leadingMonomial x `divs`) . leadingMonomial) xs++reduceMinimalGroebnerBasis :: (Field k, IsPolynomial k n, IsMonomialOrder order)+ => [OrderedPolynomial k order n] -> [OrderedPolynomial k order n]+reduceMinimalGroebnerBasis bs = filter (/= zero) $ map red bs+ where+ red x = x `modPolynomial` delete x bs++calcGroebnerBasisWith :: (Field k, IsPolynomial k n, IsMonomialOrder order, IsMonomialOrder order')+ => order -> Ideal (OrderedPolynomial k order' n) -> [OrderedPolynomial k order n]+calcGroebnerBasisWith order i = calcGroebnerBasis $ mapIdeal (changeOrder order) i++calcGroebnerBasis :: (Field k, IsPolynomial k n, IsMonomialOrder order)+ => Ideal (OrderedPolynomial k order n) -> [OrderedPolynomial k order n]+calcGroebnerBasis = reduceMinimalGroebnerBasis . minimizeGroebnerBasis . simpleBuchberger++isIdealMember :: (IsPolynomial k n, Field k, IsMonomialOrder o)+ => OrderedPolynomial k o n -> Ideal (OrderedPolynomial k o n) -> Bool+isIdealMember f ideal = groebnerTest f (calcGroebnerBasis ideal)++groebnerTest :: (IsPolynomial k n, Field k, IsMonomialOrder order)+ => OrderedPolynomial k order n -> [OrderedPolynomial k order n] -> Bool+groebnerTest f fs = f `modPolynomial` fs == zero+++thEliminationIdeal :: ( IsMonomialOrder ord, Field k, IsPolynomial k m, IsPolynomial k (n :+: m)+ )+ => SNat n+ -> Ideal (OrderedPolynomial k ord (n :+: m))+ -> Ideal (OrderedPolynomial k Lex m)+thEliminationIdeal n ideal =+ toIdeal $ [transformMonomial (dropV n) f | f <- calcGroebnerBasisWith Lex ideal+ , all (all (== 0) . take (toInt n) . toList . snd) $ getTerms f+ ]++-- | An intersection ideal of given ideals.+intersection :: forall r k n ord.+ ( IsMonomialOrder ord, Field r, IsPolynomial r k, IsPolynomial r n+ , IsPolynomial r (k :+: n)+ )+ => Vector (Ideal (OrderedPolynomial r ord n)) k -> Ideal (OrderedPolynomial r Lex n)+intersection Nil = Ideal $ singletonV one+intersection idsv@(_ :- _) =+ let sk = sLengthV idsv+ sn = sing :: SNat n+ ts = genVars (sk %+ sn)+ tis = zipWith (\ideal t -> mapIdeal ((t *) . shiftR sk) ideal) (toList idsv) ts+ j = foldr appendIdeal (principalIdeal (one - foldr (+) zero ts)) tis+ in sk `thEliminationIdeal` j++-- | Ideal quotient by a principal ideals.+quotByPrincipalIdeal :: (Field k, IsPolynomial k n, IsMonomialOrder ord)+ => Ideal (OrderedPolynomial k ord n)+ -> OrderedPolynomial k ord n+ -> Ideal (OrderedPolynomial k Lex n)+quotByPrincipalIdeal i g =+ case intersection (i :- (Ideal $ singletonV g) :- Nil) of+ Ideal gs -> Ideal $ mapV (snd . head . (`divPolynomial` [changeOrder Lex g])) gs++quotIdeal :: forall k ord n. (IsPolynomial k n, Field k, IsMonomialOrder ord)+ => Ideal (OrderedPolynomial k ord n)+ -> Ideal (OrderedPolynomial k ord n)+ -> Ideal (OrderedPolynomial k Lex n)+quotIdeal i (Ideal g) =+ case singInstance (sLengthV g) of+ SingInstance ->+ case singInstance (sLengthV g %+ (sing :: SNat n)) of+ SingInstance -> intersection $ mapV (i `quotByPrincipalIdeal`) g++-- | Saturation by a principal ideal.+saturationByPrincipalIdeal :: (Field k, IsPolynomial k n, IsMonomialOrder ord)+ => Ideal (OrderedPolynomial k ord n)+ -> OrderedPolynomial k ord n -> Ideal (OrderedPolynomial k Lex n)+saturationByPrincipalIdeal is g =+ case leqSucc (sDegree g) of+ LeqInstance -> sOne `thEliminationIdeal` addToIdeal (one - (castPolynomial g * var sOne)) (mapIdeal (shiftR sOne) is)++saturationIdeal :: forall k ord n. (IsPolynomial k n, Field k, IsMonomialOrder ord)+ => Ideal (OrderedPolynomial k ord n)+ -> Ideal (OrderedPolynomial k ord n)+ -> Ideal (OrderedPolynomial k Lex n)+saturationIdeal i (Ideal g) =+ case singInstance (sLengthV g) of+ SingInstance ->+ case singInstance (sLengthV g %+ (sing :: SNat n)) of+ SingInstance -> intersection $ mapV (i `saturationByPrincipalIdeal`) g
+ Algebra/Algorithms/Groebner/Monomorphic.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE FlexibleInstances, GADTs, PolyKinds, RecordWildCards #-}+{-# LANGUAGE TypeFamilies, TypeOperators, ViewPatterns #-}+module Algebra.Algorithms.Groebner.Monomorphic where+import qualified Algebra.Algorithms.Groebner as Gr+import Algebra.Internal+import Algebra.Ring.Noetherian+import qualified Algebra.Ring.Polynomial as Poly+import Algebra.Ring.Polynomial.Monomorphic+import Data.List+import Monomorphic++calcGroebnerBasis :: [Polyn] -> [Polyn]+calcGroebnerBasis (filter (any ((/= 0).fst)) -> []) = []+calcGroebnerBasis j =+ case uniformlyPromote j :: Monomorphic (Ideal :.: Poly.Polynomial Rational) of+ Monomorphic (Comp ideal) ->+ case ideal of+ Ideal vec ->+ case singInstance (Poly.sDegree (head $ toList vec)) of+ SingInstance -> map (renameVars vars . polyn . demote . Monomorphic) $ Gr.calcGroebnerBasis ideal+ where+ vars = nub $ sort $ concatMap buildVarsList j++isIdealMember :: Polyn -> [Polyn] -> Bool+isIdealMember f ideal =+ case promoteList (f:ideal) :: Monomorphic ([] :.: Poly.Polynomial Rational) of+ Monomorphic (Comp (f':ideal')) ->+ case singInstance (Poly.sDegree f') of+ SingInstance -> Gr.isIdealMember f' (toIdeal ideal')+ _ -> error "impossible happend!"
+ Algebra/Internal.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}+{-# LANGUAGE MultiParamTypeClasses, PolyKinds, StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies, TypeOperators #-}+module Algebra.Internal where+import Data.Proxy+import Monomorphic++toProxy :: a -> Proxy a+toProxy _ = Proxy++data Nat = Z | S Nat+data Vector (a :: *) (n :: Nat) where+ Nil :: Vector a Z+ (:-) :: a -> Vector a n -> Vector a (S n)++infixr 5 :-+deriving instance Show a => Show (Vector a n)++type family Min (n :: Nat) (m :: Nat) :: Nat+type instance Min Z Z = Z+type instance Min Z (S n) = Z+type instance Min (S m) Z = Z+type instance Min (S n) (S m) = S (Min n m)++type family Max (n :: Nat) (m :: Nat) :: Nat+type instance Max Z Z = Z+type instance Max Z (S n) = S n+type instance Max (S n) Z = S n+type instance Max (S n) (S m) = S (Max n m)++type Zero = Z+type One = S Z+type Two = S (S Z)+type Three = S (S (S Z))++type SZero = SNat Zero+type SOne = SNat One+type STwo = SNat Two+type SThree = SNat Three++sZero :: SZero+sZero = SZ++sOne :: SOne+sOne = SS sZero++sTwo :: STwo+sTwo = SS sOne++sThree :: SThree+sThree = SS sTwo++sMin :: SNat n -> SNat m -> SNat (Min n m)+sMin SZ SZ = SZ+sMin (SS _) SZ = SZ+sMin SZ (SS _) = SZ+sMin (SS n) (SS m) = SS (sMin n m)++sMax :: SNat n -> SNat m -> SNat (Max n m)+sMax SZ SZ = SZ+sMax (SS n) SZ = SS n+sMax SZ (SS n) = SS n+sMax (SS n) (SS m) = SS (sMax n m)++class Sing (n :: Nat) where+ sing :: SNat n++instance Sing Z where+ sing = SZ++instance Sing n => Sing (S n) where+ sing = SS sing++class (n :: Nat) :<= (m :: Nat)+instance Zero :<= n+instance (n :<= m) => S n :<= S m++data SNat (n :: Nat) where+ SZ :: SNat Z+ SS :: SNat n -> SNat (S n)++deriving instance Show (SNat n)++instance Monomorphicable SNat where+ type MonomorphicRep SNat = Int+ demote (Monomorphic sn) = toInt sn+ promote n+ | n < 0 = error "negative integer!"+ | n == 0 = Monomorphic SZ+ | otherwise = withPolymorhic n $ \sn -> Monomorphic $ SS sn++instance Monomorphicable (Vector a) where+ type MonomorphicRep (Vector a) = [a]+ demote (Monomorphic vec) = toList vec+ promote [] = Monomorphic Nil+ promote (x:xs) =+ case promote xs of+ Monomorphic vec -> Monomorphic $ x :- vec++lengthV :: Vector a n -> Int+lengthV Nil = 0+lengthV (_ :- xs) = 1 + lengthV xs++type family (n :: Nat) :+: (m :: Nat) :: Nat+type instance Z :+: n = n+type instance S m :+: n = S (m :+: n)++(%+) :: SNat n -> SNat m -> SNat (n :+: m)+SZ %+ n = n+SS n %+ m = SS (n %+ m)++appendV :: Vector a n -> Vector a m -> Vector a (n :+: m)+appendV (x :- xs) ys = x :- appendV xs ys+appendV Nil ys = ys++foldrV :: (a -> b -> b) -> b -> Vector a n -> b+foldrV _ b Nil = b+foldrV f a (x :- xs) = f x (foldrV f a xs)++foldlV :: (a -> b -> a) -> a -> Vector b n -> a+foldlV _ a Nil = a+foldlV f a (b :- bs) = foldlV f (f a b) bs++singletonV :: a -> Vector a (S Z)+singletonV = (:- Nil)++zipWithV :: (a -> b -> c) -> Vector a n -> Vector b n -> Vector c n+zipWithV _ Nil Nil = Nil+zipWithV f (x :- xs) (y :- ys) = f x y :- zipWithV f xs ys+zipWithV _ _ _ = error "cannot happen"++toList :: Vector a n -> [a]+toList = foldrV (:) []++instance (Eq a) => Eq (Vector a n) where+ Nil == Nil = True+ (x :- xs) == (y :- ys) = x == y && xs == ys+ _ == _ = error "impossible!"++allV :: (a -> Bool) -> Vector a n-> Bool+allV p = foldrV ((&&) . p) False++dropV :: SNat n -> Vector a (n :+: m) -> Vector a m+dropV n = snd . splitAtV n++toInt :: SNat n -> Int+toInt SZ = 0+toInt (SS n) = 1 + toInt n++splitAtV :: SNat n -> Vector a (n :+: m) -> (Vector a n, Vector a m)+splitAtV SZ xs = (Nil, xs)+splitAtV (SS n) (x :- xs) =+ case splitAtV n xs of+ (xs', ys') -> (x :- xs', ys')+splitAtV _ _ = error "could not happen!"++sLengthV :: Vector a n -> SNat n+sLengthV Nil = SZ+sLengthV (_ :- xs) = sOne %+ sLengthV xs++mapV :: (a -> b) -> Vector a n -> Vector b n+mapV _ Nil = Nil+mapV f (x :- xs) = f x :- mapV f xs++headV :: Vector a (S n) -> a+headV (x :- _) = x++tailV :: Vector a (S n) -> Vector a n+tailV (_ :- xs) = xs++data SingInstance a where+ SingInstance :: Sing a => SingInstance a++singInstance :: SNat n -> SingInstance n+singInstance SZ = SingInstance+singInstance (SS n) =+ case singInstance n of+ SingInstance -> SingInstance++data LeqInstance n m where+ LeqInstance :: (n :<= m) => LeqInstance n m++leqRefl :: SNat n -> LeqInstance n n+leqRefl SZ = LeqInstance+leqRefl (SS n) =+ case leqRefl n of+ LeqInstance -> LeqInstance++leqSucc :: SNat n -> LeqInstance n (S n)+leqSucc SZ = LeqInstance+leqSucc (SS n) =+ case leqSucc n of+ LeqInstance -> LeqInstance+
+ Algebra/Ring/Noetherian.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE DataKinds, ExistentialQuantification, FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Algebra.Ring.Noetherian ( NoetherianRing, Ideal(..), addToIdeal, toIdeal, appendIdeal+ , generators, filterIdeal, mapIdeal, principalIdeal) where+import Algebra.Internal+import Data.Complex+import Data.Function+import Data.Ord+import Data.Ratio+import Numeric.Algebra+import Prelude hiding (negate, subtract, (*), (+), (-))+import qualified Prelude as P++class (Commutative r, Ring r) => NoetherianRing r where++instance NoetherianRing Int where++instance NoetherianRing Integer where++instance (Commutative (Complex r), Ring (Complex r)) => NoetherianRing (Complex r) where+instance Integral n => NoetherianRing (Ratio n)++instance Division (Ratio Integer) where+ recip = P.recip+ (/) = (P./)+ (\\) = flip (P./)+ (^) = (^^)++instance Integral n => Commutative (Ratio n)++instance Integral n => Ring (Ratio n) where+ fromInteger = P.fromInteger+instance Integral n => Rig (Ratio n) where+ fromNatural = P.fromInteger . toInteger+instance Integral n => Monoidal (Ratio n) where+ zero = 0+instance Integral n => LeftModule Natural (Ratio n) where+ n .* r = P.sum $ replicate (fromIntegral n) r++instance Integral n => RightModule Natural (Ratio n) where+ (*.) = flip (.*)++instance Integral n => Unital (Ratio n) where+ one = 1+ pow r n = r ^^ toInteger n+instance Integral n => Group (Ratio n) where+ negate = P.negate+ times n r = toInteger n .* r+ (-) = (P.-)+ subtract = P.subtract+instance Integral n => LeftModule Integer (Ratio n) where+ n .* r = fromIntegral n P.* r+instance Integral n => RightModule Integer (Ratio n) where+ r *. n = r P.* fromIntegral n+instance Integral n => Semiring (Ratio n)+instance Integral n => Additive (Ratio n) where+ (+) = (P.+)+ sinnum1p n r = fromIntegral (n P.+ 1) P.* r+instance Integral n => Abelian (Ratio n)+instance Integral n => Multiplicative (Ratio n) where+ (*) = (P.*)+ pow1p r n = r ^^ (n P.+ 1)++data Ideal r = forall n. Ideal (Vector r n)++instance Eq r => Eq (Ideal r) where+ (==) = (==) `on` generators++instance Ord r => Ord (Ideal r) where+ compare = comparing generators++instance Show r => Show (Ideal r) where+ show = show . generators++addToIdeal :: r -> Ideal r -> Ideal r+addToIdeal i (Ideal is) = Ideal (i :- is)++toIdeal :: NoetherianRing r => [r] -> Ideal r+toIdeal = foldr addToIdeal (Ideal Nil)++appendIdeal :: Ideal r -> Ideal r -> Ideal r+appendIdeal (Ideal is) (Ideal js) = Ideal (is `appendV` js)++generators :: Ideal r -> [r]+generators (Ideal is) = toList is++filterIdeal :: NoetherianRing r => (r -> Bool) -> Ideal r -> Ideal r+filterIdeal p (Ideal i) = foldrV (\h -> if p h then addToIdeal h else id) (toIdeal []) i++principalIdeal :: r -> Ideal r+principalIdeal = Ideal . singletonV++mapIdeal :: (r -> r') -> Ideal r -> Ideal r'+mapIdeal fun (Ideal xs) = Ideal $ mapV fun xs
+ Algebra/Ring/Polynomial.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds, ScopedTypeVariables, StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies, TypeOperators, UndecidableInstances, ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-type-defaults #-}+module Algebra.Ring.Polynomial+ ( Polynomial, Monomial, MonomialOrder, Order+ , lex, revlex, graded, grlex, grevlex, transformMonomial+ , IsPolynomial, coeff, lcmMonomial, sPolynomial, polynomial+ , castMonomial, castPolynomial, toPolynomial, changeOrder+ , scastMonomial, scastPolynomial, OrderedPolynomial, showPolynomialWithVars+ , normalize, injectCoeff, varX, var, getTerms, shiftR+ , divs, tryDiv, fromList -- , genVarsV+ , leadingTerm, leadingMonomial, leadingCoeff, genVars, sDegree+ , OrderedMonomial(..), Grevlex(..), Revlex(..), Lex(..), Grlex(..)+ , IsOrder, IsMonomialOrder) where++import Algebra.Internal+import Algebra.Ring.Noetherian+import Control.Arrow+import Control.Lens+import Data.List (intercalate)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Monoid+import Data.Ord+import Data.Proxy+import Numeric.Algebra+import Prelude hiding (lex, (*), (+), (-), (^), (^^), recip, negate)+import qualified Prelude as P+import Data.Hashable++-- | N-ary Monomial. IntMap contains degrees for each x_i.+type Monomial (n :: Nat) = Vector Int n++-- | convert NAry list into Monomial.+fromList :: SNat n -> [Int] -> Monomial n+fromList SZ _ = Nil+fromList (SS n) [] = 0 :- fromList n []+fromList (SS n) (x : xs) = x :- fromList n xs++-- | Monomial order (of degree n). This should satisfy following laws:+-- (1) Totality: forall a, b (a < b || a == b || b < a)+-- (2) Additivity: a <= b ==> a + c <= b + c+-- (3) Non-negative: forall a, 0 <= a+type MonomialOrder n = Monomial n -> Monomial n -> Ordering++totalDegree :: Monomial n -> Int+totalDegree = foldrV (+) 0++-- | Lexicographical order. This *is* a monomial order.+lex :: MonomialOrder n+lex Nil Nil = EQ+lex (x :- xs) (y :- ys) = x `compare` y <> xs `lex` ys+lex _ _ = error "cannot happen"++-- | Reversed lexicographical order. This is *not* a monomial order.+revlex :: Monomial n -> Monomial n -> Ordering+revlex (x :- xs) (y :- ys) = xs `revlex` ys <> y `compare` x+revlex Nil Nil = EQ+revlex _ _ = error "cannot happen!"++-- | Convert ordering into graded one.+graded :: (Monomial n -> Monomial n -> Ordering) -> (Monomial n -> Monomial n -> Ordering)+graded cmp xs ys = comparing totalDegree xs ys <> cmp xs ys++-- | Graded lexicographical order. This *is* a monomial order.+grlex :: MonomialOrder n+grlex = graded lex++-- | Graded reversed lexicographical order. This *is* a monomial order.+grevlex :: MonomialOrder n+grevlex = graded revlex++-- | A wrapper for monomials with a certain (monomial) order.+newtype OrderedMonomial (ordering :: *) n = OrderedMonomial { getMonomial :: Monomial n }+deriving instance (Eq (Monomial n)) => Eq (OrderedMonomial ordering n)++instance Wrapped (Monomial n) (Monomial m) (OrderedMonomial o n) (OrderedMonomial o' m) where+ wrapped = iso OrderedMonomial getMonomial++-- | Class to lookup ordering from its (type-level) name.+class IsOrder (ordering :: *) where+ cmpMonomial :: Proxy ordering -> MonomialOrder n++-- * Names for orderings.+-- We didn't choose to define one single type for ordering names for the extensibility.+data Grevlex = Grevlex -- Graded reversed lexicographical order+ deriving (Show, Eq, Ord)+data Lex = Lex -- Lexicographical order+ deriving (Show, Eq, Ord)+data Grlex = Grlex -- Graded lexicographical order+ deriving (Show, Eq, Ord)+data Revlex = Revlex -- Reversed lexicographical order+ deriving (Show, Eq, Ord)++-- They're all total orderings.+instance IsOrder Grevlex where+ cmpMonomial _ = grevlex++instance IsOrder Revlex where+ cmpMonomial _ = revlex++instance IsOrder Lex where+ cmpMonomial _ = lex++instance IsOrder Grlex where+ cmpMonomial _ = grlex++-- | Class for Monomial orders.+class IsOrder name => IsMonomialOrder name where++-- Note that Revlex is not a monomial order.+-- This distinction is important when we calculate a quotient or Groebner basis.+instance IsMonomialOrder Grlex+instance IsMonomialOrder Grevlex+instance IsMonomialOrder Lex++-- | Special ordering for ordered-monomials.+instance (Eq (Monomial n), IsOrder name) => Ord (OrderedMonomial name n) where+ OrderedMonomial m `compare` OrderedMonomial n = cmpMonomial (Proxy :: Proxy name) m n++-- | For simplicity, we choose grevlex for the default monomial ordering (for the sake of efficiency).+instance (Eq (Monomial n)) => Ord (Monomial n) where+ compare = grevlex++-- | n-ary polynomial ring over some noetherian ring R.+newtype OrderedPolynomial r order n = Polynomial { terms :: Map (OrderedMonomial order n) r }+type Polynomial r = OrderedPolynomial r Grevlex++-- | Type-level constraint to check whether it forms polynomial ring or not.+type IsPolynomial r n = (NoetherianRing r, Sing n, Eq r)++-- | coefficient for a degree.+coeff :: (IsOrder order, IsPolynomial r n) => Monomial n -> OrderedPolynomial r order n -> r+coeff d = M.findWithDefault zero (OrderedMonomial d) . terms++instance Wrapped (Map (OrderedMonomial order n) r) (Map (OrderedMonomial order' m) q)+ (OrderedPolynomial r order n) (OrderedPolynomial q order' m) where+ wrapped = iso Polynomial terms++castMonomial :: (IsOrder o, IsOrder o', Sing m, n :<= m) => OrderedMonomial o n -> OrderedMonomial o' m+castMonomial = unwrapped %~ fromList sing . toList++scastMonomial :: (n :<= m) => SNat m -> OrderedMonomial o n -> OrderedMonomial o m+scastMonomial snat = unwrapped %~ fromList snat . toList++castPolynomial :: (IsPolynomial r n, IsPolynomial r m, Sing m, IsOrder o, IsOrder o', n :<= m)+ => OrderedPolynomial r o n+ -> OrderedPolynomial r o' m+castPolynomial = unwrapped %~ M.mapKeys castMonomial++scastPolynomial :: (IsOrder o, IsOrder o', IsPolynomial r n, IsPolynomial r m, n :<= m, Sing m)+ => SNat m -> OrderedPolynomial r o n -> OrderedPolynomial r o' m+scastPolynomial _ = castPolynomial++normalize :: (Eq r, IsOrder order, IsPolynomial r n)+ => OrderedPolynomial r order n -> OrderedPolynomial r order n+normalize = unwrapped %~ M.insertWith (+) (OrderedMonomial $ fromList sing []) zero . M.filter (/= zero)++instance (Eq r, IsOrder order, IsPolynomial r n) => Eq (OrderedPolynomial r order n) where+ (normalize -> Polynomial f) == (normalize -> Polynomial g) = f == g++injectCoeff :: (IsPolynomial r n) => r -> OrderedPolynomial r order n+injectCoeff r = Polynomial $ M.singleton (OrderedMonomial $ fromList sing []) r++-- | By Hilbert's finite basis theorem, a polynomial ring over a noetherian ring is also a noetherian ring.+instance (IsOrder order, IsPolynomial r n) => NoetherianRing (OrderedPolynomial r order n) where+instance (IsOrder order, IsPolynomial r n) => Ring (OrderedPolynomial r order n) where+instance (IsOrder order, IsPolynomial r n) => Rig (OrderedPolynomial r order n) where+instance (IsOrder order, IsPolynomial r n) => Group (OrderedPolynomial r order n) where+ negate (Polynomial dic) = Polynomial $ fmap negate dic+instance (IsOrder order, IsPolynomial r n) => LeftModule Integer (OrderedPolynomial r order n) where+ n .* Polynomial dic = Polynomial $ fmap (n .*) dic +instance (IsOrder order, IsPolynomial r n) => RightModule Integer (OrderedPolynomial r order n) where+ (*.) = flip (.*)+instance (IsOrder order, IsPolynomial r n) => Additive (OrderedPolynomial r order n) where+ (Polynomial f) + (Polynomial g) = normalize $ Polynomial $ M.unionWith (+) f g+instance (IsOrder order, IsPolynomial r n) => Monoidal (OrderedPolynomial r order n) where+ zero = injectCoeff zero+instance (IsOrder order, IsPolynomial r n) => LeftModule Natural (OrderedPolynomial r order n) where+ n .* Polynomial dic = Polynomial $ fmap (n .*) dic+instance (IsOrder order, IsPolynomial r n) => RightModule Natural (OrderedPolynomial r order n) where+ (*.) = flip (.*)+instance (IsOrder order, IsPolynomial r n) => Unital (OrderedPolynomial r order n) where+ one = injectCoeff one+instance (IsOrder order, IsPolynomial r n) => Multiplicative (OrderedPolynomial r order n) where+ Polynomial (M.toList -> d1) * Polynomial (M.toList -> d2) =+ let dic = [ (OrderedMonomial $ zipWithV (+) a b, r * r') | (getMonomial -> a, r) <- d1, (getMonomial -> b, r') <- d2 ]+ in normalize $ Polynomial $ M.fromListWith (+) dic+instance (IsOrder order, IsPolynomial r n) => Semiring (OrderedPolynomial r order n) where+instance (IsOrder order, IsPolynomial r n) => Commutative (OrderedPolynomial r order n) where+instance (IsOrder order, IsPolynomial r n) => Abelian (OrderedPolynomial r order n) where++instance (Eq r, IsPolynomial r n, IsOrder order, Show r) => Show (OrderedPolynomial r order n) where+ show = showPolynomialWithVars [(n, "X_"++ show n) | n <- [1..]]++showPolynomialWithVars :: (Eq a, Show a, Sing n, NoetherianRing a, IsOrder ordering)+ => [(Int, String)] -> OrderedPolynomial a ordering n -> String+showPolynomialWithVars dic p0@(Polynomial d)+ | p0 == zero = "0"+ | otherwise = intercalate " + " $ mapMaybe showTerm $ M.toDescList d+ where+ showTerm (getMonomial -> deg, c)+ | c == zero = Nothing+ | otherwise =+ let cstr = if (c == zero - one)+ then if any (/= zero) (toList deg) then "-" else "-1"+ else if (c /= one || isConstantMonomial deg)+ then show c ++ " "+ else ""+ in Just $ cstr ++ unwords (mapMaybe showDeg (zip [1..] $ toList deg))+ showDeg (n, p) | p == 0 = Nothing+ | p == 1 = Just $ showVar n+ | otherwise = Just $ showVar n ++ "^" ++ show p+ showVar n = fromMaybe ("X_" ++ show n) $ lookup n dic++isConstantMonomial :: (Eq a, Num a) => Vector a n -> Bool+isConstantMonomial v = all (== 0) $ toList v++-- | We provide Num instance to use trivial injection R into R[X].+-- Do not use signum or abs.+instance (IsMonomialOrder order, IsPolynomial r n, Num r) => Num (OrderedPolynomial r order n) where+ (+) = (Numeric.Algebra.+)+ (*) = (Numeric.Algebra.*)+ fromInteger = injectCoeff . P.fromInteger+ signum f = if f == zero then zero else injectCoeff 1+ abs = id+ negate = ((P.negate 1 :: Integer) .*)++varX :: (NoetherianRing r, Sing n, One :<= n) => OrderedPolynomial r order n+varX = Polynomial $ M.singleton (OrderedMonomial $ fromList sing [1]) one++var :: (NoetherianRing r, Sing m, S n :<= m) => SNat (S n) -> OrderedPolynomial r order m+var vIndex = Polynomial $ M.singleton (OrderedMonomial $ fromList sing (buildIndex vIndex)) one++toPolynomial :: (IsOrder order, IsPolynomial r n) => (r, Monomial n) -> OrderedPolynomial r order n+toPolynomial (c, deg) = Polynomial $ M.singleton (OrderedMonomial deg) c++polynomial :: (Sing n, Eq r, NoetherianRing r, IsOrder order) => Map (OrderedMonomial order n) r -> OrderedPolynomial r order n+polynomial dic = normalize $ Polynomial dic++buildIndex :: SNat (S n) -> [Int]+buildIndex (SS SZ) = [1]+buildIndex (SS (SS n)) = 0 : buildIndex (SS n)++leadingTerm :: (IsOrder order, IsPolynomial r n)+ => OrderedPolynomial r order n -> (r, Monomial n)+leadingTerm (Polynomial d) =+ case M.maxViewWithKey d of+ Just ((deg, c), _) -> (c, getMonomial deg)+ Nothing -> (zero, fromList sing [])++leadingMonomial :: (IsOrder order, IsPolynomial r n) => OrderedPolynomial r order n -> Monomial n+leadingMonomial = snd . leadingTerm++leadingCoeff :: (IsOrder order, IsPolynomial r n) => OrderedPolynomial r order n -> r+leadingCoeff = fst . leadingTerm++divs :: Monomial n -> Monomial n -> Bool+xs `divs` ys = and $ toList $ zipWithV (<=) xs ys++tryDiv :: Field r => (r, Monomial n) -> (r, Monomial n) -> (r, Monomial n)+tryDiv (a, f) (b, g)+ | g `divs` f = (a * recip b, zipWithV (-) f g)+ | otherwise = error "cannot divide."++lcmMonomial :: Monomial n -> Monomial n -> Monomial n+lcmMonomial = zipWithV max++sPolynomial :: (IsPolynomial k n, Field k, IsOrder order)+ => OrderedPolynomial k order n+ -> OrderedPolynomial k order n -> OrderedPolynomial k order n+sPolynomial f g =+ let h = (one, lcmMonomial (leadingMonomial f) (leadingMonomial g))+ in toPolynomial (h `tryDiv` leadingTerm f) * f - toPolynomial (h `tryDiv` leadingTerm g) * g++changeOrder :: (Eq (Monomial n), IsOrder o, IsOrder o', Sing n)+ => o' -> OrderedPolynomial k o n -> OrderedPolynomial k o' n+changeOrder _ = unwrapped %~ M.mapKeys (OrderedMonomial . getMonomial)++getTerms :: OrderedPolynomial k order n -> [(k, Monomial n)]+getTerms = map (snd &&& getMonomial . fst) . M.toDescList . terms++transformMonomial :: (IsOrder o, IsPolynomial k n, IsPolynomial k m)+ => (Monomial n -> Monomial m) -> OrderedPolynomial k o n -> OrderedPolynomial k o m+transformMonomial trans (Polynomial d) = Polynomial $ M.mapKeys (OrderedMonomial . trans . getMonomial) d++shiftR :: forall k r n ord. (Field r, IsPolynomial r n, IsPolynomial r (k :+: n), IsOrder ord)+ => SNat k -> OrderedPolynomial r ord n -> OrderedPolynomial r ord (k :+: n)+shiftR k =+ case singInstance k of+ SingInstance -> transformMonomial (appendV (fromList k []))++genVars :: forall k o n. (IsPolynomial k (S n), IsOrder o)+ => SNat (S n) -> [OrderedPolynomial k o (S n)]+genVars sn =+ let n = toInt sn+ seed = cycle $ 1 : replicate (n - 1) 0+ in map (\m -> Polynomial $ M.singleton (OrderedMonomial $ fromList sn $ take n (drop (n-m) seed)) one) [0..n-1]++sDegree :: OrderedPolynomial k ord n -> SNat n+sDegree (Polynomial dic) = sLengthV $ getMonomial $ fst $ M.findMin dic
+ Algebra/Ring/Polynomial/Monomorphic.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE DataKinds, FlexibleInstances, GADTs, PolyKinds, RecordWildCards #-}+{-# LANGUAGE TypeFamilies, TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Algebra.Ring.Polynomial.Monomorphic where+import qualified Algebra.Algorithms.Groebner as Gr+import Algebra.Internal+import Algebra.Ring.Noetherian+import qualified Algebra.Ring.Polynomial as Poly+import Control.Arrow+import Data.List+import qualified Data.Map as M+import Data.Maybe+import Monomorphic++data Variable = Variable { varName :: Char+ , varIndex :: Maybe Int+ } deriving (Eq, Ord)++instance Show Variable where+ showsPrec _ v = showChar (varName v) . maybe id ((showChar '_' .) . shows) (varIndex v)++type Polyn = [(Rational, [(Variable, Integer)])]++buildVarsList :: Polyn -> [Variable]+buildVarsList = nub . sort . concatMap (map fst . snd)++encodeMonomList :: [Variable] -> [(Variable, Integer)] -> [Int]+encodeMonomList vars mono = map (maybe 0 fromInteger . flip lookup mono) vars++encodeMonomial :: [Variable] -> [(Variable, Integer)] -> Monomorphic (Vector Int)+encodeMonomial vars mono = promote $ encodeMonomList vars mono++encodePolynomial :: Polyn -> Monomorphic (Poly.Polynomial Rational)+encodePolynomial = promote . toPolynomialSetting++toPolynomialSetting :: Polyn -> PolynomialSetting+toPolynomialSetting p =+ PolySetting { polyn = p+ , dimension = promote $ length $ buildVarsList p+ }++data PolynomialSetting = PolySetting { dimension :: Monomorphic SNat+ , polyn :: Polyn+ } deriving (Show)+++instance Poly.IsMonomialOrder ord => Monomorphicable (Poly.OrderedPolynomial Rational ord) where+ type MonomorphicRep (Poly.OrderedPolynomial Rational ord) = PolynomialSetting+ promote PolySetting{..} =+ case dimension of+ Monomorphic dim ->+ case singInstance dim of+ SingInstance -> Monomorphic $ Poly.polynomial $ M.fromList (map ((Poly.OrderedMonomial . Poly.fromList dim . encodeMonomList vars . snd) &&& fst) polyn)+ where+ vars = buildVarsList polyn+ demote (Monomorphic f) =+ PolySetting { polyn = map (second $ toMonom . map toInteger . demote . Monomorphic) $ Poly.getTerms f+ , dimension = Monomorphic $ Poly.sDegree f+ }+ where+ toMonom = zip $ Variable 'X' Nothing : [Variable 'X' (Just i) | i <- [1..]]++uniformlyPromote :: Poly.IsMonomialOrder ord+ => [Polyn] -> Monomorphic (Ideal :.: Poly.OrderedPolynomial Rational ord)+uniformlyPromote ps =+ case promote (length vars) of+ Monomorphic dim ->+ case singInstance dim of+ SingInstance -> Monomorphic $ Comp $ toIdeal $ map (Poly.polynomial . M.fromList . map (Poly.OrderedMonomial . Poly.fromList dim . encodeMonomList vars . snd &&& fst)) ps+ where+ vars = nub $ sort $ concatMap buildVarsList ps++instance Poly.IsMonomialOrder ord => Monomorphicable (Ideal :.: Poly.OrderedPolynomial Rational ord) where+ type MonomorphicRep (Ideal :.: Poly.OrderedPolynomial Rational ord) = [Polyn]+ promote = uniformlyPromote+ demote (Monomorphic (Comp (Ideal v))) = map (polyn . demote . Monomorphic) $ toList v++promoteList :: Poly.IsMonomialOrder ord => [Polyn] -> Monomorphic ([] :.: Poly.OrderedPolynomial Rational ord)+promoteList ps =+ case promote (length vars) of+ Monomorphic dim ->+ case singInstance dim of+ SingInstance -> Monomorphic $ Comp $ map (Poly.polynomial . M.fromList . map (Poly.OrderedMonomial . Poly.fromList dim . encodeMonomList vars . snd &&& fst)) ps+ where+ vars = nub $ sort $ concatMap buildVarsList ps+++{-+data Equal a b where+ Equal :: Equal a a++(%==) :: (a ~ b) => a -> b -> Equal a b+_ %== _ = Equal++thEliminationIdeal' :: Int -> [Polyn] -> [Polyn]+thEliminationIdeal' n [] = []+thEliminationIdeal' n ideal =+ let dim = length $ nub $ sort $ concatMap buildVarsList ideal+ in if n <= 0 || dim <= n+ then error "Degree error!"+ else case promoteList ideal of+ Monomorphic (Comp is@(f:_))->+ case singInstance (sDegree f) of+ SingInstance ->+ case promote n of+ Monomorphic sn ->+ case sDegree f %== (sn %+ sm) of+ Equal -> demote $ Monomorphic $ Comp $ sn `thEliminationIdeal` toIdeal is+-}++renameVars :: [Variable] -> Polyn -> Polyn+renameVars vars = map (second $ map $ first ren)+ where+ ren v = fromMaybe v $ lookup v dic+ dic = zip (Variable 'X' Nothing : [Variable 'X' (Just i) | i <- [1..]]) vars++showPolyn :: Polyn -> String+showPolyn f =+ case encodePolynomial f of+ Monomorphic f' ->+ case singInstance (Poly.sDegree f') of+ SingInstance -> Poly.showPolynomialWithVars dic f'+ where+ dic = zip [1..] $ map show $ buildVarsList f
+ Algebra/Ring/Polynomial/Parser.hs view
@@ -0,0 +1,87 @@+module Algebra.Ring.Polynomial.Parser where+import Algebra.Ring.Polynomial.Monomorphic+import Control.Applicative hiding (many)+import Control.Arrow+import Data.Char+import Data.Maybe+import Data.Ratio+import Text.Parsec hiding (optional, (<|>))+import Text.Parsec.String++variable :: Parser Variable+variable = Variable <$> letter <*> optional (char '_' *> index)++variableWithPower :: Parser (Variable, Integer)+variableWithPower = (,) <$> lexeme variable <*> option 1 power+ where+ power = symbol '^' *> parseInt++index :: Parser Int+index = digitToInt <$> digit+ <|> read <$ symbol '{' <*> lexeme (many1 digit) <* symbol '}'++monomial :: Parser [(Variable, Integer)]+monomial = many variableWithPower++term :: Parser (Rational, [(Variable, Integer)])+term = signed' $ try $ (,) <$> option 1 coefficient+ <*> monomial+ <|> (,) <$> number <*> pure []++signed' p = do+ s <- optional sign+ (c, n) <- p+ return (fromMaybe 1 s * c, n)+ where+ sign = lexeme $ char '-' *> return (negate 1)+ <|> char '+' *> return 1+++symbol :: Char -> Parser Char+symbol = lexeme . char++lexeme :: Parser a -> Parser a+lexeme p = p <* spaces++polyOp :: Parser (Polyn -> Polyn -> Polyn)+polyOp = minusPolyn <$ symbol '-'+ <|> (++) <$ symbol '+'+ where+ minusPolyn xs ys = xs ++ map (first negate) ys++expression :: Parser [(Rational, [(Variable, Integer)])]+expression = spaces *> count 1 term `chainl1` polyOp <* eof++coefficient :: Parser Rational+coefficient = char '(' *> number <* char ')'+ <|> number++number :: Parser Rational+number = signed $+ try (toRational <$> parseDouble)+ <|> try (lexeme $ (%) <$> parseInt+ <* symbol '/'+ <*> parseInt)+ <|> toRational <$> parseInt++parseInt :: Parser Integer+parseInt = lexeme $ read <$> many1 digit++signed :: Num b => Parser b -> Parser b+signed p = do+ s <- optional sign+ n <- p+ return $ fromMaybe 1 s * n+ where+ sign = lexeme $ char '-' *> return (negate 1)+ <|> char '+' *> return 1++parseDouble :: Parser Double+parseDouble = lexeme $ do+ int <- many1 digit+ _ <- char '.'+ float <- many1 digit+ return $ read $ int ++ '.':float++parsePolyn :: String -> Either ParseError Polyn+parsePolyn = parse expression "polynomial"
+ Example.hs view
@@ -0,0 +1,59 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE ConstraintKinds, NoImplicitPrelude, TypeOperators #-}+module Example where+import Algebra.Algorithms.Groebner+import Algebra.Internal+import Algebra.Ring.Noetherian+import Algebra.Ring.Polynomial+import Data.Ratio+import Numeric.Algebra+import Prelude hiding (Fractional (..), Integral (..),+ Num (..), (^), (^^))++default (Int)++(^^) :: Unital r => r -> Natural -> r+(^^) = pow++x, y, f, f1, f2 :: Polynomial (Ratio Integer) Two+x = var sOne+y = var sTwo+f = x^^2 * y + x * y^^2 + y^^2+f1 = x * y - 1+f2 = y^^2 - 1++type LexPolynomial r n = OrderedPolynomial r Lex n++heron :: Ideal (LexPolynomial (Ratio Integer) (Two :+: Two))+heron = sTwo `thEliminationIdeal` ideal+ where+ [x, y, a, b, c, s] = genVars (sThree %+ sThree) :: [LexPolynomial (Ratio Integer) (Three :+: Three)]+ ideal = toIdeal [ 2 * s - a * y+ , b^^2 - (x^^2 + y^^2)+ , c^^2 - ( (a-x) ^^ 2 + y^^2)+ ]++main :: IO ()+main = do+ putStrLn $ unwords ["(" ++ show (x + 1) ++ ")^2", "="+ , show $ (x + 1) ^^2 ]+ putStrLn $ unwords ["(" ++ show (x + 1) ++ ")(" ++ show (x - 1) ++ ")", "="+ , show $ (x + 1) * (x - 1) ]+ putStrLn $ unwords ["(" ++ show (x - 1) ++ ")(" ++ show (y^^2 + y - 1) ++ ")", "="+ , show $ (x - 1) * (y^^2 + y- 1) ]+ putStrLn ""+ putStrLn "*** deriving Heron's formula ***"+ putStrLn "Area of triangles can be determined from following equations:"+ putStrLn "\t2S = ay, b^2 = x^2 + y^2, c^2 = (a-x)^2 + y^2"+ putStrLn ", where a, b, c and S stands for three lengths of the traiangle and its area, "+ putStrLn "and (x, y) stands for the coordinate of one of its vertices"+ putStrLn "(other two vertices are assumed to be on the origin and x-axis)."+ putStrLn "Erasing x and y from the equations above, we can get Heron's formula."+ putStrLn "Using elimination ideal, this can be automatically solved."+ putStrLn "We calculate this with theory of Groebner basis with respect to 'lex'."+ putStrLn "This might take a while. please wait..."+ print heron+ putStrLn "In equation above, X_1, X_2, X_3 and X_4 stands for a, b, c and S, respectively."+ putStrLn "The ideal has just one polynomial `f' as its only generator."+ putStrLn "Solving the equation `f = 0' assuming S > 0, we can get Heron's formula."+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Hiromi ISHII++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Hiromi ISHII nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 COPYRIGHT+OWNER 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.
+ Monomorphic.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DataKinds, ExistentialQuantification, FlexibleContexts, GADTs #-}+{-# LANGUAGE PolyKinds, RankNTypes, TypeFamilies, TypeOperators #-}+{-# LANGUAGE UndecidableInstances, CPP #-}+#if __GLASGOW_HASKELL__ >= 761+module Monomorphic (module Data.Type.Monomorphic) where+import Data.Type.Monomorphic+#else+module Monomorphic ( Monomorphic (..), Monomorphicable(..)+ , demote', demoteComposed, monomorphicCompose+ , withPolymorhic, liftPoly, viaPoly, (:.:)(..)+ ) where+import Control.Arrow++newtype (:.:) f g a = Comp (f (g a))++-- | A wrapper type for polymophic types.+data Monomorphic k = forall a. Monomorphic (k a)++-- | A types which have the monomorphic representation.+class Monomorphicable k where+ -- | Monomorphic representation+ type MonomorphicRep k :: *+ -- | Promote the monomorphic value to the polymophic one.+ promote :: MonomorphicRep k -> Monomorphic k+ -- | Demote the polymorphic value to the monomorphic representation.+ demote :: Monomorphic k -> MonomorphicRep k++-- | Convinience function to demote polymorphic types into monomorphic one directly.+demote' :: Monomorphicable k => k a -> MonomorphicRep k+demote' = demote . Monomorphic++-- | Demote polymorphic nested types directly into monomorphic representation.+demoteComposed :: Monomorphicable (f :.: g) => f (g a) -> MonomorphicRep (f :.: g)+demoteComposed = demote . Monomorphic . Comp++monomorphicCompose :: f (g a) -> Monomorphic (f :.: g)+monomorphicCompose = Monomorphic . Comp++-- | Apply dependently-typed function to the monomorphic representation.+withPolymorhic :: Monomorphicable k+ => MonomorphicRep k -> (forall a. k a -> b) -> b+withPolymorhic k trans =+ case promote k of+ Monomorphic a -> trans a++-- | Flipped version of 'withPolymorhic'.+liftPoly :: Monomorphicable k+ => (forall a. k a -> b) -> MonomorphicRep k -> b+liftPoly = flip withPolymorhic++-- | Demote the function between polymorphic types into the one between monomorphic one.+viaPoly :: (Monomorphicable k, Monomorphicable k')+ => (forall x y. k x -> k' y) -> MonomorphicRep k -> MonomorphicRep k'+viaPoly f a = demote $ Monomorphic $ liftPoly f a++instance (Show (MonomorphicRep k), Monomorphicable k) => Show (Monomorphic k) where+ showsPrec d x = showString "Polymorphic " . showsPrec (d + 1) (demote x)++instance (Read (MonomorphicRep k), Monomorphicable k) => Read (Monomorphic k) where+ readsPrec i = map (first promote) . readsPrec i+#endif+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ computational-algebra.cabal view
@@ -0,0 +1,36 @@+-- Initial computational-algebra.cabal generated by cabal init. For +-- further documentation, see http://haskell.org/cabal/users-guide/++name: computational-algebra+version: 0.0.1.0+synopsis: Well-kinded computational algebra library, currently supporting Groebner basis.+description: Dependently-typed computational algebra libray for Groebner basis.+homepage: https://github.com/konn/computational-algebra+license: BSD3+license-file: LICENSE+author: Hiromi ISHII+maintainer: konn.jinro_at_gmail.com+copyright: (C) Hiromi ISHII 2013+category: Math+build-type: Simple+cabal-version: >=1.8+source-repository head+ Type: git+ Location: git://github.com/konn/computational-algebra.git++library+ exposed-modules: Algebra.Algorithms.Groebner+ , Algebra.Algorithms.Groebner.Monomorphic+ , Algebra.Ring.Noetherian+ , Algebra.Ring.Polynomial+ , Algebra.Ring.Polynomial.Monomorphic+ , Algebra.Ring.Polynomial.Parser+ other-modules: Example, Monomorphic, Algebra.Internal+ build-depends: base >= 2.0 && < 5+ , algebra == 3.*+ , tagged >= 0.4 && < 1+ , lens == 3.*+ , containers >= 0.4 && < 0.6+ , parsec == 3.*+ if impl(ghc >= 7.6.1)+ build-depends: monomorphic == 0.0.*