computational-algebra 0.3.0.0 → 0.4.0.0
raw patch · 85 files changed
+10856/−1897 lines, 85 filesdep +HUnitdep +MonadRandomdep +QuickCheckdep −peggydep −sized-vectordep ~algebradep ~basedep ~containersnew-component:exe:algebraicnew-component:exe:faugere-profnew-component:exe:groebner-profnew-component:exe:hensel-profnew-component:exe:ipsolvenew-component:exe:quotientnew-component:exe:sandpit-polynew-component:exe:solve
Dependencies added: HUnit, MonadRandom, QuickCheck, algebraic-prelude, arithmoi, computational-algebra, constraints, control-monad-loop, convertible, criterion, deepseq, dlist, entropy, hashable, hmatrix, hspec, hybrid-vectors, lazysmallcheck, matrix, mono-traversable, mtl, parallel, primes, process, quickcheck-instances, random, reflection, semigroups, sized, smallcheck, template-haskell, test-framework, test-framework-hunit, text, transformers, unamb, unordered-containers, vector
Dependencies removed: peggy, sized-vector
Dependency ranges changed: algebra, base, containers, equational-reasoning, heaps, lens, monad-loops, monomorphic, singletons, tagged, type-natural
Files
- Algebra/Algorithms/ChineseRemainder.hs +49/−0
- Algebra/Algorithms/FGLM.hs +43/−0
- Algebra/Algorithms/Groebner.hs +338/−248
- Algebra/Algorithms/Groebner/Monomorphic.hs +0/−269
- Algebra/Algorithms/PrimeTest.hs +82/−0
- Algebra/Algorithms/ZeroDim.hs +409/−0
- Algebra/Field/AlgebraicReal.hs +728/−0
- Algebra/Field/Finite.hs +238/−0
- Algebra/Field/Galois.hs +243/−0
- Algebra/Field/Galois/Conway.hs +28/−0
- Algebra/Field/Galois/Internal.hs +61/−0
- Algebra/Instances.hs +175/−0
- Algebra/Internal.hs +109/−6
- Algebra/LinkedMatrix.hs +892/−0
- Algebra/Matrix.hs +230/−0
- Algebra/Normed.hs +29/−0
- Algebra/Prelude.hs +13/−0
- Algebra/Prelude/Core.hs +36/−0
- Algebra/Ring/Ideal.hs +56/−0
- Algebra/Ring/Noetherian.hs +0/−114
- Algebra/Ring/Polynomial.hs +379/−430
- Algebra/Ring/Polynomial/Class.hs +554/−0
- Algebra/Ring/Polynomial/Factorise.hs +378/−0
- Algebra/Ring/Polynomial/Labeled.hs +263/−0
- Algebra/Ring/Polynomial/Monomial.hs +364/−0
- Algebra/Ring/Polynomial/Monomorphic.hs +0/−202
- Algebra/Ring/Polynomial/Parser.hs +0/−66
- Algebra/Ring/Polynomial/Quotient.hs +520/−0
- Algebra/Ring/Polynomial/Univariate.hs +373/−0
- Algebra/Scalar.hs +57/−0
- Monomorphic.hs +0/−5
- README.md +43/−33
- bench/SingularBench.hs +83/−0
- bench/bench.hs +102/−0
- bench/coercion.hs +102/−0
- bench/division.hs +109/−0
- bench/elimination-bench.hs +51/−0
- bench/faugere4.hs +140/−0
- bench/linear.hs +49/−0
- bench/monomials.hs +61/−0
- bench/quotient-bench-randomized.hs +61/−0
- bench/solve.hs +93/−0
- bench/sugar-bench.hs +54/−0
- bench/sugar-paper.hs +73/−0
- bench/sugar.hs +99/−0
- bench/unipol-bench.hs +253/−0
- bench/unipol-div.hs +58/−0
- bench/unipol-mult.hs +90/−0
- computational-algebra.cabal +875/−40
- data/conway.txt +52/−0
- examples/algebraic.hs +13/−0
- examples/bench.hs +0/−99
- examples/elimination-bench.hs +0/−50
- examples/faugere-prof.hs +13/−0
- examples/groebner-prof.hs +16/−0
- examples/hensel-prof.hs +21/−0
- examples/ipsolve.hs +159/−0
- examples/monomorphic.hs +1/−1
- examples/poly-02.hs +0/−12
- examples/polymorphic.hs +38/−29
- examples/quotient.hs +45/−0
- examples/sandpit-poly.hs +53/−28
- examples/sandpit.hs +0/−44
- examples/site-example.hs +51/−0
- examples/solve.hs +144/−0
- examples/sugar-bench.hs +0/−54
- examples/sugar-paper.hs +0/−68
- examples/sugar.hs +0/−99
- share/HspecSmallCheck.hs +20/−0
- share/SequenceMonomial.hs +67/−0
- share/SingularBridge.hs +123/−0
- share/Utils.hs +253/−0
- tests/Faugere5Spec-disabled.hs +61/−0
- tests/GroebnerSpec.hs +123/−0
- tests/PolynomialSpec.hs +69/−0
- tests/QuotientSpec.hs +71/−0
- tests/SingularTest.hs +15/−0
- tests/Spec.hs +1/−0
- tests/UnivariateSpec.hs +66/−0
- tests/ZeroDimSpec.hs +155/−0
- tests/division.hs +46/−0
- tests/linear.hs +33/−0
- tests/matrix.hs +28/−0
- tests/monomials.hs +47/−0
- tests/multi-table.hs +29/−0
+ Algebra/Algorithms/ChineseRemainder.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE ViewPatterns #-}+-- | Chinese Remainder for Rational numbers.+--+-- Since 0.4.0.0+module Algebra.Algorithms.ChineseRemainder+ ( recoverRat+ , rationalChineseRemainder+ ) where+import Algebra.Instances ()+import AlgebraicPrelude+import Data.List (findIndices)+import Numeric.Domain.Euclidean (euclid)+import Numeric.Domain.Euclidean (chineseRemainder)+import qualified Prelude as P++-- | Recovers rational number from Z/pZ.+recoverRat :: Integer -- ^ Bound for numerator+ -> Integer -- ^ modulus+ -> Integer -- ^ integer corresponds to the rational number.+ -> Maybe (Fraction Integer) -- ^ recovered rational number+recoverRat (abs -> k) m g+ | g == 0 = Just 0+ | otherwise =+ let ps = euclid m g+ ixs = findIndices (\(rj, _, _) -> P.abs rj < k) ps+ in if null ixs+ then Nothing+ else+ let j = last ixs+ (r, _, t) = ps !! j+ (r0,_ , t0) = ps !! (j + 1)+ q | j == 0 = 0+ | otherwise = head $ filter (\v -> r0 - v*r < k && k <= r0 - (v-1)*r) [1..]+ (r', t') = (r0 - q * r, t0 - q * t)+ in if gcd r t == 1+ then Just (r % t)+ else if gcd r' t' == 1 && abs t' <= m `quot` k+ then Just (r' % t')+ else Nothing++-- | Chinese Remainder for raional numbers.+rationalChineseRemainder :: Integer+ -> [(Integer, Integer)]+ -> Maybe (Fraction Integer)+rationalChineseRemainder k mvs =+ let m = product $ map fst mvs+ g = chineseRemainder mvs+ in recoverRat k m g+
+ Algebra/Algorithms/FGLM.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds, FlexibleContexts, MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude, TemplateHaskell #-}+module Algebra.Algorithms.FGLM (FGLMEnv(..), lMap, gLex, bLex, proced,+ monomial, look, (.==), (%==), image, Machine) where+import Algebra.Ring.Polynomial+import Control.Lens+import Control.Monad+import Control.Monad.Reader+import Control.Monad.ST+import Data.Function+import Data.Maybe+import Data.STRef+import qualified Data.Vector as V+import Prelude hiding (Num (..), recip, (^))++data FGLMEnv s r ord n = FGLMEnv { _lMap :: OrderedPolynomial r ord n -> V.Vector r+ , _gLex :: STRef s [OrderedPolynomial r Lex n]+ , _bLex :: STRef s [OrderedPolynomial r ord n]+ , _proced :: STRef s (Maybe (OrderedPolynomial r Lex n))+ , _monomial :: STRef s (OrderedMonomial Lex n)+ }++makeLenses ''FGLMEnv++type Machine s r ord n = ReaderT (FGLMEnv s r ord n) (ST s)++look :: Getting (STRef s b) (FGLMEnv s r ord n) (STRef s b) -> Machine s r ord n b+look = lift . readSTRef <=< view++(.==) :: (MonadTrans t, MonadReader s (t (ST s1))) => Getting (STRef s1 a) s (STRef s1 a) -> a -> t (ST s1) ()+v .== a = do+ ref <- view v+ lift $ writeSTRef ref a++(%==) :: (MonadTrans t, MonadReader s (t (ST s1))) => Getting (STRef s1 a) s (STRef s1 a) -> (a -> a) -> t (ST s1) ()+v %== f = do+ ref <- view v+ lift $ modifySTRef' ref f++infix 4 .==, %==++image :: (MonadReader (FGLMEnv s r ord n) f) => OrderedPolynomial r ord n -> f (V.Vector r)+image a = views lMap ($ a)
Algebra/Algorithms/Groebner.hs view
@@ -1,87 +1,63 @@-{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, FlexibleInstances #-}-{-# LANGUAGE GADTs, MultiParamTypeClasses, NoImplicitPrelude #-}-{-# LANGUAGE ParallelListComp, RankNTypes, ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell, TypeFamilies, TypeOperators #-}+{-# LANGUAGE ConstraintKinds, DataKinds, EmptyCase, FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances, GADTs, MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude, ParallelListComp, PolyKinds, RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators, ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}-module Algebra.Algorithms.Groebner (- -- * Polynomial division- divModPolynomial, divPolynomial, modPolynomial- -- * Groebner basis- , calcGroebnerBasis, calcGroebnerBasisWith, calcGroebnerBasisWithStrategy- , buchberger, syzygyBuchberger- , simpleBuchberger, primeTestBuchberger- , reduceMinimalGroebnerBasis, minimizeGroebnerBasis- -- ** Selection Strategies- , syzygyBuchbergerWithStrategy- , SelectionStrategy(..), calcWeight', GrevlexStrategy(..)- , NormalStrategy(..), SugarStrategy(..), GradedStrategy(..)- -- * Ideal operations- , isIdealMember, intersection, thEliminationIdeal, thEliminationIdealWith- , unsafeThEliminationIdealWith- , quotIdeal, quotByPrincipalIdeal- , saturationIdeal, saturationByPrincipalIdeal- -- * Resultant- , resultant, hasCommonFactor- ) where-import Algebra.Internal-import Algebra.Ring.Noetherian-import Algebra.Ring.Polynomial-import Control.Applicative-import Control.Monad-import Control.Monad.Loops-import Control.Monad.ST-import qualified Data.Foldable as H-import Data.Function-import qualified Data.Heap as H-import Data.List-import Data.Maybe-import Data.STRef-import Data.Type.Monomorphic-import Data.Type.Natural hiding (max, one, zero)-import Data.Vector.Sized hiding (all, drop, foldr, head, map,- take, zipWith)-import qualified Data.Vector.Sized as V-import Numeric.Algebra hiding ((>))-import Prelude hiding (Num (..), recip, (^))+module Algebra.Algorithms.Groebner+ (+ -- * Groebner basis+ isGroebnerBasis+ , calcGroebnerBasis, calcGroebnerBasisWith+ , calcGroebnerBasisWithStrategy+ , buchberger, syzygyBuchberger+ , simpleBuchberger, primeTestBuchberger+ , reduceMinimalGroebnerBasis, minimizeGroebnerBasis+ -- ** Selection Strategies+ , syzygyBuchbergerWithStrategy+ , SelectionStrategy(..), calcWeight', GrevlexStrategy(..)+ , NormalStrategy(..), SugarStrategy(..), GradedStrategy(..)+ -- * Ideal operations+ , isIdealMember, intersection, thEliminationIdeal, thEliminationIdealWith+ , unsafeThEliminationIdealWith+ , quotIdeal, quotByPrincipalIdeal+ , saturationIdeal, saturationByPrincipalIdeal+ -- * Resultant+ , resultant, hasCommonFactor+ , lcmPolynomial, gcdPolynomial+ ) where+import Algebra.Internal+import Algebra.Prelude.Core+import Algebra.Ring.Polynomial.Univariate (Unipol)++import Control.Lens ((%~), (&), _Wrapped)+import Control.Monad.Loops (whileM_)+import Control.Monad.ST (ST, runST)+import qualified Data.Foldable as H+import qualified Data.Heap as H+import qualified Data.Map as M+import Data.Singletons.Prelude (POrd (..), SEq (..))+import Data.Singletons.Prelude (Sing (SFalse, STrue), withSingI)+import Data.Singletons.Prelude.List (Length, Replicate, Sing (SCons))+import Data.Singletons.Prelude.List (sLength, sReplicate)+import Data.Sized.Builtin (toList)+import qualified Data.Sized.Builtin as V+import Data.STRef (STRef, modifySTRef, newSTRef)+import Data.STRef (readSTRef, writeSTRef)+import qualified Prelude as P import Proof.Equational --- | Calculate a polynomial quotient and remainder w.r.t. second argument.-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))+-- | Test if the given ideal is Groebner basis, using Buchberger criteria and relatively primeness.+isGroebnerBasis :: (IsOrderedPolynomial poly, Field (Coefficient poly))+ => Ideal poly -> Bool+isGroebnerBasis (nub . generators -> ideal) = all check $ combinations ideal 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'---- | Remainder of given polynomial w.r.t. the second argument.-modPolynomial :: (IsPolynomial r n, Field r, IsMonomialOrder order)- => OrderedPolynomial r order n- -> [OrderedPolynomial r order n]- -> OrderedPolynomial r order n-modPolynomial = (snd .) . divModPolynomial---- | A Quotient of given polynomial w.r.t. the second argument.-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`+ check (f, g) =+ let (t, u) = (leadingMonomial f , leadingMonomial g)+ in t*u == lcmMonomial t u || sPolynomial f g `modPolynomial` ideal == zero -- | The Naive buchberger's algorithm to calculate Groebner basis for the given ideal.-simpleBuchberger :: (Field k, IsPolynomial k n, IsMonomialOrder order)- => Ideal (OrderedPolynomial k order n) -> [OrderedPolynomial k order n]+simpleBuchberger :: (Field (Coefficient poly), IsOrderedPolynomial poly)+ => Ideal poly -> [poly] simpleBuchberger ideal = let gs = nub $ generators ideal in fst $ until (null . snd) (\(ggs, acc) -> let cur = nub $ ggs ++ acc in@@ -92,8 +68,8 @@ ] -- | Buchberger's algorithm slightly improved by discarding relatively prime pair.-primeTestBuchberger :: (Field r, IsPolynomial r n, IsMonomialOrder order)- => Ideal (OrderedPolynomial r order n) -> [OrderedPolynomial r order n]+primeTestBuchberger :: (Field (Coefficient poly), IsOrderedPolynomial poly)+ => Ideal poly -> [poly] primeTestBuchberger ideal = let gs = nub $ generators ideal in fst $ until (null . snd) (\(ggs, acc) -> let cur = nub $ ggs ++ acc in@@ -101,7 +77,7 @@ where calc acc = [ q | f <- acc, g <- acc, f /= g , let f0 = leadingMonomial f, let g0 = leadingMonomial g- , lcmMonomial f0 g0 /= V.zipWithSame (+) f0 g0+ , lcmMonomial f0 g0 /= f0 * g0 , let q = sPolynomial f g `modPolynomial` acc, q /= zero ] @@ -111,58 +87,40 @@ (%=) :: STRef s a -> (a -> a) -> ST s () x %= f = modifySTRef x f -padVec :: a -> Vector a n -> Vector a m -> (Vector a (Max n m), Vector a (Max n m))-padVec _ Nil Nil = (Nil, Nil)-padVec def (x :- xs) (y :- ys) =- case padVec def xs ys of- (xs', ys') -> (x :- xs', y :- ys')-padVec def (x :- xs) Nil =- case padVec def xs Nil of- (xs', ys') -> case maxZR (sLength xs) of- Refl -> (x :- xs', def :- ys')-padVec def Nil (y :- ys) =- case padVec def Nil ys of- (xs', ys') -> case maxZL (sLength ys) of- Refl -> (def :- xs', y :- ys')- combinations :: [a] -> [(a, a)] combinations xs = concat $ zipWith (map . (,)) xs $ drop 1 $ tails xs+{-# INLINE combinations #-} -- | Calculate Groebner basis applying (modified) Buchberger's algorithm. -- This function is same as 'syzygyBuchberger'.-buchberger :: (Field r, IsPolynomial r n, IsMonomialOrder order)- => Ideal (OrderedPolynomial r order n) -> [OrderedPolynomial r order n]+buchberger :: (Field (Coefficient poly), IsOrderedPolynomial poly)+ => Ideal poly -> [poly] buchberger = syzygyBuchberger -- | Buchberger's algorithm greately improved using the syzygy theory with the sugar strategy. -- Utilizing priority queues, this function reduces division complexity and comparison time. -- If you don't have strong reason to avoid this function, this function is recommended to use.-syzygyBuchberger :: (Field r, IsPolynomial r n, IsMonomialOrder order)- => Ideal (OrderedPolynomial r order n) -> [OrderedPolynomial r order n]+syzygyBuchberger :: (Field (Coefficient poly), IsOrderedPolynomial poly)+ => Ideal poly -> [poly] syzygyBuchberger = syzygyBuchbergerWithStrategy (SugarStrategy NormalStrategy)--(=@=) :: Vector Int n -> Vector Int m -> Bool-Nil =@= Nil = True-(x :- xs) =@= (y :- ys) = x == y && xs =@= ys-Nil =@= (0 :- ys) = Nil =@= ys-(0 :- xs) =@= Nil = xs =@= Nil-_ =@= _ = False--instance Eq (Monomorphic (OrderedMonomial ord)) where- Monomorphic xs == Monomorphic ys = getMonomial xs =@= getMonomial ys--instance IsMonomialOrder ord => Ord (Monomorphic (OrderedMonomial ord)) where- compare (Monomorphic (OrderedMonomial m)) (Monomorphic (OrderedMonomial m')) =- let (mm, mm') = padVec 0 m m'- in cmpMonomial (Proxy :: Proxy ord) mm mm'+{-# SPECIALISE INLINE [0]+ syzygyBuchberger :: (CoeffRing r, Field r, IsMonomialOrder n ord, KnownNat n)+ => Ideal (OrderedPolynomial r ord n) -> [OrderedPolynomial r ord n]+ #-}+{-# SPECIALISE INLINE [0]+ syzygyBuchberger :: (CoeffRing r, Field r)+ => Ideal (Unipol r) -> [Unipol r]+ #-}+{-# INLINE [1] syzygyBuchberger #-} -- | apply buchberger's algorithm using given selection strategy.-syzygyBuchbergerWithStrategy :: ( Field r, IsPolynomial r n, IsMonomialOrder order, SelectionStrategy strategy- , Ord (Weight strategy order))- => strategy -> Ideal (OrderedPolynomial r order n) -> [OrderedPolynomial r order n]+syzygyBuchbergerWithStrategy :: (Field (Coefficient poly), IsOrderedPolynomial poly,+ SelectionStrategy (Arity poly) strategy,+ Ord (Weight (Arity poly) strategy (MOrder poly)))+ => strategy -> Ideal poly -> [poly] syzygyBuchbergerWithStrategy strategy ideal = runST $ do- let gens = zip [1..] $ generators ideal- gs <- newSTRef $ H.fromList [H.Entry (leadingOrderedMonomial g) g | (_, g) <- gens]+ let gens = zip [1..] $ filter (/= zero) $ generators ideal+ gs <- newSTRef $ H.fromList [H.Entry (leadingMonomial g) g | (_, g) <- gens] b <- newSTRef $ H.fromList [H.Entry (calcWeight' strategy f g, j) (f, g) | ((_, f), (j, g)) <- combinations gens] len <- newSTRef (genericLength gens :: Integer) whileM_ (not . H.null <$> readSTRef b) $ do@@ -176,67 +134,96 @@ && (all (\k -> H.all ((/=k) . H.payload) rest) [(f, h), (g, h), (h, f), (h, g)]) && leadingMonomial h `divs` l) gs0- when (l /= V.zipWithSame (+) f0 g0 && not redundant) $ do+ when (l /= f0 * g0 && not redundant) $ do len0 <- readSTRef len let qs = (H.toList gs0) s = sPolynomial f g `modPolynomial` map H.payload qs when (s /= zero) $ do b %= H.union (H.fromList [H.Entry (calcWeight' strategy q s, j) (q, s) | H.Entry _ q <- qs | j <- [len0+1..]])- gs %= H.insert (H.Entry (leadingOrderedMonomial s) s)+ gs %= H.insert (H.Entry (leadingMonomial s) s) len %= (*2) map H.payload . H.toList <$> readSTRef gs+{-# SPECIALISE INLINE [0]+ syzygyBuchbergerWithStrategy :: (Field k, CoeffRing k, KnownNat n)+ => SugarStrategy NormalStrategy -> Ideal (OrderedPolynomial k Grevlex n) -> [OrderedPolynomial k Grevlex n]+ #-}+{-# SPECIALISE INLINE [0]+ syzygyBuchbergerWithStrategy :: (Field k, CoeffRing k)+ => SugarStrategy NormalStrategy -> Ideal (Unipol k) -> [Unipol k]+ #-} +{-# SPECIALISE INLINE [1]+ syzygyBuchbergerWithStrategy :: (Field k, CoeffRing k, KnownNat n, IsMonomialOrder n ord)+ => SugarStrategy NormalStrategy -> Ideal (OrderedPolynomial k ord n) -> [OrderedPolynomial k ord n]+ #-}+{-# SPECIALISE INLINE [1]+ syzygyBuchbergerWithStrategy :: (Field k, CoeffRing k, IsMonomialOrder n ord,+ SelectionStrategy n strategy, KnownNat n,+ Ord (Weight n strategy ord))+ => strategy -> Ideal (OrderedPolynomial k ord n) -> [OrderedPolynomial k ord n]+ #-}+{-# INLINABLE [2] syzygyBuchbergerWithStrategy #-}++ -- | Calculate the weight of given polynomials w.r.t. the given strategy.--- Buchberger's algorithm proccesses the pair with the most least weight first.--- This function requires the @Ord@ instance for the weight; this constraint is not required--- in the 'calcWeight' because of the ease of implementation. So use this function.-calcWeight' :: (SelectionStrategy s, IsPolynomial r n, IsMonomialOrder ord, Ord (Weight s ord))- => s -> OrderedPolynomial r ord n -> OrderedPolynomial r ord n -> Weight s ord+-- Buchberger's algorithm proccesses the pair with the most least weight first.+-- This function requires the @Ord@ instance for the weight; this constraint is not required+-- in the 'calcWeight' because of the ease of implementation. So use this function.+calcWeight' :: (SelectionStrategy (Arity poly) s, IsOrderedPolynomial poly)+ => s -> poly -> poly -> Weight (Arity poly) s (MOrder poly) calcWeight' s = calcWeight (toProxy s)+{-# INLINE calcWeight' #-} -- | Type-class for selection strategies in Buchberger's algorithm.-class SelectionStrategy s where- type Weight s ord :: *- calcWeight :: (IsPolynomial r n, IsMonomialOrder ord)- => Proxy s -> OrderedPolynomial r ord n -> OrderedPolynomial r ord n -> Weight s ord+class SelectionStrategy n s where+ type Weight n s ord :: *+ -- | Calculates the weight for the given pair of polynomial used for selection strategy.+ calcWeight :: (IsOrderedPolynomial poly, n ~ Arity poly)+ => Proxy s -> poly -> poly -> Weight n s (MOrder poly) -- | Buchberger's normal selection strategy. This selects the pair with--- the least LCM(LT(f), LT(g)) w.r.t. current monomial ordering.+-- the least LCM(LT(f), LT(g)) w.r.t. current monomial ordering. data NormalStrategy = NormalStrategy deriving (Read, Show, Eq, Ord) -instance SelectionStrategy NormalStrategy where- type Weight NormalStrategy ord = Monomorphic (OrderedMonomial ord)- calcWeight _ f g = Monomorphic $- OrderedMonomial (lcmMonomial (leadingMonomial f) (leadingMonomial g))- `asTypeOf` leadingOrderedMonomial f+instance SelectionStrategy n NormalStrategy where+ type Weight n NormalStrategy ord = OrderedMonomial ord n+ calcWeight _ f g = lcmMonomial (leadingMonomial f) (leadingMonomial g)+ {-# INLINE calcWeight #-} -- | Choose the pair with the least LCM(LT(f), LT(g)) w.r.t. 'Grevlex' order. data GrevlexStrategy = GrevlexStrategy deriving (Read, Show, Eq, Ord) -instance SelectionStrategy GrevlexStrategy where- type Weight GrevlexStrategy ord = Monomorphic (OrderedMonomial Grevlex)- calcWeight _ f g = Monomorphic $ OrderedMonomial $ lcmMonomial (leadingMonomial f) (leadingMonomial g)+instance SelectionStrategy n GrevlexStrategy where+ type Weight n GrevlexStrategy ord = OrderedMonomial Grevlex n+ calcWeight _ f g = changeMonomialOrderProxy Proxy $+ lcmMonomial (leadingMonomial f) (leadingMonomial g)+ {-# INLINE calcWeight #-} data GradedStrategy = GradedStrategy deriving (Read, Show, Eq, Ord) -- | Choose the pair with the least LCM(LT(f), LT(g)) w.r.t. graded current ordering.-instance SelectionStrategy GradedStrategy where- type Weight GradedStrategy ord = Monomorphic (OrderedMonomial (Graded ord))- calcWeight _ f g = Monomorphic $ OrderedMonomial (lcmMonomial (leadingMonomial f) (leadingMonomial g))+instance SelectionStrategy n GradedStrategy where+ type Weight n GradedStrategy ord = OrderedMonomial (Graded ord) n+ calcWeight _ f g = changeMonomialOrderProxy Proxy $+ lcmMonomial (leadingMonomial f) (leadingMonomial g)+ {-# INLINE calcWeight #-} + -- | Sugar strategy. This chooses the pair with the least phantom homogenized degree and then break the tie with the given strategy (say @s@). data SugarStrategy s = SugarStrategy s deriving (Read, Show, Eq, Ord) -instance SelectionStrategy s => SelectionStrategy (SugarStrategy s) where- type Weight (SugarStrategy s) ord = (Int, Weight s ord)+instance SelectionStrategy n s => SelectionStrategy n (SugarStrategy s) where+ type Weight n (SugarStrategy s) ord = (Int, Weight n s ord) calcWeight (Proxy :: Proxy (SugarStrategy s)) f g = (sugar, calcWeight (Proxy :: Proxy s) f g) where- deg' = maximum . map (totalDegree . snd) . getTerms+ deg' = maximum . map totalDegree . H.toList . orderedMonomials tsgr h = deg' h - totalDegree (leadingMonomial h) sugar = max (tsgr f) (tsgr g) + totalDegree (lcmMonomial (leadingMonomial f) (leadingMonomial g))+ {-# INLINE calcWeight #-} -minimizeGroebnerBasis :: (Field k, IsPolynomial k n, IsMonomialOrder order)- => [OrderedPolynomial k order n] -> [OrderedPolynomial k order n]++minimizeGroebnerBasis :: (Field (Coefficient poly), IsOrderedPolynomial poly)+ => [poly] -> [poly] minimizeGroebnerBasis bs = runST $ do left <- newSTRef $ map monoize $ filter (/= zero) bs right <- newSTRef []@@ -250,8 +237,8 @@ readSTRef right -- | Reduce minimum Groebner basis into reduced Groebner basis.-reduceMinimalGroebnerBasis :: (Field k, IsPolynomial k n, IsMonomialOrder order)- => [OrderedPolynomial k order n] -> [OrderedPolynomial k order n]+reduceMinimalGroebnerBasis :: (Field (Coefficient poly), IsOrderedPolynomial poly)+ => [poly] -> [poly] reduceMinimalGroebnerBasis bs = runST $ do left <- newSTRef bs right <- newSTRef []@@ -263,153 +250,256 @@ if q == zero then writeSTRef right ys else writeSTRef right (q : ys) readSTRef right -monoize :: (Field k, IsPolynomial k n, IsMonomialOrder order)- => OrderedPolynomial k order n -> OrderedPolynomial k order n-monoize f = injectCoeff (recip $ leadingCoeff f) * f- -- | Caliculating reduced Groebner basis of the given ideal w.r.t. the specified monomial order.-calcGroebnerBasisWith :: (Field k, IsPolynomial k n, IsMonomialOrder order, IsMonomialOrder order')- => order -> Ideal (OrderedPolynomial k order' n) -> [OrderedPolynomial k order n]-calcGroebnerBasisWith ord i = calcGroebnerBasis $ mapIdeal (changeOrder ord) i+calcGroebnerBasisWith :: (IsOrderedPolynomial poly,+ Field (Coefficient poly),+ IsMonomialOrder (Arity poly) order)+ => order -> Ideal poly+ -> [OrderedPolynomial (Coefficient poly) order (Arity poly)]+calcGroebnerBasisWith _ord = calcGroebnerBasis . mapIdeal injectVars+{-# INLINE [1] calcGroebnerBasisWith #-}+{-# RULES+"calcGroebnerBasisWith/sameOrderPolyn" [~1] forall x.+ calcGroebnerBasisWith x = calcGroebnerBasis+ #-} -- | Caliculating reduced Groebner basis of the given ideal w.r.t. the specified monomial order.-calcGroebnerBasisWithStrategy :: ( Field k, IsPolynomial k n, IsMonomialOrder order- , SelectionStrategy strategy, Ord (Weight strategy order))- => strategy -> Ideal (OrderedPolynomial k order n) -> [OrderedPolynomial k order n]+calcGroebnerBasisWithStrategy :: (Field (Coefficient poly), IsOrderedPolynomial poly+ , SelectionStrategy (Arity poly) strategy+ , Ord (Weight (Arity poly) strategy (MOrder poly)))+ => strategy -> Ideal poly -> [poly] calcGroebnerBasisWithStrategy strategy = reduceMinimalGroebnerBasis . minimizeGroebnerBasis . syzygyBuchbergerWithStrategy strategy -- | Caliculating reduced Groebner basis of the given ideal.-calcGroebnerBasis :: (Field k, IsPolynomial k n, IsMonomialOrder order)- => Ideal (OrderedPolynomial k order n) -> [OrderedPolynomial k order n]+calcGroebnerBasis :: (Field (Coefficient poly), IsOrderedPolynomial poly)+ => Ideal poly -> [poly] calcGroebnerBasis = reduceMinimalGroebnerBasis . minimizeGroebnerBasis . syzygyBuchberger+{-# SPECIALISE INLINE [0]+ calcGroebnerBasis :: (CoeffRing r, Field r, IsMonomialOrder n ord, KnownNat n)+ => Ideal (OrderedPolynomial r ord n) -> [OrderedPolynomial r ord n]+ #-}+{-# SPECIALISE INLINE [0]+ calcGroebnerBasis :: (CoeffRing r, Field r)+ => Ideal (Unipol r) -> [Unipol r]+ #-}+{-# INLINE [0] calcGroebnerBasis #-} + -- | Test if the given polynomial is the member of the ideal.-isIdealMember :: (IsPolynomial k n, Field k, IsMonomialOrder o)- => OrderedPolynomial k o n -> Ideal (OrderedPolynomial k o n) -> Bool+isIdealMember :: (Field (Coefficient poly), IsOrderedPolynomial poly)+ => poly -> Ideal poly -> Bool isIdealMember f ideal = groebnerTest f (calcGroebnerBasis ideal) -- | Test if the given polynomial can be divided by the given polynomials.-groebnerTest :: (IsPolynomial k n, Field k, IsMonomialOrder order)- => OrderedPolynomial k order n -> [OrderedPolynomial k order n] -> Bool+groebnerTest :: (Field (Coefficient poly), IsOrderedPolynomial poly)+ => poly -> [poly] -> Bool groebnerTest f fs = f `modPolynomial` fs == zero +newtype LengthReplicate n =+ LengthReplicate { runLengthReplicate :: forall x. Sing (x :: Nat)+ -> Length (Replicate n x) :~: n }++lengthReplicate :: SNat n -> SNat x -> Length (Replicate n x) :~: n+lengthReplicate = runLengthReplicate . induction base step+ where+ base :: LengthReplicate 0+ base = LengthReplicate $ const Refl++ step :: SNat n -> LengthReplicate n -> LengthReplicate (Succ n)+ step n (LengthReplicate ih) = LengthReplicate $ \x ->+ case (n %:+ sOne) %:== sZero of+ SFalse ->+ start (sLength (sReplicate (sSucc n) x))+ =~= sLength (SCons x (sReplicate (sSucc n %:- sOne) x))+ =~= sOne %:+ sLength (sReplicate (sSucc n %:- sOne) x)+ === sSucc (sLength (sReplicate (sSucc n %:- sOne) x))+ `because` sym (succAndPlusOneL (sLength (sReplicate (sSucc n %:- sOne) x)))+ === sSucc (sLength (sReplicate (n %:+ sOne %:- sOne) x))+ `because` succCong (lengthCong (replicateCong (minusCongL (succAndPlusOneR n) sOne) x))+ === sSucc (sLength (sReplicate n x))+ `because` succCong (lengthCong (replicateCong (plusMinus n sOne) x))+ === sSucc n `because` succCong (ih x)+ STrue -> case sCompare (n %:+ sOne) sZero of {}++lengthCong :: a :~: b -> Length a :~: Length b+lengthCong Refl = Refl++replicateCong :: a :~: b -> Sing x -> Replicate a x :~: Replicate b x+replicateCong Refl _ = Refl+ -- | Calculate n-th elimination ideal using 'WeightedEliminationOrder' ordering.-thEliminationIdeal :: ( IsMonomialOrder ord, Field k, IsPolynomial k m, IsPolynomial k (m :-: n)- , (n :<<= m) ~ True)+thEliminationIdeal :: forall poly n.+ ( IsMonomialOrder (Arity poly - n) (MOrder poly),+ Field (Coefficient poly),+ IsOrderedPolynomial poly,+ (n :<= Arity poly) ~ 'True) => SNat n- -> Ideal (OrderedPolynomial k ord m)- -> Ideal (OrderedPolynomial k ord (m :-: n))-thEliminationIdeal n =- case singInstance n of- SingInstance ->- mapIdeal (changeOrderProxy Proxy) . thEliminationIdealWith (weightedEliminationOrder n) n+ -> Ideal poly+ -> Ideal (OrderedPolynomial (Coefficient poly) (MOrder poly) (Arity poly :-. n))+thEliminationIdeal n = withSingI (sOnes n) $+ withRefl (lengthReplicate n sOne) $+ withKnownNat n $+ withKnownNat ((sing :: SNat (Arity poly)) %:-. n) $+ mapIdeal (changeOrderProxy Proxy) . thEliminationIdealWith (weightedEliminationOrder n) n -- | Calculate n-th elimination ideal using the specified n-th elimination type order.-thEliminationIdealWith :: ( IsMonomialOrder ord, Field k, IsPolynomial k m, IsPolynomial k (m :-: n)- , (n :<<= m) ~ True, EliminationType n ord, IsMonomialOrder ord')+thEliminationIdealWith :: ( IsOrderedPolynomial poly,+ m ~ Arity poly,+ k ~ Coefficient poly, Field k,+ KnownNat (m :-. n), (n :<= m) ~ 'True,+ EliminationType m n ord) => ord -> SNat n- -> Ideal (OrderedPolynomial k ord' m)- -> Ideal (OrderedPolynomial k ord (m :-: n))-thEliminationIdealWith ord n ideal =- case singInstance n of- SingInstance -> toIdeal $ [ transformMonomial (V.drop n) f- | f <- calcGroebnerBasisWith ord ideal- , all (all (== 0) . take (sNatToInt n) . toList . snd) $ getTerms f- ]+ -> Ideal poly+ -> Ideal (OrderedPolynomial k Grevlex (m :-. n))+thEliminationIdealWith = unsafeThEliminationIdealWith -- | Calculate n-th elimination ideal using the specified n-th elimination type order. -- This function should be used carefully because it does not check whether the given ordering is -- n-th elimintion type or not.-unsafeThEliminationIdealWith :: ( IsMonomialOrder ord, Field k, IsPolynomial k m, IsPolynomial k (m :-: n)- , (n :<<= m) ~ True, IsMonomialOrder ord')+unsafeThEliminationIdealWith :: ( IsOrderedPolynomial poly,+ m ~ Arity poly,+ k ~ Coefficient poly,+ Field k,+ IsMonomialOrder m ord,+ KnownNat (m :-. n), (n :<= m) ~ 'True) => ord -> SNat n- -> Ideal (OrderedPolynomial k ord' m)- -> Ideal (OrderedPolynomial k ord (m :-: n))+ -> Ideal poly+ -> Ideal (OrderedPolynomial k Grevlex (m :-. n)) unsafeThEliminationIdealWith ord n ideal =- case singInstance n of- SingInstance -> toIdeal $ [ transformMonomial (V.drop n) f- | f <- calcGroebnerBasisWith ord ideal- , all (all (== 0) . take (sNatToInt n) . toList . snd) $ getTerms f- ]+ withKnownNat n $ toIdeal $ [ f & _Wrapped %~ M.mapKeys (orderMonomial Nothing . V.drop n . getMonomial)+ | f <- calcGroebnerBasisWith ord ideal+ , all (all (== 0) . V.takeAtMost n . getMonomial . snd) $ getTerms f+ ] -- | An intersection ideal of given ideals (using 'WeightedEliminationOrder').-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 ord n)-intersection Nil = Ideal $ singleton one-intersection idsv@(_ :- _) =- let sk = sLength idsv- sn = sing :: SNat n- ts = genVars (sk %+ sn)- tis = zipWith (\ideal t -> mapIdeal ((t *) . shiftR sk) ideal) (toList idsv) ts+intersection :: forall poly k.+ ( IsMonomialOrder (k + Arity poly) (MOrder poly),+ Field (Coefficient poly), IsOrderedPolynomial poly)+ => Sized k (Ideal poly)+ -> Ideal poly+intersection idsv@(_ :< _) =+ let sk = sizedLength idsv+ sn = sing :: SNat (Arity poly)+ in withSingI (sOnes sk) $ withKnownNat (sk %:+ sn) $+ let ts = take (fromIntegral $ fromSing sk) vars+ inj :: poly -> OrderedPolynomial (Coefficient poly) (MOrder poly) (k + Arity poly)+ inj = transformMonomial (V.append $ V.replicate sk 0) . injectVars+ tis = zipWith (\ideal t -> mapIdeal ((t *) . inj) ideal) (toList idsv) ts j = foldr appendIdeal (principalIdeal (one - foldr (+) zero ts)) tis- in case plusMinusEqR sn sk of- Refl -> case propToBoolLeq (plusLeqL sk sn) of- LeqTrueInstance -> thEliminationIdeal sk j+ in withRefl (plusMinus' sk sn) $+ withWitness (plusLeqL sk sn) $+ mapIdeal injectVars $+ coerce (cong Proxy $ minusCongL (plusComm sk sn) sk `trans` plusMinus sn sk) $+ thEliminationIdeal sk j+intersection _ = Ideal $ singleton one -- | 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 ord n)+quotByPrincipalIdeal :: (IsMonomialOrder (2 + Arity poly) (MOrder poly),+ Field (Coefficient poly), IsOrderedPolynomial poly)+ => Ideal poly+ -> poly+ -> Ideal poly quotByPrincipalIdeal i g =- case intersection (i :- (Ideal $ singleton g) :- Nil) of+ case intersection (i :< (Ideal $ singleton g) :< NilL) of Ideal gs -> Ideal $ V.map (snd . head . (`divPolynomial` [g])) gs -- | Ideal quotient by the given ideal.-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 ord n)-quotIdeal i (Ideal g) =- case singInstance (sLength g) of- SingInstance ->- case singInstance (sLength g %+ (sing :: SNat n)) of- SingInstance -> intersection $ V.map (i `quotByPrincipalIdeal`) g+quotIdeal :: forall poly l.+ (IsOrderedPolynomial poly, Field (Coefficient poly),+ IsMonomialOrder (l + Arity poly) (MOrder poly),+ IsMonomialOrder (2 + Arity poly) (MOrder poly))+ => Ideal poly+ -> Sized l poly+ -> Ideal poly+quotIdeal i g =+ withKnownNat (sizedLength g) $+ withKnownNat (sizedLength g %:+ sArity g) $+ intersection $ V.map (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 ord n)+saturationByPrincipalIdeal :: forall poly.+ (IsOrderedPolynomial poly, Field (Coefficient poly),+ IsMonomialOrder (1 + Arity poly) (MOrder poly))+ => Ideal poly+ -> poly+ -> Ideal poly saturationByPrincipalIdeal is g =- case propToClassLeq $ leqSucc (sArity g) of- LeqInstance -> thEliminationIdeal sOne $ addToIdeal (one - (castPolynomial g * var sOne)) (mapIdeal (shiftR sOne) is)+ let n = sArity' g+ remap :: poly -> OrderedPolynomial (Coefficient poly) (MOrder poly) (1 + Arity poly)+ remap = shiftR sOne . injectVars+ in withKnownNat (sOne %:+ n) $+ withRefl (plusMinus' sOne n) $ withRefl (plusComm n sOne) $+ withWitness (leqStep sOne (sOne %:+ n) n Refl) $+ withWitness (lneqZero n) $+ mapIdeal injectVars $+ thEliminationIdeal sOne $+ addToIdeal (one - (remap g * varX)) $+ mapIdeal remap is -- | Saturation ideal-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 ord n)-saturationIdeal i (Ideal g) =- case singInstance (sLength g) of- SingInstance ->- case singInstance (sLength g %+ (sing :: SNat n)) of- SingInstance -> intersection $ V.map (i `saturationByPrincipalIdeal`) g+saturationIdeal :: forall poly l.+ (Field (Coefficient poly),+ IsOrderedPolynomial poly,+ IsMonomialOrder (l + Arity poly) (MOrder poly),+ IsMonomialOrder (1 + Arity poly) (MOrder poly))+ => Ideal poly+ -> Sized l poly+ -> Ideal poly+saturationIdeal i g =+ withKnownNat (sizedLength g) $+ withKnownNat (sizedLength g %:+ sArity g) $+ intersection $ V.map (i `saturationByPrincipalIdeal`) g -- | Calculate resultant for given two unary polynomimals.-resultant :: forall k ord . (Eq k, NoetherianRing k, Field k, IsMonomialOrder ord)- => OrderedPolynomial k ord One- -> OrderedPolynomial k ord One- -> k+resultant :: forall poly.+ (Field (Coefficient poly),+ IsOrderedPolynomial poly,+ Arity poly ~ 1)+ => poly+ -> poly+ -> (Coefficient poly) resultant = go one where go res h s- | totalDegree' s > 0 = let r = h `modPolynomial` [s]- res' = res * negate one ^ (totalDegree' h * totalDegree' s)- * (leadingCoeff s) ^ (totalDegree' h - totalDegree' r)- in go res' s r- | h == zero || s == zero = zero+ | totalDegree' s > 0 =+ let r = h `modPolynomial` [s]+ res' = res * negate one ^ (totalDegree' h * totalDegree' s)+ * (leadingCoeff s) ^ (totalDegree' h P.- totalDegree' r)+ in go res' s r+ | isZero h || isZero s = zero | totalDegree' h > 0 = (leadingCoeff s ^ totalDegree' h) * res | otherwise = res -hasCommonFactor :: forall k ord . (NoetherianRing k, Eq k, Field k, IsMonomialOrder ord)- => OrderedPolynomial k ord One- -> OrderedPolynomial k ord One+ _ = Refl :: Arity poly :~: 1+ -- to suppress "redundant" warning for univariate constraint.++-- | Determine whether two polynomials have a common factor with positive degree using resultant.+hasCommonFactor :: (Field (Coefficient poly),+ IsOrderedPolynomial poly,+ Arity poly ~ 1)+ => poly+ -> poly -> Bool-hasCommonFactor f g = resultant f g == zero+hasCommonFactor f g = isZero $ resultant f g++-- | Calculates the Least Common Multiply of the given pair of polynomials.+lcmPolynomial :: forall poly.+ (Field (Coefficient poly),+ IsOrderedPolynomial poly,+ IsMonomialOrder (2 + Arity poly) (MOrder poly))+ => poly+ -> poly+ -> poly+lcmPolynomial f g = head $ generators $ intersection (principalIdeal f :< principalIdeal g :< NilL)++-- | Calculates the Greatest Common Divisor of the given pair of polynomials.+gcdPolynomial :: (Field (Coefficient poly),+ IsOrderedPolynomial poly,+ IsMonomialOrder (2 + Arity poly) (MOrder poly))+ => poly+ -> poly+ -> poly+gcdPolynomial f g = snd $ head $ f * g `divPolynomial` [lcmPolynomial f g]
− Algebra/Algorithms/Groebner/Monomorphic.hs
@@ -1,269 +0,0 @@-{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, GADTs #-}-{-# LANGUAGE IncoherentInstances, OverlappingInstances, PolyKinds #-}-{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TypeFamilies #-}-{-# LANGUAGE TypeOperators, UndecidableInstances #-}--- | Monomorphic interface for Groenber basis.-module Algebra.Algorithms.Groebner.Monomorphic- ( Groebnerable- -- * Polynomial division- , divModPolynomial, divPolynomial, modPolynomial- , divModPolynomialWith, divPolynomialWith, modPolynomialWith- -- * Groebner basis- , calcGroebnerBasis, calcGroebnerBasisWith- , syzygyBuchberger, syzygyBuchbergerWith, syzygyBuchbergerWithStrategy- , primeTestBuchberger, primeTestBuchbergerWith- , simpleBuchberger, simpleBuchbergerWith- -- * Ideal operations- , isIdealMember, intersection, thEliminationIdeal, eliminate, thEliminationIdealWith, eliminateWith- , quotIdeal, quotByPrincipalIdeal- , saturationIdeal, saturationByPrincipalIdeal- -- * Resultant- , resultant, hasCommonFactor- -- * Re-exports- , Lex(..), Revlex(..), Grlex(..), Grevlex(..), IsOrder(..), IsMonomialOrder- , SelectionStrategy(..), NormalStrategy(..), SugarStrategy(..), Gr.GrevlexStrategy(..)- , Gr.GradedStrategy(..)- , calcWeight'- ) where-import Algebra.Algorithms.Groebner (NormalStrategy (..),- SelectionStrategy (..),- SugarStrategy (..),- calcWeight')-import qualified Algebra.Algorithms.Groebner as Gr-import Algebra.Internal-import Algebra.Ring.Noetherian-import Algebra.Ring.Polynomial (Grevlex (..), Grlex (..),- IsMonomialOrder, IsOrder,- Lex (..), Revlex (..),- orderedBy)-import qualified Algebra.Ring.Polynomial as Poly-import Algebra.Ring.Polynomial.Monomorphic-import Control.Arrow-import Data.List-import qualified Data.Map as M-import Data.Singletons hiding (demote, promote)-import Data.Type.Monomorphic-import Data.Type.Natural hiding (demote, one,- promote, zero)-import Data.Vector.Sized (Vector (..), sLength,- toList)-import qualified Data.Vector.Sized as V-import Numeric.Algebra-import Prelude hiding (Num (..))---- | Synonym-class (Eq r, Field r, NoetherianRing r) => Groebnerable r-instance (Eq r, Field r, NoetherianRing r) => Groebnerable r---- | Calculate a intersection of given ideals.-intersection :: forall r. (Groebnerable r)- => [[Polynomial r]] -> [Polynomial r]-intersection ps =- let vars = nub $ sort $ concatMap (concatMap buildVarsList) ps- dim = length vars- in case promote dim of- Monomorphic sdim ->- case singInstance sdim of- SingInstance ->- case promote ps :: Monomorphic (Vector [Polynomial r]) of- Monomorphic vec ->- let slen = sLength vec- in case singInstance slen of- SingInstance ->- let ids = V.map (toIdeal . map (flip orderedBy Lex . Poly.polynomial . M.mapKeys (Poly.OrderedMonomial . Poly.fromList sdim . encodeMonomList vars) . unPolynomial)) vec- in case singInstance (slen %+ sdim) of- SingInstance -> demoteComposed $ Gr.intersection ids--freshVar :: [Polynomial r] -> Variable-freshVar ps =- case maximum $ concatMap buildVarsList ps of- Variable c Nothing -> Variable c (Just 1)- Variable c (Just n) -> Variable c (Just $ n + 1)---- | Calculate saturation ideal by the principal ideal generated by the second argument.-saturationByPrincipalIdeal :: (Groebnerable r)- => [Polynomial r] -> Polynomial r -> [Polynomial r]-saturationByPrincipalIdeal j g =- let t = freshVar (g : j)- in eliminate [t] $ (one - g * injectVar t) : j---- | Calculate saturation ideal.-saturationIdeal :: Groebnerable r => [Polynomial r] -> [Polynomial r] -> [Polynomial r]-saturationIdeal i g = intersection $ map (i `saturationByPrincipalIdeal`) g---- | Calculate ideal quotient of I by principal ideal-quotByPrincipalIdeal :: Groebnerable r => [Polynomial r] -> Polynomial r -> [Polynomial r]-quotByPrincipalIdeal i g =- map (snd . head . flip (divPolynomialWith Lex) [g]) $ intersection [i, [g]]---- | Calculate the ideal quotient of I of J.-quotIdeal :: Groebnerable r => [Polynomial r] -> [Polynomial r] -> [Polynomial r]-quotIdeal i g = intersection $ map (i `quotByPrincipalIdeal`) g--divModPolynomial :: Groebnerable r- => Polynomial r -> [Polynomial r] -> ([(Polynomial r, Polynomial r)], Polynomial r)-divModPolynomial = divModPolynomialWith Grevlex--divModPolynomialWith :: forall ord r. (IsMonomialOrder ord, Groebnerable r)- => ord -> Polynomial r -> [Polynomial r]- -> ([(Polynomial r, Polynomial r)], Polynomial r)-divModPolynomialWith _ f gs =- case promoteList (f:gs) :: Monomorphic ([] :.: Poly.OrderedPolynomial r ord) of- Monomorphic (Comp (f' : gs')) ->- let sn = Poly.sArity f'- in case singInstance sn of- SingInstance ->- let (q, r) = Gr.divModPolynomial f' gs'- in (map (renameVars vars . polyn . demote' *** renameVars vars . polyn . demote') q, renameVars vars $ polyn $ demote' r)- where- vars = nub $ sort $ concatMap buildVarsList (f:gs)--divPolynomial :: Groebnerable r => Polynomial r -> [Polynomial r] -> [(Polynomial r, Polynomial r)]-divPolynomial = (fst .) . divModPolynomial--modPolynomial :: Groebnerable r => Polynomial r -> [Polynomial r] -> Polynomial r-modPolynomial = (snd .) . divModPolynomial--divPolynomialWith :: Groebnerable r => IsMonomialOrder ord => ord -> Polynomial r -> [Polynomial r] -> [(Polynomial r, Polynomial r)]-divPolynomialWith ord = (fst .) . divModPolynomialWith ord--modPolynomialWith :: (Groebnerable r, IsMonomialOrder ord)- => ord -> Polynomial r -> [Polynomial r] -> Polynomial r-modPolynomialWith ord = (snd .) . divModPolynomialWith ord--calcGroebnerBasis :: Groebnerable r => [Polynomial r] -> [Polynomial r]-calcGroebnerBasis = calcGroebnerBasisWith Grevlex--calcGroebnerBasisWith :: forall ord r. (Groebnerable r, IsMonomialOrder ord)- => ord -> [Polynomial r] -> [Polynomial r]-calcGroebnerBasisWith _ ps | any (== zero) ps = []-calcGroebnerBasisWith ord j =- case uniformlyPromote j :: Monomorphic (Ideal :.: Poly.OrderedPolynomial r ord) of- Monomorphic (Comp ideal) ->- case ideal of- Ideal vec ->- case singInstance (Poly.sArity (head $ toList vec)) of- SingInstance -> map (renameVars vars . polyn . demote . Monomorphic) $ Gr.calcGroebnerBasisWith ord ideal- where- vars = nub $ sort $ concatMap buildVarsList j--simpleBuchberger :: (Groebnerable r) => [Polynomial r] -> [Polynomial r]-simpleBuchberger = simpleBuchbergerWith Grevlex--simpleBuchbergerWith :: forall ord r. (Groebnerable r, IsMonomialOrder ord)- => ord -> [Polynomial r] -> [Polynomial r]-simpleBuchbergerWith _ ps | any (== zero) ps = []-simpleBuchbergerWith ord j =- case uniformlyPromote j :: Monomorphic (Ideal :.: Poly.OrderedPolynomial r ord) of- Monomorphic (Comp ideal) ->- case ideal of- Ideal vec ->- case singInstance (Poly.sArity (head $ toList vec)) of- SingInstance -> map (renameVars vars . polyn . demote . Monomorphic) $ Gr.simpleBuchberger ideal- where- vars = nub $ sort $ concatMap buildVarsList j--primeTestBuchberger :: (Groebnerable r) => [Polynomial r] -> [Polynomial r]-primeTestBuchberger = primeTestBuchbergerWith Grevlex--primeTestBuchbergerWith :: forall ord r. (Groebnerable r, IsMonomialOrder ord)- => ord -> [Polynomial r] -> [Polynomial r]-primeTestBuchbergerWith _ ps | any (== zero) ps = []-primeTestBuchbergerWith ord j =- case uniformlyPromote j :: Monomorphic (Ideal :.: Poly.OrderedPolynomial r ord) of- Monomorphic (Comp ideal) ->- case ideal of- Ideal vec ->- case singInstance (Poly.sArity (head $ toList vec)) of- SingInstance -> map (renameVars vars . polyn . demote . Monomorphic) $ Gr.primeTestBuchberger ideal- where- vars = nub $ sort $ concatMap buildVarsList j--syzygyBuchberger :: (Groebnerable r) => [Polynomial r] -> [Polynomial r]-syzygyBuchberger = syzygyBuchbergerWith Grevlex--syzygyBuchbergerWithStrategy :: forall strategy ord r.- ( Groebnerable r, IsMonomialOrder ord- , Gr.SelectionStrategy strategy, Ord (Gr.Weight strategy ord))- => strategy -> ord -> [Polynomial r] -> [Polynomial r]-syzygyBuchbergerWithStrategy _ _ ps | any (== zero) ps = []-syzygyBuchbergerWithStrategy strategy _ j =- case uniformlyPromote j :: Monomorphic (Ideal :.: Poly.OrderedPolynomial r ord) of- Monomorphic (Comp ideal) ->- case ideal of- Ideal vec ->- case singInstance (Poly.sArity (head $ toList vec)) of- SingInstance -> map (renameVars vars . polyn . demote . Monomorphic) $ Gr.syzygyBuchbergerWithStrategy strategy ideal- where- vars = nub $ sort $ concatMap buildVarsList j---syzygyBuchbergerWith :: forall ord r. (Groebnerable r, IsMonomialOrder ord)- => ord -> [Polynomial r] -> [Polynomial r]-syzygyBuchbergerWith _ ps | any (== zero) ps = []-syzygyBuchbergerWith ord j = syzygyBuchbergerWithStrategy (SugarStrategy NormalStrategy) ord j--isIdealMember :: forall r. Groebnerable r => Polynomial r -> [Polynomial r] -> Bool-isIdealMember f ideal =- case promoteList (f:ideal) :: Monomorphic ([] :.: Poly.Polynomial r) of- Monomorphic (Comp (f':ideal')) ->- case singInstance (Poly.sArity f') of- SingInstance -> Gr.isIdealMember f' (toIdeal ideal')- _ -> error "impossible happend!"---- | Computes the ideal with specified variables eliminated.-eliminateWith :: forall r ord . (IsMonomialOrder ord, Groebnerable r)- => ord -> [Variable] -> [Polynomial r] -> [Polynomial r]-eliminateWith ord elvs j =- case promoteListWithVarOrder (els ++ rest) j :: Monomorphic ([] :.: Poly.OrderedPolynomial r Poly.Lex) of- Monomorphic (Comp fs) ->- case promote k of- Monomorphic sk ->- let sdim = Poly.sArity $ head fs- newDim = sMax sk sdim- in case singInstance sdim of- SingInstance ->- case propToClassLeq $ maxLeqR sk sdim of- LeqInstance ->- case singInstance newDim of- SingInstance ->- let fs' = map ((flip Poly.orderedBy Poly.Lex) . Poly.scastPolynomial newDim) fs- in case propToBoolLeq $ maxLeqL sk sdim of- LeqTrueInstance ->- case singInstance (newDim %:- sk) of- SingInstance ->- map (renameVars rest) $ demoteComposed $ Gr.unsafeThEliminationIdealWith ord sk (toIdeal fs')- where- vars = nub $ sort $ concatMap buildVarsList j- (els, rest) = partition (`elem` elvs) vars- k = length els--eliminate :: forall r. Groebnerable r => [Variable] -> [Polynomial r] -> [Polynomial r]-eliminate vs j = eliminateWith Lex vs j---- | Computes nth elimination ideal.-thEliminationIdeal :: Groebnerable r => Int -> [Polynomial r] -> [Polynomial r]-thEliminationIdeal = thEliminationIdealWith Lex--thEliminationIdealWith :: (IsMonomialOrder ord, Groebnerable r) => ord -> Int -> [Polynomial r] -> [Polynomial r]-thEliminationIdealWith ord k j = eliminateWith ord (take k vars) j- where- vars = nub $ sort $ concatMap buildVarsList j---- | Calculates resultants for given two unary-polynomials.-resultant :: forall r. Groebnerable r- => Polynomial r -> Polynomial r -> r-resultant f g =- let vars = nub $ buildVarsList f ++ buildVarsList g- in case vars of- [_] ->- let f' = Poly.polynomial $ M.mapKeys (Poly.OrderedMonomial . Poly.fromList sOne . encodeMonomList vars) $- unPolynomial f- g' = Poly.polynomial $ M.mapKeys (Poly.OrderedMonomial . Poly.fromList sOne . encodeMonomList vars) $- unPolynomial g- in Gr.resultant (f' `orderedBy` Grevlex) g'- _ -> error "currently supports only unary polynomial."---- | Determin if given two unary polynomials have common factor.-hasCommonFactor :: (Eq r, Division r, NoetherianRing r) => Polynomial r -> Polynomial r -> Bool-hasCommonFactor f g = resultant f g == zero
+ Algebra/Algorithms/PrimeTest.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE NoImplicitPrelude, NoMonomorphismRestriction #-}+module Algebra.Algorithms.PrimeTest+ (repeatedSquare, modPow, fermatTest, isPseudoPrime+ ) where+import Algebra.Prelude.Core hiding (div, mod)+import Control.Lens ((&), (+~), _1)+import Control.Monad.Random (MonadRandom, uniform)+import Data.List (findIndex)+import Numeric.Decidable.Zero (isZero)+import Numeric.Domain.Euclidean ()+import Prelude (div, mod)+import qualified Prelude as P++data PrimeResult = Composite | ProbablyPrime | Prime+ deriving (Read, Show, Eq, Ord)++-- | Calculates @n@-th power efficiently, using repeated square method.+repeatedSquare :: Multiplicative r => r -> Natural -> r+repeatedSquare a n =+ let bits = tail $ binRep n+ in go a bits+ where+ go b [] = b+ go b (nk : ns) =+ go (if nk == 1 then (b*b*a) else b*b) ns+++binRep :: Natural -> [Natural]+binRep = flip go []+ where+ go 0 = id+ go k = go (k `div` 2) . ((k `mod` 2) :)++-- | Fermat-test for pseudo-primeness.+fermatTest :: MonadRandom m => Integer -> m PrimeResult+fermatTest 2 = return Prime+fermatTest n = do+ a <- uniform [2..n - 2]+ let b = modPow n (fromIntegral a) (fromIntegral $ n - 1 :: Natural)+ if b /= 1+ then return Composite+ else return ProbablyPrime++-- | @'modPow' x m p@ efficiently calculates @x ^ p `'mod'` m@.+modPow :: (P.Integral a, Euclidean r) => r -> r -> a -> r+modPow i p = go i one+ where+ go _ acc 0 = acc+ go b acc e = go ((b * b) `rem` p) (if e `mod` 2 == 1 then (acc * b) `rem` p else acc) (e `div` 2)++splitFactor :: Euclidean r => r -> r -> (Int, r)+splitFactor d n =+ let (q,r) = n `divide` d+ in if isZero q+ then (0, n)+ else splitFactor d r & _1 +~ 1++-- | @'isPseudoPrime' n@ tests if the given integer @n@ is pseudo prime.+-- It returns @'Left' p@ if @p < n@ divides @n@,+-- @'Right' 'True'@ if @n@ is pseudo-prime,+-- @'Right' 'False'@ if it is not pseudo-prime but no clue can be found.+isPseudoPrime :: MonadRandom m+ => Integer -> m (Either Integer Bool)+isPseudoPrime 2 = return $ Right True+isPseudoPrime 3 = return $ Right True+isPseudoPrime n = do+ a <- uniform [2..n P.- 2]+ let d = P.gcd a n+ return $ if d > 1+ then Left d+ else+ let (v, m) = splitFactor 2 (n-1)+ b0 = modPow n a m+ bs = take (v+1) $ iterate (\b -> b*b `mod` n) b0+ in if b0 == 1+ then Right True+ else case findIndex (== 1) bs of+ Nothing -> Right False+ Just j ->+ let g = P.gcd (bs !! j - 1) n+ in if g == 1 || g == n then Right True else Left g+
+ Algebra/Algorithms/ZeroDim.hs view
@@ -0,0 +1,409 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE ConstraintKinds, DataKinds, DefaultSignatures #-}+{-# LANGUAGE ExplicitNamespaces, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}+{-# LANGUAGE ParallelListComp, PatternSynonyms, PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-}+{-# LANGUAGE TypeFamilies, TypeOperators, TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+-- | Algorithms for zero-dimensional ideals.+--+-- Since 0.4.0.0+module Algebra.Algorithms.ZeroDim+ ( -- * Root finding for zero-dimensional ideal+ solveM, solve', solveViaCompanion, solveLinear,+ -- * Radical computation+ radical, isRadical,+ -- * Converting monomial ordering to Lex using FGLM algorithm+ fglm, fglmMap,+ -- ** Internal helper function+ solveWith, univPoly,+ reduction,+ matrixRep, subspMatrix,+ vectorRep+ ) where+import Algebra.Algorithms.FGLM+import Algebra.Algorithms.Groebner+import Algebra.Instances ()+import Algebra.Internal hiding (OLt)+import qualified Algebra.Matrix as AM+import Algebra.Prelude.Core+import Algebra.Ring.Polynomial.Quotient++import Control.Lens hiding ((:<))+import Control.Monad.Loops (whileM_)+import Control.Monad.Random hiding (next)+import Control.Monad.Reader (runReaderT)+import Control.Monad.ST (runST)+import Data.Complex (Complex (..), magnitude)+import Data.Convertible (Convertible, convert)+import qualified Data.Matrix as M+import Data.Maybe (fromJust)+import Data.Ord (comparing)+import Data.Reflection (Reifies)+import qualified Data.Sized.Builtin as SV+import Data.STRef.Strict (newSTRef)+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import qualified Numeric.Algebra as NA+import qualified Numeric.LinearAlgebra as LA+import qualified Prelude as P+import Proof.Propositional (IsTrue (Witness))++-- | Finds complex approximate roots of given zero-dimensional ideal,+-- using randomized altorithm.+--+-- See also @'solve''@ and @'solveViaCompanion'@.+solveM :: forall m r ord n.+ (Normed r, Ord r, MonadRandom m, Field r, CoeffRing r, KnownNat n,+ IsMonomialOrder n ord, Convertible r Double,+ (0 :< n) ~ 'True)+ => Ideal (OrderedPolynomial r ord n)+ -> m [Sized n (Complex Double)]+solveM ideal = {-# SCC "solveM" #-}+ withKnownNat (sSucc (sing :: SNat n)) $+ reifyQuotient (radical ideal) $ \pxy ->+ case standardMonomials' pxy of+ Just bs -> step 10 (length bs)+ Nothing -> error "Given ideal is not zero-dimensional"+ where+ step bd len = {-# SCC "solveM/step" #-}do+ coeffs <- {-# SCC "solveM/coeff-gen" #-}+ replicateM (sNatToInt (sSucc (sing :: SNat n))) $ getRandomR (-bd, bd)+ let vars = one : SV.toList allVars+ f = sum $ zipWith (.*.) (map (NA.fromInteger :: Integer -> r) coeffs) vars+ case solveWith f ideal of+ Nothing -> step (bd*2) len+ Just sols -> return sols++-- | @solveWith f is@ finds complex approximate roots of the given zero-dimensional @n@-variate polynomial system @is@,+-- using the given relatively prime polynomial @f@.+solveWith :: forall r n ord. (DecidableZero r, Normed r, Ord r, Field r, CoeffRing r,+ (0 :< n) ~ 'True, IsMonomialOrder n ord,+ KnownNat n, Convertible r Double)+ => OrderedPolynomial r ord n+ -> Ideal (OrderedPolynomial r ord n)+ -> Maybe [Sized n (Complex Double)]+solveWith f0 i0 = {-# SCC "solveWith" #-}+ withKnownNat (sSucc (sing :: SNat n)) $+ reifyQuotient (radical i0) $ \pxy ->+ let ideal = gBasis' pxy+ Just base = map (leadingMonomial . quotRepr) <$> standardMonomials' pxy+ in case {-# SCC "findOne" #-} elemIndex one base of+ Nothing -> Just []+ Just cind ->+ let f = modIdeal' pxy f0+ vars = sortBy (flip $ comparing snd) $+ map (\on -> (on, leadingMonomial $ var on `asTypeOf` f0)) $+ enumOrdinal $ sArity' f0+ inds = flip map vars $ second $ \b ->+ case findIndex (==b) base of+ Just ind -> Right ind+ Nothing ->+ let Just g = find ((==b) . leadingMonomial) ideal+ r = leadingCoeff g+ answer = mapCoeff toComplex $ injectCoeff (recip r) * (toPolynomial (leadingTerm g) - g)+ in Left answer+ mf = AM.fromLists $ map (map toComplex) $ matrixRep f+ (_, evecs) = LA.eig $ LA.tr mf+ calc vec ={-# SCC "calc" #-}+ let c = vec LA.! cind+ phi (idx, Right nth) acc = acc & ix idx .~ (vec LA.! nth) P./ c+ phi (idx, Left g) acc = acc & ix idx .~ substWith (*) acc g+ in if c == 0+ then Nothing+ else Just $ foldr ({-# SCC "rewrite-answer" #-} phi) (SV.replicate (sArity' f0) (error "indec!")) inds+ in sequence $ map calc $ LA.toColumns evecs++-- | @'solve'' err is@ finds numeric approximate root of the+-- given zero-dimensional polynomial system @is@,+-- with error <@err@.+--+-- See also @'solveViaCompanion'@ and @'solveM'@.+solve' :: forall r n ord.+ (Field r, CoeffRing r, KnownNat n, (0 :< n) ~ 'True,+ IsMonomialOrder n ord, Convertible r Double)+ => Double+ -> Ideal (OrderedPolynomial r ord n)+ -> [Sized n (Complex Double)]+solve' err ideal =+ reifyQuotient ideal $ \ii ->+ if gBasis' ii == [one]+ then []+ else+ let vs = map (nub . LA.toList . LA.eigenvalues . AM.fromLists . map (map toComplex). matrixRep . modIdeal' ii) $+ SV.toList allVars+ mul p q = toComplex p * q+ in [ xs+ | xs0 <- sequence vs+ , let xs = SV.unsafeFromList' xs0+ , all ((< err) . magnitude . substWith mul xs) $ generators ideal+ ]+ where+ _ = Witness :: IsTrue (0 :< n) -- Just to suppress "redundant constraint" warning++subspMatrix :: (Ord r, Field r, CoeffRing r, KnownNat n, IsMonomialOrder n ord)+ => Ordinal n -> Ideal (OrderedPolynomial r ord n) -> M.Matrix r+subspMatrix on ideal =+ let poly = univPoly on ideal+ v = var on `asTypeOf` head (generators ideal)+ dim = fromIntegral $ totalDegree' poly+ cfs = [negate $ coeff (leadingMonomial $ pow v (j :: Natural)) poly | j <- [0..fromIntegral (dim - 1)]]+ in (M.fromLists [replicate (dim - 1) zero]+ M.<->+ fmap unwrapAlgebra (M.identity (dim - 1))) M.<|> M.colVector (V.fromList cfs)++-- | @'solveViaCompanion' err is@ finds numeric approximate root of the+-- given zero-dimensional polynomial system @is@,+-- with error <@err@.+--+-- See also @'solve''@ and @'solveM'@.+solveViaCompanion :: forall r ord n.+ (Ord r, Field r, CoeffRing r, KnownNat n, IsMonomialOrder n ord, Convertible r Double)+ => Double+ -> Ideal (OrderedPolynomial r ord n)+ -> [Sized n (Complex Double)]+solveViaCompanion err ideal =+ if calcGroebnerBasis ideal == [one]+ then []+ else+ let vs = map (nub . LA.toList . LA.eigenvalues . LA.fromLists . matToLists . fmap toComplex . flip subspMatrix ideal) $+ enumOrdinal (sing :: SNat n)+ mul p q = toComplex p * q+ in [ xs+ | xs0 <- sequence vs+ , let xs = SV.unsafeFromList' xs0+ , all ((< err) . magnitude . substWith mul xs) $ generators ideal+ ]++matToLists :: M.Matrix a -> [[a]]+matToLists mat = [ V.toList $ M.getRow i mat | i <- [1.. M.nrows mat] ]++matrixRep :: (DecidableZero t, Eq t, Field t, KnownNat n, IsMonomialOrder n order,+ Reifies ideal (QIdeal (OrderedPolynomial t order n)))+ => Quotient (OrderedPolynomial t order n) ideal -> [[t]]+matrixRep f = {-# SCC "matrixRep" #-}+ case standardMonomials of+ Just [] -> []+ Just bases ->+ let anss = map (quotRepr . (f *)) bases+ in transpose $ map (\a -> map (flip coeff a . leadingMonomial . quotRepr) bases) anss+ Nothing -> error "Not finite dimension"++toComplex :: Convertible a Double => a -> Complex Double+toComplex a = convert a :+ 0++-- | Calculates n-th reduction of f: @f `div` < f, ∂_{x_n} f >@.+reduction :: (CoeffRing r, KnownNat n, IsMonomialOrder n ord, Field r)+ => Ordinal n -> OrderedPolynomial r ord n -> OrderedPolynomial r ord n+reduction on f = {-# SCC "reduction" #-}+ let df = {-# SCC "differentiate" #-} diff on f+ in snd $ head $ f `divPolynomial` calcGroebnerBasis (toIdeal [f, df])++-- | Calculate the monic generator of k[X_0, ..., X_n] `intersect` k[X_i].+univPoly :: forall r ord n. (Ord r, Field r, CoeffRing r, KnownNat n, IsMonomialOrder n ord)+ => Ordinal n+ -> Ideal (OrderedPolynomial r ord n)+ -> OrderedPolynomial r ord n+univPoly nth ideal = {-# SCC "univPoly" #-}+ reifyQuotient ideal $ \pxy ->+ if gBasis' pxy == [one]+ then one+ else let x = var nth+ p0 : pows = [fmap WrapAlgebra $ vectorRep $ modIdeal' pxy (pow x i)+ | i <- [0:: Natural ..]+ | _ <- zero : fromJust (standardMonomials' pxy) ]+ step m ~(p : ps) = {-# SCC "univPoly/step" #-}+ case solveLinear m p of+ Nothing -> {-# SCC "recur" #-} step ({-# SCC "consCol" #-}m M.<|> M.colVector p) ps+ Just ans ->+ let cur = fromIntegral $ V.length ans :: Natural+ in {-# SCC "buildRelation" #-}+ pow x cur - sum (zipWith (.*.) (fmap unwrapAlgebra $ V.toList ans)+ [pow x i | i <- [0 :: Natural .. cur P.- 1]])+ in step (M.colVector p0) pows++-- | Solves linear system. If the given matrix is degenerate, this returns @Nothing@.+solveLinear :: (Ord r, P.Fractional r)+ => M.Matrix r+ -> V.Vector r+ -> Maybe (V.Vector r)+solveLinear mat vec = {-# SCC "solveLinear" #-}+ if ({-# SCC "uRank" #-} uRank u) < uRank u' || M.diagProd u == 0 || uRank u < M.ncols mat+ then Nothing+ else let ans = M.getCol 1 $ p P.* M.colVector vec+ lsol = {-# SCC "solveL" #-} solveL ans+ cfs = M.getCol 1 $ q P.* M.colVector ({-# SCC "solveU" #-} solveU lsol)+ in Just cfs+ where+ Just (u, l, p, q, _, _) = M.luDecomp' mat+ Just (u', _,_, _, _, _) = M.luDecomp' (mat M.<|> M.colVector vec)+ uRank = V.foldr (\a acc -> if a /= 0 then acc + 1 else acc) (0 :: Int) . M.getDiag+ solveL v = V.create $ do+ let stop = min (M.ncols l) (M.nrows l)+ mv <- MV.replicate (M.ncols l) 0+ forM_ [0..stop - 1] $ \i -> do+ MV.write mv i $ v V.! i+ forM_ [0,1..min (i-1) (M.ncols l - 1)] $ \j -> do+ a <- MV.read mv i+ b <- MV.read mv j+ MV.write mv i $ a P.- (l M.! (i + 1, j + 1)) P.* b+ return mv+ solveU v = V.create $ do+ let stop = min (M.ncols u) (M.nrows u)+ mv <- MV.replicate (M.ncols u) 0+ forM_ [stop - 1, stop - 2 .. 0] $ \ i -> do+ MV.write mv i $ v V.! i+ forM_ [i+1,i+2..M.ncols u-1] $ \j -> do+ a <- MV.read mv i+ b <- MV.read mv j+ MV.write mv i $ a P.- (u M.! (i+1, j+1)) P.* b+ a0 <- MV.read mv i+ MV.write mv i $ a0 P./ (u M.! (i+1, i+1))+ return mv++-- | Calculate the radical of the given zero-dimensional ideal.+radical :: forall r ord n . (Ord r, CoeffRing r,+ KnownNat n, Field r, IsMonomialOrder n ord)+ => Ideal (OrderedPolynomial r ord n) -> Ideal (OrderedPolynomial r ord n)+radical ideal = {-# SCC "radical" #-}+ let gens = {-# SCC "calcGens" #-} map (\on -> reduction on $ univPoly on ideal) $ enumOrdinal (sing :: SNat n)+ in toIdeal $ calcGroebnerBasis $ toIdeal $ generators ideal ++ gens++-- | Test if the given zero-dimensional ideal is radical or not.+isRadical :: forall r ord n. (Ord r, CoeffRing r, KnownNat n,+ (0 :< n) ~ 'True,+ Field r, IsMonomialOrder n ord)+ => Ideal (OrderedPolynomial r ord n) -> Bool+isRadical ideal =+ let gens = map (\on -> reduction on $ univPoly on ideal) $+ enumOrdinal (sing :: SNat n)+ in all (`isIdealMember` ideal) gens+ where+ _ = Witness :: IsTrue (0 :< n) -- Just to suppress "redundant constraint" warning++-- solve'' :: forall r ord n.+-- (Show r, Sparse.Eq0 r, Normed r, Ord r, Field r, CoeffRing r, KnownNat n,+-- IsMonomialOrder ord, Convertible r Double, (0 :< n) ~ 'True)+-- => Double+-- -> Ideal (OrderedPolynomial r ord n)+-- -> [Sized n (Complex Double)]+-- solve'' err ideal =+-- reifyQuotient (radical ideal) $ \ii ->+-- let gbs = gBasis' ii+-- lexBase = fst $ fglm $ toIdeal gbs+-- upoly = last lexBase+-- restVars = init $ SV.toList allVars+-- calcEigs = nub . LA.toList . LA.eigenvalues . AM.fromLists+-- lastEigs = calcEigs $ matToLists $ fmap toComplex $ fmapUnwrap+-- (AM.companion maxBound $ mapCoeff WrapField upoly)+-- in if gbs == [one]+-- then []+-- else if length (lastEigs) == length (fromJust $ standardMonomials' ii)+-- then solveSpan (init lexBase) lastEigs+-- else chooseAnswer $+-- lastEigs : map (calcEigs . map (map toComplex) . matrixRep . modIdeal' ii)+-- restVars+-- where+-- mul p q = toComplex p * q+-- solveSpan rest lastEigs =+-- let answers = map (\f -> toPolynomial (leadingTerm f) - f) rest+-- substEig eig = substWith (\d b -> toComplex d * b) $ SV.unsafeFromList' $ map (const zero) rest ++ [eig]+-- in [ SV.unsafeFromList' $ map (substEig eig) answers ++ [eig]+-- | eig <- lastEigs+-- ]+-- chooseAnswer vs =+-- [ xs+-- | xs0 <- sequence vs+-- , let xs = SV.unsafeFromList' xs0+-- , all ((<err) . magnitude . substWith mul xs) $ generators ideal+-- ]++-- * FGLM++-- | Calculate the Groebner basis w.r.t. lex ordering of the zero-dimensional ideal using FGLM algorithm.+-- If the given ideal is not zero-dimensional this function may diverge.+fglm :: (Ord r, KnownNat n, Field r,+ IsMonomialOrder n ord, (0 :< n) ~ 'True)+ => Ideal (OrderedPolynomial r ord n)+ -> ([OrderedPolynomial r Lex n], [OrderedPolynomial r Lex n])+fglm ideal = reifyQuotient ideal $ \pxy ->+ fglmMap (\f -> vectorRep $ modIdeal' pxy f)++-- | Compute the kernel and image of the given linear map using generalized FGLM algorithm.+fglmMap :: forall k ord n. (Ord k, Field k, (0 :< n) ~ 'True,+ IsMonomialOrder n ord, CoeffRing k, KnownNat n)+ => (OrderedPolynomial k ord n -> V.Vector k)+ -- ^ Linear map from polynomial ring.+ -> ( [OrderedPolynomial k Lex n]+ , [OrderedPolynomial k Lex n]+ ) -- ^ The tuple of:+ --+ -- * lex-Groebner basis of the kernel of the given linear map.+ --+ -- * The vector basis of the image of the linear map.+fglmMap l = runST $ do+ env <- FGLMEnv l <$> newSTRef [] <*> newSTRef [] <*> newSTRef Nothing <*> newSTRef one+ flip runReaderT env $ do+ mainLoop+ whileM_ toContinue $ nextMonomial >> mainLoop+ (,) <$> look gLex <*> (map (changeOrder Lex) <$> look bLex)++mainLoop :: (DecidableZero r, Ord r, KnownNat n, Field r, IsMonomialOrder n o)+ => Machine s r o n ()+mainLoop = do+ m <- look monomial+ let f = toPolynomial (one, changeMonomialOrderProxy Proxy m)+ lx <- image f+ bs <- mapM image =<< look bLex+ let mat = foldr (M.<|>) (M.fromList 0 0 []) $ map (M.colVector . fmap WrapAlgebra) bs+ cond | null bs = if V.all (== zero) lx+ then Just $ V.replicate (length bs) 0+ else Nothing+ | otherwise = solveLinear mat (fmap WrapAlgebra lx)+ case cond of+ Nothing -> do+ proced .== Nothing+ bLex %== (f : )+ Just cs -> do+ bps <- look bLex+ let g = changeOrder Lex $ f - sum (zipWith (.*.) (V.toList $ fmap unwrapAlgebra cs) bps)+ proced .== Just (changeOrder Lex f)+ gLex %== (g :)++toContinue :: forall s r o n.+ ((0 :< n) ~ 'True, Ord r,+ KnownNat n, Field r)+ => Machine s r o n Bool+toContinue = do+ mans <- look proced+ case mans of+ Nothing -> return True+ Just g -> do+ let xLast = P.maximum allVars `asTypeOf` g+ return $ not $ leadingMonomial g `isPowerOf` leadingMonomial xLast+ where+ _ = Witness :: IsTrue (0 :< n) -- Just to suppress "redundant constraint" warning++nextMonomial :: forall s r ord n.+ (CoeffRing r, KnownNat n) => Machine s r ord n ()+nextMonomial = do+ m <- look monomial+ gs <- map leadingMonomial <$> look gLex+ let next = fst $ maximumBy (comparing snd) $+ [ (OrderedMonomial monom, fromEnum od)+ | od <- enumOrdinal (sing :: SNat n)+ , let monom = beta (getMonomial m) od+ , all (not . (`divs` OrderedMonomial monom)) gs+ ]+ monomial .== next++beta :: Monomial n -> Ordinal n -> Monomial n+beta xs o@(OLt k) =+ let n = sizedLength xs+ in withRefl (lneqSuccLeq k n) $+ withRefl (plusComm (n %:- sSucc k) (sSucc k)) $+ withRefl (minusPlus n (sSucc k) Witness) $+ (SV.take (sSucc k) $ xs & ix o +~ 1) SV.++ SV.replicate (n %:- sSucc k) 0+beta _ _ = error "beta: Bug in ghc!"
+ Algebra/Field/AlgebraicReal.hs view
@@ -0,0 +1,728 @@+{-# LANGUAGE BangPatterns, DataKinds, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE GADTs, MultiParamTypeClasses, NoImplicitPrelude #-}+{-# LANGUAGE NoMonomorphismRestriction, OverloadedLabels #-}+-- | Algebraic Real Numbers for exact computation+--+-- Since 0.4.0.0+module Algebra.Field.AlgebraicReal+ ( Algebraic, algebraic,+ -- * Operations+ nthRoot, nthRoot',+ improve,+ approximate, approxFractional,+ -- * Equation solver+ realRoots, complexRoots,+ -- * Interval arithmetic+ Interval(..), representative,+ includes, intersect,+ -- * Internal utility functions+ strum, presultant, factors,+ realPartPoly,imagPartPoly, sqFreePart+ )+ where+import Algebra.Prelude.Core hiding (intersect,+ normalize)+import Algebra.Ring.Polynomial.Factorise (clearDenom, factorHensel)+import Algebra.Ring.Polynomial.Univariate+import Control.Arrow ((***))+import Control.Lens (each, ifoldMap, ix, (%~),+ (&), (*~), _Wrapped)+import Control.Monad.Random+import Data.Bits+import qualified Data.Coerce as C+import qualified Data.IntMap as IM+import Data.Maybe (fromJust)+import Data.MonoTraversable+import qualified Data.Ratio as R+import qualified Data.Set as S+import qualified Data.Sized.Builtin as SV+import GHC.Num (Num)+import Math.NumberTheory.Powers+import Numeric.Algebra.Complex hiding (i)+import Numeric.Decidable.Zero (isZero)+import Numeric.Domain.GCD (gcd)+import qualified Numeric.Field.Fraction as F+import Numeric.Semiring.ZeroProduct (ZeroProductSemiring)+import qualified Prelude as P+import System.Entropy (getEntropy)+import System.IO.Unsafe (unsafePerformIO)++stdGenFromEntropy :: IO StdGen+stdGenFromEntropy = mkStdGen . ofoldr (\a -> (+) (fromEnum a) . (`shiftL` 8)) 0 <$> getEntropy 8+{-# INLINE stdGenFromEntropy #-}++factors :: Unipol Rational -> [Unipol Rational]+factors f =+ let (a, p) = clearDenom f+ in concatMap (map (monoize . mapCoeffUnipol (F.%a)) . S.toList . snd) $+ IM.toList $ snd+ $ flip evalRand (unsafePerformIO stdGenFromEntropy)+ $ factorHensel p++-- | Algebraic real numbers, which can be expressed as a root+-- of a rational polynomial.+data Algebraic = Algebraic { eqn :: Unipol Rational+ , _strumseq :: [Unipol Rational]+ , _interval :: Interval Rational+ }+ | Rational !Rational+ -- deriving (Show)+-- Invariants for constructor Algebraic:+-- (1) eqn must be monic and irreducible polynomial with degree > 1.+-- (2) strumseq is the standard strum sequence of eqn+-- (3) interval contains exactly one root of eqn++viewNthRoot :: Algebraic -> Maybe (Int, Rational)+viewNthRoot (Algebraic eq _ _) =+ let (lc, lm) = leadingTerm eq+ in if totalDegree' (eq - toPolynomial (lc, lm)) == 0+ then Just (getMonomial lm SV.%!! 0, negate $ constantTerm eq)+ else Nothing+viewNthRoot _ = Nothing++showsNthRoot :: Int -> Rational -> ShowS+showsNthRoot 1 q = showsPrec 6 q+showsNthRoot 2 q = showChar '√' . showsPrec 6 q+showsNthRoot n q = showsPrec 6 q . showString "^(1/" . shows n . showChar ')'+++instance Show Algebraic where+ showsPrec d (Rational q) = showsPrec d q+ showsPrec d a@(Algebraic eq str int) = showParen (d > 11) $+ case viewNthRoot a of+ Nothing ->+ showString "Algebraic " . showsPrec 7 eq . showChar ' '+ . showsPrec 7 str . showChar ' '+ . showsPrec 7 int+ Just (nth, q)+ | a < 0 -> showParen (5 < d && d <= 11) $+ showString "-" . showsNthRoot nth q+ | otherwise -> showsNthRoot nth q+++negateA :: Algebraic -> Algebraic+negateA r = (-1 :: Integer) .* r+{-# INLINE [1] negateA #-}++minusA :: Algebraic -> Algebraic -> Algebraic+minusA a b = plusA a (negateA b)+{-# INLINE [1] minusA #-}++instance Additive Algebraic where+ (+) = plusA+ {-# INLINE (+) #-}++instance Group Algebraic where+ negate = negateA+ {-# INLINE negate #-}+ (-) = minusA+ {-# INLINE (-) #-}+++instance Monoidal Algebraic where+ zero = Rational zero+ {-# INLINE zero #-}++instance LeftModule Natural Algebraic where+ (.*) = (.*) . P.toInteger+ {-# INLINE (.*) #-}++instance RightModule Natural Algebraic where+ (*.) = flip (.*)+ {-# INLINE (*.) #-}++instance LeftModule Integer Algebraic where+ (.*) = multA . Rational . fromIntegral+ {-# INLINE (.*) #-}++instance LeftModule (Fraction Integer) Algebraic where+ (.*) = multA . Rational+ {-# INLINE (.*) #-}++instance RightModule Integer Algebraic where+ (*.) = flip (.*)+ {-# INLINE (*.) #-}++instance RightModule (Fraction Integer) Algebraic where+ (*.) = flip (.*)+ {-# INLINE (*.) #-}++instance Multiplicative Algebraic where+ (*) = multA+ {-# INLINE (*) #-}++instance LeftModule (Scalar (Fraction Integer)) Algebraic where+ (.*) = multA . Rational . runScalar+ {-# INLINE (.*) #-}++instance RightModule (Scalar (Fraction Integer)) Algebraic where+ (*.) = flip (.*)+ {-# INLINE (*.) #-}++instance Eq Algebraic where+ Rational p == Algebraic g _ j =+ isZero (runScalar $ liftMap (const $ Scalar p) g) && p `isIn` j+ Algebraic g _ j == Rational p =+ isZero (runScalar $ liftMap (const $ Scalar p) g) && p `isIn` j+ Rational p == Rational q = p == q+ Algebraic f ss i == Algebraic g _ j+ = monoize f == monoize g && countChangeIn (i `intersect` j) ss == 1++-- | Takes intersection of two intervals.+intersect :: (Monoidal a, Ord a) => Interval a -> Interval a -> Interval a+intersect i j | disjoint i j = Interval zero zero+ | lower i <= lower j = Interval (lower j) (upper i)+ | lower j > lower i = Interval (lower i) (upper j)+intersect _ _ = error "intersect"++instance Ord Algebraic where+ compare (Rational q) (Rational r) = compare q r+ compare (Rational q) (Algebraic f sf i) =+ let i' = until (not . (q `isIn`)) (improveWith sf) i+ in if q <= lower i'+ then LT+ else if isZero (f `modPolynomial` [var 0 - injectCoeff q])+ then EQ+ else GT+ compare a@(Algebraic _ _ _) b@(Rational _) = flipOrd $ compare b a+ where+ flipOrd EQ = EQ+ flipOrd LT = GT+ flipOrd GT = LT+ compare a@(Algebraic _ sf i) b@(Algebraic _ sg j)+ | a == b = EQ+ | otherwise =+ let (i', j') = until (uncurry disjoint) (improveWith sf *** improveWith sg) (i, j)+ in if upper i' <= lower j' then LT else GT++disjoint :: Ord a => Interval a -> Interval a -> Bool+disjoint i j = upper i < lower j || upper j < lower i++instance Commutative Algebraic+instance Unital Algebraic where+ one = Rational 1+ {-# INLINE one #-}++instance Semiring Algebraic+instance Abelian Algebraic+instance Rig Algebraic+instance Ring Algebraic+instance ZeroProductSemiring Algebraic+instance Division Algebraic where+ recip = recipA+ {-# INLINE recip #-}++instance DecidableZero Algebraic where+ isZero (Rational 0) = True+ isZero _ = False+ {-# INLINE isZero #-}++instance DecidableUnits Algebraic where+ isUnit (Rational 0) = False+ isUnit _ = True+ {-# INLINE isUnit #-}++ recipUnit (Rational 0) = Nothing+ recipUnit r = Just $ recipA r++instance DecidableAssociates Algebraic where+ isAssociate (Rational 0) (Rational 0) = True+ isAssociate Algebraic{} Algebraic{} = True+ isAssociate _ _ = False+ {-# INLINE isAssociate #-}++instance UnitNormalForm Algebraic where+ splitUnit x =+ if x == 0+ then (0, Rational 1)+ else if x < 0+ then (Rational (-1), negate x)+ else (Rational 1, x)+ {-# INLINE splitUnit #-}++instance P.Num Algebraic where+ (+) = plusA+ {-# INLINE (+) #-}++ (-) = minusA+ {-# INLINE (-) #-}++ (*) = multA+ {-# INLINE (*) #-}++ abs = C.coerce (P.abs :: WrapAlgebra Algebraic -> WrapAlgebra Algebraic)+ {-# INLINE abs #-}++ signum = C.coerce (P.signum :: WrapAlgebra Algebraic -> WrapAlgebra Algebraic)+ {-# INLINE signum #-}++ negate = negateA+ {-# INLINE negate #-}++ fromInteger = Rational . fromInteger+ {-# INLINE fromInteger #-}++instance P.Fractional Algebraic where+ recip = recipA+ {-# INLINE recip #-}++ fromRational r = Rational (R.numerator r F.% R.denominator r)+ {-# INLINE fromRational #-}+++scale :: (Ord r, Multiplicative r, Monoidal r) => r -> Interval r -> Interval r+scale k (Interval l r)+ | k < zero = Interval (k * r) (k * l)+ | otherwise = Interval (k * l) (k * r)++-- | Test if the former interval includes the latter.+includes :: Ord a => Interval a -> Interval a -> Bool+Interval i j `includes` Interval i' j' = i <= i' && j' <= j+{-# INLINE includes #-}++instance Group r => Additive (Interval r) where+ (+) = plusInt+ {-# INLINE (+) #-}++plusInt :: Group r => Interval r -> Interval r -> Interval r+plusInt (Interval l u) (Interval l' u') = Interval (l + l') (u + u')++rootSumPoly :: Unipol Rational -> Unipol Rational -> Unipol Rational+rootSumPoly f g =+ normalize $ presultant (liftP f) $+ liftMap (const $ injectCoeff (var 0) - var 0) $ liftP g+ where+ liftP :: Unipol Rational -> Unipol (Unipol Rational)+ liftP = mapCoeffUnipol injectCoeff++sqFreePart :: (Eq r, Euclidean r, Division r)+ => Unipol r -> Unipol r+sqFreePart f = f `quot` gcd f (diff 0 f)++{-# RULES+"minus-cancel" [~1] forall x.+ minusA x x = Rational 0+"plusminus/right" [~1] forall x (y :: Algebraic) .+ minusA (plusA x y) y = x+"plusminus/left" [~1] forall x (y :: Algebraic) .+ minusA (plusA x y) x = y+"plusminus/left" [~1] forall x (y :: Algebraic) .+ plusA x (minusA y x) = y+"plus-zero-left" [~1] forall x.+ plusA 0 x = x+"plus-zero-right" [~1] forall x.+ plusA x 0 = x+ #-}++plusA :: Algebraic -> Algebraic -> Algebraic+plusA (Rational r) (Rational q) = Rational (r + q)+plusA a@(Algebraic _ _ _) b@(Rational _) = plusA b a+plusA (Rational r) (Algebraic f _ i) =+ let f' = liftMap (const $ var 0 - injectCoeff r) f+ in fromJust $ algebraic f' (Interval (lower i + r) (upper i + r))+plusA a@(Algebraic f _ _) b@(Algebraic g _ _) =+ let fg = rootSumPoly f g+ iij = catcher plusInt fg a b+ in fromJust $ algebraic fg iij+{-# INLINE [1] plusA #-}++isIn :: Ord a => a -> Interval a -> Bool+x `isIn` Interval i j = i < x && x <= j++-- | Smart constructor.+-- @'algebraic' f i@ represents the unique root of+-- rational polynomial @f@ in the interval @i@.+-- If no root is found, or more than one root belongs to+-- the given interval, returns @'Nothing'@.+algebraic :: Unipol Rational -> Interval Rational -> Maybe Algebraic+algebraic f i =+ let pss = [ (n, p, ss)+ | p <- factors $ sqFreePart f+ , let (n, ss) = countRootsIn p i+ , n > 0+ ]+ in case pss of+ [(1, p, ss)] ->+ Just $+ if totalDegree' p == 1+ then Rational $ negate $ constantTerm p+ else Algebraic p ss i+ _ -> Nothing++algebraic' :: Unipol Rational -> Interval Rational -> Algebraic+algebraic' p i =+ if totalDegree' p == 1+ then Rational $ negate $ constantTerm p+ else Algebraic p (strum p) i++catcher :: (Interval Rational -> Interval Rational -> Interval Rational)+ -> Unipol Rational -> Algebraic -> Algebraic -> Interval Rational+catcher app h (Algebraic _ sf i0) (Algebraic _ sg j0) =+ let lens = map size $ isolateRoots h+ (i', j') = until (\(i,j) -> all (size (app i j) <) lens)+ (improveWith sf *** improveWith sg)+ (i0, j0)+ in i' `app` j'+catcher _ _ _ _ = error "rational is impossible"++normalize :: (Eq r, Euclidean r, Division r) => Unipol r -> Unipol r+normalize = monoize . sqFreePart++shiftP :: (Domain r, Division r, Eq r, Euclidean r)+ => Unipol r -> Unipol r+shiftP f | isZero (coeff one f) = f `quot` var 0+ | otherwise = f++stabilize :: Algebraic -> Algebraic+stabilize r@Rational{} = r+stabilize ar@(Algebraic f ss int)+ | lower int * upper int >= 0 = ar+ | otherwise =+ let lh = Interval (lower int) 0+ uh = Interval 0 (upper int)+ in Algebraic f ss $ if countChangeIn lh ss == 0 then uh else lh++-- | Unsafe version of @'nthRoot'@.+nthRoot' :: Int -> Algebraic -> Algebraic+nthRoot' n = fromJust . nthRoot n++-- | @nthRoot n r@ tries to computes n-th root of+-- the given algebraic real @r@.+-- It returns @'Nothing'@ if it's undefined.+--+-- See also @'nthRoot''@.+nthRoot :: Int -> Algebraic -> Maybe Algebraic+nthRoot 1 a = Just a+nthRoot n a+ | n < 0 = recipA <$> nthRoot (abs n) a+ | n == 0 = Nothing+ | even n && a < 0 = Nothing+ | otherwise =+ case a of+ Rational p ->+ either+ (Just . Rational)+ (algebraic (var 0 ^ fromIntegral n - injectCoeff p)) $+ nthRootRat n p+ Algebraic f _ range ->+ algebraic (mapMonomialMonotonic (_Wrapped.ix 0 *~ 2) f) (nthRootInterval n range)++nthRootRat :: Int -> Rational -> Either Rational (Interval Rational)+nthRootRat 1 r = Left r+nthRootRat 2 r =+ let (p, q) = (F.numerator r, F.denominator r)+ (isp, isq) = (integerSquareRoot p, integerSquareRoot q)+ in case (exactSquareRoot p, exactSquareRoot q) of+ (Just p', Just q') -> Left (p' F.% q')+ (mp', mq') -> Right $+ Interval (fromMaybe isp mp' F.% fromMaybe (isq+1) mq')+ (fromMaybe (isp+1) mp' F.% fromMaybe isq mq')+nthRootRat 3 r =+ let (p, q) = (F.numerator r, F.denominator r)+ (isp, isq) = (integerCubeRoot p, integerCubeRoot q)+ in case (exactCubeRoot p, exactCubeRoot q) of+ (Just p', Just q') -> Left (p' F.% q')+ (mp', mq') -> Right $+ Interval (fromMaybe isp mp' F.% fromMaybe (isq+1) mq')+ (fromMaybe (isp+1) mp' F.% fromMaybe isq mq')+nthRootRat 4 r =+ let (p, q) = (F.numerator r, F.denominator r)+ (isp, isq) = (integerFourthRoot p, integerFourthRoot q)+ in case (exactFourthRoot p, exactFourthRoot q) of+ (Just p', Just q') -> Left (p' F.% q')+ (mp', mq') -> Right $+ Interval (fromMaybe isp mp' F.% fromMaybe (isq+1) mq')+ (fromMaybe (isp+1) mp' F.% fromMaybe isq mq')+nthRootRat n r =+ let (p, q) = (F.numerator r, F.denominator r)+ (isp, isq) = (integerRoot n p, integerRoot n q)+ in case (exactRoot n p, exactRoot n q) of+ (Just p', Just q') -> Left (p' F.% q')+ (mp', mq') -> Right $+ Interval (fromMaybe isp mp' F.% fromMaybe (isq+1) mq')+ (fromMaybe (isp+1) mp' F.% fromMaybe isq mq')++nthRootRatCeil :: Int -> Rational -> Rational+nthRootRatCeil 1 r = r+nthRootRatCeil 2 r =+ let p = integerSquareRoot (F.numerator r) + 1+ q = integerSquareRoot (F.denominator r)+ in p F.% q+nthRootRatCeil 3 r =+ let p = integerCubeRoot (F.numerator r) + 1+ q = integerCubeRoot (F.denominator r)+ in p F.% q+nthRootRatCeil 4 r =+ let p = integerFourthRoot (F.numerator r) + 1+ q = integerFourthRoot (F.denominator r)+ in p F.% q+nthRootRatCeil n r =+ let p = integerRoot n (F.numerator r) + 1+ q = integerRoot n (F.denominator r)+ in p F.% q++nthRootRatFloor :: Int -> Rational -> Rational+nthRootRatFloor 1 r = r+nthRootRatFloor 2 r =+ let p = integerSquareRoot (F.numerator r)+ q = integerSquareRoot (F.denominator r) + 1+ in p F.% q+nthRootRatFloor 3 r =+ let p = integerCubeRoot (F.numerator r)+ q = integerCubeRoot (F.denominator r) + 1+ in p F.% q+nthRootRatFloor 4 r =+ let p = integerFourthRoot (F.numerator r)+ q = integerFourthRoot (F.denominator r) + 1+ in p F.% q+nthRootRatFloor n r =+ let p = integerRoot n (F.numerator r)+ q = integerRoot n (F.denominator r) + 1+ in p F.% q++nthRootInterval :: Int -> Interval Rational -> Interval Rational+nthRootInterval 0 _ = error "0-th root????????"+nthRootInterval 1 i = i+nthRootInterval n (Interval lb ub)+ | n < 0 = recipInt $ Interval (nthRootRatFloor (abs n) lb) (nthRootRatCeil (abs n) ub)+ | otherwise = Interval (nthRootRatFloor n lb) (nthRootRatCeil n ub)++rootMultPoly :: Unipol Rational -> Unipol Rational -> Unipol Rational+rootMultPoly f g =+ let ts = terms' g+ d = fromIntegral $ totalDegree' g+ g' = runAdd $ ifoldMap (\m k -> Add $ toPolynomial (injectCoeff k * var 0^(P.fromIntegral $ sum m),+ (OrderedMonomial $ singleton $ d - sum m)) ) ts+ in presultant (liftP f) g'+ where+ liftP :: Unipol Rational -> Unipol (Unipol Rational)+ liftP = mapCoeffUnipol injectCoeff++instance (Ord r, Multiplicative r, Monoidal r) => Multiplicative (Interval r) where+ (*) = multInt+ {-# INLINE (*) #-}++multInt :: (Monoidal a, Ord a, Multiplicative a) => Interval a -> Interval a -> Interval a+multInt i j+ | lower i < zero && lower j < zero = Interval (upper i * upper j) (lower i * lower j)+ | lower i >= zero && lower j < zero = Interval (upper i * lower j) (lower i * upper j)+ | lower i < zero && lower j >= zero = Interval (upper j * lower i) (lower j * upper i)+ | lower i >= zero && lower j >= zero = Interval (lower j * lower i) (upper j * upper i)+multInt _ _ = error "multInt"+{-# INLINABLE multInt #-}++multA :: Algebraic -> Algebraic -> Algebraic+multA (Rational 0) _ = Rational 0+multA _ (Rational 0) = Rational 0+multA (Rational a) (Rational b) = Rational (a * b)+multA a@Rational{} b@Algebraic{} = multA b a+multA (Algebraic f _ i) (Rational a) =+ let factor = monoize . liftMap (const $ recip a .*. var 0)+ in fromJust $ algebraic (factor f) (scale a i)+ -- ? Can't we use the strum sequence given beforehand?+multA a b =+ let fg = rootMultPoly (eqn a) (eqn b)+ int = catcher multInt fg (stabilize a) (stabilize b)+ in fromJust $ algebraic fg int++defEqn :: Algebraic -> Unipol Rational+defEqn (Rational a) = var 0 - injectCoeff a+defEqn a@Algebraic{} = eqn a++improveNonzero :: Algebraic -> Interval Rational+improveNonzero (Algebraic _ ss int0) = go int0+ where+ go int =+ let (lh, bh) = bisect int+ in if countChangeIn lh ss == 0+ then bh+ else go lh+improveNonzero _ = error "improveNonzero: Rational"++recipInt :: (Num r, Ord r, Division r) => Interval r -> Interval r+recipInt i | lower i < 0 = Interval (recip $ upper i) (recip $ lower i)+ | otherwise = Interval (recip $ lower i) (recip $ upper i)++recipA :: Algebraic -> Algebraic+recipA (Rational a) = Rational (recip a)+recipA a@Algebraic{} =+ let fi = rootRecipPoly (eqn a)+ sf = strum fi+ i0 = improveNonzero a+ ls = map size $ isolateRoots fi+ i' = until (\i -> any (> size (recipInt i)) ls) (improveWith sf) i0+ in fromJust $ algebraic fi $ recipInt i'++rootRecipPoly :: Unipol Rational -> Unipol Rational+rootRecipPoly f =+ let ts = terms' f+ d = fromIntegral $ totalDegree' f+ in runAdd $ ifoldMap (\m k -> Add $ toPolynomial+ (k, OrderedMonomial $ singleton $ d - sum m) ) ts++strum :: Unipol Rational -> [Unipol Rational]+strum f = zipWith (*) (cycle [1,1,-1,-1]) $+ map (\(p,_,_) -> p * injectCoeff (recip $ abs (leadingCoeff p))) $+ reverse $ prs f (diff 0 f)++data Interval r = Interval { lower :: !r, upper :: !r } deriving (Eq, Ord)++size :: Group r => Interval r -> r+size (Interval l r) = r - l++instance Show r => Show (Interval r) where+ showsPrec _ (Interval l u) = showChar '(' . showsPrec 5 l . showString ", " . showsPrec 5 u . showChar ']'++bisect :: (Ring r, Division r) => Interval r -> (Interval r, Interval r)+bisect (Interval l u) =+ let mid = (l+u) / fromInteger' 2+ in (Interval l mid, Interval mid u)++signChange :: (Ord a, Ring a, DecidableZero a) => [a] -> Int+signChange xs =+ let nzs = filter (not . isZero) xs+ in length $ filter (< zero) $ zipWith (*) nzs (tail nzs)++countRootsIn :: Unipol Rational -> Interval Rational -> (Int, [Unipol Rational])+countRootsIn f ints =+ let ss = strum f+ in (countChangeIn ints ss, ss)++countChangeIn :: (Ord a, CoeffRing a)+ => Interval a -> [Unipol a] -> Int+countChangeIn ints ss =+ signChangeAt (lower ints) ss - signChangeAt (upper ints) ss++signChangeAt :: (Ord a, CoeffRing a) => a -> [Unipol a] -> Int+signChangeAt a fs = signChange $ map (runScalar . liftMap (const $ Scalar a)) fs++rootBound :: (Num r, Ord r, CoeffRing r, Division r, UnitNormalForm r)+ => Unipol r -> r+rootBound f+ | totalDegree' f == 0 = 0+ | otherwise =+ let a = leadingCoeff f+ in 1 + maximum (map (normaliseUnit . (/ a)) $ terms' f)++isolateRoots :: Unipol Rational -> [Interval Rational]+isolateRoots f =+ let bd = rootBound f * 2+ in go (Interval (- bd) bd)+ where+ !ss = strum f+ go int =+ let rcount = countChangeIn int ss+ in if rcount == 0+ then []+ else if rcount == 1+ then [int]+ else let (ls, us) = bisect int+ in go ls ++ go us++-- | @'improve' r@ returns the same algebraic number,+-- but with more tighter bounds.+improve :: Algebraic -> Algebraic+improve (Algebraic f ss int) = Algebraic f ss $ improveWith ss int+improve a = a++improveWith :: (Ord a, CoeffRing a, Division a)+ => [Unipol a] -> Interval a -> Interval a+improveWith ss int =+ let (ls, us) = bisect int+ in if countChangeIn ls ss == 0 then us else ls++powA :: Integral a => Algebraic -> a -> Algebraic+powA r n | n < 0 = nthRoot' (abs $ fromIntegral n) r+ | n == 0 = Rational 1+ | otherwise = r ^ P.fromIntegral n+{-# INLINE powA #-}++iterateImprove :: Rational -> Unipol Rational -> Interval Rational -> Interval Rational+iterateImprove eps f =+ iterateImproveStrum eps (strum f)++iterateImproveStrum :: Rational -> [Unipol Rational] -> Interval Rational -> Interval Rational+iterateImproveStrum eps ss int0 =+ until (\int -> size int < eps) (improveWith ss) int0++fromFraction :: P.Fractional a => Fraction Integer -> a+fromFraction q = P.fromInteger (numerator q) P./ P.fromInteger (denominator q)++-- | Pseudo resultant. should we expose this?+presultant :: (Euclidean k, CoeffRing k)+ => Unipol k -> Unipol k -> k+presultant = go one one+ where+ go !res !acc h s+ | totalDegree' s > 0 =+ let (_, r) = h `pDivModPoly` s+ (l, k, m) = (totalDegree' h, totalDegree' r, totalDegree' s) & each %~ P.toInteger+ res' = res * pow (negate one) (P.fromIntegral $ l * m)+ * pow (leadingCoeff s) (P.fromIntegral $ abs $ l - k)+ adj = pow (leadingCoeff s) (P.fromIntegral $ abs (1 + l - m))+ in go res' (acc * adj) s r+ | isZero h || isZero s = zero+ | totalDegree' h > 0 = pow (leadingCoeff s) (totalDegree' h) * res `quot` acc+ | otherwise = res `quot` acc++-- | @'realRoots' f@ finds all real roots of the rational polynomial @f@.+realRoots :: Unipol Rational -> [Algebraic]+realRoots = realRootsIrreducible . monoize <=< factors . sqFreePart++-- | Same as @'realRoots'@, but assumes that the given polynomial+-- is monic and irreducible.+realRootsIrreducible :: Unipol Rational -> [Algebraic]+realRootsIrreducible f =+ [ algebraic' f i+ | i <- isolateRoots f+ ]++instance InvolutiveMultiplication Algebraic where+ adjoint = id++instance TriviallyInvolutive Algebraic++-- | @'realRoots' f@ finds all complex roots of the rational polynomial @f@.+--+-- CAUTION: This function currently comes with really naive implementation.+-- Easy to explode.+complexRoots :: Unipol Rational -> [Complex Algebraic]+complexRoots = complexRoots' <=< factors . sqFreePart++complexRoots' :: Unipol Rational -> [Complex Algebraic]+complexRoots' f =+ let rp = realPartPoly f+ ip = imagPartPoly f+ in [ c+ | r <- realRoots rp+ , i <- realRoots ip+ , let c = Complex r i+ , liftMap (const $ c) f == Complex 0 0+ ]++realPartPoly :: Unipol Rational -> Unipol Rational+realPartPoly f =+ normalize $ liftMap (const $ 2 * var 0) $ rootSumPoly f f++imagPartPoly :: Unipol Rational -> Unipol Rational+imagPartPoly f =+ let bi = liftMap (const $ 2 * #x) $+ rootSumPoly f (liftMap (const $ negate $ var 0) f)+ in mapMonomialMonotonic (_Wrapped.ix 0 *~ 2) $+ liftMap (const $ negate #x) $+ rootMultPoly bi bi++-- | Choose representative element of the given interval.+representative :: (Additive r, Division r, Num r) => Interval r -> r+representative (Interval l r) = (l + r) / 2++-- | @'approximate' eps r@ returns rational number @r'@ close to @r@,+-- with @abs (r - r') < eps@.+approximate :: Rational -> Algebraic -> Rational+approximate _ (Rational a) = a+approximate err (Algebraic _ ss int) =+ representative $ iterateImproveStrum err ss int++-- | Same as @'approximate'@, but returns @'Fractional'@ value instead.+approxFractional :: Fractional r => Rational -> Algebraic -> r+approxFractional eps = fromFraction . approximate eps
+ Algebra/Field/Finite.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, PolyKinds #-}+{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Algebra.Field.Finite (F(), naturalRepr, reifyPrimeField, withPrimeField,+ modNat, modNat', modRat, modRat', FiniteField(..), order) where+import Algebra.Algorithms.PrimeTest+import Algebra.Prelude.Core hiding (pow)+import Algebra.Ring.Polynomial.Class (PrettyCoeff (..), ShowSCoeff (..))++import Control.DeepSeq (NFData (..))+import Control.Monad.Random (uniform)+import Control.Monad.Random (runRand)+import Control.Monad.Random (Random (..))+import qualified Data.Coerce as C+import Data.Maybe (fromMaybe)+import qualified Data.Ratio as R+import Data.Reflection (Reifies (reflect), reifyNat)+import GHC.TypeLits (KnownNat)+import Numeric.Algebra (Field)+import Numeric.Algebra (char)+import Numeric.Algebra (Natural)+import qualified Numeric.Algebra as NA+import Numeric.Rig.Characteristic (Characteristic)+import Numeric.Semiring.ZeroProduct (ZeroProductSemiring)+import qualified Prelude as P++-- | Prime field of characteristic @p@.+-- @p@ should be prime, and not statically checked.+newtype F (p :: k) = F { runF :: Integer }+ deriving (NFData)++naturalRepr :: F p -> Integer+naturalRepr = runF++instance Reifies (p :: k) Integer => Show (F p) where+ showsPrec d n@(F p) = showsPrec d (p `rem` reflect n)++instance Reifies (p :: k) Integer => PrettyCoeff (F p) where+ showsCoeff d (F p) =+ if p == 0+ then Vanished+ else if p == 1+ then OneCoeff+ else Positive $ showsPrec d p++modNat :: Reifies (p :: k) Integer => Integer -> F p+modNat = modNat' Proxy+{-# INLINE modNat #-}++modNat' :: forall proxy (p :: k). Reifies p Integer => proxy (F p) -> Integer -> F p+modNat' _ i =+ let p = reflect (Proxy :: Proxy p)+ in F (i `rem` p)+{-# INLINE modNat' #-}++reifyPrimeField :: Integer -> (forall p. KnownNat p => Proxy (F p) -> a) -> a+reifyPrimeField p f = reifyNat p (\pxy -> f (proxyF pxy))++withPrimeField :: Integer -> (forall p. KnownNat p => F p) -> Integer+withPrimeField p f = reifyPrimeField p $ runF . asProxyTypeOf f++proxyF :: Proxy (a :: k) -> Proxy (F a)+proxyF Proxy = Proxy++-- instance Reifies p Int => Noetherian (F p)++instance Eq (F p) where+ F n == F m = n == m++instance Reifies p Integer => Normed (F p) where+ type Norm (F p) = Integer+ norm fp@(F p) = p where _ = reflect fp+ liftNorm = modNat++instance Reifies p Integer => P.Num (F p) where+ fromInteger = fromInteger'+ {-# INLINE fromInteger #-}++ (+) = C.coerce ((P.+) :: WrapAlgebra (F p) -> WrapAlgebra (F p) -> WrapAlgebra (F p))+ {-# INLINE (+) #-}++ (-) = C.coerce ((P.-) :: WrapAlgebra (F p) -> WrapAlgebra (F p) -> WrapAlgebra (F p))+ {-# INLINE (-) #-}++ negate = C.coerce (P.negate :: WrapAlgebra (F p) -> WrapAlgebra (F p))+ {-# INLINE negate #-}++ (*) = C.coerce ((P.*) :: WrapAlgebra (F p) -> WrapAlgebra (F p) -> WrapAlgebra (F p))+ {-# INLINE (*) #-}++ abs = id+ signum (F 0) = F 0+ signum (F _) = F 1++pows :: (P.Integral a1, Reifies p Integer) => F p -> a1 -> F p+pows a n = modNat $ modPow (runF a) (reflect a) n++instance Reifies p Integer => NA.Additive (F p) where+ F a + F b = modNat $ a + b+ {-# INLINE (+) #-}+ sinnum1p n (F k) = modNat $ (1 P.+ P.fromIntegral n) * k+ {-# INLINE sinnum1p #-}++instance Reifies p Integer => NA.Multiplicative (F p) where+ F a * F b = modNat $ a * b+ {-# INLINE (*) #-}++ pow1p n p = pows n (p P.+ 1)+ {-# INLINE pow1p #-}++instance Reifies p Integer => NA.Monoidal (F p) where+ zero = F 0+ {-# INLINE zero #-}+ sinnum n (F k) = modNat $ P.fromIntegral n * k+ {-# INLINE sinnum #-}++instance Reifies p Integer => NA.LeftModule Natural (F p) where+ n .* F p = modNat (n .* p)+ {-# INLINE (.*) #-}++instance Reifies p Integer => NA.RightModule Natural (F p) where+ F p *. n = modNat (p *. n)+ {-# INLINE (*.) #-}++instance Reifies p Integer => NA.LeftModule Integer (F p) where+ n .* F p = modNat (n * p)+ {-# INLINE (.*) #-}++instance Reifies p Integer => NA.RightModule Integer (F p) where+ F p *. n = modNat (p * n)+ {-# INLINE (*.) #-}++instance Reifies p Integer => NA.Group (F p) where+ F a - F b = modNat $ a - b+ {-# INLINE (-) #-}++ negate (F a) = F (reflect (Proxy :: Proxy p) - a)+ {-# INLINE negate #-}++instance Reifies p Integer => NA.Abelian (F p)++instance Reifies p Integer => NA.Semiring (F p)++instance Reifies p Integer => NA.Rig (F p) where+ fromNatural = modNat . P.fromIntegral+ {-# INLINE fromNatural #-}++instance Reifies p Integer => NA.Ring (F p) where+ fromInteger = modNat+ {-# INLINE fromInteger #-}++instance Reifies p Integer => NA.DecidableZero (F p) where+ isZero (F p) = p == 0++instance Reifies p Integer => NA.Unital (F p) where+ one = F 1+ {-# INLINE one #-}+ pow = pows+ {-# INLINE pow #-}++instance Reifies p Integer => DecidableUnits (F p) where+ isUnit (F n) = n /= 0+ {-# INLINE isUnit #-}++ recipUnit n@(F k) =+ let p = fromIntegral $ reflect n+ (u,_,r) = head $ euclid p k+ in if u == 1 then Just $ modNat $ fromInteger $ r `rem` p else Nothing+ {-# INLINE recipUnit #-}++instance (Reifies p Integer) => DecidableAssociates (F p) where+ isAssociate p n =+ (isZero p && isZero n) || (not (isZero p) && not (isZero n))+ {-# INLINE isAssociate #-}++instance (Reifies p Integer) => UnitNormalForm (F p)+instance (Reifies p Integer) => IntegralDomain (F p)+instance (Reifies p Integer) => GCDDomain (F p)+instance (Reifies p Integer) => UFD (F p)+instance (Reifies p Integer) => PID (F p)+instance (Reifies p Integer) => ZeroProductSemiring (F p)+instance (Reifies p Integer) => Euclidean (F p)++instance Reifies p Integer => Division (F p) where+ recip = fromMaybe (error "recip: not unit") . recipUnit+ {-# INLINE recip #-}+ a / b = a * recip b+ {-# INLINE (/) #-}+ (^) = pows+ {-# INLINE (^) #-}++instance Reifies p Integer => P.Fractional (F p) where+ (/) = C.coerce ((P./) :: WrapAlgebra (F p) -> WrapAlgebra (F p) -> WrapAlgebra (F p))+ {-# INLINE (/) #-}++ fromRational r =+ modNat (R.numerator r) * recip (modNat $ R.denominator r)+ {-# INLINE fromRational #-}++ recip = C.coerce (P.recip :: WrapAlgebra (F p) -> WrapAlgebra (F p))+ {-# INLINE recip #-}++instance Reifies p Integer => NA.Commutative (F p)++instance Reifies p Integer => NA.Characteristic (F p) where+ char _ = fromIntegral $ reflect (Proxy :: Proxy p)+ {-# INLINE char #-}++class (Field k, Characteristic k) => FiniteField k where+ power :: proxy k -> Natural+ elements :: proxy k -> [k]++instance Reifies p Integer => FiniteField (F p) where+ power _ = 1+ {-# INLINE power #-}++ elements p = map modNat [0.. fromIntegral (char p) - 1]+ {-# INLINE elements #-}++order :: FiniteField k => proxy k -> Natural+order p = char p ^ power p+{-# INLINE order #-}++instance Reifies p Integer => Random (F p) where+ random = runRand $ uniform (elements Proxy)+ {-# INLINE random #-}+ randomR (a, b) = runRand $ uniform $ map modNat [naturalRepr a..naturalRepr b]+ {-# INLINE randomR #-}++modRat :: FiniteField k => Proxy k -> Fraction Integer -> k+modRat _ q = NA.fromInteger (numerator q) NA./ NA.fromInteger (denominator q)+{-# INLINE modRat #-}++modRat' :: FiniteField k => Fraction Integer -> k+modRat' = modRat Proxy+{-# INLINE modRat' #-}
+ Algebra/Field/Galois.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE GADTs, MultiParamTypeClasses, NoMonomorphismRestriction #-}+{-# LANGUAGE ParallelListComp, PolyKinds, QuasiQuotes, RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, TypeFamilies #-}+{-# LANGUAGE TypeOperators, UndecidableInstances #-}+module Algebra.Field.Galois (GF'(), IsGF', modPoly, modVec,+ withIrreducible, linearRepGF, linearRepGF',+ reifyGF', generateIrreducible,+ withGF', GF, ConwayPolynomial(..),+ Conway, primitive, conway,+ conwayFile, addConwayPolynomials) where+import Algebra.Field.Finite+import Algebra.Field.Galois.Conway+import Algebra.Internal+import Algebra.Prelude.Core hiding (varX)+import Algebra.Ring.Polynomial.Univariate++import Control.Lens (imap)+import Control.Monad (replicateM)+import Control.Monad.Loops (iterateUntil)+import Control.Monad.Random (MonadRandom)+import Control.Monad.Random (uniform)+import qualified Data.Foldable as F+import qualified Data.Ratio as Rat+import Data.Reflection (Reifies (..), reify)+import Data.Singletons.Prelude.Enum (SEnum (..))+import Data.Singletons.TypeLits (withKnownNat)+import qualified Data.Sized.Builtin as SV+import qualified Data.Traversable as T+import qualified Data.Vector as V+import qualified GHC.TypeLits as TL+import qualified Numeric.Algebra as NA+import Numeric.Domain.Euclidean (Euclidean)+import Numeric.Domain.GCD (GCDDomain, gcd)+import Numeric.Semiring.ZeroProduct (ZeroProductSemiring)+import qualified Prelude as P++-- | Galois field of order @p^n@.+-- @f@ stands for the irreducible polynomial over @F_p@ of degree @n@.+data GF' p (n :: TL.Nat) (f :: *) = GF' { runGF' :: Sized n (F p) }+deriving instance Reifies p Integer => Eq (GF' p n f)++-- | Galois Field of order @p^n@. This uses conway polynomials+-- as canonical minimal polynomial and it should be known at+-- compile-time (i.e. @Reifies (Conway p n) (Unipol (F n))@+-- instances should be defined to use field operations).+type GF (p :: TL.Nat) n = GF' p n (Conway p n)++modPoly :: forall p n f. (KnownNat n, Reifies p Integer) => Unipol (F p) -> GF' p n f+modPoly = GF' . polyToVec++modVec :: Sized n (F p) -> GF' p n f+modVec = GF'++instance (Reifies p Integer, Show (F p)) => Show (GF' p n f) where+ showsPrec d (GF' (v :< vs)) =+ if F.all isZero vs+ then showsPrec d v+ else showChar '<' . showString (showPolynomialWith (singleton "ξ") 0 $ vecToPoly $ v :< vs) . showChar '>'+ showsPrec _ _ = showString "0"++instance (Reifies p Integer, Show (F p)) => PrettyCoeff (GF' p n f)++varX :: CoeffRing r => Unipol r+varX = var [od|0|]++vecToPoly :: (CoeffRing r)+ => Sized n r -> Unipol r+vecToPoly v = sum $ imap (\i c -> injectCoeff c * varX^fromIntegral i) $ F.toList v++polyToVec :: forall n r. (CoeffRing r, KnownNat n) => Unipol r -> Sized n r+polyToVec f = unsafeFromList' [ coeff (leadingMonomial $ (varX ^ i) `asTypeOf` f) f+ | i <- [0..fromIntegral (fromSing (sing :: SNat n))]]++instance Reifies p Integer => Additive (GF' p n f) where+ GF' v + GF' u = GF' $ SV.zipWithSame (+) v u++instance (Reifies p Integer, KnownNat n) => Monoidal (GF' p n f) where+ zero = GF' $ SV.replicate' zero++instance Reifies p Integer => LeftModule Natural (GF' p n f) where+ n .* GF' v = GF' $ SV.map (n .*) v++instance Reifies p Integer => RightModule Natural (GF' p n f) where+ GF' v *. n = GF' $ SV.map (*. n) v++instance Reifies p Integer => LeftModule Integer (GF' p n f) where+ n .* GF' v = GF' $ SV.map (n .*) v++instance Reifies p Integer => RightModule Integer (GF' p n f) where+ GF' v *. n = GF' $ SV.map (*. n) v++instance (KnownNat n, Reifies p Integer) => Group (GF' p n f) where+ negate (GF' v) = GF' $ SV.map negate v+ GF' u - GF' v = GF' $ SV.zipWithSame (-) u v++instance (Reifies p Integer) => Abelian (GF' p n f)++instance (KnownNat n, Reifies f (Unipol (F p)), Reifies p Integer)+ => Multiplicative (GF' p n f) where+ GF' u * GF' v =+ let t = (vecToPoly u * vecToPoly v) `rem` reflect (Proxy :: Proxy f)+ in GF' $ polyToVec t++instance (KnownNat n, Reifies f (Unipol (F p)), Reifies p Integer) => Unital (GF' p n f) where+ one =+ case zeroOrSucc (sing :: SNat n) of+ IsZero -> GF' NilL+ IsSucc k -> withKnownNat k $ GF' $ one :< SV.replicate' zero++instance (KnownNat n, Reifies f (Unipol (F p)), Reifies p Integer) => Semiring (GF' p n f)++instance (KnownNat n, Reifies f (Unipol (F p)), Reifies p Integer) => Rig (GF' p n f) where+ fromNatural n =+ case zeroOrSucc (sing :: SNat n) of+ IsZero -> GF' SV.empty+ IsSucc k -> withKnownNat k $ GF' $ fromNatural n :< SV.replicate' zero++instance (KnownNat n, Reifies f (Unipol (F p)), Reifies p Integer) => Commutative (GF' p n f)++instance (KnownNat n, Reifies f (Unipol (F p)), Reifies p Integer) => Ring (GF' p n f) where+ fromInteger n =+ case zeroOrSucc (sing :: SNat n) of+ IsZero -> GF' NilL+ IsSucc k -> withKnownNat k $ GF' $ fromInteger n :< SV.replicate' zero++instance (KnownNat n, Reifies p Integer) => DecidableZero (GF' p n f) where+ isZero (GF' sv) = F.all isZero sv++instance (KnownNat n, Reifies p Integer, Reifies f (Unipol (F p))) => DecidableUnits (GF' p n f) where+ isUnit (GF' sv) = not $ F.all isZero sv+ recipUnit a | isZero a = Nothing+ | otherwise = Just $ recip a++instance (Reifies p Integer, Reifies f (Unipol (F p)), KnownNat n)+ => Characteristic (GF' p n f) where+ char _ = char (Proxy :: Proxy (F p))++instance (Reifies p Integer, Reifies f (Unipol (F p)), KnownNat n)+ => Division (GF' p n f) where+ recip f =+ let p = reflect (Proxy :: Proxy f)+ (_,_,r) = P.head $ euclid p $ vecToPoly $ runGF' f+ in GF' $ polyToVec $ r `rem` p++instance (KnownNat n, Reifies p Integer, Reifies f (Unipol (F p)))+ => DecidableAssociates (GF' p n f) where+ isAssociate p n =+ (isZero p && isZero n) || (not (isZero p) && not (isZero n))+instance (KnownNat n, Reifies p Integer, Reifies f (Unipol (F p)))+ => ZeroProductSemiring (GF' p n f)+instance (KnownNat n, Reifies p Integer, Reifies f (Unipol (F p)))+ => UnitNormalForm (GF' p n f)+instance (KnownNat n, Reifies p Integer, Reifies f (Unipol (F p)))+ => IntegralDomain (GF' p n f)+instance (KnownNat n, Reifies p Integer, Reifies f (Unipol (F p)))+ => GCDDomain (GF' p n f)+instance (KnownNat n, Reifies p Integer, Reifies f (Unipol (F p)))+ => UFD (GF' p n f)+instance (KnownNat n, Reifies p Integer, Reifies f (Unipol (F p)))+ => PID (GF' p n f)+instance (KnownNat n, Reifies p Integer, Reifies f (Unipol (F p)))+ => Euclidean (GF' p n f)++instance (Reifies p Integer, Reifies f (Unipol (F p)), KnownNat n) => P.Num (GF' p n f) where+ (+) = (NA.+)+ (-) = (NA.-)+ negate = NA.negate+ (*) = (NA.*)+ fromInteger = NA.fromInteger+ abs = error "not defined"+ signum = error "not defined"++instance (Reifies p Integer, Reifies f (Unipol (F p)), KnownNat n) => P.Fractional (GF' p n f) where+ fromRational u = fromInteger (Rat.numerator u) / fromInteger (Rat.denominator u)+ (/) = (/)+ recip = recip++-- | @generateIrreducible p n@ generates irreducible polynomial over F_@p@ of degree @n@.+generateIrreducible :: (MonadRandom m, FiniteField k, Eq k)+ => proxy k -> Natural -> m (Unipol k)+generateIrreducible p n =+ iterateUntil (\f -> all (\i -> one == gcd (varX^(order p^i) - varX) f ) [1.. n `div` 2]) $ do+ cs <- replicateM (fromIntegral n) $ uniform (elements p)+ let f = varX^n + sum [ injectCoeff c * (varX^i) | c <- cs | i <- [0..n P.- 1]]+ return f++withIrreducible :: forall p a. KnownNat p+ => Unipol (F p)+ -> (forall f (n :: Nat). (Reifies f (Unipol (F p))) => Proxy (GF' p n f) -> a)+ -> a+withIrreducible r f =+ case toSing (fromIntegral $ totalDegree' r) of+ SomeSing sn ->+ withKnownNat sn $+ reify r (f. proxyGF' (Proxy :: Proxy (F n)) sn)++reifyGF' :: MonadRandom m => Natural -> Natural+ -> (forall (p :: TL.Nat) (f :: *) (n :: TL.Nat) . (Reifies p Integer, Reifies f (Unipol (F p)))+ => Proxy (GF' p n f) -> a)+ -> m a+reifyGF' p n f = reifyPrimeField (P.toInteger p) $ \pxy -> do+ mpol <- generateIrreducible pxy n+ case toSing (fromIntegral p) of+ SomeSing sp -> return $ withKnownNat sp $ withIrreducible mpol f++linearRepGF :: GF' p n f -> V.Vector (F p)+linearRepGF = SV.unsized . runGF'++linearRepGF' :: GF' p n f -> V.Vector Integer+linearRepGF' = V.map naturalRepr . linearRepGF++withGF' :: MonadRandom m+ => Natural -> Natural+ -> (forall (p :: TL.Nat) f (n :: TL.Nat) . (Reifies p Integer, Reifies f (Unipol (F p)))+ => GF' p n f)+ -> m (V.Vector Integer)+withGF' p n f = reifyGF' p n $ V.map naturalRepr . linearRepGF . asProxyTypeOf f++proxyGF' :: Proxy (F p) -> SNat n -> Proxy f -> Proxy (GF' p n f)+proxyGF' _ _ Proxy = Proxy++-- | Type-constraint synonym to work with Galois field.+class (KnownNat n, KnownNat p, Reifies f (Unipol (F p))) => IsGF' p n f+instance (KnownNat n, KnownNat p, Reifies f (Unipol (F p))) => IsGF' p n f+++instance (KnownNat n, IsGF' p n f) => ZeroProductSemiring (GF' p n f)++instance (KnownNat n, IsGF' p n f) => FiniteField (GF' p n f) where+ power _ = fromIntegral $ fromSing (sing :: SNat n)+ elements _ =+ let sn = sing :: SNat n+ in P.map GF' $ T.sequence $+ SV.replicate sn $ elements Proxy++primitive :: forall p n f. (IsGF' p n f) => GF' p (n + 1) f+primitive = withKnownNat (sSucc (sing :: SNat n)) $ GF' $ polyToVec $ var [od|0|]++-- | Conway polynomial (if definition is known).+conway :: forall p n. ConwayPolynomial p n+ => SNat p -> SNat n -> Unipol (F p)+conway = conwayPolynomial
+ Algebra/Field/Galois/Conway.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DataKinds, FlexibleInstances, LiberalTypeSynonyms #-}+{-# LANGUAGE MultiParamTypeClasses, TemplateHaskell, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Algebra.Field.Galois.Conway+ (Conway,+ ConwayPolynomial(..),+ addConwayPolynomials,+ conwayFile) where+import Algebra.Field.Galois.Internal+import Algebra.Prelude.Core+import Control.Monad (liftM)+import Language.Haskell.TH (runIO)+import Language.Haskell.TH (DecsQ)++do dat <- tail . init . lines <$> runIO (readFile "data/conway.txt")+ concat <$> mapM (buildInstance . head . parseLine) dat++-- | Macro to add Conway polynomials dictionary.+addConwayPolynomials :: [(Integer, Integer, [Integer])] -> DecsQ+addConwayPolynomials = liftM concat . mapM buildInstance++-- | Parse conway polynomial file and define instances for them.+-- File-format must be the same as+-- <http://www.math.rwth-aachen.de/~Frank.Luebeck/data/ConwayPol/index.html?LANG=en Lueback's file>.+conwayFile :: FilePath -> DecsQ+conwayFile fp = do+ dat <- tail . init . lines <$> runIO (readFile fp)+ addConwayPolynomials $ concatMap parseLine dat
+ Algebra/Field/Galois/Internal.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DataKinds, EmptyDataDecls, FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses, NoImplicitPrelude #-}+{-# LANGUAGE NoMonomorphismRestriction, PolyKinds, ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell, UndecidableInstances #-}+module Algebra.Field.Galois.Internal+ (ConwayPolynomial(..),+ Conway,+ buildInstance,+ parseLine) where+import Algebra.Field.Finite+import Algebra.Prelude.Core hiding (lex, lift)+import Algebra.Ring.Polynomial.Univariate (Unipol)+import Data.Char (isDigit)+import Data.Char (digitToInt)+import qualified Data.Map as M+import Data.Reflection+import qualified GHC.TypeLits as TL+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (lift)+import Numeric (readInt)+import Prelude (lex)++-- | Type-class to provide the dictionary for Conway polynomials+class ConwayPolynomial (p :: TL.Nat) (n :: TL.Nat) where+ conwayPolynomial :: proxy p -> proxy n -> Unipol (F p)++-- | Empty tag to reify Conway polynomial to type-level+data Conway p n++-- instance {-# OVERLAPPABLE #-} (KnownNat p, KnownNat n) => ConwayPolynomial p n where+-- conwayPolynomial _ _ = undefined++instance (ConwayPolynomial p n) => Reifies (Conway p n) (Unipol (F p)) where+ reflect _ = conwayPolynomial (Proxy :: Proxy p) (Proxy :: Proxy n)++parseLine :: String -> [(Integer, Integer, [Integer])]+parseLine ('[':xs) =+ [(p,n,poly) | (f, ',':rest) <- lex xs+ , (p, "") <- readInt 10 isDigit digitToInt f+ , (n, ',':ys) <- readInt 10 isDigit digitToInt rest+ , (poly, _) <- readList ys+ ]+parseLine _ = []++plusOp :: ExpQ -> ExpQ -> ExpQ+plusOp e f = infixApp e [| (+) |] f++toPoly :: [Integer] -> ExpQ+toPoly as =+ foldl1 plusOp $+ zipWith (\i c -> [| injectCoeff (modNat $(litE $ integerL c)) * var 0 ^ $(lift i) |])+ [0 :: Integer ..] as++buildInstance :: (Integer, Integer, [Integer]) -> DecsQ+buildInstance (p,n,cs) =+ let tp = litT $ numTyLit p+ tn = litT $ numTyLit n+ in [d| instance {-# OVERLAPPING #-} ConwayPolynomial $tp $tn where+ conwayPolynomial _ _ = $(toPoly cs)+ {-# INLINE conwayPolynomial #-}+ |]
+ Algebra/Instances.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | This Library provides some *dangerous* instances for @Double@s and @Complex@.+module Algebra.Instances () where+import Algebra.Scalar++import AlgebraicPrelude+import Control.DeepSeq (NFData (..))+import Control.Monad.Random (Random (..), getRandom)+import Control.Monad.Random (getRandomR, runRand)+import Data.Complex (Complex (..))+import Data.Convertible.Base (Convertible (..))+import qualified Data.Ratio as P+import qualified Data.Vector as DV+import qualified Numeric.Algebra as NA+import qualified Prelude as P++instance Additive r => Additive (DV.Vector r) where+ (+) = DV.zipWith (+)++-- | These Instances are not algebraically right, but for the sake of convenience.+instance DecidableZero r => DecidableZero (Complex r) where+ isZero (a :+ b) = isZero a && isZero b++instance (NFData a) => NFData (Fraction a) where+ rnf a = rnf (numerator a) `seq` rnf (denominator a) `seq` ()++instance Additive r => Additive (Complex r) where+ (a :+ b) + (c :+ d) = (a + c) :+ (b + d)+instance Abelian r => Abelian (Complex r) where+instance (Group r, Semiring r) => Semiring (Complex r) where+instance (Group r, Rig r) => Rig (Complex r) where+ fromNatural = (:+ zero) . fromNatural+instance (Group r, Commutative r) => Commutative (Complex r) where+instance Ring r => Ring (Complex r) where+ fromInteger = (:+ zero) . fromInteger'+instance Group r => Group (Complex r) where+ (a :+ b) - (c :+ d) = (a - c) :+ (b - d)+ negate (a :+ b) = negate a :+ negate b+ times n (a :+ b) = times n a :+ times n b+instance LeftModule a r => LeftModule a (Complex r) where+ r .* (a :+ b) = (r .* a) :+ (r .* b)+instance RightModule a r => RightModule a (Complex r) where+ (a :+ b) *. r = (a *. r) :+ (b *. r)+instance Monoidal r => Monoidal (Complex r) where+ zero = zero :+ zero+instance (Group r, Monoidal r, Unital r) => Unital (Complex r) where+ one = one :+ zero+instance Additive Double where+ (+) = (P.+)+instance (Group r, Multiplicative r) => Multiplicative (Complex r) where+ (a :+ b) * (c :+ d) = (a*c - b*d) :+ (a*d + b*c)+instance LeftModule Natural Double where+ n .* d = fromIntegral n P.* d+instance RightModule Natural Double where+ d *. n = d P.* fromIntegral n+instance Monoidal Double where+ zero = 0+instance Unital Double where+ one = 1+instance Multiplicative Double where+ (*) = (P.*)+instance Commutative Double where+instance Group Double where+ (-) = (P.-)+ negate = P.negate+ subtract = P.subtract+ times n r = P.fromIntegral n P.* r+instance LeftModule Integer Double where+ n .* r = P.fromInteger n * r+instance RightModule Integer Double where+ r *. n = r * P.fromInteger n+instance Rig Double where+ fromNatural = P.fromInteger . fromNatural+instance Semiring Double where+instance Abelian Double where+instance Ring Double where+ fromInteger = P.fromInteger+instance DecidableZero Double where+ isZero 0 = True+ isZero _ = False++instance Division Double where+ recip = P.recip+ (/) = (P./)++instance P.Integral r => Additive (P.Ratio r) where+ (+) = (P.+)++instance P.Integral r => Abelian (P.Ratio r)++instance P.Integral r => LeftModule Natural (P.Ratio r) where+ n .* r = fromIntegral n P.* r++instance P.Integral r => RightModule Natural (P.Ratio r) where+ r *. n = r P.* fromIntegral n++instance P.Integral r => LeftModule Integer (P.Ratio r) where+ n .* r = P.fromInteger n P.* r++instance P.Integral r => RightModule Integer (P.Ratio r) where+ r *. n = r P.* P.fromInteger n++instance P.Integral r => Group (P.Ratio r) where+ (-) = (P.-)+ negate = P.negate+ subtract = P.subtract+ times n r = P.fromIntegral n P.* r++instance P.Integral r => Commutative (P.Ratio r)++instance (Semiring r, P.Integral r) => LeftModule (Scalar r) (P.Ratio r) where+ Scalar n .* r = (n P.% 1) * r++instance (Semiring r, P.Integral r) => RightModule (Scalar r) (P.Ratio r) where+ r *. Scalar n = r * (n P.% 1)++instance P.Integral r => Multiplicative (P.Ratio r) where+ (*) = (P.*)++instance P.Integral r => Unital (P.Ratio r) where+ one = 1++instance P.Integral r => Division (P.Ratio r) where+ (/) = (P./)+ recip = P.recip++instance P.Integral r => Monoidal (P.Ratio r) where+ zero = 0++instance P.Integral r => Semiring (P.Ratio r)++instance P.Integral r => Rig (P.Ratio r) where+ fromNatural = P.fromIntegral++instance P.Integral r => Ring (P.Ratio r) where+ fromInteger = P.fromInteger++instance P.Integral r => DecidableZero (P.Ratio r) where+ isZero 0 = True+ isZero _ = False++instance P.Integral r => DecidableUnits (P.Ratio r) where+ isUnit 0 = False+ isUnit _ = True+ recipUnit 0 = Nothing+ recipUnit n = Just (P.recip n)+ r ^? n+ | r == 0 = Just 1+ | r /= 0 = Just (r P.^^ n)+ | r == 0 && n P.> 0 = Just 0+ | otherwise = Nothing++instance Convertible (Fraction Integer) Double where+ safeConvert a = Right $ P.fromInteger (numerator a) P./ P.fromInteger (denominator a)++instance Convertible (Fraction Integer) (Complex Double) where+ safeConvert a = Right $ P.fromInteger (numerator a) P./ P.fromInteger (denominator a) :+ 0++instance (Random (Fraction Integer)) where+ random = runRand $ do+ i <- getRandom+ j <- getRandom+ return $ i % (P.abs j + 1)+ randomR (a, b) = runRand $ do+ j <- succ . P.abs <$> getRandom+ let g = foldl1 P.lcm [denominator a, denominator b, j]+ lb = g * numerator a `quot` denominator a+ ub = g * numerator b `quot` denominator b+ i <- getRandomR (lb, ub)+ return $ i % g++instance Hashable a => Hashable (DV.Vector a) where+ hashWithSalt s = hashWithSalt s . DV.toList
Algebra/Internal.hs view
@@ -1,10 +1,113 @@-{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}-{-# LANGUAGE MultiParamTypeClasses, PolyKinds, RankNTypes, StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies, TypeOperators #-}+{-# LANGUAGE CPP, DataKinds, EmptyDataDecls, ExplicitNamespaces #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses, PatternSynonyms, PolyKinds, RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}-module Algebra.Internal ( toProxy, module Data.Proxy- ) where-import Data.Proxy+module Algebra.Internal+ ( (:~:)(..), withRefl,+ module Data.Proxy,+ module Algebra.Internal) where+import Algebra.Instances () +import AlgebraicPrelude+import Control.Lens ((%~), _Unwrapping)+import Data.Proxy+import Data.Singletons.Prelude as Algebra.Internal (PNum (..),+ POrd (..),+ SNum (..),+ SOrd (..),+ Sing (SFalse, STrue),+ SingI (..),+ SingKind (..),+ SomeSing (..),+ withSingI)+import Data.Singletons.Prelude.Enum as Algebra.Internal (PEnum (..),+ SEnum (..))+import Data.Singletons.TypeLits as Algebra.Internal (KnownNat,+ withKnownNat)+import Data.Sized.Builtin as Algebra.Internal (pattern (:<),+ pattern (:>),+ pattern NilL,+ pattern NilR,+ sIndex,generate,+ singleton,+ unsafeFromList,+ unsafeFromList',+ zipWithSame)+import qualified Data.Sized.Builtin as S+import qualified Data.Sized.Flipped as Flipped (Flipped (..))+import Data.Type.Equality ((:~:) (..))+import Data.Type.Natural.Class as Algebra.Internal+import qualified Data.Type.Ordinal as O+import qualified Data.Vector as DV+import GHC.TypeLits as Algebra.Internal+import Proof.Equational (coerce, withRefl)+import Proof.Equational as Algebra.Internal (because,+ coerce,+ start, (===),+ (=~=))+import Proof.Propositional as Algebra.Internal (IsTrue (..),+ withWitness)+import qualified Data.Foldable as F+import qualified Data.Sequence as Seq+import Data.Kind (Type)+ toProxy :: a -> Proxy a toProxy _ = Proxy++type Sized n a = S.Sized DV.Vector n a+type Sized' n a = S.Sized Seq.Seq n a++coerceLength :: n :~: m -> S.Sized f n a -> S.Sized f m a+coerceLength eql = _Unwrapping Flipped.Flipped %~ coerce eql++type SNat (n :: Nat) = Sing n++sizedLength f = (S.sLength f)++padVecs :: forall a n m. a -> Sized' n a -> Sized' m a+ -> (SNat (Max n m), Sized' (Max n m) a, Sized' (Max n m) a)+padVecs d xs ys+ = let (n, m) = (S.sLength xs, S.sLength ys)+ l = sMax n m+ in case n %:<= m of+ STrue ->+ let maxISm = leqToMax n m Witness+ k = m %:- n+ nPLUSk = start (n %:+ (m %:- n))+ === m %:- n %:+ n `because` plusComm n (m %:- n)+ === m `because` minusPlus m n Witness+ === sMax n m `because` maxISm+ in (l,+ coerceLength nPLUSk (xs S.++ S.replicate k d),+ coerceLength maxISm ys)+ SFalse -> withWitness (notLeqToLeq n m) $+ let maxISn = geqToMax n m Witness+ mPLUSk :: m :+ (n :- m) :~: Max n m+ mPLUSk = start (m %:+ (n %:- m))+ === n %:- m %:+ m `because` plusComm m (n %:- m)+ === n `because` minusPlus n m Witness+ === sMax n m `because` maxISn+ in (l,+ coerceLength maxISn xs,+ coerceLength mPLUSk $ ys S.++ S.replicate (n %:- m) d)++type family Flipped f a :: Nat -> Type where+ Flipped f a = Flipped.Flipped f a++pattern Flipped :: S.Sized f n a -> Flipped f a n+pattern Flipped xs = Flipped.Flipped xs+++pattern OLt :: forall (t :: Nat). ()+ => forall (n1 :: Nat).+ ((n1 :< t) ~ 'True)+ => Sing n1 -> O.Ordinal t+pattern OLt n = O.OLt n++sNatToInt :: SNat n -> Int+sNatToInt = fromInteger . fromSing++instance Hashable a => Hashable (Seq.Seq a) where+ hashWithSalt d = hashWithSalt d . F.toList
+ Algebra/LinkedMatrix.hs view
@@ -0,0 +1,892 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE BangPatterns, DataKinds, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses, NamedFieldPuns, NoImplicitPrelude #-}+{-# LANGUAGE NoMonomorphismRestriction, PolyKinds, RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-}+{-# LANGUAGE TupleSections, UndecidableInstances, ViewPatterns #-}+{-# OPTIONS_GHC -funbox-strict-fields -Wno-type-defaults -Wno-redundant-constraints #-}+module Algebra.LinkedMatrix (Matrix, toLists, fromLists, fromList,+ swapRows, identity,nonZeroRows,nonZeroCols,+ swapCols, switchCols, switchRows, addRow,+ addCol, ncols, nrows, getRow, getCol, triangulateModular,+ scaleRow, combineRows, combineCols, transpose,+ inBound, height, width, cmap, empty, rowVector,+ colVector, rowCount, colCount, traverseRow,+ traverseCol, Entry, idx, value, substMatrix,+ catRow, catCol, (<||>), (<-->), toRows, toCols,+ zeroMat, getDiag, trace, diagProd, diag,+ scaleCol, clearRow, clearCol, index, (!),+ nonZeroEntries, rankLM, splitIndependentDirs,+ structuredGauss, multWithVector, solveWiedemann,+ henselLift, solveHensel, structuredGauss') where+import Algebra.Algorithms.ChineseRemainder+import Algebra.Field.Finite+import Algebra.Instances ()+import Algebra.Prelude.Core hiding (Vector, empty, fromList,+ generate, insert, transpose, (%),+ (<.>), (<>))++import Control.Applicative ((<|>))+import Control.Arrow ((&&&))+import Control.Arrow ((>>>))+import Control.Lens hiding (index, (<.>))+import Control.Monad (replicateM)+import Control.Monad.Loops (iterateUntil)+import Control.Monad.Random hiding (fromList)+import Control.Monad.ST.Strict (ST, runST)+import Control.Monad.State.Strict (evalState, runState)+import Control.Parallel.Strategies (parMap)+import Control.Parallel.Strategies (rdeepseq)+import Data.IntMap.Strict (IntMap, alter, insert,+ mapMaybeWithKey, minViewWithKey)+import qualified Data.IntMap.Strict as IM+import Data.IntSet (IntSet)+import qualified Data.IntSet as IS+import Data.List (minimumBy, sort)+import Data.List (sortBy)+import Data.Maybe (fromJust, fromMaybe, mapMaybe)+import Data.Monoid (First (..))+import Data.Numbers.Primes (primes)+import Data.Ord (comparing)+import Data.Proxy (Proxy (..))+import Data.Reflection (Reifies (..), reify)+import Data.Semigroup hiding (First (..))+import Data.Tuple (swap)+import Data.Vector (Vector, create, generate, thaw,+ unsafeFreeze)+import qualified Data.Vector as V+import Data.Vector.Mutable (grow)+import qualified Data.Vector.Mutable as MV+import Numeric.Decidable.Zero (isZero)+import Numeric.Domain.GCD (gcd, lcm)+import Numeric.Field.Fraction ((%))+import Numeric.Semiring.ZeroProduct (ZeroProductSemiring)+import qualified Prelude as P++data Entry a = Entry { _value :: !a+ , _idx :: !(Int, Int)+ , _rowNext :: !(Maybe Int)+ , _colNext :: !(Maybe Int)+ } deriving (Read, Show, Eq, Ord)++makeLenses ''Entry++newEntry :: a -> Entry a+newEntry v = Entry v (-1,-1) Nothing Nothing++data Matrix a = Matrix { _coefficients :: !(Vector (Entry a))+ , _rowStart :: !(IntMap Int)+ , _colStart :: !(IntMap Int)+ , _height :: !Int+ , _width :: !Int+ } deriving (Read, Show)++makeLenses ''Matrix++data BuildState = BuildState { _colMap :: !(IntMap Int)+ , _rowMap :: !(IntMap Int)+ , _curIdx :: !Int+ }+makeLenses ''BuildState++data GaussianState a = GaussianState { _input :: !(Matrix a)+ , _output :: !(Matrix a)+ , _prevCol :: !Int+ , _heavyCols :: !IntSet+ , _curRow :: !Int+ , _detAcc :: !a+ }+makeLenses ''GaussianState++instance Eq a => Eq (Matrix a) where+ n == m =+ n^.height == m^.height && n^.width == m^.width && content n == content m+ where+ content = sortBy (comparing fst) . V.toList . nonZeroEntries++data MaxEntry a b = MaxEntry { _weight :: !a+ , entry :: b+ } deriving (Read, Show, Eq, Ord)++empty :: Matrix a+empty = Matrix V.empty IM.empty IM.empty 0 0++fromLists :: DecidableZero a => [[a]] -> Matrix a+fromLists xss =+ fromList (concat $ zipWith (\i -> zipWith (\j -> ((i,j),)) [0..]) [0..] xss)+ & width .~ maximum (0 : map length xss)+ & height .~ length xss++fromCols :: DecidableZero a => [Vector a] -> Matrix a+fromCols xss =+ let h = maximum $ map V.length xss+ w = length xss+ in fromList (concat $ zipWith (\i -> V.toList . V.imap (\j -> ((j,i),))) [0..] xss)+ & width .~ w+ & height .~ h++fromList :: DecidableZero a => [((Int, Int), a)] -> Matrix a+fromList cs =+ let (as, bs) = runState (mapM initialize $ filter (view $ _2 . to (not.isZero)) cs)+ (BuildState IM.empty IM.empty (-1))+ vec = V.fromList as+ h = maximum (0:map (view $ _1._1) cs) + 1+ w = maximum (0:map (view $ _1._2) cs) + 1+ in Matrix vec (bs^.rowMap) (bs^.colMap) h w+ where+ initialize ((i, j), c) = do+ curIdx += 1+ n <- use curIdx+ nc <- use $ colMap.at j+ nr <- use $ rowMap.at i+ colMap %= insert j n+ rowMap %= insert i n+ return $ Entry { _value = c+ , _idx = (i, j)+ , _rowNext = nr+ , _colNext = nc+ }+++getDiag :: Monoidal a => Matrix a -> Vector a+getDiag mat = V.generate (min (mat^.height) (mat^.width)) $ \i ->+ fromMaybe zero $ traverseDir Nothing (\a _ e -> a <|> if i == e^.nthL Row+ then Just (e^.value )+ else Nothing) Row i mat++diagProd :: (Unital c, Monoidal c) => Matrix c -> c+diagProd = V.foldr' (*) one . getDiag++trace :: Monoidal c => Matrix c -> c+trace = V.foldr' (+) zero . getDiag++toLists :: forall a. Monoidal a => Matrix a -> [[a]]+toLists mat =+ let orig = replicate (_height mat) $ replicate (_width mat) (zero :: a)+ in go (V.toList $ _coefficients mat) orig+ where+ go [] m = m+ go (Entry{_value = v, _idx = (i,j) }:es) m =+ go es (m&ix i.ix j .~ v)++swapRows :: Int -> Int -> Matrix a -> Matrix a+swapRows = swapper Row++swapCols :: Int -> Int -> Matrix a -> Matrix a+swapCols = swapper Column++swapper :: Direction -> Int -> Int -> Matrix a -> Matrix a+swapper dir i j mat =+ let ith = mat^.startL dir.at i+ jth = mat^.startL dir.at j+ in mat & startL dir %~ alter (const jth) i . alter (const ith) j+ & coefficients %~ go ith . go jth+ where+ go Nothing v = v+ go (Just k) vec =+ let !cur = vec V.! k+ in go (cur ^. nextL dir) (vec & ix k . coordL dir %~ change)+ change k | k == i = j+ | k == j = i+ | otherwise = k++scaleDir :: (DecidableZero a, Multiplicative a) => Direction -> a -> Int -> Matrix a -> Matrix a+scaleDir dir a i mat+ | otherwise = mapDir (*a) dir i mat+ | isZero a = clearDir dir i mat++clearAt :: Int -> Matrix a -> Matrix a+clearAt k mat = mat & coefficients %~ go+ & forwardStart Column+ & forwardStart Row+ where+ !old = ((mat ^. coefficients) V.! k)+ & colNext._Just %~ shifter+ & rowNext._Just %~ shifter+ forwardStart dir =+ let l = (old ^. coordL dir)+ in startL dir %~ mapMaybeWithKey+ (\d v -> if d == l && v == k+ then old ^. nextL dir+ else Just $ shifter v)+ shiftDir sel = nextL sel %~ \case+ Nothing -> Nothing+ Just l ->+ if l == k+ then old ^. nextL sel+ else Just $ shifter l+ shifter n = if n < k then n else n - 1+ go vs = generate (V.length vs - 1) $ \n ->+ vs V.! (if n < k then n else n + 1) & shiftDir Column & shiftDir Row++clearDir :: Direction -> Int -> Matrix a -> Matrix a+clearDir dir i mat = foldl (flip clearAt) mat $ sort $ mapMaybe (fmap fst) $ V.toList $ igetDir dir i mat++clearRow :: Int -> Matrix a -> Matrix a+clearRow = clearDir Row++clearCol :: Int -> Matrix a -> Matrix a+clearCol = clearDir Column++scaleRow :: (DecidableZero a, Multiplicative a) => a -> Int -> Matrix a -> Matrix a+scaleRow = scaleDir Row++scaleCol :: (DecidableZero a, Multiplicative a) => a -> Int -> Matrix a -> Matrix a+scaleCol = scaleDir Column++mapDir :: (a -> a) -> Direction+ -> Int -> Matrix a -> Matrix a+mapDir f dir i mat = traverseDir mat trv dir i mat+ where+ trv m k _ = m & coefficients . ix k . value %~ f++traverseDir :: b -> (b -> Int -> Entry a -> b)+ -> Direction+ -> Int -> Matrix a -> b+traverseDir ini f dir i mat =+ runIdentity $ traverseDirM ini (\b j e -> return $ f b j e) dir i mat++traverseDirM :: Monad m => b -> (b -> Int -> Entry a -> m b)+ -> Direction+ -> Int -> Matrix a -> m b+traverseDirM ini f dir i mat = go (IM.lookup i (mat^.startL dir)) ini+ where+ vec = mat ^. coefficients+ go Nothing b = return b+ go (Just k) b = do+ let !cur = vec V.! k+ go (cur ^. nextL dir) =<< f b k cur++getDir :: forall a. Monoidal a+ => Direction -> Int -> Matrix a -> Vector a+getDir dir i mat =+ create $ do+ v <- MV.replicate (mat ^. lenL dir) (zero :: a)+ traverseDirM () (trav v) dir i mat+ return v+ where+ trav :: forall s. MV.MVector s a -> () -> Int -> Entry a -> ST s ()+ trav v _ _ ent = MV.write v (ent ^. nthL dir) (ent ^. value)++igetDir :: forall a. Direction -> Int -> Matrix a -> Vector (Maybe (Int, Entry a))+igetDir dir i mat =+ create $ do+ v <- MV.replicate (mat ^. lenL dir) Nothing+ traverseDirM () (trav v) dir i mat+ return v+ where+ trav :: forall s. MV.MVector s (Maybe (Int, Entry a)) -> () -> Int -> Entry a -> ST s ()+ trav v _ k ent = MV.write v (ent ^. nthL dir) (Just (k, ent))++getRow :: Monoidal a => Int -> Matrix a -> Vector a+getRow = getDir Row++getCol :: Monoidal a => Int -> Matrix a -> Vector a+getCol = getDir Column++data Direction = Row | Column deriving (Read, Show, Eq, Ord)++lenL, countL :: Direction -> Lens' (Matrix a) Int+lenL Row = width+lenL Column = height+countL Row = height+countL Column = width++nthL, coordL :: Direction -> Lens' (Entry a) Int+coordL Row = idx . _1+coordL Column = idx . _2++nthL Row = idx . _2+nthL Column = idx . _1++startL :: Direction -> Lens' (Matrix a) (IntMap Int)+startL Row = rowStart+startL Column = colStart++nextL :: Direction -> Lens' (Entry a) (Maybe Int)+nextL Row = rowNext+nextL Column = colNext++addDir :: forall a. (DecidableZero a)+ => Direction -> Vector a -> Int -> Matrix a -> Matrix a+addDir dir vec i mat = runST $ do+ mv <- thaw $ mat ^. coefficients+ let n = MV.length mv+ upd (dic, del) k e = do+ let v' = e ^. value + IM.findWithDefault zero (e ^. nthL dir) mp+ d' <- if isZero v'+ then return $ k : del+ else MV.write mv k (e & value .~ v') >> return del+ return (IM.delete (e ^. nthL dir) dic, d')+ (rest, dels) <- traverseDirM (mp, []) upd dir i mat+ mv' <- if IM.null rest+ then return mv+ else grow mv (IM.size rest)+ let app j (p, k, opo) v = do+ let preOpo = mat ^. startL (perp dir) . at j+ MV.write mv' k $ newEntry v+ & nextL dir .~ p+ & nextL (perp dir) .~ preOpo+ & coordL dir .~ i+ & nthL dir .~ j++ return (Just k, k+1, alter (const $ Just k) j opo)+ (l, _, opoStart) <- ifoldlM app (mat ^. startL dir . at i, n, mat ^. startL (perp dir)) rest+ v' <- unsafeFreeze mv'+ let mat' = mat & coefficients .~ v'+ & startL dir %~ alter (const l) i+ & startL (perp dir) .~ opoStart+ return $ foldr clearAt mat' dels+ where+ mp :: IntMap a+ mp = V.ifoldr (\k v d -> if isZero v then d else IM.insert k v d) IM.empty vec++perp :: Direction -> Direction+perp Row = Column+perp Column = Row++addRow :: (DecidableZero a) => Vector a -> Int -> Matrix a -> Matrix a+addRow = addDir Row++addCol :: (DecidableZero a) => Vector a -> Int -> Matrix a -> Matrix a+addCol = addDir Column++inBound :: (Int, Int) -> Matrix a -> Bool+inBound (i, j) mat = 0 <= i && i < mat ^. height && 0 <= j && j < mat ^. width++index :: Monoidal a => IM.Key -> Int -> Matrix a -> Maybe a+index i j mat+ | not $ inBound (i, j) mat = Nothing+ | otherwise = Just $ go (IM.lookup i $ mat ^. rowStart)+ where+ go Nothing = zero+ go (Just k) =+ let e = (mat ^. coefficients) V.! k+ in if e^.idx._2 == j+ then e ^. value+ else go (e^.rowNext)++(!) :: Monoidal a => Matrix a -> (Int, Int) -> a+(!) a (i, j) = fromJust $ index i j a++combineDir :: (DecidableZero a, Multiplicative a) => Direction -> a -> Int -> Int -> Matrix a -> Matrix a+combineDir dir alpha i j mat = addDir dir (V.map (alpha *) $ getDir dir i mat) j mat++combineRows :: (DecidableZero a, Multiplicative a) => a -> Int -> Int -> Matrix a -> Matrix a+combineRows = combineDir Row++combineCols :: (DecidableZero a, Multiplicative a) => a -> Int -> Int -> Matrix a -> Matrix a+combineCols = combineDir Column++nrows, ncols :: Matrix a -> Int+ncols = view width+nrows = view height++identity :: Unital a => Int -> Matrix a+identity n =+ let idMap = IM.fromList [(i,i) | i <- [0..n-1]]+ in Matrix (V.fromList [newEntry one & idx .~ (i,i) | i <- [0..n-1]])+ idMap idMap n n++diag :: DecidableZero a => Vector a -> Matrix a+diag v =+ let n = V.length v+ idMap = IM.fromList [(i,i) | i <- [0..n-1]]+ in clearZero $ Matrix (V.imap (\i a -> newEntry a & idx .~ (i,i)) v)+ idMap idMap n n++catDir :: DecidableZero b => Direction -> Matrix b -> Vector b -> Matrix b+catDir dir mat vec = runST $ do+ let seed = V.filter (not . isZero . snd) $ V.take (mat ^. lenL dir) $ V.indexed vec+ n = V.length $ mat ^. coefficients+ curD = mat ^. countL dir+ getNextIdx l | l == 0 = Nothing+ | otherwise = Just (n+l-1)+ mv <- flip grow (V.length seed) =<< thaw (mat^.coefficients)+ let upd (k, v) (l, opdic) = do+ MV.write mv (n+l) $ newEntry v+ & nthL dir .~ k+ & coordL dir .~ curD+ & nextL dir .~ getNextIdx l+ & nextL (perp dir) .~ IM.lookup k opdic+ return (l+1, alter (const $ Just $ n+l) k opdic)+ (l, op') <- foldlMOf folded (flip upd) (0, mat ^. startL (perp dir)) seed+ v <- unsafeFreeze mv+ return $ mat & countL dir +~ 1+ & startL dir %~ alter (const $ getNextIdx l) curD+ & startL (perp dir) .~ op'+ & coefficients .~ v++dirVector :: DecidableZero a => Direction -> Vector a -> Matrix a+dirVector Row = rowVector+dirVector Column = colVector++rowVector :: DecidableZero a => Vector a -> Matrix a+rowVector = fromLists. (:[]) . V.toList++colVector :: DecidableZero a => Vector a -> Matrix a+colVector = fromLists . map (:[]) . V.toList++toDirs :: Monoidal a => Direction -> Matrix a -> [Vector a]+toDirs dir mat = [ getDir dir i mat | i <- [0..mat^.countL dir-1]]++toRows :: Monoidal a => Matrix a -> [Vector a]+toRows = toDirs Row++toCols :: Monoidal a => Matrix a -> [Vector a]+toCols = toDirs Column++appendDir :: DecidableZero b => Direction -> Matrix b -> Matrix b -> Matrix b+appendDir dir m = foldl (catDir dir) m . toDirs dir++(<-->) :: DecidableZero b => Matrix b -> Matrix b -> Matrix b+(<-->) = appendDir Row++(<||>) :: DecidableZero b => Matrix b -> Matrix b -> Matrix b+(<||>) = appendDir Column++catRow :: DecidableZero b => Matrix b -> Vector b -> Matrix b+catRow = catDir Row++catCol :: DecidableZero b => Matrix b -> Vector b -> Matrix b+catCol = catDir Column++switchRows :: Int -> Int -> Matrix a -> Matrix a+switchRows = swapRows++switchCols :: Int -> Int -> Matrix a -> Matrix a+switchCols = swapCols++cmap :: DecidableZero a => (a1 -> a) -> Matrix a1 -> Matrix a+cmap f = clearZero . (coefficients . mapped . value %~ f)++clearZero :: DecidableZero a => Matrix a -> Matrix a+clearZero mat = V.ifoldr (\i v m -> if isZero (v^.value) then clearAt i m else m)+ mat (mat ^. coefficients)++transpose :: Matrix a -> Matrix a+transpose mat = mat & rowStart .~ mat^.colStart+ & colStart .~ mat^.rowStart+ & height .~ mat^.width+ & width .~ mat^.height+ & coefficients . each %~ swapEntry+ where+ swapEntry ent = ent & idx %~ swap+ & rowNext .~ ent ^. colNext+ & colNext .~ ent ^. rowNext++zeroMat :: Int -> Int -> Matrix a+zeroMat = Matrix V.empty IM.empty IM.empty++dirCount :: Direction -> Int -> Matrix a -> Int+dirCount = traverseDir 0 (\a _ _ -> succ a)++rowCount :: Int -> Matrix a -> Int+rowCount = dirCount Row++colCount :: Int -> Matrix a -> Int+colCount = dirCount Column++instance (Ord a, Semigroup b) => Semigroup (MaxEntry a b) where+ MaxEntry a as <> MaxEntry b bs =+ case compare a b of+ EQ -> MaxEntry a (as <> bs)+ LT -> MaxEntry b bs+ GT -> MaxEntry a as++instance (Ord a, Bounded a, Monoid b) => Monoid (MaxEntry a b) where+ mappend (MaxEntry a as) (MaxEntry b bs) =+ case compare a b of+ EQ -> MaxEntry a (as `mappend` bs)+ LT -> MaxEntry b bs+ GT -> MaxEntry a as+ mempty = MaxEntry minBound mempty+++newGaussianState :: Unital a => Matrix a -> GaussianState a+newGaussianState inp =+ GaussianState inp (identity $ inp ^. height) (-1) (getHeaviest IS.empty inp) 0 one++getHeaviest :: IntSet -> Matrix a -> IntSet+getHeaviest old inp =+ if IS.size old >= inp^.width*5`P.div`100+ then old+ else let news = entry $ mconcat $ map (\k -> MaxEntry (colCount k inp) (IS.singleton k)) $+ IS.toList $ IM.keysSet (inp^.colStart) IS.\\ old+ in news `IS.union` old++traverseRow :: b -> (b -> Int -> Entry a -> b) -> Int -> Matrix a -> b+traverseRow a f = traverseDir a f Row++traverseCol :: b -> (b -> Int -> Entry a -> b) -> Int -> Matrix a -> b+traverseCol a f = traverseDir a f Column++structuredGauss :: (DecidableZero a, Division a, Group a)+ => Matrix a -> (Matrix a, Matrix a)+structuredGauss = structuredGauss' >>> view _1 &&& view _2++structuredGauss' :: (DecidableZero a, Division a, Group a)+ => Matrix a -> (Matrix a, Matrix a, a)+structuredGauss' = evalState go . newGaussianState+ where+ countLight heavys = traverseRow (0 :: Int)+ (\(!c) _ ent -> if (ent^.coordL Column) `IS.member` heavys+ then c+ else c+1)+ go = do+ old <- use input+ destRow <- use curRow+ pcol <- use prevCol+ (_, rest) <- uses (input.colStart) (IM.split pcol)+ case minViewWithKey rest of+ _ | destRow >= old ^. height -> (,,) <$> use input <*> use output <*> use detAcc+ Nothing -> (,,) <$> use input <*> use output <*> use detAcc+ Just ((pivCol, _), _) -> do+ heavys <- use heavyCols+ prevCol .= pivCol+ let trav b _ ent = do+ if (ent ^. coordL Row) < destRow+ then do+ return b+ else do+ let lc = countLight heavys (ent ^. coordL Row) old+ return $ case b of+ Nothing -> Just (ent, lc)+ Just (p, l0)+ | l0 <= lc -> Just (p, l0)+ | otherwise -> Just (ent, lc)+ mans <- traverseDirM Nothing trav Column pivCol old+ case mans of+ Nothing -> nextElim+ Just (pivot, _) -> do+ let pivRow = pivot ^. coordL Row+ pivCoe = pivot ^. value+ sgn = if pivRow == destRow then one else negate one+ p0 <- use output+ let elim (m, p) _ ent = do+ if ent^.coordL Row /= pivRow+ then do+ let coe = negate (ent ^. value) / pivCoe+ return $ (m, p) & both %~ combineRows coe pivRow (ent ^. coordL Row)+ else do+ return (m, p)+ (input', output') <- traverseDirM (old, p0) elim Column pivCol old+ <&> both %~ scaleRow (recip pivCoe) destRow . switchRows destRow pivRow+ input .= input'+ output .= output'+ curRow += 1+ detAcc %= (*(pivCoe*sgn))+ nextElim+ nextElim = do+ oldHeavys <- use heavyCols+ newHeavyCols <- uses input (getHeaviest oldHeavys)+ heavyCols %= IS.union newHeavyCols+ go++nonZeroEntries :: Matrix a -> Vector ((Int, Int), a)+nonZeroEntries mat = V.map (view idx &&& view value) $ mat ^. coefficients++matListView :: (Show a, Monoidal a) => Matrix a -> String+matListView = unlines . map (('\t':).show) . toLists++prettyMat :: Show a => Matrix a -> String+prettyMat mat =+ unlines [ "row start: " <> starter Row+ , "col start: " <> starter Column+ , "[" <> (intercalate ", " $ V.toList $ V.imap (\i e -> "(#" <> show i <> ") " <> prettyEntry e) $ mat^.coefficients) <> "]"+ ]+ where+ starter dir = intercalate ", " (map (\(a,b) -> show a ++ " -> " ++ show b) (mat^.startL dir.to IM.toList))++prettyEntry :: Show a => Entry a -> String+prettyEntry ent =+ concat [ show $ ent^.value, " "+ , show $ ent^.idx+ , "->("+ ,showMaybe (ent^.nextL Row)+ , ", "+ ,showMaybe (ent^.nextL Column)+ , ")"+ ]+ where+ showMaybe = maybe "_" show++multWithVector :: (Multiplicative a, Monoidal a)+ => Matrix a -> Vector a -> Vector a+multWithVector mat v =+ V.generate (mat^.height) $ \i ->+ traverseRow zero (\acc _ ent -> acc + (ent^.value)*(v V.! (ent^.nthL Row))) i mat++nonZeroDirs :: Direction -> Matrix r -> [Int]+nonZeroDirs dir = view $ startL dir . to IM.keys++nonZeroRows :: Matrix r -> [Int]+nonZeroRows = nonZeroDirs Row++nonZeroCols :: Matrix r -> [Int]+nonZeroCols = nonZeroDirs Column++testCase :: Matrix (Fraction Integer)+testCase = fromLists [[0,0,0,0,0,0,2,-3,-1,0]+ ,[0,0,0,2,-3,-1,0,0,0,0]+ ,[0,2,-3,0,-1,0,0,0,0,0]+ ,[1,0,1,0,0,1,-2,0,0,0]+ ,[2,-3,0,-1,0,0,0,0,0,0]+ ,[1,0,1,0,0,1,0,0,0,-1]+ ,[1,0,1,0,0,1,-2,0,0,0]]++newtype Square n r = Square { runSquare :: Matrix r+ } deriving (Show, Eq, Additive, Multiplicative)++deriving instance (DecidableZero r, Semiring r, Multiplicative r)+ => LeftModule (Scalar r) (Square n r)+deriving instance (DecidableZero r, Semiring r, Multiplicative r)+ => RightModule (Scalar r) (Square n r)++instance (Unital r, Multiplicative r, Reifies n Integer, DecidableZero r) => Unital (Square n r) where+ one = Square $ identity $ fromInteger $ reflect (Proxy :: Proxy n)++instance (DecidableZero r, Multiplicative r) => Multiplicative (Matrix r) where+ m * n = fromList [ ((i,j),sum $ V.zipWith (*) (getRow i m) (getCol j n))+ | i <- nonZeroRows m+ , j <- nonZeroCols n+ ] & width .~ n^.width+ & height .~ m^.height+++instance (DecidableZero r, RightModule Natural r) => RightModule Natural (Matrix r) where+ m *. n = cmap (*. n) m++instance (DecidableZero r, LeftModule Natural r) => LeftModule Natural (Matrix r) where+ n .* m = cmap (n .*) m++instance (DecidableZero r, RightModule Integer r) => RightModule Integer (Matrix r) where+ m *. n = cmap (*. n) m++instance (DecidableZero r, LeftModule Integer r) => LeftModule Integer (Matrix r) where+ n .* m = cmap (n .*) m++instance (DecidableZero r)+ => Monoidal (Matrix r) where+ zero = zeroMat 0 0++instance (DecidableZero r) => Additive (Matrix r) where+ m + n =+ let dir = minimumBy (comparing $ length . flip nonZeroDirs n)+ [Row, Column]+ in foldr (\i l -> addDir dir (getDir dir i n) i l) m (nonZeroDirs dir n)++instance (DecidableZero r, Semiring r, Multiplicative r)+ => LeftModule (Scalar r) (Matrix r) where+ Scalar r .* mat = cmap (r*) mat++instance (DecidableZero r, Semiring r, Multiplicative r)+ => RightModule (Scalar r) (Matrix r) where+ mat *. Scalar r = cmap (*r) mat++instance (DecidableZero r, Group r) => Group (Matrix r) where+ negate = cmap negate++instance (DecidableZero r, Abelian r) => Abelian (Matrix r)++instance (DecidableZero r, Semiring r) => Semiring (Matrix r)++substMatrix :: (CoeffRing r)+ => Matrix r -> Polynomial r 1 -> Matrix r+substMatrix m f =+ let n = ncols m+ in if n == nrows m+ then reify (P.toInteger n) $ \pxy -> runSquare $ substUnivariate (toSquare pxy m) f+ else error "Matrix must be square"++toSquare :: proxy n -> Matrix r -> Square n r+toSquare _ = Square++(<.>) :: (Multiplicative m, Monoidal m) => Vector m -> Vector m -> m+v <.> u = sum $ V.zipWith (*) v u++krylovMinpol :: (Eq a, Ring a, DecidableZero a, DecidableUnits a,+ Field a, ZeroProductSemiring a,+ Random a, MonadRandom m)+ => Matrix a -> Vector a -> m (Polynomial a 1)+krylovMinpol m b+ | V.all isZero b = return one+ | otherwise = reify (P.toInteger n) $ \pxy -> do+ iterateUntil (\h -> V.all isZero $ multWithVector (substMatrix m h) b) $ do+ u <- replicateM n getRandom+ return $ minpolRecurrent (fromIntegral n)+ [ V.fromList u <.> multWithVector (runSquare $ toSquare pxy m ^ fromIntegral i) b+ | i <- [0..2*n-1]]+ where+ n = ncols m++-- | Solving linear equation using linearly recurrent sequence (Wiedemann algorithm).+solveWiedemann :: (Eq a, Field a, DecidableZero a, DecidableUnits a,+ ZeroProductSemiring a, Random a, MonadRandom m)+ => Matrix a -> Vector a -> m (Either (Vector a) (Vector a))+solveWiedemann a b = do+ m <- krylovMinpol a b+ return $+ let m0 = injectCoeff (coeff one m)+ g = (m - m0) `quot` varX+ in if isZero (coeff one m)+ then Left $ substMatrix a g `multWithVector` b+ else let h = negate g `quot` m0+ in Right $ substMatrix a h `multWithVector` b++rankLM :: (DecidableZero r, Division r, Group r) => Matrix r -> Int+rankLM mat =+ let m' = fst $ structuredGauss mat+ in min (length $ nonZeroRows m') (length $ nonZeroCols m')++splitIndependentDirs :: (DecidableZero a, Field a)+ => Direction -> Matrix a+ -> (Matrix a, [Int], [Int])+ -- ^ @(m', bs, as)@ with @m@ is full-rank submatrix,+ -- @bs@ are independent and @as@ are dependent.+splitIndependentDirs dir mat =+ case nonZeroDirs dir mat of+ [] -> (zero, [], [])+ [a] -> (dirVector dir $ getDir dir a mat, [a], [])+ (x:xs) -> go 1 xs (dirVector dir $ getDir dir x mat) [x] []+ where+ n = min (nrows mat) (ncols mat)+ go _ [] nat ok bad = (nat, ok, bad)+ go i (k:ks) nat ok bad+ | i >= n = (nat, ok, bad)+ | otherwise =+ let nat' = catDir dir nat $ getDir dir k mat+ in if ({-# SCC "rankLM" #-} rankLM nat') == i+ then go i ks nat ok (k:bad)+ else go (i+1) ks nat' (k:ok) bad++intDet :: Matrix Integer -> Integer+intDet mat =+ let b = V.maximum $ V.map (P.fromInteger . abs . snd) $ nonZeroEntries mat+ n = fromIntegral $ ncols mat+ c = n^(n `P.div` 2) * b^n+ r = ceilingLogBase2 (2*fromIntegral c + 1)+ ps = take r primes+ m = product ps+ d = chineseRemainder [ (p,+ reifyPrimeField p $ \pxy ->+ shiftHalf p $ naturalRepr $ view _3 $+ structuredGauss' (cmap (modNat' pxy) mat))+ | p <- ps]+ off = d `div` m+ in if d == 0+ then 0+ else minimumBy (comparing abs) [d - m * off, d - m * (off + 1)]++shiftHalf :: P.Integral a => a -> a -> a+shiftHalf p n =+ let s = p `P.div` 2+ in (n P.+ s) `P.mod` p P.- s++triangulateModular :: Matrix (Fraction Integer)+ -> (Matrix (Fraction Integer),+ Matrix (Fraction Integer))+triangulateModular mat0 =+ let ps = filter ((/= 0) . (P.mod l)) primes+ in go ps+ where+ ds = V.foldr (lcm' . abs . denominator.snd) 1 $ nonZeroEntries mat0+ mN = V.foldr (lcm' . abs . numerator . snd) 1 $ nonZeroEntries mat0+ l = lcm' ds mN+ go (p:ps) =+ let (indepRows, _, indepCols, depCols) = reifyPrimeField p $ \pxy ->+ let mat = cmap (modRat pxy) mat0+ (koho, IS.fromList -> irs, IS.fromList -> drs) =+ {-# SCC "splitRow" #-} splitIndependentDirs Row mat+ (_, IS.fromList -> ics, IS.fromList -> dcs) =+ {-# SCC "splitCol" #-} splitIndependentDirs Column koho+ in (irs,+ drs `IS.union` (IS.fromList (nonZeroRows mat0) IS.\\ irs),+ ics,+ dcs `IS.union` (IS.fromList (nonZeroCols $ extract irdic colIdentDic) IS.\\ ics))+ colIdentDic = IM.fromList $ zip [0..ncols mat0 - 1] [0..]+ irdic = IM.fromList $ zip (IS.toAscList indepRows) [0..]+ icdic = IM.fromList $ zip (IS.toAscList indepCols) [0..]+ dcdic = IM.fromList $ zip (IS.toDescList depCols) [0..]+ newIdx rd cd (i, j) = (,) <$> IM.lookup i rd <*> IM.lookup j cd+ extract rd cd = fromList (mapMaybe (\(ind, c) -> (,c) <$> newIdx rd cd ind) $+ V.toList $ nonZeroEntries mat0)+ & height .~ IM.size rd+ & width .~ IM.size cd+ spec = extract irdic icdic+ qs = filter (\r -> ds `mod` r /= 0 && ({-# SCC "checkDet" #-} reifyPrimeField r $ \pxy ->+ not $ isZero $ view _3 $+ structuredGauss' $ cmap (modRat pxy) $ spec)) primes+ anss = parMap rdeepseq (\xs -> fromJust $ ala First foldMap $+ map (\q -> solveHensel 10 q spec xs) qs) $+ toCols $ extract irdic dcdic+ permMat = build [] (ncols mat0 - 1)+ (zip (IS.toDescList indepCols) $ reverse $ toCols $ identity $ nrows spec) $+ zip (IS.toDescList depCols) anss+ origDeled = extract irdic colIdentDic & width .~ mat0^.width+ in if (spec * permMat) == origDeled+ then (permMat, spec)+ else go ps+ go _ = error "Cannot happen!"+ build ans i mns vecs+ | i < 0 = fromCols ans+ | otherwise = {-# SCC "building" #-}+ case vecs of+ ((k, v) : vs) | i == k -> build (v : ans) (i-1) mns vs+ _ ->+ case mns of+ ((l,m):mn) | i == l -> build (m : ans) (i-1) mn vecs+ _ -> build (V.empty : ans) (i-1) mns vecs++(.!) :: (a -> b) -> (t -> a) -> t -> b+(f .! g) x = f $! g x++infixr 9 .!++clearDenom :: Euclidean a => Matrix (Fraction a) -> (a, Matrix a)+clearDenom mat =+ let g = V.foldr' (lcm' . denominator . snd) one $ nonZeroEntries mat+ in (g, cmap (numerator . (* (g % one))) mat)++lcm' :: Euclidean r => r -> r -> r+lcm' n m = n * m `quot` gcd n m++henselLift :: Integer -- ^ prime number @p@+ -> Matrix Integer -- ^ original matrix @M@+ -> Matrix Integer -- ^ inverse matrix of @M@ mod @p@+ -> V.Vector Integer -- ^ coefficient vector @v@+ -> [V.Vector Integer] -- ^ vector @x@ with @Mx = b mod p@+henselLift p m q b =+ map (view _2) $ iterate step (1, V.replicate (V.length b) 0, b)+ where+ step (s, acc, r)+ | otherwise =+ let u = reifyPrimeField p $ \pxy ->+ V.map (naturalRepr . modNat' pxy) $ q `multWithVector` r+ r' = V.map (`quot` p) $ V.zipWith (-) r (m `multWithVector` u)+ in (s*p, acc + V.map (s*) u, r')+++solveHensel :: Int -> Integer+ -> Matrix (Fraction Integer)+ -> Vector (Fraction Integer)+ -> Maybe (Vector (Fraction Integer))+solveHensel cyc p mat b = {-# SCC "solveHensel" #-}+ let g0 = V.foldr (lcm . denominator . view _2) one $ nonZeroEntries mat+ g1 = V.foldr (lcm . denominator) one b+ g = lcm g0 g1 % 1+ mat' = cmap (numerator . (*g)) mat+ b' = V.map (numerator . (*g)) b+ q = reifyPrimeField p $ \pxy ->+ cmap naturalRepr $ snd $ structuredGauss $ cmap (modNat' pxy) mat'+ hls = henselLift p mat' q b'+ in go Nothing $ drop cyc $ zip [p^i | i <- [0..]] hls+ where+ go _ [] = Nothing+ go prev ((q,x):xs) =+ let mans = V.mapM (recoverRat (P.floor $ P.sqrt (fromIntegral q P./ 2 :: Double)) q) x+ in case mans of+ Just x' | mat `multWithVector` x' == b -> Just x'+ | mans == prev -> Nothing+ _ -> go mans (drop cyc xs)
+ Algebra/Matrix.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, GADTs #-}+{-# LANGUAGE KindSignatures, MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction, TypeFamilies, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Algebra.Matrix (Matrix(..), delta, companion,+ gaussReduction, maxNorm, rankWith, det,+ inverse, inverseWith) where+import Algebra.Internal+import qualified Algebra.LinkedMatrix as LM+import Algebra.Prelude.Core hiding (maxNorm, zero)++import Control.Lens (both, view, (%~), (&), _3)+import Control.Monad (when)+import qualified Data.Matrix as DM+import qualified Data.Vector as V+import GHC.Exts (Constraint)+import Numeric.Algebra (Additive, DecidableZero)+import Numeric.Algebra (Monoidal, Multiplicative)+import Numeric.Algebra (Unital)+import qualified Numeric.Algebra as NA+import qualified Numeric.Decidable.Zero as NA+import qualified Numeric.LinearAlgebra as LA+import qualified Numeric.LinearAlgebra.Devel as LA+import qualified Prelude as P++class Matrix mat where+ type Elem mat a :: Constraint+ cmap :: (Elem mat a, Elem mat b) => (a -> b) -> mat a -> mat b+ empty :: Elem mat b => mat b+ fromLists :: Elem mat a => [[a]] -> mat a+ fromCols :: Elem mat a => [V.Vector a] -> mat a+ fromCols [] = zero 0 0+ fromCols xs = foldr1 (<||>) $ map colVector xs+ fromRows :: Elem mat a => [V.Vector a] -> mat a+ fromRows [] = zero 0 0+ fromRows xs = foldr1 (<-->) $ map rowVector xs+ toCols :: Elem mat a => mat a -> [V.Vector a]+ toCols m = map (`getCol` m) [1..ncols m]+ toRows :: Elem mat a => mat a -> [V.Vector a]+ toRows m = map (`getRow` m) [1..nrows m]+ ncols :: mat a -> Int+ nrows :: mat a -> Int+ identity :: Elem mat a => Int -> mat a+ diag :: Elem mat a => V.Vector a -> mat a+ getDiag :: Elem mat a => mat a -> V.Vector a+ trace :: Elem mat a => mat a -> a+ diagProd :: Elem mat a => mat a -> a+ zero :: Elem mat a => Int -> Int -> mat a+ colVector :: Elem mat a => V.Vector a -> mat a+ rowVector :: Elem mat a => V.Vector a -> mat a+ getCol :: Elem mat a => Int -> mat a -> V.Vector a+ getRow :: Elem mat a => Int -> mat a -> V.Vector a+ switchRows :: Elem mat a => Int -> Int -> mat a -> mat a+ scaleRow :: Elem mat a => a -> Int -> mat a -> mat a+ combineRows :: Elem mat a => Int -> a -> Int -> mat a -> mat a+ trans :: Elem mat a => mat a -> mat a+ buildMatrix :: Elem mat a => Int -> Int -> ((Int, Int) -> a) -> mat a+ index :: Elem mat a => Int -> Int -> mat a -> Maybe a+ index i j m = if 1 <= i && i <= nrows m && 1 <= j && j <= ncols m+ then Just $ m ! (i, j)+ else Nothing+ (!) :: Elem mat a => mat a -> (Int, Int) -> a+ (<||>) :: Elem mat a => mat a -> mat a -> mat a+ (<-->) :: Elem mat a => mat a -> mat a -> mat a+ nonZeroRows :: (DecidableZero a, Elem mat a) => mat a -> [Int]+ nonZeroRows = map fst . filter (V.any (not . NA.isZero) . snd) . zip [1..] . toRows+ nonZeroCols :: (DecidableZero a, Elem mat a) => mat a -> [Int]+ nonZeroCols = map fst . filter (V.any (not . NA.isZero) . snd) . zip [1..] . toCols++instance Matrix DM.Matrix where+ type Elem DM.Matrix a = P.Num a+ empty = DM.zero 0 0+ cmap = fmap+ fromLists = DM.fromLists+ ncols = DM.ncols+ nrows = DM.nrows+ trans = DM.transpose+ identity = DM.identity+ diag v = DM.matrix (V.length v) (V.length v) $ \(i, j) ->+ if i == j then v V.! (i-1) else 0+ getDiag = DM.getDiag+ trace = DM.trace+ diagProd = DM.diagProd+ zero = DM.zero+ colVector = DM.colVector+ rowVector = DM.rowVector+ getCol = DM.getCol+ getRow = DM.getRow+ switchRows = DM.switchRows+ combineRows = DM.combineRows+ scaleRow = DM.scaleRow+ buildMatrix = DM.matrix+ (!) = (DM.!)+ (<||>) = (DM.<|>)+ (<-->) = (DM.<->)++swapIJ :: Eq a => a -> a -> a -> a+swapIJ i j k = if k == i then j else if k == j then i else k++instance Matrix LA.Matrix where+ type Elem LA.Matrix a = (P.Num a, LA.Numeric a, LA.Element a, LA.Container LA.Vector a)+ empty = LA.fromLists [[]]+ fromLists = LA.fromLists+ cmap = LA.cmap+ ncols = LA.cols+ nrows = LA.rows+ trans = LA.tr+ identity = LA.ident+ fromCols = LA.fromColumns . map (LA.fromList . V.toList)+ diag = LA.diag . LA.fromList . V.toList+ getDiag = V.fromList . LA.toList . LA.takeDiag+ trace = LA.sumElements . LA.takeDiag+ diagProd = LA.prodElements . LA.takeDiag+ zero i j = LA.konst 0 (i, j)+ colVector = LA.asColumn . LA.fromList . V.toList+ rowVector = LA.asRow . LA.fromList . V.toList+ toCols = map (V.fromList . LA.toList) . LA.toColumns+ toRows = map (V.fromList . LA.toList) . LA.toRows+ getCol i = V.fromList . LA.toList . (!! (i - 1)) . LA.toColumns+ getRow i = V.fromList . LA.toList . (!! (i - 1)) . LA.toRows+ switchRows i j m = m LA.? map (swapIJ (i-1) (j-1)) [0.. nrows m - 1]+ combineRows j s i m = LA.mapMatrixWithIndex (\(k,l) v -> if k == j - 1 then s P.* (m ! (i,l+1)) P.+ v else v) m+ buildMatrix w h f = LA.build (w, h) (\i j -> f (toIntLA i+1, toIntLA j+1))+ scaleRow a i = (fst .) $ LA.mutable $ \(k, l) m -> do+ v <- LA.readMatrix m k l+ when (k == i - 1) $+ LA.writeMatrix m k l (a P.* v)+ m ! (i, j) = m `LA.atIndex` (i - 1, j - 1)+ m <||> n = LA.fromColumns $ LA.toColumns m ++ LA.toColumns n+ m <--> n = LA.fromRows $ LA.toRows m ++ LA.toRows n++toIntLA :: LA.Container LA.Matrix e => e -> Int+toIntLA e = fromIntegral $ LA.toZ ((1 LA.>< 1) [e]) `LA.atIndex` (0, 0)++instance Matrix LM.Matrix where+ type Elem LM.Matrix a = (CoeffRing a, Unital a, Monoidal a, Multiplicative a, Additive a)+ cmap = LM.cmap+ (!) m pos = m LM.! (pos & both %~ pred)+ index i j = LM.index (i-1) (j-1)+ empty = LM.empty+ buildMatrix h w f = LM.fromList [((i, j), f (i,j)) | j <- [1..w], i <- [1..h]]+ trans = LM.transpose+ combineRows j s i = LM.combineRows s (i-1) (j-1)+ switchRows i j = LM.switchRows (i-1) (j-1)+ scaleRow a i = LM.scaleRow a (pred i)+ zero = LM.zeroMat+ identity = LM.identity+ diag = LM.diag+ getDiag = LM.getDiag+ diagProd = LM.diagProd+ trace = LM.trace+ getRow = LM.getRow . pred+ getCol = LM.getCol . pred+ nrows = LM.nrows+ ncols = LM.ncols+ fromLists = LM.fromLists+ (<||>) = (LM.<||>)+ (<-->) = (LM.<-->)+ rowVector = LM.rowVector+ colVector = LM.colVector+ nonZeroRows = LM.nonZeroRows+ nonZeroCols = LM.nonZeroCols++delta :: (NA.Monoidal r, NA.Unital r) => Int -> Int -> r+delta i j | i == j = NA.one+ | otherwise = NA.zero++companion :: (KnownNat n, CoeffRing r, Matrix mat,+ Elem mat r, IsMonomialOrder n ord)+ => Ordinal n -> OrderedPolynomial r ord n -> mat r+companion odn poly =+ let deg = fromIntegral $ totalDegree' poly+ vx = leadingMonomial (var odn `asTypeOf` poly)+ in buildMatrix deg deg $ \(j, k) ->+ if 1 <= k && k <= deg - 1+ then delta j (k+1)+ else NA.negate $ coeff (NA.pow vx (fromIntegral $ j-1 :: NA.Natural)) poly++-- instance SM.Arrayed (Fraction Integer) where+-- type Arr (Fraction Integer) = V.Vector++-- instance SM.Eq0 (Fraction Integer)++-- | @gaussReduction a = (a', p)@ where @a'@ is row echelon form and @p@ is pivoting matrix.+gaussReduction :: (Matrix mat, Elem mat a, Normed a, Eq a, NA.Field a)+ => mat a -> (mat a, mat a)+gaussReduction mat =+ let (a, b, _) = gaussReduction' mat in (a, b)++-- | @gaussReduction a = (a', p)@ where @a'@ is row echelon form and @p@ is pivoting matrix.+gaussReduction' :: (Matrix mat, Elem mat a, Normed a, Eq a, NA.Field a)+ => mat a -> (mat a, mat a, a)+gaussReduction' mat = {-# SCC "gaussRed" #-} go 1 1 mat (identity $ nrows mat) NA.one+ where+ go i j a p acc+ | i > nrows mat || j > ncols mat = (a, p, acc)+ | otherwise =+ let (k, new) = maximumBy (comparing $ norm . snd) [(l, a ! (l, j)) | l <- [i..nrows mat]]+ in if new == NA.zero+ then go i (j + 1) a p NA.zero+ else let prc l a0 p0+ | l == i = prc (l+1) a0 p0+ | l > nrows mat = (a0, p0)+ | otherwise =+ let coe = NA.negate (a0 ! (l, j))+ a'' = combineRows l coe i a0+ p'' = combineRows l coe i p0+ in prc (l+1) a'' p''+ (a', p') = prc 1 (scaleRow (NA.recip new) i $ switchRows i k a)+ (scaleRow (NA.recip new) i $ switchRows i k p)+ offset = if i == k then id else NA.negate+ in go (i+1) (j+1) a' p' (offset $ acc NA.* new)++det :: (Elem mat a, Eq a, NA.Field a, Normed a, Matrix mat)+ => mat a -> a+det = view _3 . gaussReduction'++maxNorm :: (Elem mat a, Normed a, Matrix mat) => mat a -> Norm a+maxNorm = maximum . concat . map (map norm . V.toList) . toRows++rankWith :: (Elem mat r, CoeffRing r, Matrix mat)+ => (mat r -> mat r) -> mat r -> Int+rankWith gauss = length . nonZeroRows . gauss++inverse :: (Elem mat a, Eq a, NA.Field a, Normed a, Matrix mat)+ => mat a -> mat a+inverse = snd . gaussReduction++inverseWith :: (mat a -> (mat a, mat a)) -> mat a -> mat a+inverseWith = (snd .)
+ Algebra/Normed.hs view
@@ -0,0 +1,29 @@+module Algebra.Normed where+import AlgebraicPrelude++-- | Additional types for /normed/ types.+class (Ord (Norm a)) => Normed a where+ type Norm a+ norm :: a -> Norm a+ liftNorm :: Norm a -> a++instance Normed Double where+ type Norm Double = Double+ norm a = abs a+ liftNorm = id++instance Normed Int where+ type Norm Int = Int+ norm = abs+ liftNorm = id++instance Normed Integer where+ type Norm Integer = Integer+ norm = abs+ liftNorm = id++instance (Ord (Norm d), Euclidean d, Euclidean (Norm d), Normed d)+ => Normed (Fraction d) where+ type Norm (Fraction d) = Fraction (Norm d)+ norm f = norm (numerator f) % norm (denominator f)+ liftNorm f = liftNorm (numerator f) % liftNorm (denominator f)
+ Algebra/Prelude.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE FlexibleContexts, NoImplicitPrelude, NoMonomorphismRestriction #-}+module Algebra.Prelude+ ( module Algebra.Prelude.Core,+ module Algebra.Ring.Polynomial.Univariate,+ module Algebra.Ring.Polynomial.Labeled,+ module Algebra.Field.Finite,+ module Algebra.Field.Galois+ ) where+import Algebra.Field.Finite+import Algebra.Field.Galois+import Algebra.Prelude.Core+import Algebra.Ring.Polynomial.Labeled+import Algebra.Ring.Polynomial.Univariate
+ Algebra/Prelude/Core.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE FlexibleContexts, NoImplicitPrelude, NoMonomorphismRestriction #-}+module Algebra.Prelude.Core+ ((%),Scalar(..),(.*.), od,Ordinal, enumOrdinal,+ logBase2,ceilingLogBase2,+ module AlgebraicPrelude,+ module Algebra.Ring.Polynomial,+ module Algebra.Ring.Ideal,+ module Algebra.Normed,+ module Algebra.Internal) where++import Algebra.Internal+import Algebra.Normed+import Algebra.Ring.Ideal+import Algebra.Ring.Polynomial+import Algebra.Scalar++import AlgebraicPrelude hiding (lex, (%))+import Data.Bits (Bits (..), FiniteBits (..))+import Data.Type.Ordinal.Builtin (Ordinal, enumOrdinal, od)++(%) :: (IsPolynomial poly, Division (Coefficient poly))+ => Coefficient poly -> Coefficient poly -> poly+n % m = injectCoeff (n / m)+infixl 7 %++type Rational = Fraction Integer++logBase2 :: Int -> Int+logBase2 x = finiteBitSize x - 1 - countLeadingZeros x+{-# INLINE logBase2 #-}++ceilingLogBase2 :: Int -> Int+ceilingLogBase2 n =+ if popCount n == 1+ then logBase2 n+ else logBase2 n + 1
+ Algebra/Ring/Ideal.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DataKinds, ExistentialQuantification, FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances, GADTs, MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Algebra.Ring.Ideal ( Ideal(..), addToIdeal, toIdeal, appendIdeal+ , generators, filterIdeal, mapIdeal, principalIdeal, isEmptyIdeal) where+import Algebra.Internal++import AlgebraicPrelude+import Control.DeepSeq+import qualified Data.Foldable as F+import qualified Data.Sized.Builtin as S++data Ideal r = forall n. Ideal (Sized n r)++isEmptyIdeal :: Ideal t -> Bool+isEmptyIdeal (Ideal t) = S.null t++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+ showsPrec d = showsPrec d . generators++addToIdeal :: (Monoidal r, Eq r) => r -> Ideal r -> Ideal r+addToIdeal i (Ideal is)+ | i == zero = Ideal is+ | otherwise = Ideal (S.cons i is)++infixr `addToIdeal`++toIdeal :: (Eq r, Monoidal r) => [r] -> Ideal r+toIdeal = foldr addToIdeal (Ideal S.empty)++appendIdeal :: Ideal r -> Ideal r -> Ideal r+appendIdeal (Ideal is) (Ideal js) = Ideal (is `S.append` js)++generators :: Ideal r -> [r]+generators (Ideal is) = S.toList is++filterIdeal :: (Eq r, Monoidal r) => (r -> Bool) -> Ideal r -> Ideal r+filterIdeal p (Ideal i) = F.foldr (\h -> if p h then addToIdeal h else id) (toIdeal []) i++principalIdeal :: r -> Ideal r+principalIdeal = Ideal . singleton++mapIdeal :: (r -> r') -> Ideal r -> Ideal r'+mapIdeal fun (Ideal xs) = Ideal $ S.map fun xs+{-# INLINE [1] mapIdeal #-}+{-# RULES "mapIdeal/id" [~1] forall x. mapIdeal id x = x #-}++instance NFData r => NFData (Ideal r) where+ rnf (Ideal is) = rnf is
− Algebra/Ring/Noetherian.hs
@@ -1,114 +0,0 @@-{-# 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 qualified Data.Complex as C-import Data.Function-import Data.Ord-import Data.Ratio-import Data.Vector.Sized (Vector (..))-import qualified Data.Vector.Sized as V-import Numeric.Algebra-import qualified Numeric.Algebra.Complex as NA-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 (NA.Complex r), Ring (NA.Complex r)) => NoetherianRing (NA.Complex r) where-instance (Commutative (C.Complex r), Ring (C.Complex r)) => NoetherianRing (C.Complex r) where-instance Integral n => NoetherianRing (Ratio n)--instance Integral n => InvolutiveMultiplication (Ratio n) where- adjoint = id-instance Integral n => InvolutiveSemiring (Ratio n)--instance Integral n => TriviallyInvolutive (Ratio n)--instance (P.Num n) => P.Num (NA.Complex n) where- abs = error "unimplemented"- signum = error "unimplemented"- fromInteger n = NA.Complex (P.fromInteger n) 0- negate (NA.Complex x y) = NA.Complex (P.negate x) (P.negate y)- NA.Complex x y + NA.Complex z w = NA.Complex (x P.+ y) (z P.+ w)- NA.Complex x y * NA.Complex z w = NA.Complex (x P.* z P.- y P.* w) (x P.* w P.+ y P.* z)--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 (V.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 `V.append` js)--generators :: Ideal r -> [r]-generators (Ideal is) = V.toList is--filterIdeal :: NoetherianRing r => (r -> Bool) -> Ideal r -> Ideal r-filterIdeal p (Ideal i) = V.foldr (\h -> if p h then addToIdeal h else id) (toIdeal []) i--principalIdeal :: r -> Ideal r-principalIdeal = Ideal . V.singleton--mapIdeal :: (r -> r') -> Ideal r -> Ideal r'-mapIdeal fun (Ideal xs) = Ideal $ V.map fun xs
Algebra/Ring/Polynomial.hs view
@@ -1,518 +1,467 @@-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, FlexibleInstances #-}-{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, LiberalTypeSynonyms #-}-{-# LANGUAGE MultiParamTypeClasses, OverlappingInstances, PolyKinds #-}-{-# LANGUAGE RankNTypes, ScopedTypeVariables, StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies, TypeOperators, UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-type-defaults #-}+{-# LANGUAGE ConstraintKinds, DataKinds, ExplicitNamespaces #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, LiberalTypeSynonyms #-}+{-# LANGUAGE MultiParamTypeClasses, NoMonomorphismRestriction #-}+{-# LANGUAGE PatternGuards, PolyKinds, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving, TemplateHaskell, TypeFamilies #-}+{-# LANGUAGE TypeOperators, TypeSynonymInstances, UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-type-defaults #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-} module Algebra.Ring.Polynomial- ( Polynomial, Monomial, MonomialOrder, EliminationType, EliminationOrder- , WeightedEliminationOrder, eliminationOrder, weightedEliminationOrder- , lex, revlex, graded, grlex, grevlex, productOrder, productOrder'- , transformMonomial, WeightProxy(..), weightOrder, totalDegree, totalDegree'- , IsPolynomial, coeff, lcmMonomial, sPolynomial, polynomial- , castMonomial, castPolynomial, toPolynomial, changeOrder, changeOrderProxy- , scastMonomial, scastPolynomial, OrderedPolynomial, showPolynomialWithVars, showPolynomialWith, showRational- , normalize, injectCoeff, varX, var, getTerms, shiftR, orderedBy- , divs, tryDiv, fromList, Coefficient(..),ToWeightVector(..)- , leadingTerm, leadingMonomial, leadingOrderedMonomial, leadingCoeff, genVars, sArity- , OrderedMonomial(..), OrderedMonomial'(..), Grevlex(..)- , Revlex(..), Lex(..), Grlex(..), Graded(..)- , ProductOrder (..), WeightOrder(..)- , IsOrder(..), IsMonomialOrder) where-import Algebra.Internal-import Algebra.Ring.Noetherian-import Control.Arrow-import Control.Lens-import Data.Function-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.Ratio-import Data.Type.Monomorphic-import Data.Type.Natural hiding (max, one, promote, zero)-import Data.Vector.Sized (Vector (..))-import qualified Data.Vector.Sized as V-import Numeric.Algebra hiding (Order (..), sum)-import Prelude hiding (lex, negate, recip, (*), (+),- (-), (^), (^^))-import qualified Prelude as P+ ( module Algebra.Ring.Polynomial.Monomial,+ module Algebra.Ring.Polynomial.Class,+ Polynomial,+ transformMonomial,+ castPolynomial, changeOrder, changeOrderProxy,+ scastPolynomial, OrderedPolynomial(..),+ allVars, substVar, homogenize, unhomogenize,+ normalize, varX, getTerms, shiftR, orderedBy,+ mapCoeff, reversal, padeApprox,+ eval, evalUnivariate,+ substUnivariate, minpolRecurrent,+ IsOrder(..)+ ) where+import Algebra.Internal+import Algebra.Ring.Polynomial.Class+import Algebra.Ring.Polynomial.Monomial+import Algebra.Scalar --- | N-ary Monomial. IntMap contains degrees for each x_i.-type Monomial (n :: Nat) = Vector Int n+import AlgebraicPrelude+import Control.DeepSeq (NFData)+import Control.Lens hiding (assign)+import qualified Data.Coerce as C+import qualified Data.Foldable as F+import qualified Data.HashSet as HS+import Data.Map (Map)+import qualified Data.Map.Strict as M+import qualified Data.Set as Set+import Data.Singletons.Prelude (POrd (..))+import qualified Data.Sized.Builtin as S+import Data.Type.Ordinal+import qualified Numeric.Algebra as NA+import Numeric.Algebra.Unital.UnitNormalForm (UnitNormalForm (..))+import qualified Numeric.Algebra.Unital.UnitNormalForm as NA+import Numeric.Domain.Integral (IntegralDomain (..))+import qualified Numeric.Ring.Class as NA+import Numeric.Semiring.ZeroProduct (ZeroProductSemiring)+import qualified Prelude as P+import Proof.Equational (symmetry) --- | Monomorphic representation for monomial.-newtype OrderedMonomial' ord = OM' { getMonomial' :: [Int] }- deriving (Read, Show, Eq)+instance Hashable r => Hashable (OrderedPolynomial r ord n) where+ hashWithSalt salt poly = hashWithSalt salt $ getTerms poly -instance Monomorphicable (OrderedMonomial ord) where- type MonomorphicRep (OrderedMonomial ord) = OrderedMonomial' ord- promote (OM' xs) =- case promote xs of- Monomorphic m -> Monomorphic $ OrderedMonomial m- demote (Monomorphic (OrderedMonomial m)) = OM' (demote (Monomorphic m))+deriving instance (CoeffRing r, IsOrder n ord, Ord r) => Ord (OrderedPolynomial r ord n) -instance IsMonomialOrder ord => Ord (OrderedMonomial' ord) where- compare = cmpMonomial' (Proxy :: Proxy ord) `on` getMonomial'+-- | n-ary polynomial ring over some noetherian ring R.+newtype OrderedPolynomial r order n = Polynomial { _terms :: Map (OrderedMonomial order n) r }+ deriving (NFData)+type Polynomial r = OrderedPolynomial r Grevlex -instance Monomorphicable (Vector Int) where- type MonomorphicRep (Vector Int) = [Int]- promote [] = Monomorphic Nil- promote (n : ns) =- case promote ns of- Monomorphic ns' -> Monomorphic (n :- ns')- demote (Monomorphic Nil) = []- demote (Monomorphic (n :- ns)) = n : demote (Monomorphic ns)+instance (KnownNat n, IsMonomialOrder n ord, CoeffRing r) => IsPolynomial (OrderedPolynomial r ord n) where+ type Coefficient (OrderedPolynomial r ord n) = r+ type Arity (OrderedPolynomial r ord n) = 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+ injectCoeff r | isZero r = Polynomial M.empty+ | otherwise = Polynomial $ M.singleton one r+ {-# INLINE injectCoeff #-} --- | apply monomial ordering to monomorphic monomials.-cmpMonomial' :: IsMonomialOrder ord => Proxy ord -> [Int] -> [Int] -> Ordering-cmpMonomial' pxy xs ys =- withPolymorhic (P.max (length xs) (length ys)) $ \n ->- cmpMonomial pxy (fromList n xs) (fromList n ys)+ sArity' = sizedLength . getMonomial . leadingMonomial+ {-# INLINE sArity' #-} --- | 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 = forall n. Monomial n -> Monomial n -> Ordering+ mapCoeff' = mapCoeff+ {-# INLINE mapCoeff' #-} -totalDegree :: Monomial n -> Int-totalDegree = V.foldl (+) 0-{-# INLINE totalDegree #-}+ monomials = HS.fromList . map getMonomial . Set.toList . orderedMonomials+ {-# INLINE monomials #-} -totalDegree' :: OrderedPolynomial k ord n -> Int-totalDegree' = maximum . (0:) . map (totalDegree . snd) . getTerms+ fromMonomial m = Polynomial $ M.singleton (OrderedMonomial m) one+ {-# INLINE fromMonomial #-} --- | Lexicographical order. This *is* a monomial order.-lex :: MonomialOrder-lex Nil Nil = EQ-lex (x :- xs) (y :- ys) = x `compare` y <> xs `lex` ys-lex _ _ = error "cannot happen"+ toPolynomial' (r, m) = Polynomial $ M.singleton (OrderedMonomial m) r+ {-# INLINE toPolynomial' #-} --- | 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!"+ polynomial' dic = normalize $ Polynomial $ M.mapKeys OrderedMonomial dic+ {-# INLINE polynomial' #-} --- | 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-{-# INLINE graded #-}-{-# RULES-"graded/grevlex" graded grevlex = grevlex-"graded/grlex" graded grlex = grlex- #-}+ terms' = M.mapKeys getMonomial . terms+ {-# INLINE terms' #-} --- | Graded lexicographical order. This *is* a monomial order.-grlex :: MonomialOrder-grlex = graded lex-{-# INLINE grlex #-}+ liftMap mor poly = sum $ map (uncurry (.*) . (Scalar *** extractPower)) $ getTerms poly+ where+ extractPower = runMult . ifoldMap (\ o -> Mult . pow (mor o) . fromIntegral) . getMonomial+ {-# INLINE liftMap #-} --- | Graded reversed lexicographical order. This *is* a monomial order.-grevlex :: MonomialOrder-grevlex = graded revlex-{-# INLINE grevlex #-}+ordVec :: forall n. KnownNat n => Sized n (Ordinal n)+ordVec = unsafeFromList' $ enumOrdinal (sing :: SNat n) --- | 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 (KnownNat n, CoeffRing r, IsMonomialOrder n ord)+ => IsOrderedPolynomial (OrderedPolynomial r ord n) where+ -- | coefficient for a degree.+ type MOrder (OrderedPolynomial r ord n) = ord+ coeff d = M.findWithDefault zero d . terms+ {-# INLINE coeff #-} -instance Wrapped (Monomial n) (Monomial m) (OrderedMonomial o n) (OrderedMonomial o' m) where- wrapped = iso OrderedMonomial getMonomial+ terms = C.coerce+ {-# INLINE terms #-} --- | Class to lookup ordering from its (type-level) name.-class IsOrder (ordering :: *) where- cmpMonomial :: Proxy ordering -> MonomialOrder+ orderedMonomials = M.keysSet . terms+ {-# INLINE orderedMonomials #-} --- * Names for orderings.--- We didn't choose to define one single type for ordering names for the extensibility.--- | Lexicographical order-data Lex = Lex- deriving (Show, Eq, Ord)+ toPolynomial (c, deg) =+ if isZero c+ then Polynomial M.empty+ else Polynomial $ M.singleton deg c+ {-# INLINE toPolynomial #-} --- | Reversed lexicographical order-data Revlex = Revlex- deriving (Show, Eq, Ord)+ polynomial = normalize . C.coerce+ {-# INLINE polynomial #-} --- | Graded reversed lexicographical order. Same as @Graded Revlex@.-data Grevlex = Grevlex- deriving (Show, Eq, Ord)+ leadingTerm (Polynomial d) =+ case M.maxViewWithKey d of+ Just ((deg, c), _) -> (c, deg)+ Nothing -> (zero, one)+ {-# INLINE leadingTerm #-} --- | Graded lexicographical order. Same as @Graded Lex@.-data Grlex = Grlex- deriving (Show, Eq, Ord)+ leadingMonomial = snd . leadingTerm+ {-# INLINE leadingMonomial #-} --- | Graded order from another monomial order.-data Graded ord = Graded ord- deriving (Read, Show, Eq, Ord)+ leadingCoeff = fst . leadingTerm+ {-# INLINE leadingCoeff #-} -instance IsOrder ord => IsOrder (Graded ord) where- cmpMonomial Proxy = graded (cmpMonomial (Proxy :: Proxy ord))+instance (KnownNat n, CoeffRing r, IsMonomialOrder n order)+ => Wrapped (OrderedPolynomial r order n) where+ type Unwrapped (OrderedPolynomial r order n) = Map (OrderedMonomial order n) r+ _Wrapped' = iso terms polynomial -instance IsMonomialOrder ord => IsMonomialOrder (Graded ord)+instance (KnownNat n, CoeffRing r, IsMonomialOrder n ord, t ~ OrderedPolynomial q ord' m)+ => Rewrapped (OrderedPolynomial r ord n) t -data ProductOrder (n :: Nat) (a :: *) (b :: *) where- ProductOrder :: SNat n -> ord -> ord' -> ProductOrder n ord ord'+castPolynomial :: (CoeffRing r, KnownNat n, KnownNat m,+ IsMonomialOrder n o, IsMonomialOrder m o')+ => OrderedPolynomial r o n+ -> OrderedPolynomial r o' m+castPolynomial = _Wrapped %~ M.mapKeys castMonomial+{-# INLINE castPolynomial #-} -productOrder :: forall ord ord' n m. (IsOrder ord, IsOrder ord', SingRep n)- => Proxy (ProductOrder n ord ord') -> Monomial m -> Monomial m -> Ordering-productOrder _ m m' =- case sing :: SNat n of- n -> case (V.splitAtMost n m, V.splitAtMost n m') of- ((xs, xs'), (ys, ys')) -> cmpMonomial (Proxy :: Proxy ord) xs ys <> cmpMonomial (Proxy :: Proxy ord') xs' ys'+scastPolynomial :: (IsMonomialOrder n o, IsMonomialOrder m o', KnownNat m,+ CoeffRing r, KnownNat n)+ => SNat m -> OrderedPolynomial r o n -> OrderedPolynomial r o' m+scastPolynomial _ = castPolynomial+{-# INLINE scastPolynomial #-} -productOrder' :: forall n ord ord' m.(IsOrder ord, IsOrder ord')- => SNat n -> ord -> ord' -> Monomial m -> Monomial m -> Ordering-productOrder' n ord ord' =- case singInstance n of SingInstance -> productOrder (toProxy $ ProductOrder n ord ord')+mapCoeff :: (KnownNat n, CoeffRing b, IsMonomialOrder n ord)+ => (a -> b) -> OrderedPolynomial a ord n -> OrderedPolynomial b ord n+mapCoeff f (Polynomial dic) = polynomial $ M.map f dic+{-# INLINE mapCoeff #-} --- | Data.Proxy provides kind-polymorphic 'Proxy' data-type, but due to bug of GHC 7.4.1,--- It canot be used as kind-polymorphic. So I define another type here.-data WeightProxy (v :: [Nat]) where- NilWeight :: WeightProxy '[]- ConsWeight :: SNat n -> WeightProxy v -> WeightProxy (n ': v)+normalize :: (DecidableZero r)+ => OrderedPolynomial r order n -> OrderedPolynomial r order n+normalize (Polynomial dic) =+ Polynomial $ M.filter (not . isZero) dic+{-# INLINE normalize #-} -data WeightOrder (v :: [Nat]) (ord :: *) where- WeightOrder :: WeightProxy (v :: [Nat]) -> ord -> WeightOrder v ord -data Proxy' (vs :: [Nat]) = Proxy'+instance (Eq r) => Eq (OrderedPolynomial r order n) where+ Polynomial f == Polynomial g = f == g+ {-# INLINE (==) #-} -class ToWeightVector (vs :: [Nat]) where- calcOrderWeight :: Proxy' vs -> Vector Int n -> Int+-- -- | By Hilbert's finite basis theorem, a polynomial ring over a noetherian ring is also a noetherian ring.+-- instance (IsMonomialOrder order, CoeffRing r, KnownNat n) => Ring (OrderedPolynomial r order n) where+instance (IsMonomialOrder n order, CoeffRing r, KnownNat n) => Ring (OrderedPolynomial r order n) where+ fromInteger 0 = Polynomial M.empty+ fromInteger n = Polynomial $ M.singleton one (fromInteger' n)+ {-# INLINE fromInteger #-} -instance ToWeightVector '[] where- calcOrderWeight Proxy' _ = 0+decZero :: DecidableZero r => r -> Maybe r+decZero n | isZero n = Nothing+ | otherwise = Just n+{-# INLINE decZero #-} -instance (SingRep n, ToWeightVector ns) => ToWeightVector (n ': ns) where- calcOrderWeight Proxy' Nil = 0- calcOrderWeight Proxy' (x :- xs) = x * sNatToInt (sing :: SNat n) + calcOrderWeight (Proxy' :: Proxy' ns) xs+instance (IsMonomialOrder n order, CoeffRing r, KnownNat n) => Rig (OrderedPolynomial r order n)+instance (IsMonomialOrder n order, CoeffRing r, KnownNat n) => Group (OrderedPolynomial r order n) where+ negate (Polynomial dic) = Polynomial $ fmap negate dic+ {-# INLINE negate #-} -weightOrder :: forall ns ord m. (ToWeightVector ns, IsOrder ord)- => Proxy (WeightOrder ns ord) -> Monomial m -> Monomial m -> Ordering-weightOrder Proxy m m' = comparing (calcOrderWeight (Proxy' :: Proxy' ns)) m m'- <> cmpMonomial (Proxy :: Proxy ord) m m'+ Polynomial f - Polynomial g = Polynomial $ M.mergeWithKey (\_ i j -> decZero (i - j)) id (fmap negate) f g+ {-# INLINE (-) #-} -instance (ToWeightVector ws, IsOrder ord) => IsOrder (WeightOrder ws ord) where- cmpMonomial p = weightOrder p -instance (IsOrder ord, IsOrder ord', SingRep n) => IsOrder (ProductOrder n ord ord') where- cmpMonomial p = productOrder p+instance (IsMonomialOrder n order, CoeffRing r, KnownNat n) => LeftModule Integer (OrderedPolynomial r order n) where+ n .* Polynomial dic = polynomial $ fmap (n .*) dic+ {-# INLINE (.*) #-} --- They're all total orderings.-instance IsOrder Grevlex where- cmpMonomial _ = grevlex+instance (IsMonomialOrder n order, CoeffRing r, KnownNat n) => RightModule Integer (OrderedPolynomial r order n) where+ (*.) = flip (.*)+ {-# INLINE (*.) #-}+instance (IsMonomialOrder n order, CoeffRing r, KnownNat n) => Additive (OrderedPolynomial r order n) where+ (Polynomial f) + (Polynomial g) = polynomial $ M.unionWith (+) f g+ {-# INLINE (+) #-}+instance (IsMonomialOrder n order, CoeffRing r, KnownNat n) => Monoidal (OrderedPolynomial r order n) where+ zero = Polynomial M.empty+ {-# INLINE zero #-}+instance (IsMonomialOrder n order, CoeffRing r, KnownNat n) => LeftModule Natural (OrderedPolynomial r order n) where+ n .* Polynomial dic = polynomial $ fmap (n .*) dic+ {-# INLINE (.*) #-}+instance (IsMonomialOrder n order, CoeffRing r, KnownNat n) => RightModule Natural (OrderedPolynomial r order n) where+ (*.) = flip (.*)+ {-# INLINE (*.) #-} -instance IsOrder Revlex where- cmpMonomial _ = revlex+instance (IsMonomialOrder n order, CoeffRing r, KnownNat n) => Unital (OrderedPolynomial r order n) where+ one = Polynomial $ M.singleton one one+ {-# INLINE one #-} -instance IsOrder Lex where- cmpMonomial _ = lex+instance (IsMonomialOrder n order, CoeffRing r, KnownNat n) => Multiplicative (OrderedPolynomial r order n) where+ Polynomial (M.toList -> d1) * Polynomial (M.toList -> d2) =+ let dic = (one, zero) : [ (a * b, r * r') | (a, r) <- d1, (b, r') <- d2, not $ isZero (r * r')+ ]+ in polynomial $ M.fromListWith (+) dic+ {-# INLINE (*) #-} -instance IsOrder Grlex where- cmpMonomial _ = grlex+instance (IsMonomialOrder n order, CoeffRing r, KnownNat n) => Semiring (OrderedPolynomial r order n) where+instance (IsMonomialOrder n order, CoeffRing r, KnownNat n) => Commutative (OrderedPolynomial r order n) where+instance (IsMonomialOrder n order, CoeffRing r, KnownNat n) => Abelian (OrderedPolynomial r order n) where+instance (IsMonomialOrder n order, CoeffRing r, KnownNat n) => LeftModule (Scalar r) (OrderedPolynomial r order n) where+ Scalar r .* Polynomial dic = polynomial $ fmap (r*) dic+ {-# INLINE (.*) #-} --- | Class for Monomial orders.-class IsOrder name => IsMonomialOrder name where+instance (IsMonomialOrder n order, CoeffRing r, KnownNat n) => RightModule (Scalar r) (OrderedPolynomial r order n) where+ Polynomial dic *. Scalar r = polynomial $ fmap (r*) dic+ {-# INLINE (*.) #-} --- 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-instance (SingRep n, IsMonomialOrder o, IsMonomialOrder o') => IsMonomialOrder (ProductOrder n o o')-instance (ToWeightVector ws, IsMonomialOrder ord) => IsMonomialOrder (WeightOrder ws ord) --- | Monomial order which can be use to calculate n-th elimination ideal.--- This should judge it as bigger that contains variables to eliminate.-class (IsMonomialOrder ord, SingRep n) => EliminationType n ord-instance SingRep n => EliminationType n Lex-instance (SingRep n, IsMonomialOrder ord, IsMonomialOrder ord') => EliminationType n (ProductOrder n ord ord')-instance (IsMonomialOrder ord) => EliminationType Z (WeightOrder '[] ord)-instance (IsMonomialOrder ord, ToWeightVector ns, EliminationType n (WeightOrder ns ord))- => EliminationType (S n) (WeightOrder (One ': ns) ord)--type EliminationOrder n = ProductOrder n Grevlex Grevlex--eliminationOrder :: SNat n -> EliminationOrder n-eliminationOrder n =- case singInstance n of- SingInstance -> ProductOrder n Grevlex Grevlex--weightedEliminationOrder :: SNat n -> WeightedEliminationOrder n Grevlex-weightedEliminationOrder n = WEOrder n (Proxy :: Proxy Grevlex)--type family EWeight (n :: Nat) :: [Nat]-type instance EWeight Z = '[]-type instance EWeight (S n) = One ': EWeight n--data WeightedEliminationOrder (n :: Nat) (ord :: *) where- WEOrder :: SNat n -> Proxy ord -> WeightedEliminationOrder n ord--instance (SingRep n, IsMonomialOrder ord) => IsOrder (WeightedEliminationOrder n ord) where- cmpMonomial Proxy m m' = comparing (calc (sing :: SNat n)) m m' <> cmpMonomial (Proxy :: Proxy ord) m m'- where- calc :: SNat l -> Vector Int m -> Int- calc (SS _) Nil = 0- calc SZ _ = 0- calc (SS l) (x :- xs)= x + calc l xs--instance (SingRep n, IsMonomialOrder ord) => IsMonomialOrder (WeightedEliminationOrder n ord)--instance (SingRep n, IsMonomialOrder ord) => EliminationType n (WeightedEliminationOrder n ord) where---- | 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, SingRep 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', SingRep m, n :<= m) => OrderedMonomial o n -> OrderedMonomial o' m-castMonomial = unwrapped %~ fromList sing . V.toList--scastMonomial :: (n :<= m) => SNat m -> OrderedMonomial o n -> OrderedMonomial o m-scastMonomial sdim = unwrapped %~ fromList sdim . V.toList--castPolynomial :: (IsPolynomial r n, IsPolynomial r m, SingRep 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, SingRep 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- Polynomial f == 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 $ V.zipWithSame (+) 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..]]+instance (IsMonomialOrder n ord, Characteristic r, KnownNat n, CoeffRing r)+ => Characteristic (OrderedPolynomial r ord n) where+ char _ = char (Proxy :: Proxy r)+ {-# INLINE char #-} -instance (SingRep n, IsOrder order) => Show (OrderedPolynomial Rational order n) where- show = showPolynomialWith [(n, "X_"++ show n) | n <- [1..]] showRational+instance (KnownNat n, CoeffRing r, IsMonomialOrder n order, PrettyCoeff r)+ => Show (OrderedPolynomial r order n) where+ showsPrec = showsPolynomialWith $ generate sing (\i -> "X_" ++ show (fromEnum i)) -showPolynomialWithVars :: (Eq a, Show a, SingRep n, NoetherianRing a, IsOrder ordering)+showPolynomialWithVars :: (CoeffRing a, Show a, KnownNat n, IsMonomialOrder n ordering) => [(Int, String)] -> OrderedPolynomial a ordering n -> String showPolynomialWithVars dic p0@(Polynomial d)- | p0 == zero = "0"+ | isZero p0 = "0" | otherwise = intercalate " + " $ mapMaybe showTerm $ M.toDescList d where showTerm (getMonomial -> deg, c)- | c == zero = Nothing+ | isZero c = Nothing | otherwise =- let cstr = if (c == zero - one)- then if any (/= zero) (V.toList deg) then "-" else "-1"- else if (c /= one || isConstantMonomial deg)- then show c ++ " "- else ""- in Just $ cstr ++ unwords (mapMaybe showDeg (zip [1..] $ V.toList deg))+ let cstr = if (not (isZero $ c - one) || isConstantMonomial deg)+ then show c ++ " "+ else if isZero (c - one) then ""+ else if isZero (c + one)+ then if any (not . isZero) (F.toList deg) then "-" else "-1"+ else ""+ in Just $ cstr ++ unwords (mapMaybe showDeg (zip [0..] $ F.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 -data Coefficient = Zero | Negative String | Positive String | Eps- deriving (Show, Eq, Ord)+isConstantMonomial :: Monomial n -> Bool+isConstantMonomial v = all (== 0) $ F.toList v -showRational :: (Integral a, Show a) => Ratio a -> Coefficient-showRational r | r == 0 = Zero- | r > 0 = Positive $ formatRat r- | otherwise = Negative $ formatRat $ abs r- where- formatRat q | denominator q == 1 = show $ numerator q- | otherwise = show (numerator q) ++ "/" ++ show (denominator q) ++ " "+-- | We provide Num instance to use trivial injection R into R[X].+-- Do not use signum or abs.+instance (IsMonomialOrder n order, CoeffRing r, KnownNat n)+ => P.Num (OrderedPolynomial r order n) where+ (+) = (+)+ {-# INLINE (+) #-} -showPolynomialWith :: (Eq a, Show a, SingRep n, NoetherianRing a, IsOrder ordering)- => [(Int, String)] -> (a -> Coefficient) -> OrderedPolynomial a ordering n -> String-showPolynomialWith vDic showCoeff p0@(Polynomial d)- | p0 == zero = "0"- | otherwise = catTerms $ mapMaybe procTerm $ M.toDescList d- where- catTerms [] = "0"- catTerms (x:xs) = concat $ showTerm True x : map (showTerm False) xs- showTerm isLeading (Zero, _) = if isLeading then "0" else ""- showTerm isLeading (Positive s, deg) = if isLeading then s ++ deg else " + " ++ s ++ deg- showTerm isLeading (Negative s, deg) = if isLeading then '-' : s ++ deg else " - " ++ s ++ deg- showTerm isLeading (Eps, deg) = if isLeading then deg else " + " ++ deg- procTerm (getMonomial -> deg, c)- | c == zero = Nothing- | otherwise =- let cKind = showCoeff c- cff | isConstantMonomial deg && c == one = Positive "1"- | isConstantMonomial deg && c == negate one = Negative "1"- | c == one = Positive ""- | c == negate one = Negative ""- | otherwise = cKind- in Just $ (cff, unwords (mapMaybe showDeg (zip [1..] $ V.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 vDic+ (*) = (*)+ {-# INLINE (*) #-} -isConstantMonomial :: (Eq a, Num a) => Vector a n -> Bool-isConstantMonomial v = all (== 0) $ V.toList v+ fromInteger = normalize . injectCoeff . fromInteger'+ {-# INLINE fromInteger #-} --- | 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+ signum f = if isZero f then zero else injectCoeff one+ {-# INLINE signum #-}+ abs = id+ {-# INLINE abs #-}+ negate = ((P.negate 1 :: Integer) .*)+ {-# INLINE negate #-} -varX :: (NoetherianRing r, SingRep n, One :<= n) => OrderedPolynomial r order n-varX = Polynomial $ M.singleton (OrderedMonomial $ fromList sing [1]) one -var :: (NoetherianRing r, SingRep m, S n :<= m) => SNat (S n) -> OrderedPolynomial r order m-var vIndex = Polynomial $ M.singleton (OrderedMonomial $ fromList sing (buildIndex vIndex)) one+instance (CoeffRing r, KnownNat n, IsMonomialOrder n ord) => DecidableZero (OrderedPolynomial r ord n) where+ isZero (Polynomial d) = M.null d+ {-# INLINE isZero #-} -toPolynomial :: (IsOrder order, IsPolynomial r n) => (r, Monomial n) -> OrderedPolynomial r order n-toPolynomial (c, deg) = Polynomial $ M.singleton (OrderedMonomial deg) c+instance (CoeffRing r, IsMonomialOrder 1 ord, ZeroProductSemiring r)+ => ZeroProductSemiring (OrderedPolynomial r ord 1) -polynomial :: (SingRep n, Eq r, NoetherianRing r, IsOrder order) => Map (OrderedMonomial order n) r -> OrderedPolynomial r order n-polynomial dic = normalize $ Polynomial dic+instance (Eq r, DecidableUnits r, DecidableZero r, Field r,+ IsMonomialOrder 1 ord, ZeroProductSemiring r)+ => DecidableAssociates (OrderedPolynomial r ord 1) where+ isAssociate = (==) `on` NA.normalize+ {-# INLINE isAssociate #-} -buildIndex :: SNat (S n) -> [Int]-buildIndex (SS SZ) = [1]-buildIndex (SS (SS n)) = 0 : buildIndex (SS n)+instance (Eq r, DecidableUnits r, DecidableZero r, Field r,+ IsMonomialOrder 1 ord, ZeroProductSemiring r)+ => UnitNormalForm (OrderedPolynomial r ord 1) where+ splitUnit f+ | isZero f = (zero, f)+ | otherwise = let lc = leadingCoeff f+ in (injectCoeff lc, injectCoeff (recip lc) * f)+ {-# INLINE splitUnit #-} -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 [])+instance (Eq r, DecidableUnits r, DecidableZero r, Field r,+ IsMonomialOrder 1 ord, ZeroProductSemiring r)+ => GCDDomain (OrderedPolynomial r ord 1)+instance (Eq r, DecidableUnits r, DecidableZero r, Field r,+ IsMonomialOrder 1 ord, ZeroProductSemiring r)+ => UFD (OrderedPolynomial r ord 1)+instance (Eq r, DecidableUnits r, DecidableZero r, Field r,+ IsMonomialOrder 1 ord, ZeroProductSemiring r)+ => PID (OrderedPolynomial r ord 1)+instance (Eq r, DecidableUnits r, DecidableZero r, Field r, IsMonomialOrder 1 ord, ZeroProductSemiring r) => Euclidean (OrderedPolynomial r ord 1) where+ f0 `divide` g = step f0 zero+ where+ lm = leadingMonomial g+ step p quo+ | isZero p = (quo, p)+ | lm `divs` leadingMonomial p =+ let q = toPolynomial $ leadingTerm p `tryDiv` leadingTerm g+ in step (p - (q * g)) (quo + q)+ | otherwise = (quo, p)+ degree f | isZero f = Nothing+ | otherwise = Just $ P.fromIntegral $ totalDegree' f -leadingMonomial :: (IsOrder order, IsPolynomial r n) => OrderedPolynomial r order n -> Monomial n-leadingMonomial = snd . leadingTerm -leadingOrderedMonomial :: (IsOrder order, IsPolynomial r n)- => OrderedPolynomial r order n -> OrderedMonomial order n-leadingOrderedMonomial = OrderedMonomial . leadingMonomial+instance (Eq r, DecidableUnits r, DecidableZero r, KnownNat n,+ Field r, IsMonomialOrder n ord, ZeroProductSemiring r)+ => ZeroProductSemiring (OrderedPolynomial r ord n) -leadingCoeff :: (IsOrder order, IsPolynomial r n) => OrderedPolynomial r order n -> r-leadingCoeff = fst . leadingTerm+instance (Eq r, DecidableUnits r, DecidableZero r, KnownNat n,+ Field r, IsMonomialOrder n ord, ZeroProductSemiring r)+ => IntegralDomain (OrderedPolynomial r ord n) where+ p `divides` q = isZero $ p `modPolynomial` [q]+ p `maybeQuot` q =+ if isZero q+ then Nothing+ else let (r, s) = p `divModPolynomial` [q]+ in if isZero s+ then Just $ snd $ head r+ else Nothing -divs :: Monomial n -> Monomial n -> Bool-xs `divs` ys = and $ V.toList $ V.zipWith (<=) xs ys+instance (CoeffRing r, IsMonomialOrder n ord, DecidableUnits r, KnownNat n) => DecidableUnits (OrderedPolynomial r ord n) where+ isUnit f =+ let (lc, lm) = leadingTerm f+ in lm == one && isUnit lc+ recipUnit f | isUnit f = injectCoeff <$> recipUnit (leadingCoeff f)+ | otherwise = Nothing -tryDiv :: Field r => (r, Monomial n) -> (r, Monomial n) -> (r, Monomial n)-tryDiv (a, f) (b, g)- | g `divs` f = (a * recip b, V.zipWithSame (-) f g)- | otherwise = error "cannot divide."+varX :: forall r n order. (CoeffRing r, KnownNat n, IsMonomialOrder n order, (0 :< n) ~ 'True)+ => OrderedPolynomial r order n+varX = var OZ -lcmMonomial :: Monomial n -> Monomial n -> Monomial n-lcmMonomial = V.zipWithSame max+-- | Substitute univariate polynomial using Horner's rule+substUnivariate :: (Module (Scalar r) b, Unital b, CoeffRing r, IsMonomialOrder 1 order)+ => b -> OrderedPolynomial r order 1 -> b+substUnivariate u f =+ let n = totalDegree' f+ in foldr (\a b -> Scalar a .* one + b * u)+ (Scalar (coeff (OrderedMonomial $ singleton $ fromIntegral n) f) .* one)+ [ coeff (OrderedMonomial $ singleton $ fromIntegral i) f | i <- [0 .. n P.- 1] ] -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+evalUnivariate :: (CoeffRing b, IsMonomialOrder 1 order) => b -> OrderedPolynomial b order 1 -> b+evalUnivariate u f =+ let n = totalDegree' f+ in if n == 0+ then coeff one f+ else foldr1 (\a b -> a + b * u) [ coeff (OrderedMonomial $ singleton $ fromIntegral i) f | i <- [0 .. n] ] -changeOrder :: (Eq (Monomial n), IsOrder o, IsOrder o', SingRep n)+-- | Evaluate polynomial at some point.+eval :: (CoeffRing r, IsMonomialOrder n order, KnownNat n)+ => Sized n r -> OrderedPolynomial r order n -> r+eval = substWith (*)++-- evalOn :: forall k a order . (SingI k, CoeffRing a, IsMonomialOrder order)+-- => OrderedPolynomial a order k -> RepArgs k a a+-- evalOn p = fromNAry $ (fromVecFun (flip eval p) :: NAry k a a)++-- | @substVar n f@ substitutes @n@-th variable with polynomial @f@,+-- without changing arity.+substVar :: (CoeffRing r, KnownNat n, IsMonomialOrder n ord, (1 :<= n) ~ 'True)+ => Ordinal n+ -> OrderedPolynomial r ord n+ -> OrderedPolynomial r ord n+ -> OrderedPolynomial r ord n+substVar p val =+ liftMap (\o -> if o == p then val else var o)++allVars :: forall k ord n . (IsMonomialOrder n ord, CoeffRing k, KnownNat n)+ => Sized n (OrderedPolynomial k ord n)+allVars = unsafeFromList' vars++changeOrder :: (CoeffRing k, Eq (Monomial n), IsMonomialOrder n o, IsMonomialOrder n o', KnownNat n) => o' -> OrderedPolynomial k o n -> OrderedPolynomial k o' n-changeOrder _ = unwrapped %~ M.mapKeys (OrderedMonomial . getMonomial)+changeOrder _ = _Wrapped %~ M.mapKeys (OrderedMonomial . getMonomial) -changeOrderProxy :: (Eq (Monomial n), IsOrder o, IsOrder o', SingRep n)- => Proxy o' -> OrderedPolynomial k o n -> OrderedPolynomial k o' n-changeOrderProxy _ = unwrapped %~ M.mapKeys (OrderedMonomial . getMonomial)+changeOrderProxy :: (CoeffRing k, Eq (Monomial n), IsMonomialOrder n o,+ IsMonomialOrder n o', KnownNat n)+ => Proxy o' -> OrderedPolynomial k o n -> OrderedPolynomial k o' n+changeOrderProxy _ = _Wrapped %~ M.mapKeys (OrderedMonomial . getMonomial) -getTerms :: OrderedPolynomial k order n -> [(k, Monomial n)]-getTerms = map (snd &&& getMonomial . fst) . M.toDescList . terms+getTerms :: OrderedPolynomial k order n -> [(k, OrderedMonomial order n)]+getTerms = map (snd &&& fst) . M.toDescList . _terms -transformMonomial :: (IsOrder o, IsPolynomial k n, IsPolynomial k m)+transformMonomial :: (IsMonomialOrder m o, CoeffRing k, KnownNat m) => (Monomial n -> Monomial m) -> OrderedPolynomial k o n -> OrderedPolynomial k o m-transformMonomial trans (Polynomial d) = Polynomial $ M.mapKeys (OrderedMonomial . trans . getMonomial) d+transformMonomial tr (Polynomial d) =+ polynomial $ M.mapKeys (OrderedMonomial . tr . getMonomial) d -orderedBy :: IsOrder o => OrderedPolynomial k o n -> o -> OrderedPolynomial k o n+orderedBy :: OrderedPolynomial k o n -> o -> OrderedPolynomial k o n p `orderedBy` _ = p -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 (V.append (fromList k []))+shiftR :: forall k r n ord. (CoeffRing r, KnownNat n, IsMonomialOrder n ord,+ IsMonomialOrder (k + n) ord)+ => SNat k -> OrderedPolynomial r ord n -> OrderedPolynomial r ord (k :+ n)+shiftR k = withKnownNat (k %:+ (sing :: SNat n)) $+ withKnownNat k $ transformMonomial (S.append (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 = sNatToInt 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]+-- | Calculate the homogenized polynomial of given one, with additional variable is the last variable.+homogenize :: forall k ord n.+ (CoeffRing k, KnownNat n, IsMonomialOrder (n+1) ord, IsMonomialOrder n ord)+ => OrderedPolynomial k ord n -> OrderedPolynomial k ord (n + 1)+homogenize f =+ withKnownNat (sSucc (sing :: SNat n)) $+ let g = substWith (.*.) (S.init allVars) f+ d = fromIntegral (totalDegree' g)+ in mapMonomialMonotonic (\m -> m & _Wrapped.ix maxBound .~ d - P.sum (m^._Wrapped)) g -sArity :: OrderedPolynomial k ord n -> SNat n-sArity (Polynomial dic) = V.sLength $ getMonomial $ fst $ M.findMin dic-{-# RULES-"sArity/zero" forall (v :: OrderedPolynomial k ord Z). sArity v = SZ-"sArity/one" forall (v :: OrderedPolynomial k ord (S Z)). sArity v = SS SZ-"sArity/two" forall (v :: OrderedPolynomial k ord (S (S Z))). sArity v = SS (SS SZ)-"sArity/three" forall (v :: OrderedPolynomial k ord (S (S (S Z)))). sArity v = SS (SS (sS SZ))-"sArity/four" forall (v :: OrderedPolynomial k ord (S (S (S (S Z))))). sArity v = SS (SS (SS (SS SZ)))-"sArity/five" forall (v :: OrderedPolynomial k ord (S (S (S (S (S Z)))))). sArity v = SS (SS (SS (SS (SS SZ))))-"sArity/sing" forall (v :: SingRep n => OrderedPolynomial k ord n). sArity (v :: OrderedPolynomial k ord n) = sing :: SNat n- #-}+unhomogenize :: forall k ord n.+ (CoeffRing k, KnownNat n, IsMonomialOrder n ord,+ IsMonomialOrder (n+1) ord)+ => OrderedPolynomial k ord (Succ n) -> OrderedPolynomial k ord n+unhomogenize f =+ withKnownNat (sSucc (sing :: SNat n)) $+ substWith (.*.)+ (coerceLength (symmetry $ succAndPlusOneR (sing :: SNat n)) $+ allVars `S.append` S.singleton one)+ f++reversal :: (CoeffRing k, IsMonomialOrder 1 o)+ => Int -> OrderedPolynomial k o 1 -> OrderedPolynomial k o 1+reversal k = transformMonomial (S.map (k - ))++padeApprox :: (Field r, DecidableUnits r, CoeffRing r, ZeroProductSemiring r,+ IsMonomialOrder 1 order)+ => Natural -> Natural -> OrderedPolynomial r order 1+ -> (OrderedPolynomial r order 1, OrderedPolynomial r order 1)+padeApprox k nmk g =+ let (r, _, t) = last $ filter ((< P.fromIntegral k) . totalDegree' . view _1) $ euclid (pow varX (k+nmk)) g+ in (r, t)+++minpolRecurrent :: forall k. (Eq k, ZeroProductSemiring k, DecidableUnits k, DecidableZero k, Field k)+ => Natural -> [k] -> Polynomial k 1+minpolRecurrent n xs =+ let h = sum $ zipWith (\a b -> injectCoeff a * b) xs [pow varX i | i <- [0.. pred (2 * n)]]+ :: Polynomial k 1+ (s, t) = padeApprox n n h+ d = fromIntegral $ max (1 + totalDegree' s) (totalDegree' t)+ in reversal d (recip (coeff one t) .*. t)
+ Algebra/Ring/Polynomial/Class.hs view
@@ -0,0 +1,554 @@+{-# LANGUAGE ConstraintKinds, DataKinds, DefaultSignatures #-}+{-# LANGUAGE ExplicitNamespaces, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE GADTs, LiberalTypeSynonyms, MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude, ParallelListComp, PolyKinds, RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- | This module provides abstract classes for finitary polynomial types.+module Algebra.Ring.Polynomial.Class+ ( IsPolynomial(..), IsOrderedPolynomial(..)+ , substCoeff, liftMapCoeff+ , CoeffRing, oneNorm, maxNorm, monoize,+ sPolynomial, pDivModPoly, content, pp,+ injectVars, vars,+ PrettyCoeff(..), ShowSCoeff(..),+ showsCoeffAsTerm, showsCoeffWithOp,+ showsPolynomialWith, showPolynomialWith,+ -- * Polynomial division+ divModPolynomial, divPolynomial, modPolynomial+ ) where+import Algebra.Internal+import Algebra.Normed+import Algebra.Ring.Polynomial.Monomial+import Algebra.Scalar++import AlgebraicPrelude+import Control.Arrow ((***))+import Control.Lens (Iso', folded, ifoldMap, iso, ix,+ maximumOf, (%~), _Wrapped)+import Data.Foldable (foldr, maximum)+import qualified Data.Foldable as F+import qualified Data.HashSet as HS+import Data.Int+import qualified Data.List as L+import qualified Data.Map.Strict as M+import Data.Maybe (catMaybes, fromMaybe)+import qualified Data.Ratio as R+import qualified Data.Set as S+import Data.Singletons.Prelude (SingKind (..))+import qualified Data.Sized.Builtin as V+import Data.Type.Ordinal (Ordinal, enumOrdinal, inclusion)+import Data.Word+import GHC.TypeLits (KnownNat, Nat)+import qualified Numeric.Algebra.Complex as NA+import Numeric.Decidable.Zero (DecidableZero (..))+import Numeric.Domain.Euclidean (Euclidean, quot)+import Numeric.Domain.GCD (gcd)+import Numeric.Field.Fraction (Fraction)+import qualified Numeric.Field.Fraction as NA+import Numeric.Natural (Natural)+import qualified Numeric.Ring.Class as NA+import qualified Prelude as P++infixl 7 *<, >*, *|<, >|*, !*++-- | Constraint synonym for rings that can be used as polynomial coefficient.+class (DecidableZero r, Ring r, Commutative r, Eq r) => CoeffRing r+instance (DecidableZero r, Ring r, Commutative r, Eq r) => CoeffRing r++-- | Polynomial in terms of free associative commutative algebra generated+-- by n-elements.+-- To effectively compute all terms, we need @'monomials'@ in addition to+-- universality of free object.+class (CoeffRing (Coefficient poly), Eq poly, DecidableZero poly, KnownNat (Arity poly),+ Module (Scalar (Coefficient poly)) poly, Ring poly, Commutative poly)+ => IsPolynomial poly where+ {-# MINIMAL ((liftMap , monomials) | terms'), (sArity | sArity') , (fromMonomial | toPolynomial' | polynomial') #-}+ -- | Coefficient ring of polynomial type.+ type Coefficient poly :: *+ -- | Arity of polynomial type.+ type Arity poly :: Nat++ -- | Universal mapping for free algebra.+ -- This corresponds to the algebraic substitution operation.+ liftMap :: (Module (Scalar (Coefficient poly)) alg, Ring alg, Commutative alg)+ => (Ordinal (Arity poly) -> alg) -> poly -> alg+ liftMap mor f =+ sum [ Scalar r .* sum [ Scalar (fromInteger' (P.fromIntegral i) :: Coefficient poly) .* mor o+ | i <- V.toList (m :: Monomial (Arity poly)) :: [Int]+ | o <- enumOrdinal (sArity (Nothing :: Maybe poly)) ]+ | (m, r) <- M.toList (terms' f) ]+ {-# INLINE liftMap #-}++ -- | A variant of @'liftMap'@, each value is given by @'Sized'@.+ subst :: (Ring alg, Commutative alg, Module (Scalar (Coefficient poly)) alg)+ => Sized (Arity poly) alg -> poly -> alg+ subst dic f = liftMap (dic V.%!!) f+ {-# INLINE subst #-}++ -- | Another variant of @'liftMap'@.+ -- This function relies on @'terms''@; if you have more efficient implementation,+ -- it is encouraged to override this method.+ substWith :: (Unital r, Monoidal m)+ => (Coefficient poly -> r -> m) -> Sized (Arity poly) r -> poly -> m+ substWith o pt poly =+ runAdd $ ifoldMap ((Add .) . flip o . extractPower) $ terms' poly+ where+ extractPower = runMult . ifoldMap (\k -> Mult . pow (pt V.%!! k) . P.fromIntegral)+ {-# INLINE substWith #-}++ -- | Arity of given polynomial.+ sArity' :: poly -> SNat (Arity poly)+ sArity' = sArity . Just++ -- | Arity of given polynomial, using type proxy.+ sArity :: proxy poly -> SNat (Arity poly)+ sArity _ = sArity' (zero :: poly)+ {-# INLINE sArity #-}++ -- | Non-dependent version of arity.+ arity :: proxy poly -> P.Integer+ arity _pxy = fromSing (sArity' (zero :: poly))+ {-# INLINE arity #-}++ -- | Inject coefficient into polynomial.+ injectCoeff :: Coefficient poly -> poly+ injectCoeff r = Scalar r .* one+ {-# INLINE injectCoeff #-}++ -- | Inject coefficient into polynomial with result-type explicitly given.+ injectCoeff' :: proxy poly -> Coefficient poly -> poly+ injectCoeff' _ = injectCoeff+ {-# INLINE injectCoeff' #-}++ -- | @'monomials' f@ returns the finite set of all monomials appearing in @f@.+ monomials :: poly -> HS.HashSet (Monomial (Arity poly))+ monomials = HS.fromList . M.keys . terms'+ {-# INLINE monomials #-}++ -- | @'monomials' f@ returns the finite set of all terms appearing in @f@;+ -- Term is a finite map from monomials to non-zero coefficient.+ terms' :: poly -> M.Map (Monomial (Arity poly)) (Coefficient poly)+ terms' f = M.fromList [ (m, c)+ | m <- HS.toList $ monomials f+ , let c = coeff' m f+ , not (isZero c)+ ]+ {-# INLINE terms' #-}++ -- | @'coeff m f'@ returns the coefficient of monomial @m@ in polynomial @f@.+ coeff' :: Monomial (Arity poly) -> poly -> Coefficient poly+ coeff' m = M.findWithDefault zero m . terms'+ {-# INLINE coeff' #-}++ -- | Calculates constant coefficient.+ constantTerm :: poly -> Coefficient poly+ constantTerm = runScalar . liftMap (\ _ -> Scalar zero)+ {-# INLINE constantTerm #-}++ -- | Inject monic monomial.+ fromMonomial :: Monomial (Arity poly) -> poly+ fromMonomial m = toPolynomial' (one , m)+ {-# INLINE fromMonomial #-}++ -- | Inject coefficient with monomial.+ toPolynomial' :: (Coefficient poly, Monomial (Arity poly)) -> poly+ toPolynomial' (r, deg) = Scalar r .* fromMonomial deg+ {-# INLINE toPolynomial' #-}++ -- | Construct polynomial from the given finite mapping from monomials to coefficients.+ polynomial' :: M.Map (Monomial (Arity poly)) (Coefficient poly) -> poly+ polynomial' dic =+ sum [ toPolynomial' (r, deg) | (deg, r) <- M.toList dic ]+ {-# INLINE polynomial' #-}++ -- | Returns total degree.+ totalDegree' :: poly -> Natural+ totalDegree' = maybe 0 fromIntegral . maximumOf folded . HS.map P.sum . monomials+ {-# INLINE totalDegree' #-}++ -- | @'var' n@ returns a polynomial representing n-th variable.+ var :: Ordinal (Arity poly) -> poly+ var nth = fromMonomial $ varMonom (sArity' (zero :: poly)) nth++ -- | Adjusting coefficients of each term.+ mapCoeff' :: (Coefficient poly -> Coefficient poly) -> poly -> poly+ mapCoeff' f = polynomial' . fmap f . terms'++ -- | @m '>|*' f@ multiplies polynomial @f@ by monomial @m@.+ (>|*) :: Monomial (Arity poly) -> poly -> poly+ m >|* f = toPolynomial' (one, m) * f++ -- | Flipped version of @('>|*')@+ (*|<) :: poly -> Monomial (Arity poly) -> poly+ (*|<) = flip (>|*)++ (!*) :: Coefficient poly -> poly -> poly+ (!*) = (.*.)+++ _Terms' :: Iso' poly (Map (Monomial (Arity poly)) (Coefficient poly))+ _Terms' = iso terms' polynomial'+ {-# INLINE _Terms' #-}++ mapMonomial :: (Monomial (Arity poly) -> Monomial (Arity poly)) -> poly -> poly+ mapMonomial tr =+ _Terms' %~ M.mapKeysWith (+) tr+ {-# INLINE mapMonomial #-}++{-# RULES+"liftMap/identity" liftMap (\ x -> x) = (P.id :: poly -> poly)+"liftMap/identity-2" liftMap P.id = (P.id :: poly -> poly)+ #-}++-- | Class to lookup ordering from its (type-level) name.+class (IsMonomialOrder (Arity poly) (MOrder poly), IsPolynomial poly) => IsOrderedPolynomial poly where+ type MOrder poly :: *+ {-# MINIMAL leadingTerm | (leadingMonomial , leadingCoeff) #-}++ -- | A variant of @'coeff''@ which takes @'OrderedMonomial'@ instead of @'Monomial'@+ coeff :: OrderedMonomial (MOrder poly) (Arity poly) -> poly -> Coefficient poly+ coeff m = coeff' (getMonomial m)+ {-# INLINE coeff #-}++ -- | The default implementation is not enough efficient.+ -- So it is strongly recomended to give explicit+ -- definition to @'terms'@.+ terms :: poly -> M.Map (OrderedMonomial (MOrder poly) (Arity poly)) (Coefficient poly)+ terms = M.mapKeys OrderedMonomial . terms'++ -- | Leading term with respect to its monomial ordering.+ leadingTerm :: poly -> (Coefficient poly, OrderedMonomial (MOrder poly) (Arity poly))+ leadingTerm = (,) <$> leadingCoeff <*> leadingMonomial+ {-# INLINE leadingTerm #-}++ -- | Leading monomial with respect to its monomial ordering.+ leadingMonomial :: poly -> OrderedMonomial (MOrder poly) (Arity poly)+ leadingMonomial = snd . leadingTerm+ {-# INLINE leadingMonomial #-}++ -- | Leading coefficient with respect to its monomial ordering.+ leadingCoeff :: poly -> Coefficient poly+ leadingCoeff = fst . leadingTerm+ {-# INLINE leadingCoeff #-}++ -- | The collection of all monomials in the given polynomial,+ -- with metadata of their ordering.+ orderedMonomials :: poly -> S.Set (OrderedMonomial (MOrder poly) (Arity poly))+ orderedMonomials = S.fromList . P.map OrderedMonomial . HS.toList . monomials+ {-# INLINE orderedMonomials #-}++ -- | A variant of @'fromMonomial'@ which takes @'OrderedMonomial'@ as argument.+ fromOrderedMonomial :: OrderedMonomial (MOrder poly) (Arity poly) -> poly+ fromOrderedMonomial = fromMonomial . getMonomial+ {-# INLINE fromOrderedMonomial #-}++ -- | A variant of @'toPolynomial''@ which takes @'OrderedMonomial'@ as argument.+ toPolynomial :: (Coefficient poly, OrderedMonomial (MOrder poly) (Arity poly)) -> poly+ toPolynomial (r, deg) = toPolynomial' (r, getMonomial deg)+ {-# INLINE toPolynomial #-}++ -- | A variant of @'polynomial''@ which takes @'OrderedMonomial'@ as argument.+ --+ -- The default implementation combines @'Data.Map.mapKeys'@ and @'polynomial''@,+ -- hence is not enough efficient. So it is strongly recomended to give explicit+ -- definition to @'polynomial'@.+ polynomial :: M.Map (OrderedMonomial (MOrder poly) (Arity poly)) (Coefficient poly)+ -> poly+ polynomial dic = polynomial' $ M.mapKeys getMonomial dic+ {-# INLINE polynomial #-}++ -- | A variant of @'(>|*)'@ which takes @'OrderedMonomial'@ as argument.+ (>*) :: OrderedMonomial (MOrder poly) (Arity poly) -> poly -> poly+ m >* f = toPolynomial (one, m) * f+ {-# INLINE (>*) #-}++ -- | Flipped version of (>*)+ (*<) :: poly -> OrderedMonomial (MOrder poly) (Arity poly) -> poly+ (*<) = flip (>*)+ {-# INLINE (*<) #-}++ _Terms :: Iso' poly (Map (OrderedMonomial (MOrder poly) (Arity poly)) (Coefficient poly))+ _Terms = iso terms polynomial+ {-# INLINE _Terms #-}++ -- | @diff n f@ partially diffrenciates @n@-th variable in the given polynomial @f@.+ -- The default implementation uses @'terms'@ and @'polynomial'@+ -- and is really naive; please consider overrideing for efficiency.+ diff :: Ordinal (Arity poly) -> poly -> poly+ diff n = _Terms %~ M.mapKeysWith (+) (_Wrapped.ix n %~ max 0 . pred)+ . M.mapMaybeWithKey df+ where+ df m v =+ let p = getMonomial m V.%!! n+ v' = NA.fromIntegral p * v+ in if p == 0 || isZero v'+ then Nothing+ else Just v'+ {-# INLINE diff #-}++ -- | Same as @'mapMonomial'@, but maping function is+ -- assumed to be strictly monotonic (i.e. @a < b@ implies @f a < f b@).+ mapMonomialMonotonic+ :: (OrderedMonomial (MOrder poly) (Arity poly) -> OrderedMonomial (MOrder poly) (Arity poly))+ -> poly -> poly+ mapMonomialMonotonic tr =+ _Terms %~ M.mapKeysMonotonic tr+ {-# INLINE mapMonomialMonotonic #-}++liftMapCoeff :: IsPolynomial poly => (Ordinal (Arity poly) -> (Coefficient poly)) -> poly -> Coefficient poly+liftMapCoeff l = runScalar . liftMap (Scalar . l)+{-# INLINE liftMapCoeff #-}++substCoeff :: IsPolynomial poly => Sized (Arity poly) (Coefficient poly) -> poly -> Coefficient poly+substCoeff l = runScalar . subst (fmap Scalar l)+{-# INLINE substCoeff #-}++-- | 1-norm of given polynomial, taking sum of @'norm'@s of each coefficients.+oneNorm :: (IsPolynomial poly, Normed (Coefficient poly),+ Monoidal (Norm (Coefficient poly))) => poly -> Norm (Coefficient poly)+oneNorm = sum . P.map norm . F.toList . terms'+{-# INLINE oneNorm #-}++-- | Maximum norm of given polynomial, taking maximum of the @'norm'@s of each coefficients.+maxNorm :: (IsPolynomial poly, Normed (Coefficient poly)) => poly -> Norm (Coefficient poly)+maxNorm = maximum . map norm . F.toList . terms'+{-# INLINE maxNorm #-}++-- | Make the given polynomial monic.+-- If the given polynomial is zero, it returns as it is.+monoize :: (Field (Coefficient poly), IsOrderedPolynomial poly)+ => poly -> poly+monoize f | isZero f = zero+ | otherwise = recip (leadingCoeff f) .*. f+{-# INLINE monoize #-}++-- | @'sPolynomial'@ calculates the S-Polynomial of given two polynomials.+sPolynomial :: (IsOrderedPolynomial poly, Field (Coefficient poly))+ => poly+ -> poly -> poly+sPolynomial f g =+ let h = (one, lcmMonomial (leadingMonomial f) (leadingMonomial g))+ in toPolynomial (h `tryDiv` leadingTerm f) * f - toPolynomial (h `tryDiv` leadingTerm g) * g++-- | @pDivModPoly f g@ calculates the pseudo quotient and reminder of @f@ by @g@.+pDivModPoly :: (k ~ Coefficient poly, Euclidean k, IsOrderedPolynomial poly)+ => poly -> poly+ -> (poly, poly)+f0 `pDivModPoly` g =+ let k = fromIntegral $ totalDegree' f0 :: Integer+ l = fromIntegral $ totalDegree' g :: Integer+ in step (injectCoeff (pow (leadingCoeff g) (P.fromInteger (max 0 $ 1 + k - l) :: Natural)) * f0) zero+ where+ lm = leadingMonomial g+ step p quo+ | isZero p = (quo, p)+ | lm `divs` leadingMonomial p =+ let q = toPolynomial $ (leadingCoeff p `quot` leadingCoeff g, leadingMonomial p / leadingMonomial g)+ in step (p - (q * g)) (quo + q)+ | otherwise = (quo, p)++-- | The content of a polynomial f is the @'gcd'@ of all its coefficients.+content :: (IsPolynomial poly, Euclidean (Coefficient poly)) => poly -> Coefficient poly+content = foldr gcd zero . terms'+{-# INLINE content #-}++-- | @'pp' f@ calculates the primitive part of given polynomial @f@,+-- namely @f / content(f)@.+pp :: (Euclidean (Coefficient poly), IsPolynomial poly) => poly -> poly+pp f = mapCoeff' (`quot` content f) f+{-# INLINE pp #-}++injectVars :: ((Arity r :<= Arity r') ~ 'P.True,+ IsPolynomial r,+ IsPolynomial r',+ Coefficient r ~ Coefficient r') => r -> r'+injectVars = liftMap (var . inclusion)+{-# INLINE [1] injectVars #-}+{-# RULES "injectVars/identity" injectVars = P.id #-}++vars :: forall poly. IsPolynomial poly => [poly]+vars = map var $ enumOrdinal (sArity (Nothing :: Maybe poly))++-- | Coefficients which admits pretty-printing+class (P.Show r) => PrettyCoeff r where+ showsCoeff :: Int -> r -> ShowSCoeff+ showsCoeff d a = Positive (P.showsPrec d a)++defaultShowsOrdCoeff :: (P.Show r, Unital r, Group r, P.Ord r)+ => Int -> r -> ShowSCoeff+defaultShowsOrdCoeff d r+ | r P.== negate one = Negative Nothing+ | r P.< zero = Negative (Just $ P.showsPrec d (negate r))+ | r P.== zero = Vanished+ | r P.== one = OneCoeff+ | otherwise = Positive (P.showsPrec d r)++instance PrettyCoeff P.Integer where+ showsCoeff = defaultShowsOrdCoeff++instance PrettyCoeff Natural where+ showsCoeff d r+ | r == 0 = Vanished+ | otherwise = Positive (P.showsPrec d r)++instance PrettyCoeff P.Int where+ showsCoeff = defaultShowsOrdCoeff++instance PrettyCoeff Int64 where+ showsCoeff = defaultShowsOrdCoeff+instance PrettyCoeff Int16 where+ showsCoeff = defaultShowsOrdCoeff+instance PrettyCoeff Int32 where+ showsCoeff = defaultShowsOrdCoeff+instance PrettyCoeff Int8 where+ showsCoeff = defaultShowsOrdCoeff++instance PrettyCoeff Word64 where+ showsCoeff = defaultShowsOrdCoeff++instance PrettyCoeff Word16 where+ showsCoeff = defaultShowsOrdCoeff++instance PrettyCoeff Word32 where+ showsCoeff = defaultShowsOrdCoeff++instance PrettyCoeff Word8 where+ showsCoeff = defaultShowsOrdCoeff++instance (P.Integral a, PrettyCoeff a) => PrettyCoeff (R.Ratio a) where+ showsCoeff d r =+ if R.denominator r == 1+ then showsCoeff 10 (R.numerator r)+ else defaultShowsOrdCoeff d r++instance (PrettyCoeff r) => PrettyCoeff (NA.Complex r) where+ showsCoeff d (NA.Complex r i) =+ case (showsCoeff 10 r, showsCoeff 10 i) of+ (Vanished, Vanished) -> Vanished+ (Vanished, Positive s) -> Positive (s . P.showString " I")+ (Vanished, Negative s) -> Negative (Just $ fromMaybe P.id s . P.showString " I")+ (Positive s, Vanished) -> Positive s+ (Negative s, Vanished) -> Negative s+ (s, t) ->+ Positive $ P.showParen (d P.> 10) $+ showsCoeffAsTerm s . showsCoeffWithOp t++instance {-# OVERLAPPING #-} PrettyCoeff (Fraction P.Integer) where+ showsCoeff d r =+ if NA.denominator r == one+ then showsCoeff d (NA.numerator r)+ else defaultShowsOrdCoeff d r++instance {-# OVERLAPS #-}+ (PrettyCoeff r, Eq r, Euclidean r) => PrettyCoeff (Fraction r) where+ showsCoeff d r =+ if NA.denominator r == one+ then showsCoeff d (NA.numerator r)+ else Positive (P.showsPrec d r)++-- | Pretty-printing conditional for coefficients.+-- Each returning @'P.ShowS'@ must not have any sign.+data ShowSCoeff = Negative (Maybe P.ShowS)+ | Vanished+ | OneCoeff+ | Positive P.ShowS++-- | ShowS coefficients as term.+--+-- @+-- showsCoeffAsTerm 'Vanished' "" = ""+-- showsCoeffAsTerm ('Negative' (shows "12")) "" = "-12"+-- showsCoeffAsTerm ('Positive' (shows "12")) "" = "12"+-- @+showsCoeffAsTerm :: ShowSCoeff -> P.ShowS+showsCoeffAsTerm Vanished = P.id+showsCoeffAsTerm (Negative s) = P.showChar '-' . fromMaybe (P.showChar '1') s+showsCoeffAsTerm OneCoeff = P.showChar '1'+showsCoeffAsTerm (Positive s) = s++-- | ShowS coefficients prefixed with infix operator.+--+-- @+-- (shows 12 . showsCoeffWithOp 'Vanished') "" = "12"+-- (shows 12 . showsCoeffWithOp ('Negative' (shows 34))) "" = "12 - 34"+-- (shows 12 . showsCoeffWithOp ('Positive' (shows 34))) "" = "12 + 34"+-- @+showsCoeffWithOp :: ShowSCoeff -> P.ShowS+showsCoeffWithOp Vanished = P.id+showsCoeffWithOp (Negative s) = P.showString " - " . fromMaybe (P.showChar '1') s+showsCoeffWithOp OneCoeff = P.showString " + 1"+showsCoeffWithOp (Positive s) = P.showString " + " . s++showPolynomialWith :: (IsPolynomial poly, PrettyCoeff (Coefficient poly))+ => Sized (Arity poly) P.String+ -> Int+ -> poly+ -> P.String+showPolynomialWith vs i p = showsPolynomialWith vs i p ""++showsPolynomialWith :: (IsPolynomial poly, PrettyCoeff (Coefficient poly))+ => Sized (Arity poly) P.String+ -> Int+ -> poly+ -> P.ShowS+showsPolynomialWith vsVec d f = P.showParen (d P.> 10) $+ let tms = map (showMonom *** showsCoeff 10) $ M.toDescList $ terms' f+ in case tms of+ [] -> P.showString "0"+ (mc : ts) -> P.foldr1 (.) $+ (showTermOnly mc) : map showRestTerm ts+ where+ showTermOnly (Nothing, Vanished) = P.id+ showTermOnly (Nothing, s) = showsCoeffAsTerm s+ showTermOnly (Just m, OneCoeff) = m+ showTermOnly (Just m, Negative Nothing) = P.showChar '-' . m+ showTermOnly (Just _, Vanished) = P.id+ showTermOnly (Just m, t) = showsCoeffAsTerm t . P.showChar ' ' . m+ showRestTerm (Nothing, Vanished) = P.id+ showRestTerm (Nothing, s) = showsCoeffWithOp s+ showRestTerm (Just m, OneCoeff) = P.showString " + " . m+ showRestTerm (Just m, Negative Nothing) = P.showString " - " . m+ showRestTerm (Just _, Vanished) = P.id+ showRestTerm (Just m, t) = showsCoeffWithOp t . P.showChar ' ' . m+ vs = F.toList vsVec+ showMonom m =+ let fs = catMaybes $ P.zipWith showFactor vs $ F.toList m+ in if P.null fs+ then Nothing+ else Just $ foldr (.) P.id $ L.intersperse (P.showChar ' ') (map P.showString fs)+ showFactor _ 0 = Nothing+ showFactor v 1 = Just v+ showFactor v n = Just $ v P.++ "^" P.++ P.show n++-- | Calculate a polynomial quotient and remainder w.r.t. second argument.+divModPolynomial :: (IsOrderedPolynomial poly, Field (Coefficient poly))+ => poly -> [poly]+ -> ([(poly, poly)], poly)+divModPolynomial f0 fs = loop f0 zero (P.zip (L.nub fs) (P.repeat zero))+ where+ loop p r dic+ | isZero p = (dic, r)+ | otherwise =+ let ltP = toPolynomial $ leadingTerm p+ in case L.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 P.++ (g, old + q) : ys+ in loop (p - (q * g)) r dic'+{-# INLINABLE divModPolynomial #-}++-- | Remainder of given polynomial w.r.t. the second argument.+modPolynomial :: (IsOrderedPolynomial poly, Field (Coefficient poly))+ => poly -> [poly] -> poly+modPolynomial = (snd .) . divModPolynomial++-- | A Quotient of given polynomial w.r.t. the second argument.+divPolynomial :: (IsOrderedPolynomial poly, Field (Coefficient poly))+ => poly -> [poly] -> [(poly, poly)]+divPolynomial = (fst .) . divModPolynomial++infixl 7 `divPolynomial`+infixl 7 `modPolynomial`+infixl 7 `divModPolynomial`
+ Algebra/Ring/Polynomial/Factorise.hs view
@@ -0,0 +1,378 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE BangPatterns, DataKinds, FlexibleContexts, GADTs #-}+{-# LANGUAGE MultiParamTypeClasses, NoImplicitPrelude, OverloadedStrings #-}+{-# LANGUAGE ParallelListComp, PatternSynonyms, PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables, TupleSections #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+module Algebra.Ring.Polynomial.Factorise+ ( -- * Factorisation+ factorise, factorQBigPrime, factorHensel,+ -- * Internal helper functions+ distinctDegFactor,+ equalDegreeSplitM, equalDegreeFactorM,+ henselStep, clearDenom,+ squareFreePart, squareFreeDecomp+ ) where+import Algebra.Algorithms.PrimeTest hiding (modPow)+import Algebra.Field.Finite+import Algebra.Prelude.Core+import Algebra.Ring.Polynomial.Quotient+import Algebra.Ring.Polynomial.Univariate++import Control.Applicative ((<|>))+import Control.Arrow ((***), (<<<))+import Control.Lens (both, ifoldl, (%~), (&))+import Control.Monad (guard, replicateM)+import Control.Monad (when)+import Control.Monad.Loops (iterateUntil, untilJust)+import Control.Monad.Random (MonadRandom, uniform)+import Control.Monad.ST.Strict (ST, runST)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Loop (continue, foreach, while)+import qualified Data.DList as DL+import Data.IntMap (IntMap)+import qualified Data.IntMap.Strict as IM+import qualified Data.List as L+import Data.Maybe (fromJust)+import Data.Monoid (Sum (..))+import Data.Monoid ((<>))+import Data.Numbers.Primes (primes)+import Data.Proxy (Proxy (..))+import qualified Data.Set as S+import qualified Data.Sized.Builtin as SV+import Data.STRef.Strict (STRef, modifySTRef, newSTRef)+import Data.STRef.Strict (readSTRef, writeSTRef)+import qualified Data.Traversable as F+import Data.Type.Ordinal (pattern OZ)+import qualified Data.Vector as V+import Math.NumberTheory.Logarithms (intLog2', integerLogBase')+import Math.NumberTheory.Powers.Squares (integerSquareRoot)+import Numeric.Decidable.Zero (isZero)+import Numeric.Domain.GCD (gcd, lcm)+import qualified Numeric.Field.Fraction as F+import qualified Prelude as P++-- | @distinctDegFactor f@ computes the distinct-degree decomposition of the given+-- square-free polynomial over finite field @f@.+distinctDegFactor :: forall k. (Eq k, FiniteField k)+ => Unipol k -- ^ Square-free polynomial over finite field.+ -> [(Natural, Unipol k)] -- ^ Distinct-degree decomposition.+distinctDegFactor f0 = zip [1..] $ go id (var OZ :: Unipol k) f0 []+ where+ go gs h f =+ let h' = modPow h (order (Proxy :: Proxy k)) f+ g' = gcd (h' - var 0) f+ f' = f `quot` g'+ gs' = gs . (g' :)+ in if f' == one+ then gs'+ else go gs' h' f'++modPow :: (Field (Coefficient poly), IsOrderedPolynomial poly)+ => poly -> Natural -> poly -> poly+modPow a p f = withQuotient (principalIdeal f) $+ repeatedSquare (modIdeal a) p++traceCharTwo :: (Unital m, Monoidal m) => Natural -> m -> m+traceCharTwo m a = sum [ a ^ (2 ^ i) | i <- [0..pred m]]++equalDegreeSplitM :: forall k m. (MonadRandom m, CoeffRing k, FiniteField k)+ => Unipol k+ -> Natural+ -> m (Maybe (Unipol k))+equalDegreeSplitM f d+ | fromIntegral (totalDegree' f) `mod` d /= 0 = return Nothing+ | otherwise = do+ let q = fromIntegral $ order (Proxy :: Proxy k)+ n = totalDegree' f+ els = elements (Proxy :: Proxy k)+ e <- uniform [1..n P.- 1]+ cs <- replicateM (fromIntegral e) $ uniform els+ let a = var 0 ^ fromIntegral e ++ sum (zipWith (*) (map injectCoeff cs) [var 0 ^ l | l <-[0..]])+ g1 = gcd a f+ return $ (guard (g1 /= one) >> return g1)+ <|> do let b | charUnipol f == 2 = traceCharTwo (powerUnipol f*d) a+ | otherwise = modPow a ((pred $ q^d)`div`2) f+ g2 = gcd (b - one) f+ guard (g2 /= one && g2 /= f)+ return g2++equalDegreeFactorM :: (Eq k, FiniteField k, MonadRandom m)+ => Unipol k -> Natural -> m [Unipol k]+equalDegreeFactorM f d = go f >>= \a -> return (a [])+ where+ go h | totalDegree' h == 0 = return id+ | otherwise =+ if fromIntegral (totalDegree' h) == d+ then return (h:)+ else do+ g <- untilJust (equalDegreeSplitM h d)+ l <- go g+ r <- go (h `quot` g)+ return $ l . r++factorSquareFree :: (Eq k, FiniteField k, MonadRandom m)+ => Unipol k -> m [Unipol k]+factorSquareFree f =+ concat <$> mapM (uncurry $ flip equalDegreeFactorM) (filter ((/= one) . snd) $ distinctDegFactor f)++squareFreePart :: (Eq k, FiniteField k)+ => Unipol k -> Unipol k+squareFreePart f =+ let !n = fromIntegral $ totalDegree' f+ u = gcd f (diff 0 f)+ v = f `quot` u+ f' = u `quot` gcd u (v ^ n)+ in if f' == one+ then v+ else v * squareFreePart (pthRoot f')++yun :: (CoeffRing r, Field r)+ => Unipol r -> IntMap (Unipol r)+yun f = let f' = diff OZ f+ u = gcd f f'+ in go 1 IM.empty (f `quot` u) (f' `quot` u)+ where+ go !i dic v w =+ let t = w - diff OZ v+ h = gcd v t+ v' = v `quot` h+ w' = t `quot` h+ dic' = IM.insert i h dic+ in if v' == one+ then dic'+ else go (i+1) dic' v' w'++charUnipol :: forall r. Characteristic r => Unipol r -> Natural+charUnipol _ = char (Proxy :: Proxy r)++powerUnipol :: forall r. FiniteField r => Unipol r -> Natural+powerUnipol _ = power (Proxy :: Proxy r)++pthRoot :: (CoeffRing r, Characteristic r) => Unipol r -> Unipol r+pthRoot f =+ let !p = charUnipol f+ in if p == 0+ then error "char R should be positive prime"+ else mapMonomial (SV.map (`P.div` fromIntegral p)) f++squareFreeDecomp :: (Eq k, Characteristic k, Field k)+ => Unipol k -> IntMap (Unipol k)+squareFreeDecomp f =+ let dcmp = yun f+ f' = ifoldl (\i u g -> u `quot` (g ^ fromIntegral i)) f dcmp+ p = fromIntegral $ charUnipol f+ in if charUnipol f == 0+ then dcmp+ else if isZero (f' - one)+ then dcmp+ else IM.filter (not . isZero . subtract one) $+ IM.unionWith (*) dcmp $ IM.mapKeys (p*) $ squareFreeDecomp $ pthRoot f'++-- | Factorise a polynomial over finite field using Cantor-Zassenhaus algorithm+factorise :: (MonadRandom m, CoeffRing k, FiniteField k)+ => Unipol k -> m [(Unipol k, Natural)]+factorise f = do+ concat <$> mapM (\(r, h) -> map (,fromIntegral r) <$> factorSquareFree h) (IM.toList $ squareFreeDecomp f)++clearDenom :: (CoeffRing a, Euclidean a)+ => Unipol (Fraction a) -> (a, Unipol a)+clearDenom f =+ let g = foldr (lcm . denominator) one $ terms' f+ in (g, mapCoeffUnipol (numerator . ((g F.% one)*)) f)++-- | Factorise the given integer-coefficient polynomial,+-- choosing a large enough prime.+factorQBigPrime :: (MonadRandom m)+ => Unipol Integer -> m (Integer, IntMap (Set (Unipol Integer)))+factorQBigPrime = wrapSQFFactor factorSqFreeQBP++-- | Factorise the given interger-coefficient polynomial by Hensel lifting.+factorHensel :: (MonadRandom m)+ => Unipol Integer -> m (Integer, IntMap (Set (Unipol Integer)))+factorHensel = wrapSQFFactor factorHenselSqFree++wrapSQFFactor :: (MonadRandom m)+ => (Unipol Integer -> m [Unipol Integer])+ -> Unipol Integer -> m (Integer, IntMap (Set (Unipol Integer)))+wrapSQFFactor fac f0 = do+ let (g, c) | leadingCoeff f0 < 0 = (- pp f0, - content f0)+ | otherwise = (pp f0, content f0)+ ts0 <- F.mapM (secondM fac . clearDenom) (squareFreeDecomp $ monoize $ mapCoeffUnipol (F.% 1) g)+ let anss = IM.toList ts0+ k = c * leadingCoeff g `div` product (map (fst.snd) anss)+ return $ (k, IM.fromList $ map (second $ S.fromList . snd) anss)+++secondM :: Functor f => (t -> f a) -> (t1, t) -> f (t1, a)+secondM f (a, b)= (a,) <$> f b++(<@>) :: (a -> b) -> STRef s a -> ST s b+(<@>) f r = f <$> readSTRef r++infixl 5 <@>++factorSqFreeQBP :: (MonadRandom m)+ => Unipol Integer -> m [Unipol Integer]+factorSqFreeQBP f+ | n == 1 = return [f]+ | otherwise = do+ p <- iterateUntil isSqFreeMod (uniform ps)+ reifyPrimeField p $ \fp -> do+ let fbar = mapCoeffUnipol (modNat' fp) f+ gvec <- V.fromList . concatMap (uncurry (flip replicate) <<< (normalizeMod p . mapCoeffUnipol naturalRepr) *** fromEnum)+ <$> factorise (monoize fbar)+ return $ runST $ do+ bb <- newSTRef b+ s <- newSTRef 1+ ts <- newSTRef [0..V.length gvec - 1]+ gs <- newSTRef []+ f' <- newSTRef f+ while ((<=) <$> (2*) <@> s <*> length <@> ts) $ do+ ts0 <- lift $ readSTRef ts+ s0 <- lift $ readSTRef s+ b0 <- lift $ readSTRef bb+ foreach (comb s0 ts0) $ \ss -> do+ let delta = ts0 L.\\ ss+ g' = normalizeMod p $ b0 .*. product [ gvec V.! i | i <- ss]+ h' = normalizeMod p $ b0 .*. product [ gvec V.! i | i <- delta]+ when (oneNorm g' * oneNorm h' <= floor b') $ do+ lift $ lift $ do+ writeSTRef ts delta+ modifySTRef gs (pp g' :)+ writeSTRef f' $ pp h'+ writeSTRef bb $ leadingCoeff $ pp h'+ lift continue+ lift $ modifySTRef s (+1)+ (:) <$> readSTRef f' <*> readSTRef gs+ where+ ps = takeWhile (< floor (4*b')) $ dropWhile (<= ceiling (2*b')) $ tail primes+ b = leadingCoeff f+ a = maxNorm f+ b' = P.product [ P.sqrt (fromIntegral n P.+ 1), 2 P.^^ n, fromIntegral a, fromIntegral b]+ :: Double+ n = totalDegree' f+ isSqFreeMod :: Integer -> Bool+ isSqFreeMod p = reifyPrimeField p $ \fp ->+ let fbar = mapCoeffUnipol (modNat' fp) f+ in gcd fbar (diff OZ fbar) == one++factorHenselSqFree :: MonadRandom m+ => Unipol Integer -> m [Unipol Integer]+factorHenselSqFree f =+ let lc = leadingCoeff f+ Just p = find isGoodPrime primes+ normF = integerSquareRoot (getSum $ foldMap (Sum . (^2)) $ terms f) + 1+ power = succ $ intLog2' $ integerLogBase' p $ normF * 2 ^ (totalDegree' f + 1)+ in reifyPrimeField p $ \fp -> do+ let lc' = modNat' fp lc+ f0 = mapCoeffUnipol ((/lc') . modNat' fp) f+ fps <- factorise f0+ let gs = multiHensel (fromIntegral p) power f $+ map (mapCoeffUnipol naturalRepr . fst) fps+ return $ loop (p^2^fromIntegral power) 1 (length gs) f gs []+ where+ lc = leadingCoeff f+ isGoodPrime p = reifyPrimeField p $ \fp ->+ lc `mod` p /= 0 && isSquareFree (mapCoeffUnipol (modNat' fp) f)+ loop pk !l m !h gs acc+ | fromIntegral (2 * l) > m = if h == one then acc else h : acc+ | otherwise =+ let cands = [ (ss, g, q)+ | ss <- comb l gs+ , let g = normalizeMod pk $ lc .* product ss+ , let (q, r) = pDivModPoly (lc .* h) g+ , isZero r+ , leadingCoeff q * leadingCoeff g == lc * leadingCoeff h+ ]+ in case cands of+ [] -> loop pk (l + 1) m h gs acc+ ((ss, g, q) : _) ->+ let u = leadingCoeff g `div` content g+ in loop pk l m (mapCoeff' (`div` u) q) (gs L.\\ ss) (pp g : acc)++-- | Given that @f = gh (mod m)@ with @sg + th = 1 (mod m)@ and @leadingCoeff f@ isn't zero divisor mod m,+-- @henselStep m f g h s t@ calculates the unique (g', h', s', t') s.t.+-- @f = g' h' (mod m^2), g' = g (mod m), h' = h (mod m), s' = s (mod m), t' = t (mod m)@, @h'@ monic.+henselStep :: (Eq r, Euclidean r)+ => r -- ^ modulus+ -> Unipol r+ -> Unipol r+ -> Unipol r+ -> Unipol r+ -> Unipol r+ -> (Unipol r, Unipol r, Unipol r, Unipol r)+henselStep m f g h s t =+ let modCoeff = mapCoeffUnipol (`rem` m^2)+ divModSq u v = mapCoeffUnipol (F.% one) u `divide` mapCoeffUnipol (F.% one) v+ & both %~ mapCoeffUnipol (fromJust . modFraction (m^2))+ e = modCoeff $ f - g * h+ (q, r) = divModSq (s*e) h+ g' = modCoeff $ g + t * e + q * g+ h' = modCoeff $ h + r+ b = modCoeff $ s*g' + t*h' - one+ (c, d) = divModSq (s*b) h'+ s' = modCoeff $ s - d+ t' = modCoeff $ t - t*b - c*g'+ in (g', h', s', t')++-- | Repeatedly applies hensel lifting for monics.+repeatHensel :: Integer -> Int+ -> Unipol Integer+ -> Unipol Integer -> Unipol Integer+ -> Unipol Integer -> Unipol Integer+ -> (Unipol Integer, Unipol Integer, Unipol Integer, Unipol Integer)+repeatHensel !m 0 _ g h s t = (normalizeMod m g, normalizeMod m h, s, t)+repeatHensel !m n f g h s t =+ let (g', h', s', t') = henselStep m f g h s t+ in repeatHensel (m ^ 2) (n - 1) f g' h' s' t'++-- | Monic hensel lifting for many factors.+multiHensel :: Natural -- ^ prime @p@+ -> Int -- ^ iteration count @k@.+ -> Unipol Integer -- ^ original polynomial+ -> [Unipol Integer] -- ^ coprime factorisation mod @p@+ -> [Unipol Integer] -- ^ coprime factorisation mod @p^(2^k)@.+multiHensel p n f [_] = [normalizeMod (fromNatural p^fromIntegral n) f]+multiHensel p n f [g, h] = reifyPrimeField (fromNatural p) $ \fp ->+ let (_, s0, t0) = head $+ euclid+ (mapCoeffUnipol (modNat' fp) g)+ (mapCoeffUnipol (modNat' fp) h)+ (s, t) = (s0, t0) & both %~ mapCoeffUnipol naturalRepr+ (g', h', _, _) = repeatHensel (fromNatural p) n f g h s t+ in [g', h']+multiHensel p n f gs = reifyPrimeField (fromNatural p) $ \fp ->+ let (ls, rs) = splitAt (length gs `div` 2) gs+ (l, r) = (product ls, product rs)+ (_, s0, t0) = head $+ euclid+ (mapCoeffUnipol (modNat' fp) l)+ (mapCoeffUnipol (modNat' fp) r)+ (s, t) = (s0, t0) & both %~ mapCoeffUnipol naturalRepr+ (fl, fr, _, _) = repeatHensel (fromNatural p) n f l r s t+ in multiHensel p n fl ls ++ multiHensel p n fr rs++recipMod :: (Euclidean a, Eq a) => a -> a -> Maybe a+recipMod m u =+ let (a, r, _) : _ = euclid u m+ in if a == one+ then Just r else Nothing++modFraction :: (Euclidean s, Eq s) => s -> Fraction s -> Maybe s+modFraction m d = ((numerator d `rem` m) *) <$> recipMod m (denominator d)++comb :: Int -> [a] -> [[a]]+comb = (DL.toList .) . go+ where+ go 0 [] = DL.singleton []+ go _ [] = DL.empty+ go k (x:xs) = DL.map (x :) (go (k - 1) xs) <> go k xs++normalizeMod :: Integer -> Unipol Integer -> Unipol Integer+normalizeMod p = mapCoeffUnipol (subtract half . (`mod` p) . (+ half))+ where half = p `div` 2++isSquareFree :: forall poly. (IsOrderedPolynomial poly, GCDDomain poly) => poly -> Bool+isSquareFree f = (f `gcd` diff 0 f) == one
+ Algebra/Ring/Polynomial/Labeled.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE CPP, ConstraintKinds, DataKinds, EmptyCase, FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances, GADTs, KindSignatures, IncoherentInstances #-}+{-# LANGUAGE MultiParamTypeClasses, PolyKinds, RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-}+{-# LANGUAGE TypeFamilies, TypeInType, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses, OverloadedLabels #-}+module Algebra.Ring.Polynomial.Labeled+ (IsUniqueList, LabPolynomial(..),+ LabPolynomial', LabUnipol,+ canonicalMap,+ canonicalMap',+ IsSubsetOf) where+import Algebra.Internal+import Algebra.Ring.Polynomial.Class+import Algebra.Ring.Polynomial+import Algebra.Ring.Polynomial.Univariate+import Algebra.Scalar++import qualified Prelude as P+import Data.Function (on)+import Data.Singletons.Prelude+import Data.Singletons.Prelude.Enum (SEnum (..))+import Data.Singletons.Prelude.List hiding (Group)+import qualified Data.Sized.Builtin as S+import Data.Type.Natural.Class (IsPeano (..), sOne)+import Data.Type.Ordinal+import GHC.Exts (Constraint)+import qualified Data.List as L+import Numeric.Algebra hiding (Order (..))+import Numeric.Decidable.Zero+import Prelude hiding (Integral (..), Num (..),+ product, sum)+import GHC.OverloadedLabels (IsLabel(..))++type family UniqueList' (x :: Symbol) (xs :: [Symbol]) :: Constraint where+ UniqueList' x '[] = ()+ UniqueList' x (x ': xs) = TypeError ('Text "The variable " ':<>: 'ShowType x ':<>: 'Text " occurs more than once!")+ UniqueList' x (y ': xs) = UniqueList' x xs++type family UniqueList (xs :: [Symbol]) :: Constraint where+ UniqueList '[] = ()+ UniqueList (x ': xs) = (UniqueList' x xs, UniqueList xs)++class (UniqueList xs) => IsUniqueList (xs :: [Symbol])+instance (UniqueList xs) => IsUniqueList (xs :: [Symbol])++-- | This instance allows something like @#x :: LabPolynomial (OrderedPolynomial Integer Grevlex 3) '["x", "y", "z"]@.+instance (KnownSymbol symb,+ SingI vars,+ UniqueList vars,+ IsPolynomial poly,+ Wraps vars poly,+ Elem symb vars ~ 'True) => IsLabel symb (LabPolynomial poly vars) where+ fromLabel k =+ let vs = fromSing (sing :: Sing vars)+ v = symbolVal' k+ in maybe (error "impossible!") (var . toEnum) $ L.elemIndex v vs++data LabPolynomial poly (vars :: [Symbol]) where+ LabelPolynomial :: (IsUniqueList vars, Length vars ~ Arity poly)+ => { unLabelPolynomial :: poly }+ -> LabPolynomial poly vars++-- | Convenient type-synonym for @'LabPlynomial'@ wrapping @'OrderedPolynomial'@+-- and @'Unipol'@.+type family LabPolynomial' r ord vars where+ LabPolynomial' r ord '[x] = LabPolynomial (Unipol r) '[x]+ LabPolynomial' r ord vars = LabPolynomial (OrderedPolynomial r ord (Length vars)) vars++-- | Convenient type-synonym for @'LabPlynomial'@ wrapping univariate polynomial @'Unipol'@.+type LabUnipol r sym = LabPolynomial (Unipol r) '[sym]++type Wraps vars poly = (IsUniqueList vars, Arity poly ~ Length vars)++instance (PrettyCoeff (Coefficient poly), IsOrderedPolynomial poly, SingI vars)+ => Show (LabPolynomial poly vars) where+ showsPrec d (LabelPolynomial f) =+ let svs = sing :: Sing vars+ vs = fromSing svs+ vsVec = generate sing $ \i -> vs !! fromEnum i+ in showsPolynomialWith vsVec d f++instance (UniqueList vars, Arity poly ~ Length vars, P.Num poly)+ => P.Num (LabPolynomial poly vars) where+ fromInteger = LabelPolynomial . P.fromInteger+ LabelPolynomial f + LabelPolynomial g = LabelPolynomial $ f P.+ g+ LabelPolynomial f * LabelPolynomial g = LabelPolynomial $ f P.* g+ abs = LabelPolynomial . P.abs . unLabelPolynomial+ LabelPolynomial f - LabelPolynomial g = LabelPolynomial $ f P.- g+ negate = LabelPolynomial . P.negate . unLabelPolynomial+ signum = LabelPolynomial . P.signum . unLabelPolynomial++instance (Wraps vars poly, Additive poly) => Additive (LabPolynomial poly vars) where+ LabelPolynomial f + LabelPolynomial g = LabelPolynomial $ f + g+ {-# INLINE (+) #-}++instance (Wraps vars poly, Multiplicative poly) => Multiplicative (LabPolynomial poly vars) where+ LabelPolynomial f * LabelPolynomial g =+ LabelPolynomial $ f * g+ {-# INLINE (*) #-}++instance (Wraps vars poly, Abelian poly) => Abelian (LabPolynomial poly vars)+instance (Wraps vars poly, Commutative poly) => Commutative (LabPolynomial poly vars)+instance (Wraps vars poly, Unital poly) => Unital (LabPolynomial poly vars) where+ one = LabelPolynomial one+ {-# INLINE one #-}++instance (Wraps vars poly, Group poly) => Group (LabPolynomial poly vars) where+ negate (LabelPolynomial f) = LabelPolynomial (negate f)+ {-# INLINE negate #-}++instance (Wraps vars poly, RightModule Natural poly) => RightModule Natural (LabPolynomial poly vars) where+ LabelPolynomial f *. a = LabelPolynomial $ f *. a+ {-# INLINE (*.) #-}++instance (Wraps vars poly, LeftModule Natural poly) => LeftModule Natural (LabPolynomial poly vars) where+ a .* LabelPolynomial f = LabelPolynomial $ a .* f+ {-# INLINE (.*) #-}++instance (Wraps vars poly, RightModule Integer poly) => RightModule Integer (LabPolynomial poly vars) where+ LabelPolynomial f *. a = LabelPolynomial $ f *. a+ {-# INLINE (*.) #-}++instance (Wraps vars poly, LeftModule Integer poly) => LeftModule Integer (LabPolynomial poly vars) where+ a .* LabelPolynomial f = LabelPolynomial $ a .* f+ {-# INLINE (.*) #-}++instance (Wraps vars poly, Monoidal poly) => Monoidal (LabPolynomial poly vars) where+ zero = LabelPolynomial zero+ {-# INLINE zero #-}++instance (Wraps vars poly, Semiring poly) => Semiring (LabPolynomial poly vars)+instance (Wraps vars poly, Rig poly) => Rig (LabPolynomial poly vars)+instance (Wraps vars poly, Ring poly) => Ring (LabPolynomial poly vars) where+ fromInteger n = LabelPolynomial (fromInteger n :: poly)+ {-# INLINE fromInteger #-}++instance (Wraps vars poly, LeftModule (Scalar r) poly) => LeftModule (Scalar r) (LabPolynomial poly vars) where+ a .* LabelPolynomial f = LabelPolynomial $ a .* f+ {-# INLINE (.*) #-}++instance (Wraps vars poly, RightModule (Scalar r) poly) => RightModule (Scalar r) (LabPolynomial poly vars) where+ LabelPolynomial f *. a = LabelPolynomial $ f *. a+ {-# INLINE (*.) #-}++instance (Wraps vars poly, DecidableZero poly) => DecidableZero (LabPolynomial poly vars) where+ isZero = isZero . unLabelPolynomial++instance (Wraps vars poly, Eq poly) => Eq (LabPolynomial poly vars) where+ (==) = (==) `on` unLabelPolynomial+ (/=) = (/=) `on` unLabelPolynomial++instance (Wraps vars poly, Ord poly) => Ord (LabPolynomial poly vars) where+ compare = compare `on` unLabelPolynomial+ (<=) = (<=) `on` unLabelPolynomial+ (>=) = (>=) `on` unLabelPolynomial+ (<) = (<) `on` unLabelPolynomial+ (>) = (>) `on` unLabelPolynomial++instance (IsPolynomial poly, Wraps vars poly) => IsPolynomial (LabPolynomial poly vars) where+ type Coefficient (LabPolynomial poly vars) = Coefficient poly+ type Arity (LabPolynomial poly vars) = Arity poly++ liftMap mor = liftMap mor . unLabelPolynomial+ {-# INLINE liftMap #-}++ terms' = terms' . unLabelPolynomial+ {-# INLINE terms' #-}++ monomials = monomials . unLabelPolynomial+ {-# INLINE monomials #-}++ coeff' m = coeff' m . unLabelPolynomial+ {-# INLINE coeff' #-}++ constantTerm = constantTerm . unLabelPolynomial+ {-# INLINE constantTerm #-}++ sArity _ = sArity (Proxy :: Proxy poly)+ {-# INLINE sArity #-}++ arity _ = arity (Proxy :: Proxy poly)+ {-# INLINE arity #-}++ fromMonomial m = LabelPolynomial (fromMonomial m :: poly)+ {-# INLINE fromMonomial #-}++ toPolynomial' (r, deg) = LabelPolynomial (toPolynomial' (r, deg) :: poly)+ {-# INLINE toPolynomial' #-}++ polynomial' dic = LabelPolynomial (polynomial' dic :: poly)+ {-# INLINE polynomial' #-}++ totalDegree' = totalDegree' . unLabelPolynomial+ {-# INLINE totalDegree' #-}++instance (IsOrderedPolynomial poly, Wraps vars poly) => IsOrderedPolynomial (LabPolynomial poly vars) where+ type MOrder (LabPolynomial poly vars) = MOrder poly++ leadingTerm = leadingTerm . unLabelPolynomial+ {-# INLINE leadingTerm #-}++ leadingCoeff = leadingCoeff . unLabelPolynomial+ {-# INLINE leadingCoeff #-}++ fromOrderedMonomial m = LabelPolynomial (fromOrderedMonomial m :: poly)+ {-# INLINE fromOrderedMonomial #-}++ toPolynomial (r, deg) = LabelPolynomial (toPolynomial (r, deg) :: poly)+ {-# INLINE toPolynomial #-}++ polynomial dic = LabelPolynomial (polynomial dic :: poly)+ {-# INLINE polynomial #-}++ terms = terms . unLabelPolynomial+ {-# INLINE terms #-}++ coeff m = coeff m . unLabelPolynomial+ {-# INLINE coeff #-}++class (All (FlipSym0 @@ ElemSym0 @@ ys) xs ~ 'True) => IsSubsetOf (xs :: [a]) (ys :: [a]) where+ _suppress :: proxy xs -> proxy ys -> x -> x+ _suppress _ _ = id+instance (All (FlipSym0 @@ ElemSym0 @@ ys) xs ~ 'True) => IsSubsetOf (xs :: [a]) (ys :: [a])++-- | So unsafe! Don't expose it!+permute0 :: (SEq k) => SList (xs :: [k]) -> SList (ys :: [k]) -> Sized (Length xs) Integer+permute0 SNil _ = S.NilL+permute0 (SCons x xs) ys =+ case sElemIndex x ys of+ SJust n ->+ let k = sLength xs+ in coerceLength (plusComm k sOne) $ withKnownNat (sSucc k) $+ withKnownNat k $ (fromSing n S.:< permute0 xs ys)+ SNothing -> error "oops, you called permute0 for non-subset..."++permute :: forall (xs :: [k]) ys. (IsSubsetOf xs ys , SEq k)+ => SList xs -> SList ys -> Sized (Length xs) Integer+permute = _suppress (Proxy :: Proxy xs) (Proxy :: Proxy ys) permute0++canonicalMap :: forall xs ys poly poly'.+ (SingI xs, SingI ys, IsSubsetOf xs ys,+ Wraps xs poly, Wraps ys poly',+ IsPolynomial poly, IsPolynomial poly',+ Coefficient poly ~ Coefficient poly')+ => LabPolynomial poly xs -> LabPolynomial poly' ys+canonicalMap (LabelPolynomial f) =+ let sxs = sing :: Sing xs+ sys = sing :: Sing ys+ dics = permute sxs sys+ ords = enumOrdinal (sArity $ Just ans)+ mor o = var (ords !! fromInteger (dics S.%!! o)) :: poly'+ ans = liftMap mor f+ in LabelPolynomial ans+{-# INLINE canonicalMap #-}++canonicalMap' :: (SingI xs, SingI ys, IsSubsetOf xs ys,+ Wraps xs poly, Wraps ys poly',+ IsPolynomial poly, IsPolynomial poly',+ Coefficient poly ~ Coefficient poly')+ => proxy poly' -> proxy' ys -> LabPolynomial poly xs -> LabPolynomial poly' ys+canonicalMap' _ _ = canonicalMap+{-# INLINE canonicalMap' #-}
+ Algebra/Ring/Polynomial/Monomial.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE ConstraintKinds, DataKinds, ExistentialQuantification #-}+{-# LANGUAGE ExplicitNamespaces, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, IncoherentInstances #-}+{-# LANGUAGE LiberalTypeSynonyms, MultiParamTypeClasses, ParallelListComp #-}+{-# LANGUAGE PatternSynonyms, PolyKinds, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving, TemplateHaskell, TypeApplications #-}+{-# LANGUAGE TypeFamilies, TypeOperators, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Algebra.Ring.Polynomial.Monomial+ ( Monomial, OrderedMonomial(..),+ IsOrder(..), IsMonomialOrder, MonomialOrder,+ IsStrongMonomialOrder,+ isRelativelyPrime, totalDegree, ProductOrder(..),+ productOrder, productOrder', WeightProxy, WeightOrder(..),+ gcdMonomial, divs, isPowerOf, tryDiv, lcmMonomial,+ Lex(..), EliminationType, EliminationOrder,+ WeightedEliminationOrder, eliminationOrder, weightedEliminationOrder,+ lex, revlex, graded, grlex, grevlex,+ weightOrder, Grevlex(..), fromList,+ Revlex(..), Grlex(..), Graded(..),+ castMonomial, scastMonomial, varMonom,+ changeMonomialOrder, changeMonomialOrderProxy, sOnes,+ withStrongMonomialOrder, cmpAnyMonomial, orderMonomial+ ) where+import Algebra.Internal++import AlgebraicPrelude hiding (lex)+import Control.DeepSeq (NFData (..))+import Control.Lens (Ixed (..), alaf, imap,+ makeLenses, makeWrapped, (%~),+ (&), (.~), _Wrapped)+import Data.Constraint ((:=>) (..), Dict (..))+import qualified Data.Constraint as C+import Data.Constraint.Forall+import qualified Data.Foldable as F+import Data.Hashable (Hashable (..))+import Data.Kind (Type)+import Data.Maybe (catMaybes)+import Data.Monoid (Dual (..))+import Data.Monoid ((<>))+import qualified Data.MonoTraversable.Unprefixed as MT+import Data.Ord (comparing)+import Data.Singletons.Prelude (POrd (..), SList, Sing ())+import Data.Singletons.Prelude (SingKind (..))+import Data.Singletons.Prelude.List (Length, Replicate, sReplicate)+import Data.Singletons.TypeLits (withKnownNat)+import qualified Data.Sized.Builtin as V+import Data.Type.Natural.Class (IsPeano (..), PeanoOrder (..))+import Data.Type.Ordinal (Ordinal (..), ordToInt)+-- import Prelude hiding (Fractional (..),+-- Integral (..), Num (..),+-- Real (..), lex, product, sum)+import qualified Prelude as P++-- | N-ary Monomial. IntMap contains degrees for each x_i- type Monomial (n :: Nat) = Sized n Int+type Monomial n = Sized' n Int++-- | A wrapper for monomials with a certain (monomial) order.+newtype OrderedMonomial ordering n =+ OrderedMonomial { getMonomial :: Monomial n }+ deriving (NFData)++makeLenses ''OrderedMonomial+makeWrapped ''OrderedMonomial++-- | convert NAry list into Monomial.+fromList :: SNat n -> [Int] -> Monomial n+fromList len = V.fromListWithDefault len 0++-- | 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++isRelativelyPrime :: OrderedMonomial ord n -> OrderedMonomial ord n -> Bool+isRelativelyPrime n m = lcmMonomial n m == n * m++totalDegree :: OrderedMonomial ord n -> Int+totalDegree = P.sum . getMonomial+{-# INLINE totalDegree #-}++-- | Lexicographical order. This *is* a monomial order.+lex :: MonomialOrder n+lex m n = P.foldMap (uncurry compare) $ V.zipSame m n+{-# INLINE [2] lex #-}++-- | Reversed lexicographical order. This is *not* a monomial order.+revlex :: MonomialOrder n+revlex xs ys = foldl (flip (<>)) EQ $ V.zipWithSame (flip compare) xs ys+{-# INLINE [2] revlex #-}++-- | Convert ordering into graded one.+graded :: MonomialOrder n -> MonomialOrder n+graded cmp xs ys = comparing F.sum xs ys <> cmp xs ys+{-# INLINE[2] graded #-}+{-# RULES+"graded/graded" [~1] forall x. graded (graded x) = graded x+ #-}++-- | Graded lexicographical order. This *is* a monomial order.+grlex :: MonomialOrder n+grlex = graded lex+{-# INLINE [2] grlex #-}++-- | Graded reversed lexicographical order. This *is* a monomial order.+grevlex :: MonomialOrder n+grevlex = graded revlex+{-# INLINE [2] grevlex #-}++deriving instance Hashable (Monomial n) => Hashable (OrderedMonomial ordering n)+deriving instance (Eq (Monomial n)) => Eq (OrderedMonomial ordering n)+instance KnownNat n => Show (OrderedMonomial ord n) where+ show xs =+ let vs = catMaybes $ V.toList $+ imap (\n i ->+ if i > 0+ then Just ("X_" ++ show (ordToInt n) ++ if i == 1 then "" else "^" ++ show i)+ else Nothing)+ $ getMonomial xs+ in if null vs then "1" else unwords vs++instance Multiplicative (OrderedMonomial ord n) where+ OrderedMonomial n * OrderedMonomial m = OrderedMonomial $ V.zipWithSame (+) n m++instance KnownNat n => Division (OrderedMonomial ord n) where+ recip = _Wrapped %~ V.map P.negate+ OrderedMonomial n / OrderedMonomial m = OrderedMonomial $ V.zipWithSame (-) n m++instance KnownNat n => Unital (OrderedMonomial ord n) where+ one = OrderedMonomial $ fromList sing []++-- | Class to lookup ordering from its (type-level) name.+class IsOrder (n :: Nat) (ordering :: *) where+ cmpMonomial :: Proxy ordering -> MonomialOrder n++head' :: (0 :< n) ~ 'True => Sized' n a -> a+head' = V.head+{-# INLINE head' #-}++-- We know that Monomial ordering coincides on lex ordering+-- on univariate monomials.+{-# RULES+"cmpMonomial/unary" [~1]+ forall (pxy :: IsMonomialOrder 1 (o :: *) => Proxy o)+ (xs :: Sized' 1 Int)+ (ys :: Sized' 1 Int).+ cmpMonomial pxy xs ys = comparing head' xs ys+ #-}++-- * Names for orderings.+-- We didn't choose to define one single type for ordering names for the extensibility.+-- | Lexicographical order+data Lex = Lex+ deriving (Show, Eq, Ord)++-- | Reversed lexicographical order+data Revlex = Revlex+ deriving (Show, Eq, Ord)++-- | Graded reversed lexicographical order. Same as @Graded Revlex@.+data Grevlex = Grevlex+ deriving (Show, Eq, Ord)++-- | Graded lexicographical order. Same as @Graded Lex@.+data Grlex = Grlex+ deriving (Show, Eq, Ord)++-- | Graded order from another monomial order.+data Graded ord = Graded ord+ deriving (Read, Show, Eq, Ord)++instance IsOrder n ord => IsOrder n (Graded ord) where+ cmpMonomial Proxy = graded (cmpMonomial (Proxy :: Proxy ord))+ {-# INLINE [1] cmpMonomial #-}++instance IsMonomialOrder n ord => IsMonomialOrder n (Graded ord)++data ProductOrder (n :: Nat) (m :: Nat) (a :: *) (b :: *) where+ ProductOrder :: Sing n -> Sing m -> ord -> ord' -> ProductOrder n m ord ord'++productOrder :: forall ord ord' n m. (IsOrder n ord, IsOrder m ord', KnownNat n, KnownNat m)+ => Proxy (ProductOrder n m ord ord') -> MonomialOrder (n + m)+productOrder _ mon mon' =+ let n = sing :: SNat n+ m = sing :: SNat m+ in withWitness (plusLeqL n m) $+ case (V.splitAt n mon, V.splitAt n mon') of+ ((xs, xs'), (ys, ys')) ->+ cmpMonomial (Proxy :: Proxy ord) xs ys <>+ cmpMonomial (Proxy :: Proxy ord')+ (coerceLength (plusMinus' n m) xs')+ (coerceLength (plusMinus' n m) ys')++productOrder' :: forall n ord ord' m.(IsOrder n ord, IsOrder m ord')+ => SNat n -> SNat m -> ord -> ord' -> MonomialOrder (n + m)+productOrder' n m _ _ =+ withKnownNat n $ withKnownNat m $+ productOrder (Proxy :: Proxy (ProductOrder n m ord ord'))++type WeightProxy (v :: [Nat]) = SList v++data WeightOrder (v :: [Nat]) (ord :: Type) where+ WeightOrder :: SList (v :: [Nat]) -> Proxy ord -> WeightOrder v ord++calcOrderWeight :: forall vs n. (SingI vs, KnownNat n)+ => Proxy (vs :: [Nat]) -> Monomial n -> Int+calcOrderWeight Proxy = calcOrderWeight' (sing :: SList vs)+{-# INLINE calcOrderWeight #-}++calcOrderWeight' :: forall vs n. KnownNat n => SList (vs :: [Nat]) -> Monomial n -> Int+calcOrderWeight' slst m =+ let cfs = V.fromListWithDefault' (0 :: Int) $ map P.fromIntegral $ fromSing slst+ in P.sum $ V.zipWithSame (*) cfs m+{-# INLINE [2] calcOrderWeight' #-}++weightOrder :: forall n ns ord. (KnownNat n, IsOrder n ord, SingI ns)+ => Proxy (WeightOrder ns ord) -> MonomialOrder n+weightOrder Proxy m m' =+ comparing (calcOrderWeight (Proxy :: Proxy ns)) m m'+ <> cmpMonomial (Proxy :: Proxy ord) m m'+{-# INLINE weightOrder #-}++instance (KnownNat n, IsOrder n ord, SingI ws)+ => IsOrder n (WeightOrder ws ord) where+ cmpMonomial p = weightOrder p+ {-# INLINE [1] cmpMonomial #-}++instance (IsOrder n ord, IsOrder m ord', KnownNat m, KnownNat n, k ~ (n + m))+ => IsOrder k (ProductOrder n m ord ord') where+ cmpMonomial p = productOrder p+ {-# INLINE [1] cmpMonomial #-}++-- They're all total orderings.+instance IsOrder n Grevlex where+ cmpMonomial _ = grevlex+ {-# INLINE [1] cmpMonomial #-}++instance IsOrder n Revlex where+ cmpMonomial _ = revlex+ {-# INLINE [1] cmpMonomial #-}++instance IsOrder n Lex where+ cmpMonomial _ = lex+ {-# INLINE [1] cmpMonomial #-}++instance IsOrder n Grlex where+ cmpMonomial _ = grlex+ {-# INLINE [1] cmpMonomial #-}++-- | Class for Monomial orders.+class IsOrder n name => IsMonomialOrder n name where++-- Note that Revlex is not a monomial order.+-- This distinction is important when we calculate a quotient or Groebner basis.+instance IsMonomialOrder n Grlex+instance IsMonomialOrder n Grevlex+instance IsMonomialOrder n Lex+instance (KnownNat n, KnownNat m, IsMonomialOrder n o, IsMonomialOrder m o', k ~ (n + m))+ => IsMonomialOrder k (ProductOrder n m o o')+instance (KnownNat k, SingI ws, IsMonomialOrder k ord)+ => IsMonomialOrder k (WeightOrder ws ord)++lcmMonomial :: OrderedMonomial ord n -> OrderedMonomial ord n -> OrderedMonomial ord n+lcmMonomial (OrderedMonomial m) (OrderedMonomial n) = OrderedMonomial $ V.zipWithSame max m n++gcdMonomial :: OrderedMonomial ord n -> OrderedMonomial ord n -> OrderedMonomial ord n+gcdMonomial (OrderedMonomial m) (OrderedMonomial n) = OrderedMonomial $ V.zipWithSame P.min m n+++divs :: OrderedMonomial ord n -> OrderedMonomial ord n -> Bool+(OrderedMonomial xs) `divs` (OrderedMonomial ys) = and $ V.toList $ V.zipWith (<=) xs ys++isPowerOf :: KnownNat n => OrderedMonomial ord n -> OrderedMonomial ord n -> Bool+OrderedMonomial n `isPowerOf` OrderedMonomial m =+ case V.sFindIndices (> 0) m of+ [ind] -> F.sum n == V.sIndex ind n+ _ -> False++tryDiv :: Field r => (r, OrderedMonomial ord n) -> (r, OrderedMonomial ord n) -> (r, OrderedMonomial ord n)+tryDiv (a, f) (b, g)+ | g `divs` f = (a * recip b, OrderedMonomial $ V.zipWithSame (-) (getMonomial f) (getMonomial g))+ | otherwise = error "cannot divide."++varMonom :: SNat n -> Ordinal n -> Monomial n+varMonom len o = V.replicate len 0 & ix o .~ 1+{-# INLINE varMonom #-}++-- | Monomial order which can be use to calculate n-th elimination ideal of m-ary polynomial.+-- This should judge monomial to be bigger if it contains variables to eliminate.+class (IsMonomialOrder n ord, KnownNat n) => EliminationType n m ord+instance KnownNat n => EliminationType n m Lex+instance (KnownNat n, KnownNat m, IsMonomialOrder n ord, IsMonomialOrder m ord', k ~ (n + m), KnownNat k)+ => EliminationType k n (ProductOrder n m ord ord')+instance (IsMonomialOrder k ord, ones ~ (Replicate n 1), SingI ones,+ (Length ones :<= k) ~ 'True, KnownNat k)+ => EliminationType k n (WeightOrder ones ord)++type EliminationOrder n m = ProductOrder n m Grevlex Grevlex++eliminationOrder :: SNat n -> SNat m -> EliminationOrder n m+eliminationOrder n m =+ withKnownNat n $ ProductOrder n m Grevlex Grevlex++sOnes :: Sing n -> Sing (Replicate n 1)+sOnes n = sReplicate n (sing :: Sing 1)++weightedEliminationOrder :: SNat n -> WeightedEliminationOrder n Grevlex+weightedEliminationOrder n =+ WeightOrder (sOnes n) (Proxy :: Proxy Grevlex)++type WeightedEliminationOrder (n :: Nat) (ord :: Type) =+ WeightOrder (Replicate n 1) ord++-- | Special ordering for ordered-monomials.+instance (Eq (Monomial n), IsOrder n 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 {-# OVERLAPPING #-} Ord (Monomial n) where+ compare = grevlex++castMonomial :: (KnownNat m) => OrderedMonomial o n -> OrderedMonomial o' m+castMonomial = _Wrapped %~ fromList sing . V.toList++scastMonomial :: SNat m -> OrderedMonomial o n -> OrderedMonomial o m+scastMonomial sdim = _Wrapped %~ fromList sdim . V.toList++changeMonomialOrder :: o' -> OrderedMonomial ord n -> OrderedMonomial o' n+changeMonomialOrder _ = OrderedMonomial . getMonomial++changeMonomialOrderProxy :: Proxy o' -> OrderedMonomial ord n -> OrderedMonomial o' n+changeMonomialOrderProxy _ = OrderedMonomial . getMonomial++class (IsMonomialOrder n ord) => IsMonomialOrder' ord n+instance (IsMonomialOrder n ord) => IsMonomialOrder' ord n++instance IsMonomialOrder' ord n :=> IsMonomialOrder n ord where+ ins = C.Sub Dict++-- | Monomial ordering which can do with monomials of arbitrary large arity.+type IsStrongMonomialOrder ord = Forall (IsMonomialOrder' ord)++withStrongMonomialOrder :: forall ord n r proxy (proxy' :: Nat -> Type).+ (IsStrongMonomialOrder ord)+ => proxy ord -> proxy' n -> (IsMonomialOrder n ord => r) -> r+withStrongMonomialOrder _ _ r = r C.\\ dict+ where+ ismToPrim = (ins :: IsMonomialOrder' ord n C.:- IsMonomialOrder n ord)+ primeInst = inst :: Forall (IsMonomialOrder' ord) C.:- IsMonomialOrder' ord n+ dict = ismToPrim `C.trans` primeInst++-- | Comparing monomials with different arity,+-- padding with @0@ at bottom of the shorter monomial to+-- make the length equal.+cmpAnyMonomial :: IsStrongMonomialOrder ord+ => Proxy ord -> Monomial n -> Monomial m -> Ordering+cmpAnyMonomial pxy t t' =+ let (l, u, u') = padVecs 0 t t'+ in withStrongMonomialOrder pxy l $ cmpMonomial pxy u u'++orderMonomial :: proxy ord -> Monomial n -> OrderedMonomial ord n+orderMonomial _ = OrderedMonomial+{-# INLINE orderMonomial #-}
− Algebra/Ring/Polynomial/Monomorphic.hs
@@ -1,202 +0,0 @@-{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}-{-# LANGUAGE MultiParamTypeClasses, PolyKinds, RecordWildCards, TypeFamilies #-}-{-# LANGUAGE TypeOperators, ViewPatterns, OverlappingInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Algebra.Ring.Polynomial.Monomorphic where-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 Data.Type.Natural hiding (one, zero, promote)-import Data.Type.Monomorphic-import qualified Numeric.Algebra as NA-import Data.Ratio-import qualified Data.Vector.Sized as V--data Variable = Variable { varName :: Char- , varIndex :: Maybe Int- } deriving (Eq, Ord)--instance (Eq r, NoetherianRing r, Num r) => Num (Polynomial r) where- fromInteger n = Polynomial $ M.singleton M.empty $ fromInteger n- (+) = (NA.+)- (*) = (NA.*)- negate = NA.negate- abs = id- signum (normalize -> f)- | f == NA.zero = NA.zero- | otherwise = NA.one--instance Show Variable where- showsPrec _ v = showChar (varName v) . maybe id ((showChar '_' .) . shows) (varIndex v)--type Monomial = M.Map Variable Integer--newtype Polynomial k = Polynomial { unPolynomial :: M.Map Monomial k }- deriving (Eq, Ord)--normalize :: (Eq k, NA.Monoidal k) => Polynomial k -> Polynomial k-normalize (Polynomial dic) =- Polynomial $ M.filterWithKey (\k v -> v /= NA.zero || M.null k) $ M.mapKeysWith (NA.+) normalizeMonom dic--normalizeMonom :: Monomial -> Monomial-normalizeMonom = M.filter (/= 0)--instance (Eq r, NoetherianRing r) => NoetherianRing (Polynomial r)-instance (Eq r, NoetherianRing r) => NA.Commutative (Polynomial r)-instance (Eq r, NoetherianRing r) => NA.Multiplicative (Polynomial r) where- Polynomial (M.toList -> d1) * Polynomial (M.toList -> d2) =- let dic = [ (M.unionWith (+) a b, r NA.* r') | (a, r) <- d1, (b, r') <- d2 ]- in normalize $ Polynomial $ M.fromListWith (NA.+) dic--instance (Eq r, NoetherianRing r) => NA.Ring (Polynomial r)-instance (Eq r, NoetherianRing r) => NA.Group (Polynomial r) where- negate (Polynomial dic) = Polynomial $ fmap NA.negate dic-instance (Eq r, NoetherianRing r) => NA.Rig (Polynomial r)-instance (Eq r, NoetherianRing r) => NA.Unital (Polynomial r) where- one = Polynomial $ M.singleton M.empty NA.one-instance (Eq r, NoetherianRing r) => NA.Monoidal (Polynomial r) where- zero = Polynomial $ M.singleton M.empty NA.zero-instance (Eq r, NoetherianRing r) => NA.LeftModule NA.Natural (Polynomial r) where- n .* Polynomial dic = Polynomial $ fmap (n NA..*) dic -instance (Eq r, NoetherianRing r) => NA.RightModule NA.Natural (Polynomial r) where- (*.) = flip (NA..*)-instance (Eq r, NoetherianRing r) => NA.LeftModule Integer (Polynomial r) where- n .* Polynomial dic = Polynomial $ fmap (n NA..*) dic -instance (Eq r, NoetherianRing r) => NA.RightModule Integer (Polynomial r) where- (*.) = flip (NA..*)-instance (Eq r, NoetherianRing r) => NA.Semiring (Polynomial r)-instance (Eq r, NoetherianRing r) => NA.Abelian (Polynomial r)-instance (Eq r, NoetherianRing r) => NA.Additive (Polynomial r) where- (Polynomial f) + (Polynomial g) = normalize $ Polynomial $ M.unionWith (NA.+) f g--buildVarsList :: Polynomial r -> [Variable]-buildVarsList = nub . sort . concatMap M.keys . M.keys . unPolynomial--encodeMonomList :: [Variable] -> Monomial -> [Int]-encodeMonomList vars mono = map (maybe 0 fromInteger . flip M.lookup mono) vars--encodeMonomial :: [Variable] -> Monomial -> Monomorphic (V.Vector Int)-encodeMonomial vars mono = promote $ encodeMonomList vars mono--encodePolynomial :: (Monomorphicable (Poly.Polynomial r))- => Polynomial r -> Monomorphic (Poly.Polynomial r)-encodePolynomial = promote . toPolynomialSetting--toPolynomialSetting :: Polynomial r -> PolynomialSetting r-toPolynomialSetting p =- PolySetting { polyn = p- , dimension = promote $ length $ buildVarsList p- }--data PolynomialSetting r = PolySetting { dimension :: Monomorphic (Sing :: Nat -> *)- , polyn :: Polynomial r- }--instance (Integral a, Show a) => Show (Polynomial (Ratio a)) where- show = showRatPolynomial--instance (Eq r, NoetherianRing r, Show r) => Show (Polynomial r) where- show = showPolynomial--instance (Eq r, NoetherianRing r, Poly.IsMonomialOrder ord)- => Monomorphicable (Poly.OrderedPolynomial r ord) where- type MonomorphicRep (Poly.OrderedPolynomial r ord) = PolynomialSetting r- promote PolySetting{..} =- case dimension of- Monomorphic dim ->- case singInstance dim of- SingInstance -> Monomorphic $ Poly.polynomial $ M.mapKeys (Poly.OrderedMonomial . Poly.fromList dim . encodeMonomList vars) $ unPolynomial polyn- where- vars = buildVarsList polyn- demote (Monomorphic f) =- PolySetting { polyn = Polynomial $ M.fromList $- map (toMonom . map toInteger . demote . Monomorphic . snd &&& fst) $ Poly.getTerms f- , dimension = Monomorphic $ Poly.sArity f- }- where- toMonom = M.fromList . zip (Variable 'X' Nothing : [Variable 'X' (Just i) | i <- [1..]])--uniformlyPromoteWithDim :: (Eq r, NoetherianRing r)- => Poly.IsMonomialOrder ord- => Int -> [Polynomial r] -> Monomorphic (Ideal :.: Poly.OrderedPolynomial r ord)-uniformlyPromoteWithDim d ps =- case promote d of- Monomorphic dim ->- case singInstance dim of- SingInstance -> Monomorphic $ Comp $ toIdeal $ map (Poly.polynomial . M.mapKeys (Poly.OrderedMonomial . Poly.fromList dim . encodeMonomList vars) . unPolynomial) ps- where- vars = nub $ sort $ concatMap buildVarsList ps--uniformlyPromote :: (Eq r, NoetherianRing r, Poly.IsMonomialOrder ord)- => [Polynomial r] -> Monomorphic (Ideal :.: Poly.OrderedPolynomial r ord)-uniformlyPromote ps = uniformlyPromoteWithDim (length vars) ps- where- vars = nub $ sort $ concatMap buildVarsList ps--instance (NoetherianRing r, Eq r, Poly.IsMonomialOrder ord)- => Monomorphicable (Ideal :.: Poly.OrderedPolynomial r ord) where- type MonomorphicRep (Ideal :.: Poly.OrderedPolynomial r ord) = [Polynomial r]- promote = uniformlyPromote- demote (Monomorphic (Comp (Ideal v))) = map (polyn . demote . Monomorphic) $ V.toList v--promoteList :: (Eq r, NoetherianRing r, Poly.IsMonomialOrder ord)- => [Polynomial r] -> Monomorphic ([] :.: Poly.OrderedPolynomial r ord)-promoteList ps = promoteListWithDim (length vars) ps- where- vars = nub $ sort $ concatMap buildVarsList ps--promoteListWithVarOrder :: (Eq r, NoetherianRing r, Poly.IsMonomialOrder ord)- => [Variable] -> [Polynomial r] -> Monomorphic ([] :.: Poly.OrderedPolynomial r ord)-promoteListWithVarOrder dic ps =- case promote dim of- Monomorphic sdim ->- case singInstance sdim of- SingInstance -> Monomorphic $ Comp $ map (Poly.polynomial . M.mapKeys (Poly.OrderedMonomial . Poly.fromList sdim . encodeMonomList vars) . unPolynomial) ps- where- vs0 = nub $ sort $ concatMap buildVarsList ps- (_, rest) = partition (`elem` dic) vs0- vars = dic ++ rest- dim = length vars--promoteListWithDim :: (NoetherianRing r, Eq r, Poly.IsMonomialOrder ord)- => Int -> [Polynomial r] -> Monomorphic ([] :.: Poly.OrderedPolynomial r ord)-promoteListWithDim dim ps =- case promote dim of- Monomorphic sdim ->- case singInstance sdim of- SingInstance -> Monomorphic $ Comp $ map (Poly.polynomial . M.mapKeys (Poly.OrderedMonomial . Poly.fromList sdim . encodeMonomList vars) . unPolynomial) ps- where- vars = nub $ sort $ concatMap buildVarsList ps--renameVars :: [Variable] -> Polynomial r -> Polynomial r-renameVars vars = Polynomial . M.mapKeys (M.mapKeys ren) . unPolynomial- where- ren v = fromMaybe v $ lookup v dic- dic = zip (Variable 'X' Nothing : [Variable 'X' (Just i) | i <- [1..]]) vars--showPolynomial :: (Show r, Eq r, NoetherianRing r) => Polynomial r -> String-showPolynomial f =- case encodePolynomial f of- Monomorphic f' ->- case singInstance (Poly.sArity f') of- SingInstance -> Poly.showPolynomialWithVars dic f'- where- dic = zip [1 :: Int ..] $ map show $ buildVarsList f--showRatPolynomial :: (Integral a, Show a) => Polynomial (Ratio a) -> String-showRatPolynomial f =- case encodePolynomial f of- Monomorphic f' ->- case singInstance (Poly.sArity f') of- SingInstance -> Poly.showPolynomialWith dic Poly.showRational f'- where- dic = zip [1 :: Int ..] $ map show $ buildVarsList f--injectVar :: NA.Unital r => Variable -> Polynomial r-injectVar var = Polynomial $ M.singleton (M.singleton var 1) NA.one--injectCoeff :: r -> Polynomial r-injectCoeff c = Polynomial $ M.singleton M.empty c
− Algebra/Ring/Polynomial/Parser.hs
@@ -1,66 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE QuasiQuotes #-}-module Algebra.Ring.Polynomial.Parser ( monomial, expression, variable, variableWithPower- , number, integer, natural, parsePolyn) where-import Algebra.Ring.Polynomial.Monomorphic-import Control.Applicative hiding (many)-import qualified Data.Map as M-import Data.Ratio-import qualified Numeric.Algebra as NA-import Text.Peggy--[peggy|-expression :: Polynomial Rational- = expr !.--letter :: Char- = [a-zA-Z]--variable :: Variable- = letter ('_' integer)? { Variable $1 (fromInteger <$> $2) }--variableWithPower :: (Variable, Integer)- = variable "^" natural { ($1, $2) }- / variable { ($1, 1) }--expr :: Polynomial Rational- = expr "+" term { $1 + $2 }- / expr "-" term { $1 - $2 }- / term--term :: Polynomial Rational- = number space* monoms { injectCoeff $1 * $3 }- / number { injectCoeff $1 }- / monoms--monoms :: Polynomial Rational- = monoms space * fact { $1 * $3 }- / fact--fact :: Polynomial Rational- = fact "^" natural { $1 ^ $2 }- / "(" expr ")"- / monomial { toPolyn [($1, 1)] }--monomial :: Monomial- = variableWithPower+ { M.fromListWith (+) $1 }--number :: Rational- = integer "/" integer { $1 % $2 }- / integer '.' [0-9]+ { realToFrac (read (show $1 ++ '.' : $2) :: Double) }- / integer { fromInteger $1 }--integer :: Integer- = "-" natural { negate $1 }- / natural--natural :: Integer- = [1-9] [0-9]* { read ($1 : $2) }--|]--toPolyn :: [(Monomial, Ratio Integer)] -> Polynomial (Ratio Integer)-toPolyn = normalize . Polynomial . M.fromList--parsePolyn :: String -> Either ParseError (Polynomial Rational)-parsePolyn = parseString expression "polynomial"
+ Algebra/Ring/Polynomial/Quotient.hs view
@@ -0,0 +1,520 @@+{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances, GADTs, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash, MultiParamTypeClasses, PolyKinds, RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Algebra.Ring.Polynomial.Quotient+ ( Quotient(), QIdeal(), reifyQuotient, modIdeal+ , modIdeal', quotRepr, withQuotient, vectorRep+ , genQuotVars, genQuotVars', gBasis', matRep0+ , standardMonomials, standardMonomials', matRepr'+ , reduce, multWithTable, multUnamb, isZeroDimensional+ )+ where+import Algebra.Algorithms.Groebner (calcGroebnerBasis)+import Algebra.Field.Finite (F)+import Algebra.Internal+import Algebra.Prelude.Core+import Algebra.Ring.Polynomial.Univariate (Unipol)++import Control.DeepSeq+import Control.Lens (folded, ifoldMap, minimumOf)+import qualified Data.Coerce as C+import qualified Data.HashMap.Lazy as HM+import qualified Data.Map as Map+import qualified Data.Matrix as M+import Data.Monoid (Sum (..))+import Data.Reflection+import Data.Unamb (unamb)+import qualified Data.Vector as V+import qualified Numeric.Algebra as NA+import qualified Prelude as P++-- | The polynomial modulo the ideal indexed at the last type-parameter.+newtype Quotient poly ideal = Quotient { quotRepr_ :: poly }+ deriving (Eq)++-- | Representative polynomial of given quotient polynomial.+quotRepr :: Quotient poly ideal -> poly+quotRepr = quotRepr_++data QIdeal poly = ZeroDimIdeal { _gBasis :: ![poly]+ , _vBasis :: ![OrderedMonomial (MOrder poly) (Arity poly)]+ , multTable :: Table poly+ }+ | QIdeal { _gBasis :: [poly]+ }++instance NFData poly => NFData (Quotient poly ideal) where+ rnf (Quotient op) = rnf op++type Table poly = HM.HashMap+ (OrderedMonomial (MOrder poly) (Arity poly),+ OrderedMonomial (MOrder poly) (Arity poly))+ poly++vectorRep :: forall poly ideal.+ (IsOrderedPolynomial poly, Reifies ideal (QIdeal poly))+ => Quotient poly ideal -> V.Vector (Coefficient poly)+vectorRep f =+ let ZeroDimIdeal _ base _ = reflect f+ mf = quotRepr f+ in V.fromList $ map (flip coeff mf) base+{-# SPECIALISE INLINE+ vectorRep :: (IsMonomialOrder n ord, CoeffRing r, KnownNat n,+ Reifies ideal (QIdeal (OrderedPolynomial r ord n)))+ => Quotient (OrderedPolynomial r ord n) ideal -> V.Vector r+ #-}+{-# SPECIALISE INLINE+ vectorRep :: (CoeffRing r, Reifies ideal (QIdeal (Unipol r)))+ => Quotient (Unipol r) ideal -> V.Vector r+ #-}+{-# SPECIALISE INLINE+ vectorRep :: (IsMonomialOrder n ord, KnownNat n,+ Reifies ideal (QIdeal (OrderedPolynomial Rational ord n)))+ => Quotient (OrderedPolynomial Rational ord n) ideal -> V.Vector Rational+ #-}+{-# SPECIALISE INLINE+ vectorRep :: (Reifies ideal (QIdeal (Unipol Rational)))+ => Quotient (Unipol Rational) ideal -> V.Vector Rational+ #-}+{-# SPECIALISE INLINE+ vectorRep :: (KnownNat p, IsMonomialOrder n ord, KnownNat n,+ Reifies ideal (QIdeal (OrderedPolynomial (F p) ord n)))+ => Quotient (OrderedPolynomial (F p) ord n) ideal -> V.Vector (F p)+ #-}+{-# SPECIALISE INLINE+ vectorRep :: (Reifies ideal (QIdeal (Unipol (F p))), KnownNat p)+ => Quotient (Unipol (F p)) ideal -> V.Vector (F p)+ #-}+{-# INLINE vectorRep #-}++matRepr' :: forall poly ideal.+ (Field (Coefficient poly),+ Reifies ideal (QIdeal poly), IsOrderedPolynomial poly)+ => Quotient poly ideal -> M.Matrix (Coefficient poly)+matRepr' f =+ let ZeroDimIdeal _bs _ _ = reflect f+ in C.coerce $ getSum $+ ifoldMap+ (\t c ->+ Sum $ fmap (WrapAlgebra . (c *)) $ matRep0 (Proxy :: Proxy poly) (Proxy :: Proxy ideal) t)+ (terms (quotRepr_ f))+{-# SPECIALISE INLINE+ matRepr' :: (IsMonomialOrder n ord, CoeffRing r, KnownNat n, Field r,+ Reifies ideal (QIdeal (OrderedPolynomial r ord n)))+ => Quotient (OrderedPolynomial r ord n) ideal -> M.Matrix r+ #-}+{-# SPECIALISE INLINE+ matRepr' :: (Field r, CoeffRing r, Reifies ideal (QIdeal (Unipol r)))+ => Quotient (Unipol r) ideal -> M.Matrix r+ #-}+{-# SPECIALISE INLINE+ matRepr' :: (IsMonomialOrder n ord, KnownNat n,+ Reifies ideal (QIdeal (OrderedPolynomial Rational ord n)))+ => Quotient (OrderedPolynomial Rational ord n) ideal -> M.Matrix Rational+ #-}+{-# SPECIALISE INLINE+ matRepr' :: (Reifies ideal (QIdeal (Unipol Rational)))+ => Quotient (Unipol Rational) ideal -> M.Matrix Rational+ #-}+{-# SPECIALISE INLINE+ matRepr' :: (IsMonomialOrder n ord, KnownNat n, KnownNat p,+ Reifies ideal (QIdeal (OrderedPolynomial (F p) ord n)))+ => Quotient (OrderedPolynomial (F p) ord n) ideal -> M.Matrix (F p)+ #-}+{-# SPECIALISE INLINE+ matRepr' :: (Reifies ideal (QIdeal (Unipol (F p))), KnownNat p)+ => Quotient (Unipol (F p)) ideal -> M.Matrix (F p)+ #-}+{-# INLINE matRepr' #-}++matRep0 :: forall poly ideal.+ (IsOrderedPolynomial poly, Field (Coefficient poly), Reifies ideal (QIdeal poly))+ => Proxy poly -> Proxy ideal -> OrderedMonomial (MOrder poly) (Arity poly) -> M.Matrix (Coefficient poly)+matRep0 _ pxy m =+ let ZeroDimIdeal _ bs table = reflect pxy+ in foldr (M.<|>) (M.fromList 0 0 [])+ [ M.colVector $ vectorRep $ modIdeal' pxy (HM.lookupDefault zero (m, b) table)+ | b <- bs ]+{-# SPECIALISE INLINE+ matRep0 :: (IsMonomialOrder n ord, Field r, CoeffRing r, KnownNat n,+ Reifies ideal (QIdeal (OrderedPolynomial r ord n)))+ => Proxy (OrderedPolynomial r ord n) -> Proxy ideal -> OrderedMonomial ord n -> M.Matrix r+ #-}+{-# SPECIALISE INLINE+ matRep0 :: (CoeffRing r, Field r, Reifies ideal (QIdeal (Unipol r)))+ => Proxy (Unipol r) -> Proxy ideal -> OrderedMonomial Grevlex 1 -> M.Matrix r+ #-}+{-# SPECIALISE INLINE+ matRep0 :: (IsMonomialOrder n ord,KnownNat n,+ Reifies ideal (QIdeal (OrderedPolynomial Rational ord n)))+ => Proxy (OrderedPolynomial Rational ord n) -> Proxy ideal -> OrderedMonomial ord n -> M.Matrix Rational+ #-}+{-# SPECIALISE INLINE+ matRep0 :: (Reifies ideal (QIdeal (Unipol Rational)))+ => Proxy (Unipol Rational) -> Proxy ideal -> OrderedMonomial Grevlex 1 -> M.Matrix Rational+ #-}+{-# SPECIALISE INLINE+ matRep0 :: (IsMonomialOrder n ord,KnownNat n, KnownNat p,+ Reifies ideal (QIdeal (OrderedPolynomial (F p) ord n)))+ => Proxy (OrderedPolynomial (F p) ord n) -> Proxy ideal -> OrderedMonomial ord n -> M.Matrix (F p)+ #-}+{-# SPECIALISE INLINE+ matRep0 :: (Reifies ideal (QIdeal (Unipol (F p))), KnownNat p)+ => Proxy (Unipol (F p)) -> Proxy ideal -> OrderedMonomial Grevlex 1 -> M.Matrix (F p)+ #-}+{-# INLINE matRep0 #-}++multUnamb :: (IsOrderedPolynomial poly, Field (Coefficient poly),+ Reifies ideal (QIdeal poly))+ => Quotient poly ideal -> Quotient poly ideal+ -> Quotient poly ideal+multUnamb a b = unamb (a * b) (multWithTable a b)+{-# SPECIALISE INLINE+ multUnamb :: (CoeffRing r, IsMonomialOrder n ord, KnownNat n,+ Field r, Reifies ideal (QIdeal (OrderedPolynomial r ord n)))+ => Quotient (OrderedPolynomial r ord n) ideal+ -> Quotient (OrderedPolynomial r ord n) ideal+ -> Quotient (OrderedPolynomial r ord n) ideal+ #-}+{-# SPECIALISE INLINE+ multUnamb :: (CoeffRing r, Field r, Reifies ideal (QIdeal (Unipol r)))+ => Quotient (Unipol r) ideal+ -> Quotient (Unipol r) ideal+ -> Quotient (Unipol r) ideal+ #-}+{-# SPECIALISE INLINE+ multUnamb :: (IsMonomialOrder n ord, KnownNat n,+ Reifies ideal (QIdeal (OrderedPolynomial Rational ord n)))+ => Quotient (OrderedPolynomial Rational ord n) ideal+ -> Quotient (OrderedPolynomial Rational ord n) ideal+ -> Quotient (OrderedPolynomial Rational ord n) ideal+ #-}+{-# SPECIALISE INLINE+ multUnamb :: (Reifies ideal (QIdeal (Unipol Rational)))+ => Quotient (Unipol Rational) ideal+ -> Quotient (Unipol Rational) ideal+ -> Quotient (Unipol Rational) ideal+ #-}+{-# SPECIALISE INLINE+ multUnamb :: (IsMonomialOrder n ord, KnownNat n, KnownNat p,+ Reifies ideal (QIdeal (OrderedPolynomial (F p) ord n)))+ => Quotient (OrderedPolynomial (F p) ord n) ideal+ -> Quotient (OrderedPolynomial (F p) ord n) ideal+ -> Quotient (OrderedPolynomial (F p) ord n) ideal+ #-}+{-# SPECIALISE INLINE+ multUnamb :: (Reifies ideal (QIdeal (Unipol (F p))), KnownNat p)+ => Quotient (Unipol (F p)) ideal+ -> Quotient (Unipol (F p)) ideal+ -> Quotient (Unipol (F p)) ideal+ #-}+{-# INLINE multUnamb #-}++multWithTable :: (IsOrderedPolynomial poly, Reifies ideal (QIdeal poly))+ => Quotient poly ideal -> Quotient poly ideal+ -> Quotient poly ideal+multWithTable f g =+ let qid = reflect f+ table = multTable qid+ in sum [ Quotient $ c .*. d .*. (HM.lookupDefault zero (l, r) table)+ | (l,c) <- Map.toList $ terms $ quotRepr_ f+ , (r,d) <- Map.toList $ terms $ quotRepr_ g+ ]++{-# SPECIALISE INLINE+ multWithTable :: (CoeffRing r, IsMonomialOrder n ord, KnownNat n,+ Reifies ideal (QIdeal (OrderedPolynomial r ord n)))+ => Quotient (OrderedPolynomial r ord n) ideal+ -> Quotient (OrderedPolynomial r ord n) ideal+ -> Quotient (OrderedPolynomial r ord n) ideal+ #-}+{-# SPECIALISE INLINE+ multWithTable :: (CoeffRing r, Reifies ideal (QIdeal (Unipol r)))+ => Quotient (Unipol r) ideal+ -> Quotient (Unipol r) ideal+ -> Quotient (Unipol r) ideal+ #-}+{-# INLINE multWithTable #-}+++instance Show poly => Show (Quotient poly ideal) where+ show (Quotient f) = show f++buildMultTable :: (IsOrderedPolynomial poly, Field (Coefficient poly))+ => [poly] -> [OrderedMonomial (MOrder poly) (Arity poly)] -> Table poly+buildMultTable bs ms =+ HM.fromList [ ((p, q), (toPolynomial (one, p) * toPolynomial (one, q)) `modPolynomial` bs)+ | p <- ms, q <- ms]+{-# SPECIALISE INLINE+ buildMultTable :: (IsMonomialOrder n ord, Field r, CoeffRing r, KnownNat n)+ => [OrderedPolynomial r ord n]+ -> [OrderedMonomial ord n]+ -> Table (OrderedPolynomial r ord n)+ #-}+{-# SPECIALISE INLINE+ buildMultTable :: (Field r, CoeffRing r)+ => [Unipol r]+ -> [OrderedMonomial Grevlex 1]+ -> Table (Unipol r)+ #-}++stdMonoms :: forall poly.+ (IsOrderedPolynomial poly, Field (Coefficient poly))+ => [poly] -> Maybe [OrderedMonomial (MOrder poly) (Arity poly)]+stdMonoms basis = do+ let lms = map leadingTerm basis+ dim = sing :: SNat (Arity poly)+ tests = zip (diag 1 0 dim) (diag 0 1 dim)+ mexp (val, test) = [ P.foldr (+) 0 $ zipWithSame (*) val $ getMonomial lm0+ | (c, lm0) <- lms, c /= zero+ , let a = P.foldr (+) 0 $ zipWithSame (*) (getMonomial lm0) test+ , a == 0+ ]+ degs <- mapM (minimumOf folded . mexp) tests+ return $ sort [ monom+ | ds0 <- sequence $ map (enumFromTo 0) degs+ , let monom = OrderedMonomial $ fromList dim ds0+ , let ds = toPolynomial (one, monom)+ , ds `modPolynomial` basis == ds+ ]+{-# SPECIALISE+ stdMonoms :: (IsMonomialOrder n ord, Field r, CoeffRing r, KnownNat n)+ => [OrderedPolynomial r ord n]+ -> Maybe [OrderedMonomial ord n]+ #-}+{-# SPECIALISE+ stdMonoms :: (Field r, CoeffRing r)+ => [Unipol r]+ -> Maybe [OrderedMonomial Grevlex 1]+ #-}++diag :: a -> a -> SNat n -> [Sized' n a]+diag d z n = [ generate n (\j -> if i == j then d else z)+ | i <- enumOrdinal n+ ]+{-# INLINE diag #-}++-- | Find the standard monomials of the quotient ring for the zero-dimensional ideal,+-- which are form the basis of it as k-vector space.+standardMonomials' :: (IsOrderedPolynomial poly, Field (Coefficient poly),+ Reifies ideal (QIdeal poly))+ => Proxy ideal -> Maybe [Quotient poly ideal]+standardMonomials' pxy =+ case reflect pxy of+ ZeroDimIdeal _ vB _ -> Just $ map (modIdeal . toPolynomial . (,) one) vB+ _ -> Nothing+{-# SPECIALISE INLINE+ standardMonomials' :: (IsMonomialOrder n ord, CoeffRing r, KnownNat n, Field r,+ Reifies ideal (QIdeal (OrderedPolynomial r ord n)))+ => Proxy ideal -> Maybe [Quotient (OrderedPolynomial r ord n) ideal]+ #-}+{-# SPECIALISE INLINE+ standardMonomials' :: (CoeffRing r, Field r, Reifies ideal (QIdeal (Unipol r)))+ => Proxy ideal -> Maybe [Quotient (Unipol r) ideal]+ #-}+{-# INLINE standardMonomials' #-}++standardMonomials :: forall poly ideal.+ (IsOrderedPolynomial poly, Field (Coefficient poly),+ Reifies ideal (QIdeal poly))+ => Maybe [Quotient poly ideal]+standardMonomials = standardMonomials' (Proxy :: Proxy ideal)+{-# SPECIALISE INLINE+ standardMonomials :: (IsMonomialOrder n ord, CoeffRing r, KnownNat n, Field r,+ Reifies ideal (QIdeal (OrderedPolynomial r ord n)))+ => Maybe [Quotient (OrderedPolynomial r ord n) ideal]+ #-}+{-# SPECIALISE INLINE+ standardMonomials :: (CoeffRing r, Field r, Reifies ideal (QIdeal (Unipol r)))+ => Maybe [Quotient (Unipol r) ideal]+ #-}+{-# INLINE standardMonomials #-}++genQuotVars' :: forall poly ideal.+ (IsOrderedPolynomial poly, Field (Coefficient poly),+ Reifies ideal (QIdeal poly))+ => Proxy ideal -> [Quotient poly ideal]+genQuotVars' pxy = map (modIdeal' pxy) vars+{-# SPECIALISE INLINE+ genQuotVars' :: (IsMonomialOrder n ord, CoeffRing r, KnownNat n, Field r,+ Reifies ideal (QIdeal (OrderedPolynomial r ord n)))+ => Proxy ideal -> [Quotient (OrderedPolynomial r ord n) ideal]+ #-}+{-# SPECIALISE INLINE+ genQuotVars' :: (CoeffRing r, Field r, Reifies ideal (QIdeal (Unipol r)))+ => Proxy ideal -> [Quotient (Unipol r) ideal]+ #-}+{-# INLINE genQuotVars' #-}++genQuotVars :: forall poly ideal. (IsOrderedPolynomial poly, Field (Coefficient poly),+ Reifies ideal (QIdeal poly))+ => [Quotient poly ideal]+genQuotVars = genQuotVars' (Proxy :: Proxy ideal)++{-# SPECIALISE INLINE+ genQuotVars :: (IsMonomialOrder n ord, CoeffRing r, KnownNat n, Field r,+ Reifies ideal (QIdeal (OrderedPolynomial r ord n)))+ => [Quotient (OrderedPolynomial r ord n) ideal]+ #-}+{-# SPECIALISE INLINE+ genQuotVars :: (CoeffRing r, Field r, Reifies ideal (QIdeal (Unipol r)))+ => [Quotient (Unipol r) ideal]+ #-}+{-# INLINE genQuotVars #-}++-- | Polynomial modulo ideal.+modIdeal :: forall poly ideal.+ (IsOrderedPolynomial poly, Field (Coefficient poly),+ Reifies ideal (QIdeal poly))+ => poly -> Quotient poly ideal+modIdeal = modIdeal' (Proxy :: Proxy ideal)++gBasis' :: (Reifies ideal (QIdeal poly))+ => Proxy ideal -> [poly]+gBasis' pxy = _gBasis (reflect pxy)+{-# SPECIALISE INLINE+ gBasis' :: (Reifies ideal (QIdeal (OrderedPolynomial r ord n)))+ => Proxy ideal -> [OrderedPolynomial r ord n]+ #-}+{-# SPECIALISE INLINE+ gBasis' :: (Reifies ideal (QIdeal (Unipol r)))+ => Proxy ideal -> [Unipol r]+ #-}+{-# INLINE gBasis' #-}++-- | Polynomial modulo ideal given by @Proxy@.+modIdeal' :: (IsOrderedPolynomial poly, Field (Coefficient poly),+ Reifies ideal (QIdeal poly))+ => Proxy ideal -> poly -> Quotient poly ideal+modIdeal' pxy f = Quotient $ f `modPolynomial` _gBasis (reflect pxy)+{-# SPECIALISE INLINE+ modIdeal' :: (IsMonomialOrder n ord, CoeffRing r, KnownNat n, Field r,+ Reifies ideal (QIdeal (OrderedPolynomial r ord n)))+ => Proxy ideal -> OrderedPolynomial r ord n+ -> Quotient (OrderedPolynomial r ord n) ideal+ #-}+{-# SPECIALISE INLINE+ modIdeal' :: (CoeffRing r, Field r,+ Reifies ideal (QIdeal (Unipol r)))+ => Proxy ideal -> Unipol r+ -> Quotient (Unipol r) ideal+ #-}+{-# INLINE modIdeal' #-}++buildQIdeal :: (IsOrderedPolynomial poly, Field (Coefficient poly))+ => Ideal poly -> QIdeal poly+buildQIdeal ideal =+ let bs = sortBy (comparing leadingMonomial) $! calcGroebnerBasis ideal+ in case stdMonoms bs of+ Nothing -> QIdeal bs+ Just ms -> ZeroDimIdeal bs ms (buildMultTable bs ms)+{-# SPECIALISE INLINE+ buildQIdeal :: (IsMonomialOrder n ord, CoeffRing r, KnownNat n, Field r)+ => Ideal (OrderedPolynomial r ord n)+ -> QIdeal (OrderedPolynomial r ord n)+ #-}+{-# SPECIALISE INLINE+ buildQIdeal :: (CoeffRing r, Field r)+ => Ideal (Unipol r)+ -> QIdeal (Unipol r)+ #-}+{-# INLINE buildQIdeal #-}++-- | Reifies the ideal at the type-level. The ideal can be recovered with 'reflect'.+reifyQuotient :: (IsOrderedPolynomial poly, Field (Coefficient poly))+ => Ideal poly+ -> (forall (ideal :: *). Reifies ideal (QIdeal poly) => Proxy ideal -> a)+ -> a+reifyQuotient ideal = reify (buildQIdeal ideal)+{-# INLINE reifyQuotient #-}++-- | Computes polynomial modulo ideal.+withQuotient :: (IsOrderedPolynomial poly, Field (Coefficient poly))+ => Ideal poly+ -> (forall (ideal :: *). Reifies ideal (QIdeal poly) => Quotient poly ideal)+ -> poly+withQuotient ideal v = reifyQuotient ideal (quotRepr_ . asProxyOf v)+{-# INLINE withQuotient #-}++asProxyOf :: f s -> Proxy s -> f s+asProxyOf a _ = a+{-# INLINE asProxyOf #-}++deriving instance Additive poly => Additive (Quotient poly ideal)+deriving instance Monoidal poly => Monoidal (Quotient poly ideal)+deriving instance Group poly => Group (Quotient poly ideal)+deriving instance Abelian poly => Abelian (Quotient poly ideal)++instance Monoidal poly+ => LeftModule Natural (Quotient poly ideal) where+ r .* f = Quotient $ r .* quotRepr_ f+instance Monoidal poly+ => RightModule Natural (Quotient poly ideal) where+ f *. r = Quotient $ r .* quotRepr_ f+instance Group poly+ => LeftModule Integer (Quotient poly ideal) where+ r .* f = Quotient $ r .* quotRepr_ f+instance Group poly+ => RightModule Integer (Quotient poly ideal) where+ f *. r = Quotient $ r .* quotRepr_ f+++instance (Field (Coefficient poly), IsOrderedPolynomial poly, Reifies ideal (QIdeal poly))+ => Multiplicative (Quotient poly ideal) where+ f * g = modIdeal $ quotRepr_ f * quotRepr_ g++instance (Field (Coefficient poly), IsOrderedPolynomial poly, Reifies ideal (QIdeal poly))+ => Semiring (Quotient poly ideal)+instance (Field (Coefficient poly), IsOrderedPolynomial poly, Reifies ideal (QIdeal poly))+ => Unital (Quotient poly ideal) where+ one = modIdeal one+instance (Field (Coefficient poly), IsOrderedPolynomial poly,+ Reifies ideal (QIdeal poly))+ => Rig (Quotient poly ideal)+instance (Field (Coefficient poly),+ IsOrderedPolynomial poly,+ Reifies ideal (QIdeal poly))+ => Ring (Quotient poly ideal)+instance (r ~ (Coefficient poly), Field (Coefficient poly),+ IsOrderedPolynomial poly)+ => LeftModule (Scalar r) (Quotient poly ideal) where+ r .* f = Quotient $ r .* quotRepr_ f+instance (r ~ (Coefficient poly), IsOrderedPolynomial poly)+ => RightModule (Scalar r) (Quotient poly ideal) where+ f *. r = Quotient $ quotRepr_ f *. r++instance (Field (Coefficient poly), UnitNormalForm poly, IsOrderedPolynomial poly,+ Reifies ideal (QIdeal poly))+ => P.Num (Quotient poly ideal) where+ (+) = (NA.+)+ (*) = (NA.*)+ fromInteger = Quotient . unwrapAlgebra . P.fromInteger+ signum = Quotient . unwrapAlgebra . P.signum . WrapAlgebra . quotRepr_+ abs = Quotient . unwrapAlgebra . P.abs . WrapAlgebra . quotRepr_+ negate = Quotient . unwrapAlgebra . P.negate . WrapAlgebra . quotRepr_++-- | Reduce polynomial modulo ideal.+reduce :: (IsOrderedPolynomial poly, Field (Coefficient poly))+ => poly -> Ideal poly -> poly+reduce f i = withQuotient i $ modIdeal f+{-# SPECIALISE INLINE+ reduce :: (IsMonomialOrder n ord, CoeffRing r, KnownNat n, Field r)+ => OrderedPolynomial r ord n+ -> Ideal (OrderedPolynomial r ord n)+ -> OrderedPolynomial r ord n+ #-}+{-# SPECIALISE INLINE+ reduce :: (CoeffRing r, Field r)+ => Unipol r+ -> Ideal (Unipol r)+ -> Unipol r+ #-}+{-# INLINE reduce #-}++isZeroDimensional :: (IsOrderedPolynomial poly, Field (Coefficient poly))+ => [poly] -> Bool+isZeroDimensional ii = isJust $ stdMonoms $ calcGroebnerBasis $ toIdeal ii+{-# INLINE isZeroDimensional #-}
+ Algebra/Ring/Polynomial/Univariate.hs view
@@ -0,0 +1,373 @@+{-# LANGUAGE BangPatterns, ConstraintKinds, DataKinds, FlexibleContexts #-}+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude, ScopedTypeVariables, StandaloneDeriving #-}+{-# LANGUAGE TypeApplications, TypeFamilies, UndecidableSuperClasses #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+-- | Polynomial type optimized to univariate polynomial.+module Algebra.Ring.Polynomial.Univariate+ (Unipol(), naiveMult, karatsuba,+ divModUnipolByMult, divModUnipol,+ mapCoeffUnipol,+ module Algebra.Ring.Polynomial.Class,+ module Algebra.Ring.Polynomial.Monomial) where+import Algebra.Prelude.Core+import Algebra.Ring.Polynomial.Class+import Algebra.Ring.Polynomial.Monomial++import Control.Arrow (first)+import Control.DeepSeq (NFData)+import Data.Function (on)+import Data.Hashable (Hashable (hashWithSalt))+import qualified Data.HashSet as HS+import Data.IntMap (IntMap)+import qualified Data.IntMap as IM+import qualified Data.Map.Strict as M+import Data.Maybe (mapMaybe)+import Data.Ord (comparing)+import qualified Data.Sized.Builtin as SV+import qualified Numeric.Algebra as NA+import Numeric.Decidable.Zero (DecidableZero (..))+import qualified Prelude as P+import GHC.OverloadedLabels+-- | Univariate polynomial.+-- It uses @'IM.IntMap'@ as its internal representation;+-- so if you want to treat the power greater than @maxBound :: Int@,+-- please consider using other represntation.+newtype Unipol r = Unipol { runUnipol :: IM.IntMap r }+ deriving (NFData)++instance Hashable r => Hashable (Unipol r) where+ hashWithSalt p = hashWithSalt p . IM.toList . runUnipol++-- | By this instance, you can use @#x@ for+-- the unique variable of @'Unipol' r@.+instance Unital r => IsLabel "x" (Unipol r) where+ fromLabel _ = Unipol $ IM.singleton 1 one++normaliseUP :: DecidableZero r => Unipol r -> Unipol r+normaliseUP (Unipol r) = Unipol $ IM.filter (not . isZero) r++divModUnipol :: (CoeffRing r, Field r) => Unipol r -> Unipol r -> (Unipol r, Unipol r)+divModUnipol f g =+ if isZero g then error "Divided by zero!" else loop f zero+ where+ (dq, cq) = leadingTermIM g+ loop p !acc =+ let (dp, cp) = leadingTermIM p+ coe = cp/cq+ deg = dp - dq+ canceler = Unipol $ IM.map (*coe) $ IM.mapKeysMonotonic (+ deg) (runUnipol g)+ in if dp < dq || isZero p+ then (acc, p)+ else loop (p - canceler) $+ Unipol $ IM.insert deg coe $ runUnipol acc+{-# INLINE divModUnipol #-}++divModUnipolByMult :: (Eq r, Field r) => Unipol r -> Unipol r -> (Unipol r, Unipol r)+divModUnipolByMult f g =+ if isZero g then error "Divided by zero!" else+ let ((n,_), (m,_)) = (leadingTermIM f, leadingTermIM g)+ i = logBase2 (n - m + 1) + 1+ g' = reversalIM g+ t = recipBinPow i g'+ q = reversalIMWith (n - m) $+ modVarPower (n - m + 1) $+ t * reversalIM f+ in if n >= m+ then (q, f - g * q)+ else (zero, f)+{-# INLINE divModUnipolByMult #-}++recipBinPow :: (Eq r, Field r)+ => Int -> Unipol r -> Unipol r+recipBinPow i f =+ let g 0 = Unipol $ IM.singleton 0 $ recip (constantTerm f)+ g k = let p = g (k - 1)+ in modVarPower (2^fromIntegral k) (P.fromInteger 2 * p - p*p * f)+ in g i+{-# INLINE recipBinPow #-}++modVarPower :: Int -> Unipol r -> Unipol r+modVarPower n = Unipol . fst . IM.split n . runUnipol+{-# INLINE modVarPower #-}++reversalIM :: Monoidal r => Unipol r -> Unipol r+reversalIM m = reversalIMWith (fst $ leadingTermIM m) m+{-# INLINE reversalIM #-}++reversalIMWith :: Monoidal r => Int -> Unipol r -> Unipol r+reversalIMWith d = Unipol . IM.mapKeys (d -) . runUnipol+{-# INLINE reversalIMWith #-}++++instance (Eq r, Field r) => DecidableUnits (Unipol r) where+ isUnit f =+ let (lc, lm) = leadingTerm f+ in lm == one && isUnit lc+ recipUnit f | isUnit f = injectCoeff <$> recipUnit (leadingCoeff f)+ | otherwise = Nothing+instance (Eq r, Field r) => DecidableAssociates (Unipol r) where+ isAssociate = (==) `on` normaliseUnit++instance (Eq r, Field r) => UnitNormalForm (Unipol r) where+ splitUnit f+ | isZero f = (zero, f)+ | otherwise = let lc = leadingCoeff f+ in (injectCoeff lc, injectCoeff (recip lc) * f)+instance (Eq r, Field r) => GCDDomain (Unipol r)+instance (Eq r, Field r) => ZeroProductSemiring (Unipol r)+instance (Eq r, Field r) => IntegralDomain (Unipol r)+instance (Eq r, Field r) => UFD (Unipol r)+instance (Eq r, Field r) => PID (Unipol r)+instance (Eq r, Field r) => Euclidean (Unipol r) where+ divide f g =+ if totalDegree' f `min` totalDegree' g < 50+ then divModUnipol f g+ else divModUnipolByMult f g+ degree f = if isZero f then Nothing else Just (totalDegree' f)++leadingTermIM :: Monoidal r => Unipol r -> (Int, r)+leadingTermIM = maybe (0, zero) fst . IM.maxViewWithKey . runUnipol+{-# INLINE leadingTermIM #-}++instance CoeffRing r => P.Num (Unipol r) where+ fromInteger = NA.fromInteger+ (+) = (NA.+)+ (*) = (NA.*)+ negate = NA.negate+ (-) = (NA.-)+ abs = id+ signum f =+ if isZero f+ then zero+ else one++(%!!) :: Sized (n :: Nat) a -> SV.Ordinal (n :: Nat) -> a+(%!!) = (SV.%!!)++{-# RULES+"var x^n" forall (x :: SV.Ordinal 1) n.+ pow (varUnipol x) n = Unipol (IM.singleton (fromEnum n) one)+ #-}++{-# RULES+"pow1p x n" forall (x :: SV.Ordinal 1) n.+ NA.pow1p (varUnipol x) n = Unipol (IM.singleton (fromEnum n + 1) one)+ #-}++{-# RULES+"x ^ n" forall (x :: SV.Ordinal 1) n.+ (varUnipol x) ^ n = Unipol (IM.singleton (fromEnum n) one)+ #-}++varUnipol :: Unital r => SV.Ordinal 1 -> Unipol r+varUnipol _ = Unipol $ IM.singleton 1 one+{-# NOINLINE CONLIKE [1] varUnipol #-}++instance (Eq r, DecidableZero r) => Eq (Unipol r) where+ (==) = (==) `on` IM.filter (not . isZero) . runUnipol+ (/=) = (/=) `on` IM.filter (not . isZero) . runUnipol++instance (Ord r, DecidableZero r) => Ord (Unipol r) where+ compare = comparing runUnipol+ (<) = (<) `on` runUnipol+ (>) = (>) `on` runUnipol+ (<=) = (<=) `on` runUnipol+ (>=) = (>=) `on` runUnipol++-- | Polynomial multiplication, naive version.+naiveMult :: (DecidableZero r, Multiplicative r) => Unipol r -> Unipol r -> Unipol r+naiveMult (Unipol f) (Unipol g) =+ Unipol $+ IM.filter (not . isZero) $+ IM.fromListWith (+)+ [ (n+m, p*q)+ | (n, p) <- IM.toList f, (m, q) <- IM.toList g+ ]++-- | Polynomial multiplication using Karatsuba's method.+karatsuba :: forall r. CoeffRing r => Unipol r -> Unipol r -> Unipol r+karatsuba f0 g0 =+ let n0 = fromIntegral (totalDegree' f0 `max` totalDegree' g0) + 1+ -- The least @m@ such that deg(f), deg(g) <= 2^m - 1.+ m0 = toEnum $ ceilingLogBase2 n0+ in Unipol $ loop m0 (runUnipol f0) (runUnipol g0)+ where+ linearProduct op (a, b) (c, d) =+ let (ac, bd, abdc) = (a `op` c, b `op` d, (a - b) `op` (d - c))+ in (ac, abdc + ac + bd, bd)+ {-# SPECIALISE INLINE+ linearProduct :: (r -> r -> r) -> (r, r) -> (r, r) -> (r, r, r)+ #-}+ {-# SPECIALISE INLINE+ linearProduct :: (Unipol r -> Unipol r -> Unipol r)+ -> (Unipol r, Unipol r)+ -> (Unipol r, Unipol r)+ -> (Unipol r, Unipol r, Unipol r)+ #-}++ divideAt m h =+ let (l, mk, u) = IM.splitLookup m h+ in (maybe id (IM.insert 0) mk $ IM.mapKeysMonotonic (subtract m) u, l)+ {-# INLINE divideAt #-}++ xCoeff = IM.findWithDefault zero 1+ {-# INLINE xCoeff #-}+ cCoeff = IM.findWithDefault zero 0+ {-# INLINE cCoeff #-}++ loop !m !f !g+ | m <= 1 =+ let (a, b, c) =+ linearProduct (*)+ (xCoeff f, cCoeff f)+ (xCoeff g, cCoeff g)+ in IM.fromAscList $+ filter (not . isZero . snd)+ [(0, c), (1, b), (2, a)]+ | otherwise =+ let (f1, f2) = divideAt (2^(m P.- 1)) f -- f = f1 x^m + f2+ (g1, g2) = divideAt (2^(m P.- 1)) g -- g = g1 x^m + g2+ (Unipol m2, Unipol m1, Unipol c) =+ linearProduct ((Unipol .) . loop (m P.- 1) `on` runUnipol)+ (Unipol f1, Unipol f2)+ (Unipol g1, Unipol g2)+ in IM.unionsWith (+) [IM.mapKeysMonotonic (2^m+) m2,+ IM.mapKeysMonotonic (2^(m P.- 1)+) m1, c]+{-# INLINABLE karatsuba #-}+++decZero :: DecidableZero r => r -> Maybe r+decZero r = if isZero r then Nothing else Just r++instance (DecidableZero r) => Additive (Unipol r) where+ Unipol f + Unipol g =+ Unipol $ IM.mergeWithKey (\_ a b -> decZero (a + b)) id id f g++instance (DecidableZero r, Abelian r) => Abelian (Unipol r)++instance (DecidableZero r, RightModule Natural r) => RightModule Natural (Unipol r) where+ Unipol r *. n = Unipol $ IM.mapMaybe (decZero . (*. n)) r++instance (DecidableZero r, LeftModule Natural r) => LeftModule Natural (Unipol r) where+ n .* Unipol r = Unipol $ IM.mapMaybe (decZero . (n .*)) r++instance (DecidableZero r, RightModule Integer r) => RightModule Integer (Unipol r) where+ Unipol r *. n = Unipol $ IM.mapMaybe (decZero . (*. n)) r++instance (DecidableZero r, LeftModule Integer r) => LeftModule Integer (Unipol r) where+ n .* Unipol r = Unipol $ IM.mapMaybe (decZero . (n .*)) r++instance (CoeffRing r, Multiplicative r) => Multiplicative (Unipol r) where+ f * g =+ if totalDegree' f `min` totalDegree' g > 50+ then karatsuba f g+ else f `naiveMult` g++diffIMap :: (DecidableZero r, Group r) => IntMap r -> IntMap r -> IntMap r+diffIMap = IM.mergeWithKey (\_ a b -> decZero (a - b)) id (fmap negate)+{-# INLINE diffIMap #-}++instance (DecidableZero r, Group r) => Group (Unipol r) where+ negate (Unipol r) = Unipol $ IM.map negate r+ {-# INLINE negate #-}++ Unipol f - Unipol g = Unipol $ diffIMap f g+ {-# INLINE (-) #-}++instance (CoeffRing r, Unital r) => Unital (Unipol r) where+ one = Unipol $ IM.singleton 0 one++instance (CoeffRing r, Commutative r) => Commutative (Unipol r)++instance (DecidableZero r, Semiring r) => LeftModule (Scalar r) (Unipol r) where+ Scalar q .* Unipol f+ | isZero q = zero+ | otherwise = Unipol $ IM.mapMaybe (decZero . (q *)) f++instance (CoeffRing r, DecidableZero r) => Semiring (Unipol r)++instance (CoeffRing r, DecidableZero r) => Rig (Unipol r) where+ fromNatural 0 = Unipol IM.empty+ fromNatural n = Unipol $ IM.singleton 0 (fromNatural n)++instance (CoeffRing r, DecidableZero r) => Ring (Unipol r) where+ fromInteger 0 = Unipol IM.empty+ fromInteger n = Unipol $ IM.singleton 0 (fromInteger' n)++instance (DecidableZero r, Semiring r) => RightModule (Scalar r) (Unipol r) where+ Unipol f *. Scalar q+ | isZero q = zero+ | otherwise = Unipol $ IM.mapMaybe (decZero . (* q)) f++instance DecidableZero r => Monoidal (Unipol r) where+ zero = Unipol IM.empty++instance DecidableZero r => DecidableZero (Unipol r) where+ isZero = IM.null . runUnipol++instance CoeffRing r => IsPolynomial (Unipol r) where+ type Arity (Unipol r) = 1+ type Coefficient (Unipol r) = r+ injectCoeff r =+ if isZero r+ then zero+ else Unipol $ IM.singleton 0 r+ {-# INLINE injectCoeff #-}+ coeff' l = IM.findWithDefault zero (SV.head l) . runUnipol+ {-# INLINE coeff' #-}+ monomials = HS.fromList . map (singleton) . IM.keys . runUnipol+ {-# INLINE monomials #-}+ terms' = M.fromList . map (first singleton) . IM.toList . runUnipol+ {-# INLINE terms' #-}+ sArity _ = sing+ sArity' _ = sing+ arity _ = 1+ constantTerm = IM.findWithDefault zero 0 . runUnipol+ {-# INLINE constantTerm #-}+ liftMap g f@(Unipol dic) =+ let u = g 0+ n = maybe 0 (fst . fst) $ IM.maxViewWithKey $ runUnipol f+ in foldr (\a b -> a .*. one + b * u)+ (IM.findWithDefault zero n dic .*. one)+ [IM.findWithDefault zero k dic | k <- [0..n-1]]+ {-# INLINABLE liftMap #-}+ fromMonomial = Unipol . flip IM.singleton one . SV.head+ {-# INLINE fromMonomial #-}+ toPolynomial' (c, m) =+ if isZero c+ then Unipol IM.empty+ else Unipol $ IM.singleton (SV.head m) c+ {-# INLINE toPolynomial' #-}+ polynomial' = Unipol . IM.fromList+ . mapMaybe (\(s, v) -> if isZero v then Nothing else Just (SV.head s, v))+ . M.toList+ {-# INLINE polynomial' #-}+ totalDegree' = fromIntegral . maybe 0 (fst . fst) . IM.maxViewWithKey . runUnipol+ {-# INLINE totalDegree' #-}+ var = varUnipol+ mapCoeff' f = Unipol . IM.mapMaybe (decZero . f) . runUnipol+ {-# INLINE mapCoeff' #-}+ m >|* Unipol dic =+ let n = SV.head m+ in if n == 0+ then Unipol dic+ else Unipol $ IM.mapKeys (n +) dic+ {-# INLINE (>|*) #-}++instance CoeffRing r => IsOrderedPolynomial (Unipol r) where+ type MOrder (Unipol r) = Grevlex+ terms = M.mapKeys (orderMonomial (Nothing :: Maybe Grevlex)) . terms'+ leadingTerm =+ maybe (zero, one)+ (\((a, b),_) -> (b, OrderedMonomial $ SV.singleton a))+ . IM.maxViewWithKey . runUnipol+ {-# INLINE leadingTerm #-}++instance (CoeffRing r, PrettyCoeff r) => Show (Unipol r) where+ showsPrec = showsPolynomialWith (SV.singleton "x")++mapCoeffUnipol :: DecidableZero b => (a -> b) -> Unipol a -> Unipol b+mapCoeffUnipol f (Unipol a) =+ Unipol $ IM.mapMaybe (decZero . f) a
+ Algebra/Scalar.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+module Algebra.Scalar (Scalar(..), (.*.)) where+import AlgebraicPrelude+import qualified Data.Coerce as C+import Algebra.Normed+import Control.Lens+import qualified Prelude as P++-- | @'Scalar' r@ provides almost the same type-instances as @r@,+-- but it can also behave as a @'Module'@ over @r@ itself.+newtype Scalar r = Scalar { runScalar :: r }+ deriving (Read, Show, Eq, Ord, Additive,+ Integral, Real, Enum+ ,Multiplicative, Unital)++(.*.) :: (Module (Scalar r) m)+ => r -> m -> m+r .*. f = Scalar r .* f++infixr 8 .*.+instance Normed r => Normed (Scalar r) where+ type Norm (Scalar r) = Norm r+ norm = norm . runScalar+ liftNorm = runScalar . liftNorm+deriving instance DecidableAssociates r => DecidableAssociates (Scalar r)+deriving instance DecidableUnits r => DecidableUnits (Scalar r)+deriving instance UnitNormalForm r => UnitNormalForm (Scalar r)++deriving instance P.Num r => P.Num (Scalar r)++deriving instance P.Fractional r => P.Fractional (Scalar r)+deriving instance Monoidal r => Monoidal (Scalar r)+deriving instance Group r => Group (Scalar r)+deriving instance Semiring r => Semiring (Scalar r)+deriving instance Ring r => Ring (Scalar r)+deriving instance Abelian r => Abelian (Scalar r)+deriving instance Rig r => Rig (Scalar r)+deriving instance Commutative r => Commutative (Scalar r)+deriving instance Division r => Division (Scalar r)+deriving instance LeftModule Integer r => LeftModule Integer (Scalar r)+deriving instance RightModule Integer r => RightModule Integer (Scalar r)+deriving instance LeftModule Natural r => LeftModule Natural (Scalar r)+deriving instance RightModule Natural r => RightModule Natural (Scalar r)+instance Semiring r => RightModule r (Scalar r) where+ Scalar r *. q = Scalar $ r * q+ {-# INLINE (*.) #-}+instance Semiring r => LeftModule r (Scalar r) where+ r .* Scalar q = Scalar $ r * q+ {-# INLINE (.*) #-}++instance (Semiring r) => LeftModule (Scalar r) (Scalar r) where+ Scalar r .* Scalar q = Scalar $ r * q++instance (Semiring r) => RightModule (Scalar r) (Scalar r) where+ Scalar r *. Scalar q = Scalar $ r * q
− Monomorphic.hs
@@ -1,5 +0,0 @@-{-# LANGUAGE DataKinds, ExistentialQuantification, FlexibleContexts, GADTs #-}-{-# LANGUAGE PolyKinds, RankNTypes, TypeFamilies, TypeOperators #-}-{-# LANGUAGE UndecidableInstances, CPP #-}-module Monomorphic (module Data.Type.Monomorphic) where-import Data.Type.Monomorphic
README.md view
@@ -1,47 +1,57 @@ Computational Algebra Library ==============================+[](https://travis-ci.org/konn/computational-algebra) -Installation---------------```{sh}-$ cabal install computational-algebra-```+**For more detail, please read [Official Project Site](http://konn.github.io/computational-algebra/)**. -If you once installed the same version of this package and want to reinstall, please run `cabal clean` first to avoid the GHC's bug.+Overview+--------+The `computational-algebra` is the computational algebra system, implemented as a Embedded Domain Specific Language (*EDSL*) in [Haskell](https://www.haskell.org).+This library provides many functionality for computational algebra, especially ideal computation such as Groebner basis calculation. -What is this?---------------This library provides data-types and functions to manipulate polynomials.-This is built up with GHC's nice type features.+Thanks to Haskell's powerful language features, this library achieves the following goals: -It contains following things:+Type-Safety+: Haskell's static type system enforces **static correctness** and prevents you from violating invariants. -* Compute Groebner basis using Buchberger Algorithm-* Ideal membership problem-* Elimination ideal calculation- * This library provides the monomial orders of l-th elimination type other than lex order, such as elimination order, product order,...-* Ideal operations- * Saturation Ideal, Quotient ideal,...+Flexibility+: With the powerful type-system of Haskell,+ we can write **highly abstract program** resulted in **easy-to-extend** system. -There are two interfaces:+Efficiency+: Haskell comes with many **aggressive optimization mechanism** and **parallel computation features**,+ which enables us to write efficient program. -* Dependently-typed I/F- * Arity-paramaterized polynomials. It uses vector representations for monomials.- `Algebra.Ring.Polynomial` and `Algebra.Algorithms.Groebner`.+This package currently provides the following functionalities: -* Monomorphic wrapper I/F- * Not-so-dependently-typed interface to wrap dependently-typed ones. `Algebra.Ring.Polynomial.Monomorphic` and `Algebra.Algorithms.Groebner.Monomorphic`.+* Groebner basis calculation w.r.t. arbitrary monomial ordering+ * Currently using Buchberger's algorithm with some optimization+ * Faugere's F_4 algorithms is experimentally implemented,+ but currently not as fast as Buchberger's algorithm +* Computation in the (multivariate) polynomial ring over arbitarary field and its quotient ring+ * Ideal membership problem+ * Ideal operations such as intersection, saturation and so on.+ * Zero-dimensional ideal operation and conversion via FGLM algorithm+ * Variable elimination+* Find numeric solutions for polynomial system with real coefficient +Requirements and Installation+------------------------------+Old version of this package is uploaded on [Hackage](http://hackage.haskell.org/package/computational-algebra), but it's rather outdated.+Most recent version of `computational-algebra` is developed on GitHub. -For more information, please read `examples/polymorphic.hs` and `examples/monomorphic.hs`.+It uses the most agressive language features recently implemented in [Glasgow Haskell Compiler](https://www.haskell.org/ghc/), so it requires at least GHC 8.0.1 and+also it depends on many packages currently not available on Hackage, but you can install it fairly easily with help of [The Haskell Tool Stack](https://docs.haskellstack.org/en/stable/README/). -Known Issues--------------Due to GHC 7.4.*'s bug, this library contains extra modules and functionalities as follows:+```zsh+$ curl -sSL https://get.haskellstack.org/ | sh+ # if you haven't install Stack yet+$ git clone https://github.com/konn/computational-algebra+$ cd computational-algebra+$ stack build+``` -* `Monomorphic` data-type and his friends- * This is completely separeted as [`monomorphic`](http://hackage.haskell.org/package/monomorphic) package. But due to GHC 7.4.1, which is shipped with latest Haskell Platform, I include the functionality from this library for a while.-* Singleton types and functions- * Because the [`singletons`](http://hackage.haskell.org/package/singletons) package is not available in GHC 7.4.1, I provide limited version of the functionalities of that package in `Algebra.Internal` module. After new HP released, I will entirely rewrite all source codes using `singletons`.-* Type-level natural numbers and size-parameterized vectors- * For the similar reason, I include `SNat` and `Vector` data-type in `Algebra.Internal` module, which is separated as [`sized-vector`](http://hackage.haskell.org/package/sized-vector) package. Their proofs are so messy, so I will entirely rewrite these after new HP released with my unreleased package [`equational-reasoning`](https://github.com/konn/equational-reasoning-in-haskell), which provides the functionalities similar to Agda's EqReasoning.+In addition, you may need to install GSL and LAPACK (for matrix computation) beforehand.+You can install them via Homebrew (OS X), `apt-get`, or other major package management systems.++### [Read More in Official Project Site](http://konn.github.io/computational-algebra/)
+ bench/SingularBench.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE GADTs, OverloadedStrings, QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+module SingularBench where+import Algebra.Algorithms.Groebner.Monomorphic+import Algebra.Internal+import Algebra.Ring.Polynomial (Coefficient (..),+ ProductOrder (..),+ ToWeightVector (..),+ WeightOrder (..),+ WeightProxy (..),+ showRational)+import Algebra.Ring.Polynomial.Monomorphic+import Control.Arrow+import Data.List+import qualified Data.Map as M+import Data.Monoid+import Data.Singletons+import Data.Type.Natural+import System.Process++formatPoly :: Polynomial (Fraction Integer) -> String+formatPoly (Polynomial dic) = intercalate "+" $+ map (uncurry formatTerm) $ M.toList dic++formatTerm :: M.Map Variable Integer -> (Fraction Integer) -> String+formatTerm k v+ | M.null k = showCoeff $ showRational v+ | otherwise = concat ["(", showCoeff $ showRational v, ")*", formatMonom k]++showCoeff :: Coefficient -> String+showCoeff Zero = "0"+showCoeff (Negative str) = '-':str+showCoeff (Positive str) = str+showCoeff Eps = "1"++formatMonom :: Monomial -> String+formatMonom = intercalate "*" . map (uncurry (++) <<< show *** ('^':).show) . M.toList++formatIdeal :: [Polynomial (Fraction Integer)] -> String+formatIdeal = intercalate ", " . map formatPoly++class IsMonomialOrder ord => SingularRep ord where+ singularRep :: ord -> String++instance SingularRep Lex where+ singularRep _ = "lp"++instance SingularRep Grlex where+ singularRep _ = "Dp"++instance SingularRep Grevlex where+ singularRep _ = "dp"++instance (SingI n, SingularRep o1, SingularRep o2) => SingularRep (ProductOrder n o1 o2) where+ singularRep (ProductOrder n o1 o2) = concat ["(", singularRep o1, "(", show (sNatToInt n), "),"+ , singularRep o2, ")"+ ]++instance (ToWeightVector vec, SingularRep ord) => SingularRep (WeightOrder vec ord) where+ singularRep (WeightOrder vec ord) = concat ["(a(", init $ tail $ show $ tovec vec, "),"+ , singularRep ord, ")"+ ]+ where+ tovec :: WeightProxy v -> [Int]+ tovec NilWeight = []+ tovec (ConsWeight n ns) = sNatToInt n : tovec ns++type Ideal = [Polynomial (Fraction Integer)]++skeleton :: SingularRep ord => ord -> [Polynomial (Fraction Integer)] -> String+skeleton ord ideal =+ unlines [ "LIB \"poly.lib\";"+ , concat ["ring R = 0,("+ ,intercalate "," (map show $ nub $ sort $ concatMap buildVarsList ideal)+ , "),"+ , singularRep ord, ";"]+ , "ideal I =" <> formatIdeal ideal <> ";"+ , "std(I);"+ , "quit;"+ ]+singularWith :: SingularRep ord => ord -> Ideal -> IO String+singularWith = (readProcess "singular" [] .) . skeleton+
+ bench/bench.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}+{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings, PolyKinds, QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell, UndecidableInstances, DataKinds, NoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}+import Algebra.Algorithms.Groebner+import Algebra.Prelude+import Control.DeepSeq+import Control.Parallel.Strategies+import Criterion.Main++i1, i2, i4 :: [OrderedPolynomial (Fraction Integer) Grevlex 3]+(i1, i2, i4) = ([x^2 + y^2 + z^2 - 1, x^2 + y^2 + z^2 - 2*x, 2*x -3*y - z],+ [x^2 * y - 2*x*y - 4*z - 1, z-y^2, x^3 - 4*z*y],+ [ z^5 + y^4 + x^3 - 1, z^3 + y^3 + x^2 - 1]+ )+ where+ [x,y,z] = vars++i3 :: [OrderedPolynomial Rational Grevlex 6]+i3 = [ 2 * s - a * y, b^2 - (x^2 + y^2), c^2 - ( (a-x) ^ 2 + y^2)]+ where+ [x,y,s,a,b,c] = vars++main :: IO ()+main = do+ defaultMain $ [ env (return $! toIdeal $ map (changeOrder Lex) i1) $ \ ~ideal ->+ bgroup "lex01"+ [ bench "simple" $ nf simpleBuchberger ideal+ , bench "relprime" $ nf primeTestBuchberger ideal+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy) ideal+ , bench "syz+sugar" $ nf syzygyBuchberger ideal+ ]+ , env (return $! toIdeal $ map (changeOrder Grlex) i1) $ \ ~ideal ->+ bgroup "grlex01"+ [ bench "simple" $ nf simpleBuchberger ideal+ , bench "relprime" $ nf primeTestBuchberger ideal+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy) ideal+ , bench "syz+sugar" $ nf syzygyBuchberger ideal+ ]+ , env (return $! toIdeal $ map (changeOrder Grevlex) i1) $ \ ~ideal ->+ bgroup "grevlex01"+ [ bench "simple" $ nf simpleBuchberger ideal+ , bench "relprime" $ nf primeTestBuchberger ideal+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy) ideal+ , bench "syz+sugar" $ nf syzygyBuchberger ideal+ ]+ , env (return $! toIdeal $ map (changeOrder Grlex) i2) $ \ ~ideal ->+ bgroup "grlex02"+ [ bench "simple" $ nf simpleBuchberger ideal+ , bench "relprime" $ nf primeTestBuchberger ideal+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy) ideal+ , bench "syz+sugar" $ nf syzygyBuchberger ideal+ ]+ , env (return $! toIdeal $ map (changeOrder Grevlex) i2) $ \ ~ideal ->+ bgroup "grevlex02"+ [ bench "simple" $ nf simpleBuchberger ideal+ , bench "relprime" $ nf primeTestBuchberger ideal+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy) ideal+ , bench "syz+sugar" $ nf syzygyBuchberger ideal+ -- -- , bench "singular" $ nfIO (singularWith Grevlex ideal)+ ]+ , env (return $! toIdeal $ map (changeOrder Lex) i3) $ \ ~ideal ->+ bgroup "lex03"+ [ bench "simple" $ nf simpleBuchberger ideal+ , bench "relprime" $ nf primeTestBuchberger ideal+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy) ideal+ , bench "syz+sugar" $ nf syzygyBuchberger ideal+ -- -- , bench "singular" $ nfIO (singularWith Grevlex ideal)+ ]+ , env (return $! toIdeal $ map (changeOrder Grlex) i3) $ \ ~ideal ->+ bgroup "grlex03"+ [ bench "simple" $ nf simpleBuchberger ideal+ , bench "relprime" $ nf primeTestBuchberger ideal+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy) ideal+ , bench "syz+sugar" $ nf syzygyBuchberger ideal+ -- -- , bench "singular" $ nfIO (singularWith Grevlex ideal)+ ]+ , env (return $! toIdeal $ map (changeOrder Grevlex) i3) $ \ ~ideal ->+ bgroup "grevlex03"+ [ bench "simple" $ nf simpleBuchberger ideal+ , bench "relprime" $ nf primeTestBuchberger ideal+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy) ideal+ , bench "syz+sugar" $ nf syzygyBuchberger ideal+ -- -- , bench "singular" $ nfIO (singularWith Grevlex ideal)+ ]+ , env (return $! toIdeal $ map (changeOrder Grlex) i4) $ \ ~ideal ->+ bgroup "grlex04"+ [ bench "simple" $ nf simpleBuchberger ideal+ , bench "relprime" $ nf primeTestBuchberger ideal+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy) ideal+ , bench "syz+sugar" $ nf syzygyBuchberger ideal+ -- -- , bench "singular" $ nfIO (singularWith Grevlex ideal)+ ]+ , env (return $! toIdeal $ map (changeOrder Grevlex) i4) $ \ ~ideal ->+ bgroup "grevlex04"+ [ bench "simple" $ nf simpleBuchberger ideal+ , bench "relprime" $ nf primeTestBuchberger ideal+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy) ideal+ , bench "syz+sugar" $ nf syzygyBuchberger ideal+ -- -- , bench "singular" $ nfIO (singularWith Grevlex ideal)+ ]+ ]
+ bench/coercion.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses, NoImplicitPrelude, PolyKinds #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans -freduction-depth=1000 #-}+module Main where+import Algebra.Algorithms.Groebner+import Algebra.Ring.Ideal+import Algebra.Ring.Polynomial+import Algebra.Scalar+import Control.DeepSeq+import Control.Monad+import Control.Parallel.Strategies+import Criterion+import Data.Type.Natural hiding (one)+import Data.Vector.Sized (Vector (..))+import qualified Data.Vector.Sized as V+import Numeric.Algebra hiding ((.*), (<), (^))+import qualified Numeric.Algebra as NA+import Numeric.Field.Fraction (Fraction)+import Prelude hiding (Fractional (..),+ Integral (..), Num (..),+ Real (..), sum, (^^))+import qualified Prelude as P+import Progression.Main++x, y, z :: Polynomial (Fraction Integer) Three+[x, y, z] = vars++(.*) :: SingI n => (Fraction Integer) -> Polynomial (Fraction Integer) n -> Polynomial (Fraction Integer) n+(.*) = (.*.)++infixl 7 .*++(^^) :: Unital r => r -> NA.Natural -> r+(^^) = NA.pow++eqn01 :: Ideal (Polynomial (Fraction Integer) Three)+eqn01 = toIdeal [x^^2 - 2*x*z + 5, x*y^^2+y*z+1, 3*y^^2 - 8*x*z]++eqn02 :: Ideal (Polynomial (Fraction Integer) Three)+eqn02 =+ toIdeal [x^^2 + 2*y^^2 - y - 2*z+ ,x^^2 - 8*y^^2 + 10*z - 1+ ,x^^2 - 7*y*z+ ]++eqn03 :: Ideal (Polynomial (Fraction Integer) Three)+eqn03 = toIdeal [x^^2 + y^^2 + z^^2 - 2*x+ ,x^^3 - y*z - x+ ,x - y + 2*z+ ]++eqn04 :: Ideal (Polynomial (Fraction Integer) Three)+eqn04 = toIdeal [x*y + z - x*z, x^^2 - z, 2*x^^3 - x^^2 * y * z - 1]++f01 :: Polynomial (Fraction Integer) Three+f01 = -4*x^^4*y^^4 - (1/3).*(x^^3*y^^4*z) + (4/5).*(x^^2*y^^2*z^^4) - (1/5).*(x*y^^2*z^^5)++f02 :: Polynomial (Fraction Integer) Three+f02 = (3/4).*x^^6 - (6/5).*(x^^5*y) + 4*y^^5*z++f03 :: Polynomial (Fraction Integer) Four+f03 = (6/7).* (a^^7*b^^3*c^^4) - (4/3) .* (a^^5*b^^6*c*d^^2) - a^^4*b^^2*c^^4*d^^4+ where+ a, b, c, d :: Polynomial (Fraction Integer) Four+ [a, b, c, d] = vars++main :: IO ()+main = do+ v10 <- return $!! ((V.replicate [snat|10|] ()) `using` rdeepseq)+ v100 <- return $!! ((V.replicate [snat|100|] ()) `using` rdeepseq)+ v200 <- return $!! ((V.replicate [snat|200|] ()) `using` rdeepseq)+ v300 <- return $!! ((V.replicate [snat|300|] ()) `using` rdeepseq)+ v400 <- return $!! ((V.replicate [snat|400|] ()) `using` rdeepseq)+ case01 <- return $!! (eqn01 `using` rdeepseq)+ case02 <- return $!! (eqn02 `using` rdeepseq)+ case03 <- return $!! (eqn03 `using` rdeepseq)+ case04 <- return $!! (eqn04 `using` rdeepseq)+ poly01 <- return $!! (f01 `using` rdeepseq)+ poly02 <- return $!! (f02 `using` rdeepseq)+ poly03 <- return $!! (f03 `using` rdeepseq)+ defaultMain $ bgroup "coercion" $+ [ bgroup "unhomogenize"+ [ bench "01" $ nf unhomogenize poly01+ , bench "02" $ nf unhomogenize poly02+ , bench "03" $ nf unhomogenize poly03+ ]+-- These are too expensive...+ , bgroup "intersection"+ [ bench "two" $ nf intersection (case01 :- case02 :- Nil)+ , bench "three" $ nf intersection (case03 :- case01 :- case02 :- Nil)+ , bench "four" $ nf intersection (case04 :- case03 :- case01 :- case02 :- Nil)+ ]+ , bgroup "satByPrinc"+ [ bench "01" $ nf (saturationByPrincipalIdeal case01) f01+ , bench "02" $ nf (saturationByPrincipalIdeal case02) f01+ , bench "03" $ nf (saturationByPrincipalIdeal case03) f01+ , bench "04" $ nf (saturationByPrincipalIdeal case01) f02+ , bench "05" $ nf (saturationByPrincipalIdeal case02) f02+ , bench "06" $ nf (saturationByPrincipalIdeal case03) f02+ ]+ ]
+ bench/division.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}+{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings, PolyKinds, QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}+module Main where+import Algebra.Algorithms.Groebner+import Algebra.Ring.Ideal+import Algebra.Ring.Polynomial+import Control.Applicative+import Control.Concurrent+import Control.DeepSeq+import Control.Monad+import Control.Parallel.Strategies+import Criterion.Main+import Data.Type.Natural hiding (one)+import Prelude hiding (product)+import System.Process+import Test.QuickCheck+import Utils++makeIdeals :: SingI n => Int -> SNat n -> Int -> IO [(Polynomial (Fraction Integer) n, [Polynomial (Fraction Integer) n])]+makeIdeals count sn dpI = do+ ideals <- take count . map generators <$> sample' (resize dpI (idealOfDim sn))+ fs <- take count <$> sample' (polyOfDim sn)+ return $ zip fs ideals++mkTestCases :: SingI n => [(Polynomial (Fraction Integer) n, [Polynomial (Fraction Integer) n])] -> IO [Benchmark]+mkTestCases is =+ forM (zip [1..] is) $ \(n, (f0, gs0)) -> do+ f <- return $!! (f0 `using` rdeepseq)+ gs <- return $!! (gs0 `using` rdeepseq)+ return $ bgroup (concat ["case-",show n])+ [ bench "ST+LoopT" $ nf (uncurry divModPolynomial') (f, gs)+ , bench "ST+monad" $ nf (uncurry divModPolynomial'') (f, gs)+ , bench "List" $ nf (uncurry divModPolynomial) (f, gs)+ ]++main :: IO ()+main = do+ putStrLn "generating case01..."+ case01 <- mkTestCases =<< makeIdeals 3 sTwo 5+ putStrLn "generating case02..."+ case02 <- mkTestCases =<< makeIdeals 3 sThree 7+ putStrLn "generating case03..."+ case04 <- mkTestCases =<< makeIdeals 3 sFour 7+ putStrLn "done. purge and sleep 10secs..."+ system "purge"+ threadDelay $ 10^7+ defaultMain $+ [ bgroup "2-ary" case01+ , bgroup "3-ary" case02+ , bgroup "4-ary" case04+ ]++{-+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 = runST $ do+ f <- newSTRef f0+ r <- newSTRef zero+ dic <- V.unsafeThaw $ V.fromList (zip (nub fs) (repeat zero))+ let len = MV.length dic+ whileM_ ((/= zero) <$> readSTRef f) $ do+ p <- readSTRef f+ divable <- foreach' False [0..len - 1] $ \i -> do+ (g, old) <- lift $ MV.read dic i+ when (leadingMonomial g `divs` leadingMonomial p) $ do+ let q = toPolynomial $ leadingTerm p `tryDiv` leadingTerm g+ lift $ do+ MV.write dic i (g, old + q)+ modifySTRef f (subtract $ q * g)+ exitWith True+ unless divable $ do+ let ltP = toPolynomial $ leadingTerm p+ modifySTRef' f (subtract ltP)+ modifySTRef' r (+ ltP)+ (,) <$> (V.toList <$> V.unsafeFreeze dic)+ <*> readSTRef r++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 = runST $ do+ f <- newSTRef f0+ r <- newSTRef zero+ dic <- V.unsafeThaw $ V.fromList (zip (nub fs) (repeat zero))+ let len = MV.length dic+ whileM_ ((/= zero) <$> readSTRef f) $ do+ p <- readSTRef f+ mi <- newSTRef 0+ divable <- newSTRef False+ whileM_ (andM [not <$> readSTRef divable, (<len) <$> readSTRef mi]) $ do+ i <- readSTRef mi+ (g, old) <- MV.read dic i+ when (leadingMonomial g `divs` leadingMonomial p) $ do+ let q = toPolynomial $ leadingTerm p `tryDiv` leadingTerm g+ MV.write dic i (g, old + q)+ modifySTRef f (subtract $ q * g)+ writeSTRef divable True+ modifySTRef mi (+1)+ gone <- readSTRef divable+ unless gone $ do+ let ltP = toPolynomial $ leadingTerm p+ modifySTRef' f (subtract ltP)+ modifySTRef' r (+ ltP)+ (,) <$> (V.toList <$> V.unsafeFreeze dic)+ <*> readSTRef r+-}
+ bench/elimination-bench.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings, PolyKinds #-}+{-# LANGUAGE TemplateHaskell, UndecidableInstances #-}+import Algebra.Algorithms.Groebner.Monomorphic+import Algebra.Internal+import Algebra.Ring.Polynomial (eliminationOrder, weightedEliminationOrder)+import Algebra.Ring.Polynomial.Monomorphic+import Control.DeepSeq+import Control.Parallel.Strategies+import Criterion.Main+import Criterion.Types+import Data.Type.Natural+import Numeric.Algebra (LeftModule (..))+import qualified Numeric.Algebra as NA++x, y, z, w, s, a, b, c, t, u, v :: Polynomial (Fraction Integer)+[x, y, z, w, s, a, b, c, t, u, v, x', y'] = map (injectVar . flip Variable Nothing) "xyzwsabctuvXY"++instance NFData Variable where+ rnf (Variable x y) = rnf x `seq` rnf y `seq` ()++instance NFData (Polynomial (Fraction Integer)) where+ rnf (Polynomial dic) = rnf dic++i1, i2, i3, i4 :: [Polynomial (Fraction Integer)]+i1 = [x - (t + u), y - (t^2 + 2*t*u), z - (t^3 + 3*t^2*u)]+i2 = [t^2 + x^2+y^2+z^2, t^2 + 2*x^2 - x*y -z^2, t+ y^3-z^3]+i3 = [ 2 * s - a * y', b^2 - (x'^2 + y'^2), c^2 - ( (a-x') ^ 2 + y'^2)+ ]+i4 = [ x - (3*u + 3*u*v^2 - u^3), y - (3*v + 3*u^2*v - v^3), z - (3*u^2 - 3*v^2)]++mkTestCase :: SingI n => String -> [Polynomial (Fraction Integer)] -> SNat n -> Benchmark+mkTestCase name ideal nth =+ bgroup name [ bench "lex" $ nf (calcGroebnerBasisWith Lex) ideal+ , bench "product" $ nf (calcGroebnerBasisWith (eliminationOrder nth)) ideal+ , bench "weight" $ nf (calcGroebnerBasisWith (weightedEliminationOrder nth)) ideal+ ]++main :: IO ()+main = do+ ideal1 <- return $! (i1 `using` rdeepseq)+ ideal2 <- return $! (i2 `using` rdeepseq)+ ideal3 <- return $! (i3 `using` rdeepseq)+ ideal4 <- return $! (i4 `using` rdeepseq)+ [var_x, var_y, var_t] <- return $! (map (flip Variable Nothing) "xyt" `using` rdeepseq)+ defaultMain $ [ mkTestCase "heron" ideal3 sTwo+ , mkTestCase "implicit01" ideal2 sOne+ , mkTestCase "implicit03" ideal1 sTwo+ , mkTestCase "implicit04" ideal4 sTwo+ ]+
+ bench/faugere4.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE NoImplicitPrelude, NoMonomorphismRestriction, DataKinds, FlexibleContexts #-}+module Main where+import Algebra.Algorithms.Faugere4+import Algebra.Algorithms.Groebner+import qualified Algebra.LinkedMatrix as LM+import Algebra.Matrix+import Algebra.Prelude+import Control.DeepSeq+import Control.Parallel.Strategies+import Criterion+import Criterion.Main+import qualified Data.Matrix as DM+import Data.Proxy (Proxy (..))+import Test.QuickCheck++import Utils++s3 :: SNat 3+s3 = sing++s4 :: SNat 4+s4 = sing++s6 :: SNat 6+s6 = sing++f4Repa = faugere4 optimalStrategy+f4DM = faugere4G (Proxy :: Proxy DM.Matrix) optimalStrategy+-- f4SM = faugere4G (Proxy :: Proxy Sparse) optimalStrategy+f4LM = faugere4LM optimalStrategy+f4LMN = faugere4G (Proxy :: Proxy LM.Matrix) optimalStrategy+f4Mod = faugere4Modular optimalStrategy++ideal3 :: [OrderedPolynomial (Fraction Integer) Grevlex 3]+ideal3 = [x^2 + y^2 + z^2 - 1, x^2 + y^2 + z^2 - 2*x, 2*x -3*y - z]+ where+ [x,y,z] = vars++ideal4 :: [OrderedPolynomial (Fraction Integer) Grevlex 3]+ideal4 = [x^2 * y - 2*x*y - 4*z - 1, z-y^2, x^3 - 4*z*y]+ where+ [x,y,z] = vars++ideal5 :: [OrderedPolynomial (Fraction Integer) Grevlex 6]+ideal5 = [ 2 * s - a * y, b^2 - (x^2 + y^2), c^2 - ( (a-x) ^ 2 + y^2)+ ]+ where+ [s,x,y,a,b,c] = vars++ideal6 :: [OrderedPolynomial (Fraction Integer) Grevlex 3]+ideal6 = [ z^5 + y^4 + x^3 - 1, z^3 + y^3 + x^2 - 1]+ where+ [x,y,z] = vars++buildCase :: NFData b => a -> String -> (a -> b) -> Benchmark+buildCase i name calc = bench name $ nf calc i++main :: IO ()+main = do+ i1 <- return $!! (cyclic s3 `using` rdeepseq)+ i2 <- return $!! (cyclic s4 `using` rdeepseq)+ i3 <- return $!! (toIdeal ideal3 `using` rdeepseq)+ i4 <- return $!! (toIdeal ideal4 `using` rdeepseq)+ i5 <- return $!! (toIdeal ideal5 `using` rdeepseq)+ i6 <- return $!! (toIdeal ideal6 `using` rdeepseq)+ rand0 <- sample' $ idealOfDim s3+ rnd <- return $!! (head (drop 2 rand0) `using` rdeepseq)+ putStrLn $ concat [ "random ideal: ", show rnd ]+ defaultMain $+ [ bgroup "cyclic-3" $+ map (uncurry $ buildCase i1)+ [("buchberger", toIdeal . calcGroebnerBasis)+ , ("F4-repa", f4Repa)+ , ("F4-dm", f4DM)+ -- , ("F4-sparse", f4SM)+ , ("F4-link-naive", f4LMN)+ , ("F4-link-str", f4LM)+ , ("F4-modular" , f4Mod)+ ]+ , bgroup "cyclic-4" $+ map (uncurry $ buildCase i2)+ [("buchberger", toIdeal . calcGroebnerBasis)+ , ("F4-repa", f4Repa)+ , ("F4-dm", f4DM)+ -- , ("F4-sparse", f4SM)+ , ("F4-link-naive", f4LMN)+ , ("F4-link-str", f4LM)+ , ("F4-modular" , f4Mod)+ ]+ , bgroup "I3" $+ map (uncurry $ buildCase i3)+ [("buchberger", toIdeal . calcGroebnerBasis)+ , ("F4-repa", f4Repa)+ , ("F4-dm", f4DM)+ -- , ("F4-sparse", f4SM)+ , ("F4-link-naive", f4LMN)+ , ("F4-link-str", f4LM)+ , ("F4-modular" , f4Mod)+ ]+ , bgroup "I4" $+ map (uncurry $ buildCase i4)+ [("buchberger", toIdeal . calcGroebnerBasis)+ , ("F4-repa", f4Repa)+ , ("F4-dm", f4DM)+ -- , ("F4-sparse", f4SM)+ , ("F4-link-naive", f4LMN)+ , ("F4-link-str", f4LM)+ , ("F4-modular" , f4Mod)+ ]+ , bgroup "I5" $+ map (uncurry $ buildCase i5)+ [("buchberger", toIdeal . calcGroebnerBasis)+ , ("F4-repa", f4Repa)+ , ("F4-dm", f4DM)+ -- , ("F4-sparse", f4SM)+ , ("F4-link-naive", f4LMN)+ , ("F4-link-str", f4LM)+ , ("F4-modular" , f4Mod)+ ]+ , bgroup "I6" $+ map (uncurry $ buildCase i6)+ [("buchberger", toIdeal . calcGroebnerBasis)+ , ("F4-repa", f4Repa)+ , ("F4-dm", f4DM)+ -- , ("F4-sparse", f4SM)+ , ("F4-link-naive", f4LMN)+ , ("F4-link-str", f4LM)+ , ("F4-modular" , f4Mod)+ ]+ , bgroup "random-3ary" $+ map (uncurry $ buildCase rnd)+ [("buchberger", toIdeal . calcGroebnerBasis)+ , ("F4-repa", f4Repa)+ , ("F4-dm", f4DM)+ -- , ("F4-sparse", f4SM)+ , ("F4-link-naive", f4LMN)+ , ("F4-link-str", f4LM)+ , ("F4-modular" , f4Mod)+ ]+ ]
+ bench/linear.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}+{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings, PolyKinds, QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}+module Main where+import Algebra.Algorithms.ZeroDim+import Control.Concurrent+import Control.DeepSeq+import Control.Monad+import Control.Parallel.Strategies+import Criterion.Main+import qualified Data.Matrix as M+import qualified Data.Vector as V+import Prelude hiding (product)+import System.Process+import Test.QuickCheck+import Utils++makeLinear :: Int -> Int -> IO [(M.Matrix (Fraction Integer), V.Vector (Fraction Integer))]+makeLinear count dpI =+ liftM (take count) $ sample' $ do+ Equation m v <- resize dpI arbitrarySolvable+ return (M.fromLists m, V.fromList v)++mkTestCases :: [(M.Matrix (Fraction Integer), V.Vector (Fraction Integer))] -> IO [Benchmark]+mkTestCases lins0 = do+ lins <- return $!! (lins0 `using` rdeepseq)+ forM (zip [1..] lins) $ \(n,ex) -> do+ return $ bgroup (concat ["case-",show n])+ [ bench "rank" $ nf (uncurry solveLinear') ex+ , bench "length" $ nf (uncurry solveLinear) ex+ ]++main :: IO ()+main = do+ putStrLn "generating case01..."+ case01 <- mkTestCases =<< makeLinear 5 10+ putStrLn "generating case02..."+ case02 <- mkTestCases =<< makeLinear 5 5+ putStrLn "generating case03..."+ case03 <- mkTestCases =<< makeLinear 5 20+ putStrLn "done. purge and sleep 10secs..."+ _ <- system "purge"+ threadDelay $ 10^7+ defaultMain $+ [ bgroup "size5" case02+ , bgroup "size10" case01+ , bgroup "size20" case03+ ]
+ bench/monomials.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE ExistentialQuantification, ImpredicativeTypes, RankNTypes #-}+module Main where+import qualified Algebra.Ring.Polynomial as P+import qualified Algebra.Ring.PolynomialAccumulated as PA+import Control.Applicative+import Control.DeepSeq+import Control.Monad+import Control.Parallel.Strategies+import Criterion.Main+import Data.Type.Monomorphic+import qualified SequenceMonomial as S+import System.Random+import Test.QuickCheck++data MonomPair = forall n. MonomPair { getMonoms :: !(P.Monomial n, P.Monomial n) }+data AMonomPair = forall n. AMonomPair { getAMonoms :: !(PA.Monomial n, PA.Monomial n) }++instance NFData MonomPair where+ rnf (MonomPair (n, m)) = rnf n `seq` rnf m `seq` ()++instance NFData AMonomPair where+ rnf (AMonomPair (n, m)) = rnf n `seq` rnf m `seq` ()++main :: IO ()+main = do+ as0 <- replicateM 5 genMonomial+ as <- return $!! (as0 `using` rdeepseq)+ defaultMain $ zipWith mkTestCase [1..] as++genMonomial :: IO (MonomPair, AMonomPair, (S.Monomial, S.Monomial))+genMonomial = do+ len <- abs <$> randomRIO (5, 20)+ liftM head . sample' $ do+ m <- map abs <$> vector len+ n <- map abs <$> vector len+ let mp = withPolymorhic len $ \sn -> MonomPair (P.fromList sn m, P.fromList sn n)+ amp = withPolymorhic len $ \sn -> AMonomPair (PA.fromList sn m, PA.fromList sn n)+ return (mp, amp, (S.fromList m, S.fromList n))++instance NFData Ordering where+ rnf EQ = ()+ rnf LT = ()+ rnf GT = ()++mkTestCase :: Int -> (MonomPair, AMonomPair, (S.Monomial, S.Monomial)) -> Benchmark+mkTestCase n (MonomPair m, AMonomPair am, m') =+ bgroup ("case-" ++ show n ++ "-len" ++ show len) $+ map subcase+ [ ("lex", P.lex, PA.lex, S.lex)+ , ("revlex", P.revlex, PA.revlex, S.revlex)+ , ("grlex", P.grlex, PA.grlex, S.grlex)+ , ("grevlex", P.grevlex, PA.grevlex, S.grevlex)+ ]+ where+ len = S.length $ fst m'+ subcase :: (String, P.MonomialOrder, PA.MonomialOrder, S.MonomialOrder) -> Benchmark+ subcase (name, pol, apol, sq) =+ bgroup name [ bench "vector" $ nf (uncurry pol) m+ , bench "accvec" $ nf (uncurry apol) am+ , bench "sequence" $ nf (uncurry sq) m'+ ]
+ bench/quotient-bench-randomized.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}+{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings, PolyKinds #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}+module Main where+import Algebra.Prelude+import Algebra.Ring.Ideal+import Algebra.Ring.Polynomial+import Algebra.Ring.Polynomial.Quotient+import Control.Applicative+import Control.Concurrent+import Control.DeepSeq+import Control.Monad+import Control.Parallel.Strategies+import Criterion.Main+import Data.List (foldl')+import Data.Maybe+import Numeric.Algebra hiding ((>), (^))+import Numeric.Field.Fraction (Fraction)+import Prelude hiding (product)+import qualified Prelude as P+import System.Process+import Test.QuickCheck+import Utils++sTwo :: SNat 2+sTwo = sing++makeIdeals :: KnownNat n => Int -> SNat n -> Int -> IO [Ideal (Polynomial (Fraction Integer) n)]+makeIdeals count _ dpI = take count . map getIdeal <$> sample' (resize dpI arbitrary `suchThat` isNonTrivial)++mkTestCases :: KnownNat n => Int -> Int -> [Ideal (Polynomial (Fraction Integer) n)] -> IO [Benchmark]+mkTestCases count size is =+ forM (zip [1..] is) $ \(n, ideal) -> do+ reifyQuotient ideal $ \ii -> do+ let dim = maybe 0 length $ standardMonomials' ii+ fs0 <- take count <$> sample' (resize size $ quotOfDim ii)+ putStrLn $ concat [ "\t subcase ", show n, " has dimension "+ , show dim]+ fs <- return $! (fs0 `using` rdeepseq)+ return $ bgroup (concat ["case-",show n, "-", show dim, "dim"])+ [ bench "naive" $ nf product fs+ , bench "table" $ nf (foldl multWithTable one) fs+ ]++main :: IO ()+main = do+ putStrLn "generating case01..."+ case01 <- mkTestCases 2 8 =<< makeIdeals 3 sTwo 7+ putStrLn "generating case02..."+ case02 <- mkTestCases 3 8 =<< makeIdeals 3 sTwo 7+ putStrLn "generating case03..."+ case04 <- mkTestCases 10 8 =<< makeIdeals 3 sTwo 7+ putStrLn "done. purge and sleep 10secs..."+ system "purge"+ threadDelay $ 10 P.^ 7+ defaultMain $+ [ bgroup "binary" case01+ , bgroup "ternary" case02+ , bgroup "10-ary" case04+ ]
+ bench/solve.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, GADTs #-}+{-# LANGUAGE MultiParamTypeClasses, NoImplicitPrelude, PolyKinds #-}+{-# LANGUAGE TypeFamilies, TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}+module Main where+import Algebra.Algorithms.ZeroDim+import Algebra.Prelude hiding ((^), (^^))+import Algebra.Ring.Ideal+import Algebra.Ring.Polynomial+import Algebra.Scalar++import Control.Applicative+import Control.DeepSeq+import Control.Monad+import Control.Monad.Random+import Control.Parallel.Strategies+import Criterion+import Criterion.Main+import Numeric.Algebra hiding ((<), (^))+import qualified Numeric.Algebra as NA+import Numeric.Field.Fraction (Fraction)+import Prelude hiding (Fractional (..),+ Integral (..), Num (..),+ Real (..), sum, (^^))+import qualified Prelude as P+import Test.QuickCheck+import Utils++sFour :: Sing 4+sFour = sing :: SNat 4++x, y, z :: Polynomial (Fraction Integer) 3+[x, y, z] = vars++(.*) :: KnownNat n => Fraction Integer -> Polynomial (Fraction Integer) n -> Polynomial (Fraction Integer) n+(.*) = (.*.)++infixl 7 .*++(^^) :: Unital r => r -> NA.Natural -> r+(^^) = NA.pow++eqn01 :: Ideal (Polynomial (Fraction Integer) 3)+eqn01 = toIdeal [x^^2 - 2*x*z + 5, x*y^^2+y*z+1, 3*y^^2 - 8*x*z]++eqn02 :: Ideal (Polynomial (Fraction Integer) 3)+eqn02 =+ toIdeal [x^^2 + 2*y^^2 - y - 2*z+ ,x^^2 - 8*y^^2 + 10*z - 1+ ,x^^2 - 7*y*z+ ]++eqn03 :: Ideal (Polynomial (Fraction Integer) 3)+eqn03 = toIdeal [x^^2 + y^^2 + z^^2 - 2*x+ ,x^^3 - y*z - x+ ,x - y + 2*z+ ]++eqn04 :: Ideal (Polynomial (Fraction Integer) 3)+eqn04 = toIdeal [x*y + z - x*z, x^^2 - z, 2*x^^3 - x^^2 * y * z - 1]++mkBench :: (KnownNat n, (0 :< n) ~ 'True) => Ideal (Polynomial (Fraction Integer) n) -> IO [Benchmark]+mkBench is = do+ gen <- newStdGen+ return [ bench "naive" $ nf (solve' 1e-10) is+ , bench "lefteigen" $ nf (flip evalRand gen . solveM) is+ , bench "companion" $ nf (solveViaCompanion 1e-10) is+ -- , bench "power" $ nf (solve'' 1e-10) is+ ]++randomCase :: (0 :< n) ~ 'True+ => Int -> SNat n -> IO [Ideal (Polynomial (Fraction Integer) n)]+randomCase count sn = do+ as <- take count . map getIdeal <$> sample' (zeroDimOf sn)+ mapM (\a -> return $!! (a `using` rdeepseq)) as++main :: IO ()+main = do+ case01 <- mkBench =<< (return $!! (eqn01 `using` rdeepseq))+ case02 <- mkBench =<< (return $!! (eqn02 `using` rdeepseq))+ case03 <- mkBench =<< (return $!! (eqn03 `using` rdeepseq))+ case04 <- mkBench =<< (return $!! (eqn04 `using` rdeepseq))+ cases <- mapM mkBench =<< randomCase 4 sFour+-- cases' <- mapM mkBench =<< randomCase 1 sTen+ -- name : rest <- getArgs+ -- withArgs (("-n"++name) : rest) $ defaultMain $ {-bgroup "solution" $ -}+ defaultMain $+ [ bgroup "ternary-01" case01+ , bgroup "ternary-02" case02+ , bgroup "ternary-03" case03+ , bgroup "ternary-04" case04+ ] ++ zipWith (\i -> bgroup ("4-ary-0"++show i)) [5..] cases+-- ++ zipWith (\i -> bgroup ("10-ary-0"++show i)) [8] cases'
+ bench/sugar-bench.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}+{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings, PolyKinds #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}+import Algebra.Algorithms.Groebner.Monomorphic+import Algebra.Ring.Polynomial.Monomorphic+import Control.DeepSeq+import Control.Parallel.Strategies+import Criterion.Main++x, y, z, w, s, a, b, c :: Polynomial (Fraction Integer)+[x, y, z, w, s, a, b, c] = map (injectVar . flip Variable Nothing) "xyzwSabc"++instance NFData Variable where+ rnf (Variable x y) = rnf x `seq` rnf y `seq` ()++instance NFData (Polynomial (Fraction Integer)) where+ rnf (Polynomial dic) = rnf dic++i1, i2, i3, i4 :: [Polynomial (Fraction Integer)]+i1 = [x^2 + y^2 + z^2 - 1, x^2 + y^2 + z^2 - 2*x, 2*x -3*y - z]+i2 = [x^2 * y - 2*x*y - 4*z - 1, z-y^2, x^3 - 4*z*y]+i3 = [ 2 * s - a * y, b^2 - (x^2 + y^2), c^2 - ( (a-x) ^ 2 + y^2)+ ]+i4 = [ z^5 + y^4 + x^3 - 1, z^3 + y^3 + x^2 - 1]++mkTestCases :: (Eq r, Show a, r ~ (Fraction Integer)) => a -> [Polynomial r] -> [Benchmark]+mkTestCases num ideal = [ mkTC ("lex0" ++ show num) ideal Lex+ , mkTC ("grlex0" ++ show num) ideal Grlex+ , mkTC ("grevlex0" ++ show num) ideal Grevlex+ ]++mkTC :: (r ~ (Fraction Integer), IsMonomialOrder ord) => String -> [Polynomial r] -> ord -> Benchmark+mkTC name ideal ord =+ bgroup name [ bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy ord) ideal+ , bench "syz+grevsel" $ nf (syzygyBuchbergerWithStrategy GrevlexStrategy ord) ideal+ , bench "syz+grad" $ nf (syzygyBuchbergerWithStrategy GradedStrategy ord) ideal+ , bench "syz+sugar" $ nf (syzygyBuchbergerWithStrategy (SugarStrategy NormalStrategy) ord) ideal+ , bench "syz+grsugar" $ nf (syzygyBuchbergerWithStrategy (SugarStrategy GradedStrategy) ord) ideal+ ]++main :: IO ()+main = do+ ideal1 <- return $! (i1 `using` rdeepseq)+ ideal2 <- return $! (i2 `using` rdeepseq)+ ideal3 <- return $! (i3 `using` rdeepseq)+ ideal4 <- return $! (i4 `using` rdeepseq)+ defaultMain $ concat $+ [ mkTestCases 1 ideal1+ , [mkTC "grlex02" ideal2 Grlex, mkTC "grevlex02" ideal2 Grevlex]+ , mkTestCases 3 ideal3+ , [mkTC "grlex04" ideal4 Grlex, mkTC "grevlex04" ideal4 Grevlex]+ ]+
+ bench/sugar-paper.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}+{-# LANGUAGE MultiParamTypeClasses, NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings, PolyKinds, TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}+module Main where+import Algebra.Algorithms.Groebner+import Algebra.Internal+import Algebra.Ring.Ideal+import Algebra.Ring.Polynomial+import Algebra.Scalar++import Control.Parallel.Strategies+import Criterion.Main+import Numeric.Field.Fraction (Fraction)++i1 :: [OrderedPolynomial (Fraction Integer) Grevlex 7]+i1 = [y * w - (1 / 2) !* z * w + t*w+ ,(-2/7) !* u * w^2 + (10/7) !* v * w^2 - (20/7) !* w^3 + t* u - 5 * t* v + 10 * t* w+ ,(2/7) !* y* w^2 - (2/7) !* z* w^2 + (6/7) !* t* w^2 - y* t + z* t - 3 * t^2+ ,-2 * v^3 + 4 * u* v* w + 5 * v^2 * w - 6 * u* w^2 - 7 * v* w^2 + 15 * w^3 + 42 * y* v+ ,-14 * z* v - 63 * y* w + 21 * z* w - 42 * t* w + 147 * x+ ,(-9/7) !* u* w^3 + (45/7) !* v* w^3 - (135/7) !* w^4 + 2 * z* v^2 - 2 * t* v^2 - 4 * z* u* w+10 * t* u* w - 2 * z* v* w - 28 * t* v* w + 4 * z* w^2 + 86 * t* w^2 - 42 * y* z+14 * z^2 + 42 * y* t - 14 * z* t - 21 * x* u + 105 * x* v - 315 * x* w+ ,(6/7) !* y* w^3 - (9/7) !* z* w^3 + (36/7) !* t* w^3 - 2 * z* v^2 - 4 * y* t* w + 6 * z* t* w - 24 * t^2 * w + 4 * x* u* w + 2 * x* v* w - 4 * x* w^2 + 56 * x* y - 35 * x* z + 84 * x* t+ ,2 * u* v* w - 6 !* v^2 * w - u* w^2 + 13 * v* w^2 - 5 * w^3 + 14 * y* w - 28 * t* w+ ,u^2 * w - 3 * u* v* w + 5 * u* w^2 + 14 * y* w - 28 * t* w+ ,-2 * z* u* w - 2 * t* u* w + 4 * y* v* w + 6 * z* v* w - 2 * t* v* w - 16 * y* w^2 - 10 * z* w^2 + 22 * t* w^2 + 42 * x* w+ ,(28/3) !* y* u* w + (8/3) !* z* u* w - (20/3) !* t* u* w - (88/3) !* y* v* w - 8 * z* v* w +(68/3) !* t* v* w + 52 * y* w^2 + (40/3) !* z* w^2 - 44 * t* w^2 - 84 * x* w+ ,-4 * y* z* w + 10 * y* t* w + 8 * z* t* w - 20 * t^2 * w + 12 * x* u* w - 30 * x* v* w + 15 * x* w^2+ ,-1 * y^2 * w + (1/2) !* y* z* w + y* t* w - z* t* w + 2 * t^2 * w - 3 * x* u* w + 6 * x* v* w - 3 * x* w^2+ , 8 * x* y* w - 4 * x* z* w + 8 * x* t* w+ ]+ where+ [t,u,v,w,x,y,z] = vars++i2 :: [OrderedPolynomial (Fraction Integer) Grevlex 5]+i2 = [35 * y^4 - 30*x*y^2 - 210*y^2*z + 3*x^2 + 30*x*z - 105*z^2 +140*y*t - 21*u+ ,5*x*y^3 - 140*y^3*z - 3*x^2*y + 45*x*y*z - 420*y*z^2 + 210*y^2*t -25*x*t + 70*z*t + 126*y*u+ ]+ where [t,u,x,y,z] = vars++i3 :: [OrderedPolynomial (Fraction Integer) Grevlex 4]+i3 = [ x^31 - x^6 - x- y, x^8 - z, x^10 -t]+ where+ [t,x,y,z] = vars++i4 :: [OrderedPolynomial (Fraction Integer) Grevlex 4]+i4 = [ w+x+y+z, w*x+x*y+y*z+z*w, w*x*y + x*y*z + y*z*w + z*w*x, w*x*y*z]+ where+ [x,y,z,w] = vars++mkTestCases :: (Show a, KnownNat n) => a -> Ideal (Polynomial (Fraction Integer) n) -> [Benchmark]+mkTestCases num ideal = [ mkTC ("lex0" ++ show num) (mapIdeal (changeOrder Lex) ideal)+ , mkTC ("grevlex0" ++ show num) (mapIdeal (changeOrder Grevlex) ideal)+ ]++mkTC :: (IsMonomialOrder n ord, KnownNat n) => String -> Ideal (OrderedPolynomial (Fraction Integer) ord n) -> Benchmark+mkTC name ideal =+ bgroup name [ bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy) ideal+ , bench "syz+sugar" $ nf (syzygyBuchbergerWithStrategy (SugarStrategy NormalStrategy)) ideal+ ]++main :: IO ()+main = do+ -- ideal1 <- return $! (toIdeal i1 `using` rdeepseq)+ ideal2 <- return $! (toIdeal i2 `using` rdeepseq)+ ideal3 <- return $! (toIdeal i3 `using` rdeepseq)+ ideal4 <- return $! (toIdeal i4 `using` rdeepseq)+ defaultMain $+ mkTestCases 1 ideal2+ ++ mkTestCases 2 ideal4+ ++ [mkTC "grevlex03" ideal3]+
+ bench/sugar.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}+{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings, PolyKinds, QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}+import Algebra.Algorithms.Groebner.Monomorphic+import Algebra.Ring.Polynomial.Monomorphic+import Control.DeepSeq+import Control.Parallel.Strategies+import Criterion.Main+import SingularBench++x, y, z, w, s, a, b, c :: Polynomial (Fraction Integer)+[x, y, z, w, s, a, b, c] = map (injectVar . flip Variable Nothing) "xyzwSabc"++instance NFData Variable where+ rnf (Variable x y) = rnf x `seq` rnf y `seq` ()++instance NFData (Polynomial (Fraction Integer)) where+ rnf (Polynomial dic) = rnf dic++i1, i2, i3, i4 :: [Polynomial (Fraction Integer)]+i1 = [x^2 + y^2 + z^2 - 1, x^2 + y^2 + z^2 - 2*x, 2*x -3*y - z]+i2 = [x^2 * y - 2*x*y - 4*z - 1, z-y^2, x^3 - 4*z*y]+i3 = [ 2 * s - a * y, b^2 - (x^2 + y^2), c^2 - ( (a-x) ^ 2 + y^2)+ ]+i4 = [ z^5 + y^4 + x^3 - 1, z^3 + y^3 + x^2 - 1]++main :: IO ()+main = do+ ideal1 <- return $! (i1 `using` rdeepseq)+ ideal2 <- return $! (i2 `using` rdeepseq)+ ideal3 <- return $! (i3 `using` rdeepseq)+ ideal4 <- return $! (i4 `using` rdeepseq)+ defaultMain $ [bgroup "lex01"+ [ bench "simple" $ nf (simpleBuchbergerWith Lex) ideal1+ , bench "relprime" $ nf (primeTestBuchbergerWith Lex) ideal1+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Lex) ideal1+ , bench "syz+sugar" $ nf (syzygyBuchbergerWith Lex) ideal1+ ]+ ,bgroup "grlex01"+ [ bench "simple" $ nf (simpleBuchbergerWith Grlex) ideal1+ , bench "relprime" $ nf (primeTestBuchbergerWith Grlex) ideal1+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grlex) ideal1+ , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grlex) ideal1+ ]+ ,bgroup "grevlex01"+ [ bench "simple" $ nf (simpleBuchbergerWith Grevlex) ideal1+ , bench "relprime" $ nf (primeTestBuchbergerWith Grevlex) ideal1+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grevlex) ideal1+ , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grevlex) ideal1+ ]+ ,bgroup "grlex02"+ [ bench "simple" $ nf (simpleBuchbergerWith Grlex) ideal2+ , bench "relprime" $ nf (primeTestBuchbergerWith Grlex) ideal2+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grlex) ideal2+ , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grlex) ideal2+ ]+ ,bgroup "grevlex02"+ [ bench "simple" $ nf (simpleBuchbergerWith Grevlex) ideal2+ , bench "relprime" $ nf (primeTestBuchbergerWith Grevlex) ideal2+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grevlex) ideal2+ , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grevlex) ideal2+ -- , bench "singular" $ nfIO (singularWith Grevlex ideal2)+ ]+ ,bgroup "lex03"+ [ bench "simple" $ nf (simpleBuchbergerWith Lex) ideal3+ , bench "relprime" $ nf (primeTestBuchbergerWith Lex) ideal3+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Lex) ideal3+ , bench "syz+sugar" $ nf (syzygyBuchbergerWith Lex) ideal3+ -- , bench "singular" $ nfIO (singularWith Lex ideal3)+ ]+ ,bgroup "grlex03"+ [ bench "simple" $ nf (simpleBuchbergerWith Grlex) ideal3+ , bench "relprime" $ nf (primeTestBuchbergerWith Grlex) ideal3+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grlex) ideal3+ , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grlex) ideal3+ -- , bench "singular" $ nfIO (singularWith Grlex ideal3)+ ]+ ,bgroup "grevlex03"+ [ bench "simple" $ nf (simpleBuchbergerWith Grevlex) ideal3+ , bench "relprime" $ nf (primeTestBuchbergerWith Grevlex) ideal3+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grevlex) ideal3+ , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grevlex) ideal3+ ]+ ,bgroup "grlex04"+ [ bench "simple" $ nf (simpleBuchbergerWith Grlex) ideal4+ , bench "relprime" $ nf (primeTestBuchbergerWith Grlex) ideal4+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grlex) ideal4+ , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grlex) ideal4+ -- , bench "singular" $ nfIO (singularWith Grlex ideal4)+ ]+ ,bgroup "grevlex04"+ [ bench "simple" $ nf (simpleBuchbergerWith Grevlex) ideal4+ , bench "relprime" $ nf (primeTestBuchbergerWith Grevlex) ideal4+ , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grevlex) ideal4+ , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grevlex) ideal4+ -- , bench "singular" $ nfIO (singularWith Grevlex ideal4)+ ]+ ]
+ bench/unipol-bench.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE DataKinds, NoImplicitPrelude #-}+module Main where+import Algebra.Field.Finite+import Algebra.Prelude hiding ((%))+import Algebra.Ring.Polynomial.Univariate+import Criterion.Main+import qualified Data.Map as M+import qualified Data.Sized.Builtin as SV+import Numeric.Field.Fraction ((%))++main :: IO ()+main =+ defaultMain+ [ bgroup "mult"+ [ bgroup "Rational"+ [ env ((,)<$>generateFrom rat_5_simple_a<*>generateFrom rat_5_simple_b) $ \ ~((fu,fg,fl), (gu,gg,gl)) ->+ bgroup "5-simple"+ [bench "Unipol" $ nf (uncurry (*)) (fu, gu)+ ,bench "Ordered/Grevlex" $ nf (uncurry (*)) (fg, gg)+ ,bench "Ordered/Lex" $ nf (uncurry (*)) (fl, gl)+ ]+ , env ((,)<$>generateFrom rat_5_complex_a<*>generateFrom rat_5_complex_b) $ \ ~((fu,fg,fl), (gu,gg,gl)) ->+ bgroup "5-complex"+ [bench "Unipol" $ nf (uncurry (*)) (fu, gu)+ ,bench "Ordered/Grevlex" $ nf (uncurry (*)) (fg, gg)+ ,bench "Ordered/Lex" $ nf (uncurry (*)) (fl, gl)+ ]+ , env ((,)<$>generateFrom rat_100_simple_a<*>generateFrom rat_100_simple_b) $ \ ~((fu,fg,fl), (gu,gg,gl)) ->+ bgroup "100-simple"+ [bench "Unipol" $ nf (uncurry (*)) (fu, gu)+ ,bench "Ordered/Grevlex" $ nf (uncurry (*)) (fg, gg)+ ,bench "Ordered/Lex" $ nf (uncurry (*)) (fl, gl)+ ]+ , env ((,)<$>generateFrom rat_100_complex_a<*>generateFrom rat_100_complex_b) $ \ ~((fu,fg,fl), (gu,gg,gl)) ->+ bgroup "100-complex"+ [bench "Unipol" $ nf (uncurry (*)) (fu, gu)+ ,bench "Ordered/Grevlex" $ nf (uncurry (*)) (fg, gg)+ ,bench "Ordered/Lex" $ nf (uncurry (*)) (fl, gl)+ ]+ , env ((,)<$>generateFrom rat_1000_simple_a<*>generateFrom rat_1000_simple_b) $ \ ~((fu,fg,fl), (gu,gg,gl)) ->+ bgroup "1000-simple"+ [bench "Unipol" $ nf (uncurry (*)) (fu, gu)+ ,bench "Ordered/Grevlex" $ nf (uncurry (*)) (fg, gg)+ ,bench "Ordered/Lex" $ nf (uncurry (*)) (fl, gl)+ ]+ ]+ , bgroup "F_103"+ [ env ((,)<$>generateFrom f103_5_a <*>generateFrom f103_5_b) $ \ ~((fu,fg,fl), (gu,gg,gl)) ->+ bgroup "5"+ [bench "Unipol" $ nf (uncurry (*)) (fu, gu)+ ,bench "Ordered/Grevlex" $ nf (uncurry (*)) (fg, gg)+ ,bench "Ordered/Lex" $ nf (uncurry (*)) (fl, gl)+ ]+ , env ((,)<$>generateFrom f103_100_a <*>generateFrom f103_100_b) $ \ ~((fu,fg,fl), (gu,gg,gl)) ->+ bgroup "100"+ [bench "Unipol" $ nf (uncurry (*)) (fu, gu)+ ,bench "Ordered/Grevlex" $ nf (uncurry (*)) (fg, gg)+ ,bench "Ordered/Lex" $ nf (uncurry (*)) (fl, gl)+ ]+ , env ((,)<$>generateFrom f103_1000_a <*>generateFrom f103_1000_b) $ \ ~((fu,fg,fl), (gu,gg,gl)) ->+ bgroup "1000"+ [bench "Unipol" $ nf (uncurry (*)) (fu, gu)+ ,bench "Ordered/Grevlex" $ nf (uncurry (*)) (fg, gg)+ ,bench "Ordered/Lex" $ nf (uncurry (*)) (fl, gl)+ ]+ ]+ ]+ , bgroup "div"+ [ bgroup "Rational"+ [ env ((,)<$>generateFrom rat_100_simple_a<*>generateFrom rat_5_simple_b) $ \ ~((fu,fg,fl), (gu,gg,gl)) ->+ bgroup "100-simple % 5-simple"+ [bench "Unipol" $ nf (uncurry divide) (fu, gu)+ ,bench "Ordered/Grevlex" $ nf (uncurry divide) (fg, gg)+ ,bench "Ordered/Lex" $ nf (uncurry divide) (fl, gl)+ ]+ , env ((,)<$>generateFrom rat_100_complex_a<*>generateFrom rat_5_complex_b) $ \ ~((fu,fg,fl), (gu,gg,gl)) ->+ bgroup "100-complex % 5-complex"+ [bench "Unipol" $ nf (uncurry divide) (fu, gu)+ ,bench "Ordered/Grevlex" $ nf (uncurry divide) (fg, gg)+ ,bench "Ordered/Lex" $ nf (uncurry divide) (fl, gl)+ ]+ ]+ , env ((,)<$>generateFrom rat_500_simple<*>generateFrom rat_400_simple) $ \ ~((fu,fg,fl), (gu,gg,gl)) ->+ bgroup "500 % 400"+ [bench "Unipol" $ nf (uncurry divide) (fu, gu)+ ,bench "Ordered/Grevlex" $ nf (uncurry divide) (fg, gg)+ ,bench "Ordered/Lex" $ nf (uncurry divide) (fl, gl)+ ]+ -- , env ((,)<$>generateFrom rat_1000_simple_a<*>generateFrom rat_5_complex_b) $ \ ~((fu,fg,fl), (gu,gg,gl)) ->+ -- bgroup "1000 % 5-complex"+ -- [bench "Unipol" $ nf (uncurry divide) (fu, gu)+ -- ,bench "Ordered/Grevlex" $ nf (uncurry divide) (fg, gg)+ -- ,bench "Ordered/Lex" $ nf (uncurry divide) (fl, gl)+ -- ]+ -- , env ((,)<$>generateFrom rat_1000_simple_a<*>generateFrom rat_100_simple_b) $ \ ~((fu,fg,fl), (gu,gg,gl)) ->+ -- bgroup "1000 % 100-simple"+ -- [bench "Unipol" $ nf (uncurry divide) (fu, gu)+ -- ,bench "Ordered/Grevlex" $ nf (uncurry divide) (fg, gg)+ -- ,bench "Ordered/Lex" $ nf (uncurry divide) (fl, gl)+ -- ]+ -- , env ((,)<$>generateFrom rat_1000_simple_a<*>generateFrom rat_100_complex_b) $ \ ~((fu,fg,fl), (gu,gg,gl)) ->+ -- bgroup "1000 % 100-complex"+ -- [bench "Unipol" $ nf (uncurry divide) (fu, gu)+ -- ,bench "Ordered/Grevlex" $ nf (uncurry divide) (fg, gg)+ -- ,bench "Ordered/Lex" $ nf (uncurry divide) (fl, gl)+ -- ]+ , bgroup "F_103"+ [ env ((,)<$>generateFrom f103_100_a <*>generateFrom f103_5_b) $ \ ~((fu,fg,fl), (gu,gg,gl)) ->+ bgroup "100 % 5"+ [bench "Unipol" $ nf (uncurry divide) (fu, gu)+ ,bench "Ordered/Grevlex" $ nf (uncurry divide) (fg, gg)+ ,bench "Ordered/Lex" $ nf (uncurry divide) (fl, gl)+ ]+ -- , env ((,)<$>generateFrom f103_1000_a <*>generateFrom f103_5_b) $ \ ~((fu,fg,fl), (gu,gg,gl)) ->+ -- bgroup "1000 % 5"+ -- [bench "Unipol" $ nf (uncurry divide) (fu, gu)+ -- ,bench "Ordered/Grevlex" $ nf (uncurry divide) (fg, gg)+ -- ,bench "Ordered/Lex" $ nf (uncurry divide) (fl, gl)+ -- ]+ , env ((,)<$>generateFrom f103_500_a <*>generateFrom f103_250_b) $ \ ~((fu,fg,fl), (gu,gg,gl)) ->+ bgroup "500 % 250"+ [bench "Unipol" $ nf (uncurry divide) (fu, gu)+ ,bench "Ordered/Grevlex" $ nf (uncurry divide) (fg, gg)+ ,bench "Ordered/Lex" $ nf (uncurry divide) (fl, gl)+ ]+ ]+ ]+ , bgroup "subst"+ [ bgroup "Rational"+ [ env ((,) <$> generateFrom rat_5_simple_a+ <*> return (const $ Scalar (42424242 :: Rational))) $+ \ ~((a,b,c), inp) ->+ bgroup "5-simple"+ [bench "Unipol" $ nf (runScalar . uncurry liftMap) (inp, a)+ ,bench "Ordered/Grevlex" $ nf (runScalar . uncurry liftMap) (inp, b)+ ,bench "Ordered/Lex" $ nf (runScalar . uncurry liftMap) (inp, c)+ ]+ , env ((,) <$> generateFrom rat_5_complex_a+ <*> return (const $ Scalar (42424242 :: Rational))) $+ \ ~((a,b,c), inp) ->+ bgroup "5-complex"+ [bench "Unipol" $ nf (runScalar . uncurry liftMap) (inp, a)+ ,bench "Ordered/Grevlex" $ nf (runScalar . uncurry liftMap) (inp, b)+ ,bench "Ordered/Lex" $ nf (runScalar . uncurry liftMap) (inp, c)+ ]+ , env ((,) <$> generateFrom rat_100_simple_a+ <*> return (const $ Scalar (42424242 :: Rational))) $+ \ ~((a,b,c), inp) ->+ bgroup "100-simple"+ [bench "Unipol" $ nf (runScalar . uncurry liftMap) (inp, a)+ ,bench "Ordered/Grevlex" $ nf (runScalar . uncurry liftMap) (inp, b)+ ,bench "Ordered/Lex" $ nf (runScalar . uncurry liftMap) (inp, c)+ ]+ , env ((,) <$> generateFrom rat_100_complex_a+ <*> return (const $ Scalar (42424242 :: Rational))) $+ \ ~((a,b,c), inp) ->+ bgroup "100-complex"+ [bench "Unipol" $ nf (runScalar . uncurry liftMap) (inp, a)+ ,bench "Ordered/Grevlex" $ nf (runScalar . uncurry liftMap) (inp, b)+ ,bench "Ordered/Lex" $ nf (runScalar . uncurry liftMap) (inp, c)+ ]+ , env ((,) <$> generateFrom rat_1000_simple_a+ <*> return (const $ Scalar (42424242 :: Rational))) $+ \ ~((a,b,c), inp) ->+ bgroup "1000-simple"+ [bench "Unipol" $ nf (runScalar . uncurry liftMap) (inp, a)+ ,bench "Ordered/Grevlex" $ nf (runScalar . uncurry liftMap) (inp, b)+ ,bench "Ordered/Lex" $ nf (runScalar . uncurry liftMap) (inp, c)+ ]+ ]+ , bgroup "F_103"+ [env ((,) <$> generateFrom f103_5_a+ <*> return (const $ Scalar (61 :: F 103))) $+ \ ~((a,b,c), inp) ->+ bgroup "5"+ [ bench "Unipol" $ nf (runScalar . uncurry liftMap) (inp, a)+ , bench "Ordered/Grevlex" $ nf (runScalar . uncurry liftMap) (inp, b)+ , bench "Ordered/Lex" $ nf (runScalar . uncurry liftMap) (inp, c)+ ]+ ,env ((,) <$> generateFrom f103_100_a+ <*> return (const $ Scalar (61 :: F 103))) $+ \ ~((a,b,c), inp) ->+ bgroup "100"+ [ bench "Unipol" $ nf (runScalar . uncurry liftMap) (inp, a)+ , bench "Ordered/Grevlex" $ nf (runScalar . uncurry liftMap) (inp, b)+ , bench "Ordered/Lex" $ nf (runScalar . uncurry liftMap) (inp, c)+ ]+ ,env ((,) <$> generateFrom f103_1000_a+ <*> return (const $ Scalar (61 :: F 103))) $+ \ ~((a,b,c), inp) ->+ bgroup "1000"+ [ bench "Unipol" $ nf (runScalar . uncurry liftMap) (inp, a)+ , bench "Ordered/Grevlex" $ nf (runScalar . uncurry liftMap) (inp, b)+ , bench "Ordered/Lex" $ nf (runScalar . uncurry liftMap) (inp, c)+ ]+ ]+ ]+ ]++f103_5_a, f103_5_b :: [F 103]+f103_5_a = [27,56,51,27,18]+f103_5_b = [72,23,74,63,48]++f103_500_a, f103_250_b :: [F 103]+f103_500_a = [54,30,86,98,57,68,53,38,20,59,66,17,89,1,68,3,75,0,94,96,2,19,99,45,95,5,97,45,6,70,30,94,97,41,61,74,76,93,53,42,90,99,75,50,46,101,52,83,71,19,57,44,29,61,37,97,88,95,27,10,86,74,79,41,96,66,31,29,96,2,11,80,47,35,24,52,22,15,101,35,102,10,56,31,96,23,102,55,69,78,46,80,39,24,5,54,65,101,50,18,78,100,102,31,50,66,58,2,91,95,33,67,54,38,9,97,40,6,44,11,35,50,12,39,46,8,24,99,10,71,10,49,13,71,9,12,57,13,29,71,14,16,0,50,21,9,98,17,38,35,16,95,38,61,26,7,91,13,101,22,27,102,73,100,47,36,38,9,70,29,102,39,53,65,76,89,50,100,10,102,73,63,73,44,17,69,60,65,95,98,7,17,88,61,89,85,3,0,94,6,79,40,76,60,63,44,83,100,96,19,74,89,27,23,39,48,77,64,26,49,0,59,63,5,57,56,82,3,101,57,64,54,29,77,44,21,54,8,82,9,60,83,48,81,9,19,33,7,20,21,62,12,62,75,10,98,96,76,66,21,55,81,98,33,30,27,63,65,61,1,79,18,85,34,11,90,45,86,36,20,100,43,89,15,88,2,14,7,97,32,44,96,38,70,11,45,22,15,62,20,43,78,7,25,0,71,16,101,101,78,38,92,29,26,77,40,52,76,57,101,6,22,49,57,46,37,101,52,60,53,58,29,102,90,10,32,31,91,4,99,81,36,94,75,57,91,72,73,38,11,42,98,77,93,28,6,92,4,47,56,53,17,54,10,84,17,97,43,70,20,47,72,35,89,46,89,33,55,99,9,91,39,67,46,38,65,46,38,64,84,54,67,6,84,37,32,48,26,70,17,36,90,92,49,56,45,77,93,33,81,32,39,52,78,15,26,73,4,89,37,77,3,50,53,59,66,61,34,15,86,16,80,72,75,69,44,78,31,9,22,24,68,69,101,4,4,42,5,37,37,37,65,14,53,0,11,6,91,66,69,24,26,59,100,93,68,29,58,26,77,94,24,81,35,50,56,29,95,31,3,15,5,46,53,54,81,27,13,91,59,70,33,42,72,4,10,45,72,55,92]+f103_250_b = [86,56,71,15,58,63,69,17,3,4,18,98,73,19,13,49,76,53,25,1,5,36,84,15,75,33,23,33,71,102,17,80,19,90,25,37,1,90,36,26,69,53,32,98,79,2,42,66,69,42,64,34,81,31,40,17,27,4,97,57,25,54,6,56,44,26,94,101,60,102,50,26,22,56,14,17,6,36,70,68,9,24,94,22,78,22,5,101,8,48,12,4,31,28,101,81,100,78,63,27,100,0,22,91,96,54,58,94,38,102,81,47,26,37,14,65,70,42,19,24,49,73,36,13,60,26,33,13,16,9,79,15,13,84,24,21,28,72,17,23,84,13,12,7,4,24,41,77,20,42,29,75,22,59,38,66,51,66,76,82,96,86,50,78,20,94,45,26,72,92,2,27,45,36,89,61,25,38,56,56,13,14,97,54,11,54,29,68,48,22,37,60,59,68,90,75,47,92,32,24,68,42,98,35,84,17,47,19,38,3,53,98,51,23,16,39,86,27,94,1,93,36,82,39,29,3,102,37,83,75,40,47,16,31,44,60,69,88,41,72,11,70,50,48,12,15,20,72,35,28]+++f103_100_a, f103_100_b :: [F 103]+f103_100_a = [13,17,43,68,10,64,36,38,95,99,42,30,60,6,100,100,76,14,36,29,42,2,95,55,50,45,36,16,24,5,80,32,33,21,34,13,98,66,101,55,7,38,78,53,36,0,77,54,17,3,41,95,87,99,101,92,73,57,44,96,33,29,20,68,35,78,43,57,78,42,41,42,82,77,54,64,83,14,102,79,40,46,52,40,34,46,30,100,31,38,38,65,102,95,85,67,14,80,59,54]+f103_100_b = [80,42,92,90,65,30,94,79,77,51,46,35,1,99,74,6,84,6,41,92,30,45,99,40,5,83,21,20,9,30,20,92,50,82,101,58,63,39,74,57,23,85,39,15,85,81,31,41,31,98,2,102,59,10,42,101,65,41,35,69,86,66,36,21,24,50,58,21,28,57,28,94,100,59,36,82,20,102,46,14,4,100,13,29,61,43,17,41,94,13,93,61,18,99,54,33,51,35,19,82]++f103_1000_a, f103_1000_b :: [F 103]+f103_1000_a = [76,3,84,44,1,43,49,94,6,94,26,29,78,0,14,75,9,51,79,49,37,6,1,1,24,69,6,79,81,37,32,20,56,33,61,43,56,29,95,57,42,98,53,52,14,43,73,75,63,16,55,89,63,25,51,95,11,79,25,34,59,96,58,58,25,15,89,72,73,36,32,37,92,78,66,17,76,17,80,99,52,93,100,13,76,91,56,82,47,22,59,9,101,74,6,54,47,27,55,41,71,88,67,90,96,22,46,81,16,17,56,33,87,101,55,6,71,28,37,69,91,95,100,45,68,18,101,9,65,59,23,30,81,81,0,15,28,20,31,25,85,44,8,73,44,32,28,40,69,16,70,76,27,16,52,69,42,40,87,51,40,8,38,32,15,87,73,83,67,32,9,57,85,3,36,9,20,101,27,53,23,37,26,79,47,95,97,78,72,26,96,35,71,11,12,36,65,16,92,33,24,40,76,3,83,79,70,10,101,64,62,31,87,94,25,91,54,55,89,81,81,101,61,69,18,74,31,58,58,48,16,72,48,26,1,60,65,20,19,40,75,71,51,4,1,10,1,90,0,88,52,52,71,69,90,59,72,15,78,96,41,101,5,101,90,6,28,12,56,0,52,69,81,49,48,0,38,4,59,98,88,85,6,87,86,83,84,90,47,91,47,39,95,102,5,98,74,88,29,33,54,68,65,38,65,52,28,9,73,69,82,81,35,30,89,101,75,2,29,50,84,94,96,4,25,45,61,72,25,77,10,83,47,38,6,93,46,7,24,41,52,58,74,41,14,63,31,5,83,45,32,22,55,6,32,80,45,98,67,93,15,95,64,16,57,7,77,68,49,45,26,82,35,35,48,59,27,60,61,102,26,64,93,44,54,38,0,18,66,87,75,23,43,88,52,57,57,2,1,18,32,51,96,91,18,54,95,76,49,95,75,60,50,0,64,101,34,102,98,22,58,45,33,65,78,71,31,43,21,38,56,82,67,72,95,68,63,17,44,6,37,3,0,69,95,40,90,59,0,12,76,97,71,17,16,75,9,0,12,46,20,5,99,52,77,34,36,35,94,39,84,76,39,56,57,0,92,20,55,75,40,36,37,10,30,82,32,58,49,65,45,7,79,79,35,99,55,70,21,72,102,42,42,63,22,3,93,10,73,83,74,62,78,13,17,16,13,42,31,26,7,54,16,0,8,37,99,24,62,27,52,34,9,20,35,33,14,22,12,78,88,92,87,41,100,8,49,60,21,7,88,24,74,9,3,31,85,70,3,101,17,54,57,64,62,19,94,84,28,0,82,50,79,37,55,91,11,70,85,101,95,85,99,60,0,24,19,72,46,25,5,49,6,57,6,98,12,87,45,53,31,50,62,64,90,44,29,66,67,66,45,33,10,96,60,44,29,83,41,4,77,92,77,51,99,87,41,13,36,14,96,25,100,65,65,7,19,81,11,65,29,92,34,64,21,59,91,22,24,45,18,9,74,45,81,84,99,37,60,44,0,65,43,24,97,45,42,40,52,37,29,3,97,50,96,63,88,9,9,12,42,86,10,71,78,100,48,75,62,44,64,0,27,93,0,36,85,84,14,28,45,72,28,64,86,3,53,72,34,98,52,44,67,52,6,1,42,83,34,28,28,98,55,51,71,86,93,88,2,77,50,39,13,96,15,34,98,59,49,36,3,65,30,18,90,61,47,57,76,70,33,66,44,73,31,71,92,97,33,11,70,26,8,24,65,5,61,30,65,56,33,43,0,76,79,14,1,65,1,40,62,57,58,8,92,94,32,11,16,38,57,71,64,19,32,32,56,29,82,97,22,71,21,36,84,4,86,72,32,19,84,55,0,6,71,19,41,50,8,40,96,31,28,52,82,5,43,17,76,72,94,68,77,93,67,68,27,79,25,81,84,2,26,67,59,91,101,70,101,49,6,5,24,87,56,7,53,3,6,43,99,54,62,57,43,91,22,61,27,51,55,12,51,0,54,95,46,29,99,76,19,55,31,77,98,100,71,33,22,53,97,82,87,18,46,4,18,65,7,70,63,97,57,2,25,88,61,96,55,48,101,26,7,46,46,68,80,3,38,7,7,65,24,31,89,49,58,64,88,58,91,13,4,52,61,47,99,62,97,67,65,55,94,96,89,20,66,44,70,21,59,76,17,69,83,80,62,0,24,99,2,8,23,63,73,22,82,84,28,35,32,61,72,102,46,42,83,95,65,41,10,67,58,91,94,57,73,37,80,56,58,83,79,36,9,71,58,75,48,30]++f103_1000_b = [10,19,56,97,50,82,6,93,81,87,10,100,24,86,69,6,78,40,18,13,71,62,88,35,85,15,46,89,69,73,29,57,75,75,44,90,1,37,7,44,69,96,31,17,89,50,5,49,59,85,27,100,6,54,48,13,10,13,14,48,3,86,10,54,30,79,53,92,101,1,33,4,87,15,90,0,79,69,22,41,16,34,95,101,23,50,87,86,58,91,64,92,61,51,101,67,77,77,2,43,100,7,26,2,25,93,18,101,83,92,6,66,61,2,17,95,41,13,57,90,0,50,16,23,96,39,35,74,21,69,99,102,29,15,52,42,29,70,11,48,12,83,45,11,15,43,65,84,84,40,12,20,13,3,75,88,86,85,79,25,89,74,61,90,74,86,54,27,58,96,95,20,32,20,88,46,101,44,82,89,89,59,51,82,73,64,82,78,89,98,91,54,27,5,83,99,67,30,10,21,96,53,58,82,38,31,69,57,88,49,52,51,30,0,90,53,99,33,36,88,46,91,9,52,63,3,56,10,66,30,58,38,29,54,88,20,98,64,93,65,29,62,68,46,72,93,47,63,99,17,33,63,93,46,100,27,4,100,83,19,44,29,39,95,12,101,26,2,24,2,76,7,56,48,10,53,20,98,69,54,57,43,47,57,77,59,26,40,19,99,95,44,43,64,6,73,73,38,6,101,22,64,56,60,102,54,92,44,35,98,15,11,32,63,39,76,4,30,37,11,100,87,63,85,93,97,45,30,99,76,14,96,7,4,20,40,54,76,37,37,98,73,54,30,87,41,62,90,0,62,69,81,33,77,86,13,29,22,97,14,35,50,55,30,50,61,7,50,52,7,25,26,86,10,81,22,68,5,88,89,54,76,10,8,43,47,46,65,39,21,48,12,75,79,20,80,56,30,88,62,5,63,62,18,70,74,76,73,3,40,33,63,17,84,32,15,38,62,99,7,30,91,29,12,53,37,88,30,101,66,42,91,38,34,78,59,10,12,85,22,65,93,95,36,31,102,66,35,88,42,23,12,75,25,5,15,38,22,75,32,64,24,58,80,22,33,70,0,55,19,24,8,48,51,41,94,72,23,97,30,20,54,14,101,12,44,63,2,52,28,44,11,18,4,65,57,52,22,37,101,53,88,84,93,48,43,88,40,85,5,16,92,87,30,79,30,88,35,31,35,5,92,31,79,59,25,98,47,46,48,90,91,11,37,59,8,73,58,47,8,53,34,47,63,67,100,24,61,17,1,96,11,97,5,14,19,31,45,34,73,35,2,23,59,23,66,74,55,24,53,80,19,13,7,54,15,71,59,49,27,95,32,85,87,88,2,45,73,66,10,87,50,64,70,61,26,33,46,62,45,54,76,20,102,18,30,31,2,48,15,53,5,76,35,94,19,64,17,3,93,7,65,31,32,10,42,68,9,98,39,92,46,59,25,9,81,24,4,26,75,99,20,47,17,77,39,59,26,28,30,32,87,74,12,33,36,37,67,97,57,80,46,51,71,67,91,79,0,85,64,49,80,89,44,97,32,19,99,19,5,9,93,19,22,83,101,56,22,80,15,74,69,55,10,63,65,10,26,99,3,86,26,68,74,102,95,26,95,78,23,6,24,14,74,40,67,52,83,31,17,20,64,32,84,6,44,86,77,50,19,51,59,66,18,31,13,96,13,66,19,47,36,27,14,96,1,37,82,90,93,82,100,31,2,5,22,90,92,82,40,30,69,7,51,4,71,69,69,76,72,31,25,10,41,69,10,79,0,83,32,102,76,63,96,43,52,83,53,18,98,34,46,81,44,76,66,80,70,91,19,43,52,17,101,11,70,70,31,90,19,46,38,49,34,28,20,11,89,99,23,1,44,51,23,34,68,21,9,51,88,27,32,102,3,66,49,9,99,86,30,16,8,82,49,2,76,85,69,64,49,12,80,46,35,80,69,92,87,2,82,10,88,98,17,28,42,41,28,89,77,15,88,49,87,17,74,92,95,4,20,77,15,26,26,63,64,100,20,65,29,91,25,14,66,39,92,58,33,70,51,52,76,36,96,5,6,97,94,100,12,23,98,2,98,36,19,100,23,26,69,64,37,92,40,16,27,70,10,98,86,100,31,35,91,10,101,83,102,34,57,3,20,69,17,56,67,67,33,8,25,0,3,86,91,21,77,1,102,100,10,40,25,64,12,63,5,69,70,39,21,93,21,7,6,53,80,45,70,43,29,42,25,101,81,64,19,21,94,52,98,34,82,37,38,70,91,49,19,72,41]++type OGUnipol k = OrderedPolynomial k Grevlex 1+type OLUnipol k = OrderedPolynomial k Lex 1++generateFrom :: (Eq k, Field k)+ => [k] -> IO (Unipol k, OGUnipol k, OLUnipol k)+generateFrom cfs = do+ let vecs = M.fromList $ zip [SV.singleton i | i <- [0..]] cfs+ return (polynomial' vecs, polynomial' vecs, polynomial' vecs)++rat_5_simple_a, rat_5_simple_b :: [Rational]+rat_5_simple_a = [17 / 49,83 / 22,(-3) / 2,(-71)/ 92,6 / 5]+rat_5_simple_b = [95 / 53,(-75) / 38,(-70) / 93,(-47) / 44,(-55) / 61]++rat_5_complex_a, rat_5_complex_b :: [Rational]+rat_5_complex_a = [(-4377) % 96973,(-11900) % 72461,20167 % 24319,52987 % 7886,14666 % 5337]+rat_5_complex_b = [47539 % 75894,(-80643) % 87553,93229 % 97773,10695 % 10382,29823 % 28031]++rat_100_simple_a, rat_100_simple_b :: [Rational]+rat_100_simple_a = [10 % 81,58 % 57,89 % 90,30 % 37,60 % 91,(-11) % 2,57 % 14,11 % 10,9 % 25,(-25) % 54,(-21) % 97,9 % 11,30 % 71,8 % 9,(-59) % 100,12 % 19,15 % 14,(-17) % 22,0 % 1,9 % 41,88 % 41,(-29) % 27,19 % 16,(-49) % 46,(-65) % 84,(-32) % 45,(-55) % 59,29 % 43,10 % 31,49 % 54,(-9) % 20,3 % 23,97 % 5,75 % 43,9 % 17,95 % 36,(-23) % 21,(-23) % 14,88 % 81,(-21) % 44,(-1) % 1,(-19) % 28,10 % 17,84 % 37,(-66) % 29,(-15) % 37,(-37) % 31,17 % 7,76 % 43,82 % 75,(-7) % 43,(-20) % 1,29 % 70,(-63) % 64,5 % 84,13 % 19,13 % 45,7 % 25,(-93) % 2,(-7) % 1,91 % 59,(-33) % 80,99 % 61,36 % 13,(-99) % 49,23 % 24,87 % 56,(-19) % 34,12 % 1,(-53) % 12,2 % 1,(-19) % 73,39 % 41,2 % 5,89 % 72,13 % 5,67 % 45,17 % 12,24 % 55,(-41) % 94,(-71) % 6,38 % 1,(-12) % 1,(-21) % 20,9 % 32,56 % 29,(-29) % 74,(-70) % 89,(-9) % 16,(-30) % 7,37 % 55,(-41) % 13,38 % 21,97 % 96,1 % 2,(-65) % 42,(-61) % 70,(-2) % 1,73 % 37,62 % 39]+rat_100_simple_b = [43 % 82,(-67) % 80,(-16) % 15,(-56) % 47,47 % 32,71 % 86,(-59) % 51,53 % 31,40 % 31,85 % 44,(-11) % 25,43 % 18,28 % 11,(-9) % 14,(-64) % 27,(-62) % 87,(-95) % 54,(-34) % 29,(-58) % 23,50 % 31,1 % 24,(-97) % 98,11 % 98,(-45) % 47,(-5) % 24,(-17) % 95,(-23) % 71,(-9) % 5,(-3) % 20,99 % 17,(-21) % 43,2 % 31,(-27) % 91,(-23) % 1,11 % 8,(-34) % 53,(-31) % 21,100 % 73,(-58) % 39,(-12) % 41,80 % 31,73 % 68,1 % 19,65 % 69,(-55) % 32,(-5) % 6,32 % 29,(-7) % 2,69 % 83,(-10) % 93,(-7) % 52,0 % 1,(-96) % 97,(-37) % 36,44 % 63,1 % 17,(-55) % 49,(-8) % 5,15 % 7,(-76) % 9,(-86) % 59,(-34) % 25,(-24) % 35,88 % 13,97 % 57,43 % 48,17 % 76,79 % 29,(-74) % 15,35 % 58,(-79) % 58,(-41) % 73,1 % 16,(-53) % 95,(-40) % 81,75 % 41,(-23) % 13,(-67) % 6,(-3) % 8,(-10) % 13,12 % 17,17 % 89,7 % 37,41 % 21,23 % 51,4 % 5,27 % 68,37 % 60,(-72) % 53,(-50) % 33,91 % 47,53 % 18,(-43) % 1,2 % 3,(-16) % 13,3 % 58,(-1) % 11,13 % 33,(-61) % 17,(-5) % 7]++rat_100_complex_a, rat_100_complex_b :: [Rational]+rat_100_complex_a = [(-13076) % 60455,38891 % 46344,15633 % 30362,86709 % 5758,(-17270) % 28159,(-33139) % 15802,73121 % 23743,43523 % 2865,22853 % 74977,(-21449) % 21915,(-38967) % 8912,10472 % 44645,(-1771) % 28368,(-62816) % 53453,22426 % 34351,43015 % 25058,40723 % 95891,(-78266) % 24161,(-21631) % 15314,68376 % 6079,1968 % 6085,31729 % 27661,1937 % 1748,(-56162) % 69315,27837 % 20485,65142 % 48721,97881 % 55954,(-94268) % 53419,86900 % 61873,(-57763) % 25701,(-29573) % 37126,21470 % 15813,46747 % 30029,14200 % 19583,(-66819) % 72905,(-64473) % 30001,85 % 71,(-97969) % 38377,13767 % 1096,19415 % 22691,(-63763) % 50213,(-28324) % 3499,(-26771) % 27091,70085 % 62294,(-37676) % 14575,(-1441) % 244,11669 % 934,6717 % 7625,(-99753) % 4531,4107 % 52051,12896 % 30483,14519 % 12010,(-33071) % 96813,27641 % 1528,(-13257) % 45121,9914 % 32799,71319 % 86494,(-77567) % 57844,(-9965) % 4154,50857 % 75421,(-67097) % 20060,(-72162) % 48347,(-45275) % 5398,39985 % 34839,4799 % 1733,20909 % 52597,90627 % 20470,(-55729) % 48186,7806 % 68159,(-38989) % 25855,18639 % 77972,14808 % 3751,(-66883) % 36737,24499 % 7587,(-98743) % 88573,(-2399) % 9215,(-313) % 1229,(-16481) % 6612,47584 % 35627,(-9979) % 95811,(-17401) % 10775,(-15062) % 4631,(-2000) % 6959,(-38285) % 21044,542 % 29303,(-284) % 491,9325 % 4909,1734 % 2063,(-15289) % 71914,23215 % 50436,14697 % 49076,(-20854) % 41111,(-52548) % 60211,(-11679) % 28936,5902 % 89577,(-7813) % 88597,54587 % 65830,(-62773) % 34579,(-61665) % 24877,(-23326) % 7083]+rat_100_complex_b = [7773 % 779,20989 % 14443,(-48341) % 46412,(-30675) % 30554,41025 % 33371,(-115) % 30217,2113 % 28328,(-14647) % 6910,(-22507) % 10278,(-31810) % 33711,41736 % 17467,2276 % 2279,(-43865) % 89336,88527 % 84422,(-23925) % 26164,32147 % 48275,(-56648) % 58933,29136 % 44033,(-7282) % 12437,16939 % 27060,(-84778) % 69525,(-16843) % 66022,5990 % 7961,(-88215) % 56432,20294 % 87859,(-62075) % 81311,(-2939) % 37904,15653 % 7290,28847 % 27535,(-49699) % 12943,(-13949) % 1146,17656 % 15011,48527 % 41852,(-18341) % 9603,63995 % 61559,(-13267) % 10631,77727 % 5990,(-70597) % 78206,31607 % 30325,(-42229) % 23704,14434 % 14949,(-56808) % 43789,(-46663) % 46883,13 % 23555,(-98366) % 59211,(-1667) % 18498,(-87) % 172,39410 % 45321,77239 % 39427,(-21209) % 24267,28587 % 79867,18359 % 26376,25197 % 4189,49719 % 49802,11059 % 7338,13621 % 66324,(-60163) % 51263,(-23285) % 49417,93196 % 3443,(-6870) % 10363,(-85283) % 24177,2911 % 5687,440 % 89,(-13553) % 34203,(-73850) % 18519,(-95636) % 64123,(-13809) % 43547,60911 % 37673,96643 % 53076,(-9285) % 17579,(-707) % 21621,151 % 5783,8515 % 20277,14587 % 9392,(-49877) % 24489,(-38543) % 86539,(-55186) % 74719,(-85894) % 35775,737 % 795,(-38014) % 40261,(-53078) % 91757,(-33751) % 85511,(-627) % 16106,(-25910) % 29843,8965 % 3471,(-24518) % 607,15308 % 15757,(-26519) % 32414,(-60049) % 74084,9106 % 38095,43336 % 3495,69259 % 82600,49823 % 14240,30467 % 14261,22157 % 35983,58430 % 8031,(-24693) % 39905,48021 % 47726,95511 % 56279,(-19277) % 31641]++rat_1000_simple_a, rat_1000_simple_b :: [Rational]+rat_1000_simple_a =+ [57 % 91,(-11) % 17,(-11) % 16,(-13) % 5,3 % 17,98 % 73,(-41) % 98,29 % 39,87 % 61,21 % 20,(-2) % 3,66 % 61,30 % 37,21 % 22,(-15) % 26,31 % 27,62 % 77,(-93) % 58,(-30) % 61,(-26) % 49,(-68) % 5,(-5) % 6,(-74) % 69,(-5) % 18,49 % 76,13 % 9,(-1) % 6,7 % 3,(-3) % 2,(-11) % 13,(-59) % 35,(-31) % 86,(-5) % 3,(-9) % 2,(-100) % 89,43 % 87,(-1) % 19,23 % 38,98 % 57,(-15) % 7,44 % 83,(-81) % 97,24 % 47,84 % 23,(-9) % 43,(-49) % 19,(-25) % 6,1 % 8,(-14) % 19,14 % 11,43 % 45,53 % 29,(-1) % 4,(-59) % 40,77 % 39,89 % 71,(-18) % 47,(-65) % 76,43 % 39,(-99) % 40,(-79) % 14,(-1) % 1,81 % 14,(-3) % 10,91 % 73,47 % 5,46 % 5,(-32) % 81,23 % 68,(-100) % 37,11 % 7,(-10) % 7,(-14) % 1,(-8) % 19,11 % 8,(-49) % 27,9 % 7,67 % 21,(-16) % 81,5 % 86,(-1) % 9,74 % 95,8 % 27,(-48) % 71,(-29) % 41,25 % 28,(-6) % 1,23 % 22,(-67) % 76,(-67) % 70,14 % 15,11 % 63,33 % 61,(-13) % 7,(-97) % 64,7 % 2,100 % 63,(-66) % 29,3 % 7,(-4) % 17,33 % 76,(-16) % 33,(-17) % 26,(-95) % 47,(-2) % 3,(-39) % 14,43 % 18,63 % 65,(-17) % 5,(-25) % 21,(-22) % 43,(-92) % 11,(-28) % 57,41 % 8,(-4) % 25,(-32) % 9,19 % 1,(-73) % 56,(-33) % 8,71 % 35,79 % 51,11 % 15,(-37) % 5,89 % 61,(-16) % 7,(-46) % 11,(-4) % 85,(-14) % 25,(-83) % 16,19 % 63,(-74) % 1,(-73) % 55,47 % 13,88 % 35,(-83) % 14,(-44) % 37,25 % 92,71 % 96,5 % 12,(-16) % 81,72 % 97,75 % 77,(-23) % 9,(-81) % 40,12 % 91,12 % 67,51 % 56,43 % 13,(-83) % 24,(-17) % 36,(-78) % 29,(-44) % 21,(-5) % 1,46 % 31,3 % 10,(-79) % 97,34 % 69,(-17) % 48,11 % 56,100 % 37,22 % 85,67 % 34,(-66) % 59,71 % 90,(-59) % 18,(-22) % 19,34 % 53,(-1) % 6,(-34) % 49,(-41) % 77,(-3) % 1,(-98) % 11,50 % 91,(-10) % 3,(-8) % 93,60 % 7,(-30) % 1,1 % 4,(-2) % 87,(-4) % 3,63 % 50,22 % 21,53 % 69,100 % 11,21 % 11,(-7) % 26,(-58) % 7,(-55) % 67,(-87) % 83,3 % 19,(-5) % 17,(-9) % 4,(-97) % 87,85 % 76,(-41) % 70,(-37) % 12,75 % 79,(-13) % 14,(-2) % 1,(-13) % 4,(-38) % 97,(-55) % 46,(-81) % 79,(-73) % 88,77 % 4,(-5) % 6,(-47) % 13,(-35) % 52,(-50) % 83,4 % 9,43 % 41,23 % 36,58 % 81,19 % 36,21 % 5,(-31) % 5,1 % 74,9 % 16,1 % 1,0 % 1,(-43) % 81,(-19) % 21,(-40) % 47,47 % 40,(-28) % 41,(-98) % 51,(-88) % 89,19 % 94,(-11) % 54,1 % 1,(-18) % 13,(-1) % 1,24 % 25,(-9) % 11,50 % 23,(-1) % 8,17 % 42,19 % 14,54 % 61,(-5) % 8,83 % 74,(-21) % 26,(-83) % 40,4 % 3,(-9) % 4,93 % 44,(-24) % 5,(-46) % 45,33 % 5,(-1) % 38,(-33) % 14,1 % 94,0 % 1,(-8) % 7,13 % 10,23 % 16,63 % 92,17 % 27,31 % 9,(-67) % 33,13 % 8,(-77) % 5,35 % 69,13 % 68,(-10) % 93,1 % 25,64 % 35,3 % 7,(-17) % 7,(-12) % 35,4 % 57,(-39) % 77,(-12) % 5,100 % 7,80 % 81,(-32) % 79,(-59) % 3,100 % 53,17 % 25,(-47) % 66,(-38) % 35,(-81) % 100,17 % 44,81 % 14,92 % 85,5 % 3,19 % 1,12 % 13,(-79) % 47,27 % 91,19 % 89,(-53) % 63,(-23) % 52,21 % 22,79 % 64,(-21) % 47,(-39) % 23,(-13) % 2,75 % 47,(-5) % 14,37 % 26,17 % 27,(-51) % 73,14 % 31,0 % 1,45 % 47,91 % 82,(-86) % 87,(-83) % 52,49 % 36,16 % 5,(-32) % 47,(-33) % 23,(-19) % 84,(-50) % 47,(-93) % 92,46 % 19,(-67) % 92,8 % 11,65 % 72,49 % 6,(-5) % 7,(-11) % 8,7 % 47,11 % 1,7 % 27,(-90) % 77,(-15) % 77,(-67) % 8,4 % 3,95 % 11,(-15) % 7,16 % 33,(-2) % 3,(-2) % 13,(-9) % 50,(-58) % 7,(-92) % 17,(-29) % 11,1 % 57,(-85) % 98,(-26) % 41,(-41) % 12,93 % 4,(-69) % 73,(-67) % 82,(-38) % 5,92 % 51,85 % 29,(-92) % 11,71 % 60,22 % 97,(-21) % 25,5 % 26,91 % 89,4 % 11,12 % 59,49 % 47,(-69) % 80,57 % 67,53 % 27,(-45) % 8,29 % 5,(-35) % 43,12 % 19,83 % 57,(-2) % 5,(-25) % 42,20 % 29,(-9) % 1,(-17) % 11,(-17) % 66,100 % 33,6 % 17,(-35) % 13,9 % 14,(-82) % 73,(-88) % 79,(-24) % 11,38 % 1,5 % 69,(-79) % 29,(-28) % 29,(-1) % 15,21 % 58,5 % 12,38 % 7,(-17) % 1,(-38) % 49,(-8) % 15,(-79) % 34,(-47) % 54,(-22) % 31,(-37) % 9,57 % 43,(-19) % 42,(-19) % 42,11 % 23,(-5) % 16,17 % 66,79 % 87,(-18) % 19,(-11) % 36,11 % 61,45 % 86,(-48) % 77,4 % 19,(-24) % 47,(-1) % 12,(-43) % 53,(-93) % 80,2 % 85,76 % 69,(-10) % 1,(-1) % 2,43 % 31,(-98) % 73,(-7) % 15,(-2) % 7,(-57) % 29,(-52) % 41,(-46) % 7,(-58) % 9,89 % 53,25 % 68,(-11) % 31,(-76) % 55,(-3) % 31,91 % 41,45 % 8,(-19) % 15,(-4) % 49,14 % 15,(-43) % 94,16 % 19,21 % 37,(-19) % 58,44 % 71,(-23) % 21,50 % 19,94 % 65,1 % 4,(-1) % 21,13 % 32,47 % 34,10 % 43,(-29) % 15,7 % 6,28 % 43,11 % 18,85 % 71,(-79) % 22,(-4) % 1,(-65) % 36,(-87) % 74,48 % 25,56 % 97,81 % 77,19 % 29,79 % 38,(-37) % 4,89 % 5,17 % 62,51 % 56,9 % 4,(-1) % 12,27 % 94,53 % 37,53 % 68,(-3) % 4,(-13) % 64,(-43) % 29,11 % 3,(-11) % 10,47 % 66,22 % 83,(-86) % 23,37 % 72,53 % 50,22 % 49,(-21) % 47,2 % 15,(-37) % 87,(-47) % 88,(-55) % 39,(-15) % 28,42 % 1,44 % 15,2 % 7,(-2) % 15,(-10) % 91,80 % 33,(-96) % 17,(-87) % 65,47 % 69,(-5) % 7,(-83) % 41,29 % 3,2 % 7,(-24) % 65,30 % 7,7 % 8,(-5) % 9,(-14) % 1,(-33) % 26,(-8) % 7,(-43) % 14,(-38) % 25,(-1) % 27,71 % 99,(-65) % 27,(-14) % 89,20 % 21,(-7) % 5,21 % 2,85 % 21,(-22) % 23,37 % 41,(-7) % 2,(-6) % 31,84 % 25,(-68) % 21,(-39) % 40,(-8) % 43,(-32) % 11,(-99) % 65,70 % 79,(-71) % 31,79 % 29,(-6) % 65,(-49) % 69,23 % 5,31 % 57,74 % 97,(-85) % 77,(-42) % 85,(-37) % 41,20 % 97,(-79) % 84,69 % 80,25 % 21,11 % 6,73 % 82,(-12) % 11,(-85) % 13,(-23) % 64,67 % 52,(-31) % 59,23 % 29,93 % 17,(-11) % 37,(-3) % 28,13 % 49,(-53) % 13,(-17) % 5,(-29) % 50,79 % 54,(-49) % 38,13 % 2,17 % 21,(-41) % 14,0 % 1,(-75) % 52,67 % 52,(-1) % 20,(-7) % 6,(-85) % 61,(-43) % 9,(-1) % 1,37 % 83,(-53) % 37,(-64) % 13,(-41) % 67,(-85) % 18,(-99) % 50,3 % 74,3 % 8,(-1) % 20,68 % 81,(-53) % 61,(-17) % 4,(-13) % 23,(-49) % 45,(-91) % 40,(-51) % 43,71 % 33,20 % 93,(-23) % 26,22 % 25,59 % 94,66 % 37,83 % 15,46 % 61,(-13) % 19,(-78) % 29,(-61) % 6,23 % 40,(-11) % 7,83 % 36,(-23) % 19,(-59) % 21,(-1) % 3,64 % 47,59 % 83,(-13) % 6,31 % 9,(-39) % 89,21 % 19,7 % 4,2 % 47,15 % 43,(-62) % 11,(-36) % 13,(-71) % 89,71 % 37,(-12) % 5,(-43) % 46,98 % 73,86 % 71,13 % 71,(-37) % 56,(-73) % 70,(-31) % 38,(-79) % 83,61 % 99,(-81) % 13,(-11) % 4,(-52) % 41,39 % 44,(-29) % 75,14 % 9,14 % 31,(-10) % 3,75 % 17,(-16) % 13,86 % 1,92 % 63,13 % 48,(-49) % 24,(-55) % 37,18 % 25,46 % 9,26 % 37,(-90) % 17,43 % 20,(-77) % 9,1 % 7,(-3) % 50,38 % 9,(-2) % 69,59 % 17,25 % 87,(-71) % 57,(-8) % 3,5 % 6,7 % 13,45 % 19,50 % 29,(-43) % 12,96 % 73,(-55) % 14,92 % 63,11 % 45,94 % 3,27 % 16,(-67) % 65,2 % 5,(-61) % 5,(-34) % 47,(-6) % 13,35 % 32,(-61) % 38,(-17) % 63,(-27) % 94,(-23) % 45,38 % 1,(-67) % 81,26 % 33,(-38) % 43,74 % 41,(-8) % 11,(-2) % 47,(-23) % 3,6 % 23,(-7) % 12,37 % 35,89 % 52,11 % 20,(-8) % 1,(-61) % 26,12 % 1,(-26) % 1,(-7) % 10,39 % 32,33 % 8,(-61) % 14,(-19) % 23,28 % 37,(-41) % 73,58 % 67,(-41) % 61,(-92) % 59,(-3) % 44,(-91) % 67,(-82) % 99,(-89) % 51,5 % 6,(-13) % 18,(-25) % 74,29 % 36,(-3) % 41,29 % 52,2 % 57,(-28) % 39,(-12) % 11,25 % 61,(-18) % 7,(-68) % 23,5 % 23,62 % 29,48 % 67,(-93) % 65,(-37) % 70,63 % 44,10 % 19,(-23) % 8,3 % 5,(-11) % 13,(-44) % 13,(-23) % 7,19 % 1,(-41) % 11,(-5) % 8,(-42) % 43,23 % 9,(-46) % 63,(-81) % 43,(-1) % 24,76 % 41,(-61) % 20,44 % 61,52 % 83,(-45) % 74,7 % 6,(-1) % 19,1 % 6,(-2) % 3,100 % 7,33 % 73,7 % 16,(-2) % 49,89 % 8,47 % 34,1 % 3,47 % 1,(-79) % 45,(-13) % 2,40 % 57,(-11) % 19,(-91) % 46,(-59) % 81,33 % 5,0 % 1,41 % 31,(-61) % 37,7 % 37,(-32) % 23,77 % 27,(-61) % 8,15 % 41,(-49) % 16,33 % 10,(-10) % 63,40 % 49,7 % 2,(-91) % 60,(-51) % 37,(-7) % 96,32 % 23,(-3) % 7,4 % 49,53 % 84,(-81) % 80,67 % 61,(-23) % 8,18 % 65,(-26) % 87,(-23) % 21,(-73) % 90,(-6) % 49,55 % 47,(-49) % 26,(-41) % 27,(-73) % 62,95 % 79,5 % 46,17 % 22,(-9) % 10,18 % 43,(-28) % 15,(-26) % 37,30 % 67,40 % 77,(-7) % 6,(-83) % 28,65 % 46,79 % 45,(-27) % 20,22 % 27,23 % 30,4 % 43,(-40) % 71,89 % 83,25 % 26,8 % 3,(-1) % 11,(-8) % 15,(-47) % 45,(-51) % 46,5 % 1,(-70) % 51,(-11) % 16,18 % 83,41 % 54,(-52) % 71,(-3) % 4,53 % 81,(-15) % 37,(-1) % 17,55 % 9,94 % 7,16 % 33,33 % 13,(-16) % 69,(-17) % 37,(-27) % 34,(-70) % 33,(-43) % 23,(-64) % 95,11 % 32,16 % 7,53 % 94,(-43) % 14,12 % 7,3 % 53,(-51) % 71,41 % 24,99 % 28,31 % 17,(-31) % 32,9 % 31,(-99) % 14,5 % 86,7 % 8,46 % 25,1 % 8,(-71) % 55,(-84) % 23,19 % 45,(-65) % 44,47 % 74,89 % 40,63 % 65,(-4) % 23,(-30) % 11,(-7) % 85,(-61) % 39,5 % 72,4 % 43,(-32) % 49,31 % 7,(-64) % 37,(-95) % 59,59 % 70,52 % 25,(-7) % 48,37 % 13,47 % 33,37 % 72,20 % 29,33 % 40,53 % 40,91 % 16,(-3) % 4,57 % 25,(-1) % 8,(-91) % 40,(-16) % 75,(-74) % 81,7 % 54,38 % 23,(-93) % 88,48 % 37,(-76) % 31,(-21) % 29,(-4) % 1,(-16) % 85,23 % 9,22 % 9,19 % 20,(-7) % 8,(-15) % 29,(-97) % 19,67 % 82,(-79) % 82,31 % 57,(-40) % 23,(-25) % 12,14 % 37,(-21) % 76,(-52) % 49,(-76) % 3,(-17) % 31,31 % 51,(-43) % 32,(-23) % 54,(-70) % 33,41 % 34,1 % 2,(-25) % 29,78 % 41,92 % 63,94 % 97,(-23) % 15,33 % 1,(-69) % 14,100 % 31,79 % 22,(-50) % 47,20 % 19,(-26) % 79,(-6) % 1,(-99) % 23,31 % 99,(-11) % 10,32 % 17,5 % 8,79 % 90,(-97) % 62,31 % 36,85 % 31,(-38) % 71,1 % 5,(-5) % 8,(-3) % 62,(-5) % 6,47 % 30,(-27) % 98,(-11) % 59,(-3) % 2,(-79) % 71,36 % 43,(-1) % 1,(-3) % 2,(-5) % 7,(-34) % 97,31 % 25,50 % 81,(-44) % 5,(-68) % 43,(-25) % 71,25 % 4,(-1) % 2,38 % 69,38 % 25,(-59) % 8,46 % 5,57 % 89,13 % 5,11 % 7,(-89) % 88,(-15) % 1,7 % 54,8 % 67,66 % 61,(-71) % 64,(-2) % 1,(-86) % 95,(-13) % 38,(-45) % 19,31 % 12,(-22) % 7,(-1) % 8,(-21) % 19,(-59) % 67,(-7) % 81,(-2) % 55,(-14) % 39,(-91) % 57,(-43) % 28,(-6) % 5,(-9) % 13,82 % 89,(-71) % 51,28 % 33,(-11) % 2,47 % 3,(-8) % 77,59 % 34,(-27) % 13]+rat_1000_simple_b =+ [(-61) % 69,7 % 4,(-3) % 41,(-51) % 62,5 % 6,(-7) % 5,(-21) % 26,(-26) % 19,(-4) % 25,43 % 53,(-37) % 10,(-14) % 11,15 % 49,28 % 95,(-97) % 96,(-30) % 79,(-10) % 7,13 % 50,3 % 50,10 % 11,28 % 3,(-76) % 39,12 % 1,16 % 7,(-71) % 9,63 % 80,32 % 81,(-32) % 5,99 % 10,27 % 1,34 % 79,59 % 48,5 % 12,(-23) % 5,(-53) % 2,92 % 59,(-11) % 3,(-5) % 8,(-48) % 5,(-16) % 9,24 % 17,49 % 29,25 % 39,63 % 26,37 % 33,(-23) % 44,(-86) % 81,(-13) % 5,19 % 5,18 % 11,35 % 57,61 % 35,(-2) % 1,89 % 63,42 % 59,(-25) % 1,100 % 49,(-82) % 57,(-7) % 11,(-13) % 47,(-3) % 19,(-13) % 5,(-11) % 4,(-11) % 9,(-2) % 95,1 % 55,91 % 76,1 % 14,(-24) % 35,(-58) % 15,28 % 23,(-65) % 96,58 % 15,1 % 77,19 % 79,79 % 51,(-1) % 6,85 % 28,77 % 52,(-7) % 94,(-55) % 14,72 % 43,(-37) % 44,1 % 13,6 % 1,(-21) % 52,(-13) % 19,(-5) % 22,19 % 7,(-15) % 16,60 % 61,(-52) % 63,(-66) % 43,(-15) % 71,(-45) % 68,37 % 1,71 % 79,(-1) % 19,8 % 5,(-3) % 86,41 % 74,(-11) % 2,(-1) % 12,42 % 17,7 % 19,7 % 5,(-3) % 5,(-1) % 44,51 % 94,(-97) % 22,66 % 7,34 % 53,(-46) % 9,(-79) % 91,(-1) % 1,(-3) % 61,(-7) % 10,16 % 3,(-45) % 14,(-17) % 38,(-87) % 46,(-57) % 5,13 % 22,37 % 88,51 % 41,53 % 35,(-77) % 58,77 % 39,31 % 11,25 % 2,95 % 8,9 % 92,29 % 21,1 % 1,41 % 36,(-87) % 64,13 % 8,35 % 47,(-27) % 17,(-9) % 100,5 % 34,(-83) % 88,6 % 41,(-55) % 59,(-13) % 72,(-52) % 49,(-98) % 53,(-4) % 13,44 % 89,94 % 55,99 % 31,(-28) % 73,(-15) % 22,91 % 25,(-8) % 9,(-29) % 92,(-27) % 25,(-57) % 49,25 % 29,1 % 1,(-25) % 37,23 % 27,(-5) % 22,(-67) % 58,9 % 37,(-24) % 17,69 % 29,95 % 84,7 % 45,(-32) % 11,(-49) % 73,11 % 1,(-25) % 16,80 % 7,9 % 4,(-57) % 37,31 % 51,(-83) % 2,6 % 19,(-76) % 89,(-29) % 36,16 % 39,26 % 21,79 % 27,26 % 21,(-23) % 3,11 % 82,(-11) % 38,(-45) % 23,(-31) % 89,71 % 52,(-97) % 18,21 % 20,41 % 76,(-5) % 33,100 % 93,56 % 65,(-32) % 7,(-50) % 49,51 % 70,(-97) % 62,5 % 3,5 % 1,(-6) % 1,4 % 19,(-1) % 31,14 % 23,19 % 8,15 % 13,(-6) % 1,17 % 12,44 % 13,23 % 27,36 % 5,(-27) % 46,(-6) % 23,(-50) % 7,52 % 19,(-73) % 9,89 % 57,(-27) % 7,(-17) % 6,(-37) % 49,35 % 44,(-14) % 9,67 % 38,(-73) % 86,11 % 1,(-8) % 9,22 % 41,18 % 79,(-61) % 12,55 % 13,17 % 29,54 % 67,(-37) % 15,(-19) % 54,61 % 41,36 % 25,2 % 5,(-12) % 5,(-51) % 49,(-93) % 64,(-5) % 9,(-17) % 4,(-27) % 19,38 % 5,(-17) % 57,(-83) % 72,(-83) % 79,(-3) % 1,93 % 37,(-13) % 36,(-7) % 26,(-28) % 25,9 % 11,(-2) % 3,(-22) % 3,61 % 63,(-93) % 41,(-32) % 11,(-76) % 23,(-4) % 63,87 % 97,52 % 87,(-44) % 23,(-21) % 10,89 % 98,62 % 89,15 % 44,(-45) % 62,(-44) % 1,(-13) % 90,(-92) % 51,(-35) % 16,(-31) % 4,91 % 24,73 % 26,1 % 2,(-67) % 33,29 % 11,(-23) % 27,41 % 75,(-7) % 48,51 % 73,(-9) % 95,(-13) % 70,(-24) % 5,(-15) % 29,(-80) % 73,(-61) % 54,(-29) % 47,(-41) % 25,31 % 48,5 % 8,64 % 51,11 % 31,(-16) % 17,4 % 1,(-1) % 63,(-11) % 24,39 % 28,(-36) % 71,(-58) % 11,(-75) % 52,35 % 64,(-77) % 41,11 % 78,87 % 56,91 % 51,(-33) % 80,46 % 7,31 % 13,19 % 8,(-10) % 17,7 % 83,(-14) % 9,(-19) % 54,(-22) % 45,17 % 33,47 % 40,0 % 1,(-45) % 76,26 % 19,(-13) % 57,100 % 3,65 % 53,(-92) % 41,24 % 1,9 % 10,(-17) % 11,41 % 4,24 % 1,17 % 3,41 % 10,(-71) % 50,9 % 14,(-11) % 26,76 % 1,13 % 69,(-4) % 5,(-5) % 3,23 % 25,(-11) % 4,(-11) % 3,73 % 54,16 % 45,1 % 2,15 % 17,17 % 60,(-43) % 19,34 % 73,(-17) % 20,(-69) % 22,23 % 17,(-53) % 76,(-19) % 25,50 % 41,1 % 1,(-3) % 5,(-1) % 31,(-23) % 20,(-54) % 59,(-25) % 13,(-1) % 2,71 % 61,77 % 1,71 % 82,4 % 17,(-13) % 4,(-11) % 24,(-7) % 97,1 % 3,(-62) % 59,(-51) % 64,93 % 94,(-59) % 17,24 % 19,37 % 33,51 % 35,(-6) % 1,97 % 43,58 % 59,58 % 61,(-1) % 10,37 % 34,29 % 11,49 % 48,(-47) % 37,33 % 86,(-6) % 85,9 % 28,(-8) % 61,(-49) % 55,5 % 2,(-93) % 89,(-67) % 9,(-97) % 86,45 % 49,(-20) % 11,(-18) % 23,48 % 31,4 % 1,20 % 43,52 % 95,(-41) % 13,71 % 48,10 % 19,(-50) % 27,(-37) % 68,(-86) % 67,(-20) % 23,5 % 78,45 % 4,(-23) % 94,(-4) % 5,92 % 53,(-19) % 31,(-95) % 69,(-44) % 21,(-8) % 21,23 % 100,(-22) % 5,22 % 23,8 % 19,(-40) % 49,(-12) % 95,21 % 11,(-28) % 33,(-98) % 25,73 % 45,1 % 62,(-35) % 31,(-14) % 3,3 % 5,4 % 3,1 % 2,99 % 95,46 % 25,(-31) % 27,(-16) % 19,(-4) % 11,(-43) % 85,47 % 44,21 % 88,11 % 7,(-45) % 83,(-1) % 10,(-6) % 7,(-82) % 59,4 % 7,(-24) % 19,(-27) % 32,(-31) % 11,(-5) % 57,37 % 53,32 % 15,(-19) % 18,33 % 10,(-94) % 73,(-11) % 31,(-43) % 77,(-29) % 41,(-29) % 43,5 % 9,(-1) % 1,(-37) % 91,6 % 37,(-22) % 87,83 % 3,23 % 22,(-41) % 17,(-59) % 50,(-7) % 26,(-17) % 27,(-93) % 61,3 % 13,(-31) % 17,(-16) % 59,7 % 5,25 % 9,(-89) % 47,(-3) % 10,7 % 9,(-23) % 66,43 % 97,(-10) % 21,(-73) % 88,1 % 1,63 % 85,15 % 58,(-7) % 96,26 % 31,98 % 37,(-1) % 2,97 % 37,6 % 7,(-14) % 17,85 % 84,(-94) % 35,36 % 17,(-23) % 7,21 % 29,58 % 1,7 % 13,81 % 67,(-69) % 16,(-2) % 19,73 % 88,(-45) % 7,37 % 30,10 % 33,(-73) % 87,67 % 97,(-4) % 3,(-40) % 53,(-27) % 5,95 % 58,97 % 99,45 % 52,(-15) % 19,(-7) % 67,(-76) % 97,(-1) % 2,(-41) % 53,93 % 59,(-37) % 39,43 % 31,(-95) % 48,(-71) % 35,(-23) % 39,(-65) % 3,(-3) % 4,(-31) % 49,(-89) % 97,(-7) % 6,73 % 70,(-3) % 7,57 % 52,(-47) % 68,(-11) % 6,(-5) % 3,(-9) % 8,(-37) % 72,1 % 1,10 % 3,(-29) % 97,17 % 48,75 % 56,(-17) % 33,(-28) % 31,(-67) % 58,29 % 43,(-74) % 55,(-19) % 33,44 % 39,(-7) % 11,(-9) % 13,8 % 21,47 % 31,(-18) % 17,(-5) % 4,19 % 40,(-13) % 5,(-73) % 57,9 % 97,0 % 1,1 % 1,1 % 5,23 % 25,(-35) % 38,18 % 47,(-34) % 31,17 % 79,(-21) % 20,(-29) % 28,7 % 24,5 % 39,(-62) % 63,(-10) % 29,13 % 16,25 % 84,56 % 97,(-2) % 89,2 % 11,(-11) % 16,(-41) % 18,47 % 48,(-100) % 27,82 % 89,74 % 63,49 % 36,(-75) % 37,29 % 54,(-11) % 48,(-71) % 95,(-22) % 5,83 % 75,(-8) % 3,(-13) % 38,53 % 31,89 % 14,2 % 15,(-14) % 99,(-19) % 8,11 % 41,(-5) % 4,9 % 4,(-1) % 4,(-99) % 4,(-18) % 29,61 % 14,(-3) % 16,2 % 13,(-3) % 5,(-39) % 17,(-11) % 54,95 % 99,19 % 29,(-4) % 33,(-11) % 24,(-2) % 3,27 % 55,(-25) % 99,3 % 7,(-26) % 15,50 % 3,(-89) % 41,(-97) % 91,3 % 5,(-91) % 94,(-51) % 83,21 % 13,(-49) % 25,(-17) % 20,(-87) % 19,(-85) % 82,100 % 33,39 % 31,(-4) % 9,(-15) % 16,92 % 49,70 % 57,40 % 29,38 % 41,8 % 89,30 % 23,88 % 87,(-8) % 3,100 % 91,38 % 87,41 % 52,(-61) % 99,(-1) % 10,7 % 11,70 % 87,(-7) % 4,(-43) % 67,79 % 9,(-58) % 69,(-11) % 9,(-23) % 10,9 % 2,(-30) % 91,2 % 29,81 % 91,11 % 61,25 % 89,(-11) % 19,(-54) % 37,5 % 16,21 % 43,35 % 54,(-14) % 19,14 % 57,(-43) % 50,47 % 74,79 % 28,60 % 41,(-2) % 7,(-31) % 37,17 % 7,69 % 28,7 % 25,38 % 23,3 % 1,(-60) % 91,(-25) % 3,53 % 8,(-62) % 53,89 % 49,(-23) % 13,(-25) % 92,(-13) % 69,31 % 6,(-97) % 22,(-1) % 12,10 % 9,4 % 13,(-51) % 53,(-1) % 73,19 % 84,5 % 4,41 % 1,(-43) % 67,37 % 35,(-98) % 25,62 % 69,(-97) % 76,(-17) % 14,(-18) % 23,49 % 13,78 % 29,(-9) % 40,(-3) % 1,(-78) % 11,(-100) % 69,75 % 32,69 % 53,(-6) % 7,23 % 90,3 % 4,29 % 35,33 % 7,29 % 28,17 % 12,97 % 83,(-4) % 5,(-37) % 10,(-2) % 3,5 % 31,(-49) % 31,(-1) % 8,(-23) % 65,6 % 7,(-10) % 23,61 % 88,47 % 20,(-3) % 92,(-74) % 75,3 % 70,(-76) % 87,90 % 11,(-68) % 7,(-87) % 11,60 % 97,(-97) % 31,20 % 89,27 % 29,12 % 35,(-40) % 27,(-22) % 59,(-17) % 20,(-7) % 8,33 % 80,(-85) % 29,25 % 53,3 % 22,(-4) % 15,49 % 94,(-18) % 35,(-22) % 53,13 % 77,(-57) % 26,28 % 83,27 % 44,(-10) % 19,(-99) % 40,(-11) % 9,17 % 16,71 % 59,7 % 31,(-7) % 1,29 % 25,1 % 4,25 % 27,13 % 73,(-15) % 7,4 % 19,19 % 3,93 % 16,(-77) % 96,47 % 14,(-95) % 86,(-46) % 5,(-5) % 12,(-19) % 9,58 % 17,(-12) % 37,(-5) % 16,(-53) % 9,7 % 76,(-27) % 38,7 % 5,79 % 45,(-7) % 47,(-44) % 31,0 % 1,61 % 26,25 % 3,8 % 75,(-34) % 15,(-17) % 30,91 % 67,(-1) % 55,(-8) % 19,21 % 41,(-51) % 19,(-13) % 32,8 % 43,(-8) % 17,9 % 1,(-6) % 7,(-81) % 28,(-91) % 5,43 % 25,64 % 83,40 % 63,(-40) % 93,(-34) % 7,(-96) % 55,28 % 43,17 % 16,5 % 56,(-93) % 100,(-43) % 94,(-29) % 19,(-83) % 53,(-61) % 81,19 % 86,69 % 37,(-37) % 58,(-7) % 85,1 % 16,39 % 74,95 % 62,(-56) % 85,(-23) % 49,(-57) % 74,37 % 93,19 % 78,(-1) % 41,(-13) % 19,(-38) % 13,95 % 72,(-21) % 62,(-98) % 33,(-89) % 52,(-45) % 41,39 % 5,(-21) % 2,44 % 7,24 % 25,(-5) % 73,(-3) % 2,(-31) % 44,61 % 22,57 % 85,(-83) % 44,40 % 11,(-73) % 24,4 % 1,(-54) % 7,(-5) % 14,(-13) % 20,(-46) % 59,48 % 31,31 % 21,17 % 33,(-52) % 27,66 % 35,(-79) % 60,(-4) % 3,(-2) % 3,16 % 23,(-2) % 15,(-23) % 26,74 % 39,33 % 29,65 % 18,23 % 73,80 % 7,(-13) % 24,(-24) % 85,79 % 86,46 % 43,(-41) % 24,(-28) % 11,17 % 57,31 % 89,(-23) % 48,89 % 75,19 % 18,(-16) % 27,5 % 23,0 % 1,85 % 13,(-71) % 22,25 % 12,15 % 1,11 % 13,(-55) % 6,(-21) % 79,83 % 17,91 % 80,(-27) % 83,0 % 1,61 % 15,(-5) % 7,(-35) % 61,1 % 17,(-53) % 29,(-13) % 14,(-10) % 11,65 % 99,28 % 75,5 % 27,(-51) % 80,(-69) % 49,24 % 1,(-1) % 10,0 % 1,43 % 34,(-27) % 73,5 % 18,(-13) % 11,3 % 4,74 % 91,25 % 37,66 % 35,76 % 97,(-53) % 37,(-16) % 33,(-16) % 67,5 % 9,50 % 7,(-7) % 20,67 % 79,41 % 49,16 % 31,6 % 5,(-11) % 16,(-11) % 9,21 % 46,(-13) % 23,(-7) % 13,99 % 47,13 % 30,(-13) % 10,47 % 96,(-13) % 43,91 % 55,49 % 23,(-34) % 43,(-13) % 77,(-68) % 7,86 % 75,(-53) % 17,(-1) % 5,9 % 4,27 % 28,(-33) % 8,(-37) % 64,89 % 2,13 % 31,(-99) % 1,50 % 83,(-3) % 11,4 % 27,(-36) % 55,(-17) % 19,(-4) % 19,33 % 31,(-75) % 8,10 % 3,(-31) % 27,41 % 4,(-40) % 11,(-31) % 13,(-3) % 22,67 % 76,89 % 54,95 % 46,(-18) % 31,(-46) % 17,56 % 79,(-81) % 50,(-32) % 35,(-79) % 51,82 % 55,(-38) % 65,12 % 43,(-5) % 4,(-10) % 7,(-29) % 26,26 % 33,(-49) % 83,90 % 71,(-1) % 9,32 % 17]++rat_500_simple :: [Rational]+rat_500_simple = [(-84) % 101,(-73) % 62,157 % 147,8 % 71,34 % 19,(-4) % 15,(-169) % 165,(-49) % 4,16 % 63,21 % 167,130 % 161,(-24) % 47,40 % 129,(-68) % 77,39 % 16,(-9) % 32,11 % 190,(-32) % 23,22 % 47,99 % 10,(-197) % 191,(-25) % 29,17 % 3,(-149) % 166,50 % 163,63 % 43,(-173) % 51,(-77) % 109,(-1) % 27,(-89) % 45,34 % 35,(-34) % 25,119 % 41,29 % 21,15 % 2,198 % 89,17 % 191,(-18) % 61,(-129) % 56,170 % 179,16 % 37,59 % 33,19 % 32,(-12) % 79,(-121) % 181,31 % 4,145 % 127,47 % 172,(-133) % 180,26 % 53,47 % 125,31 % 33,(-89) % 146,95 % 79,163 % 172,36 % 55,2 % 27,(-164) % 27,199 % 51,61 % 77,(-1) % 41,88 % 169,169 % 188,78 % 131,(-31) % 119,(-17) % 1,193 % 90,5 % 62,(-109) % 85,(-34) % 95,(-181) % 57,34 % 53,157 % 142,(-14) % 19,(-30) % 61,(-173) % 96,83 % 54,(-114) % 107,26 % 35,92 % 167,(-163) % 38,(-147) % 164,68 % 65,7 % 8,(-3) % 10,21 % 47,(-80) % 159,77 % 128,(-197) % 19,80 % 161,17 % 48,39 % 178,(-105) % 122,14 % 25,(-11) % 15,(-23) % 32,101 % 68,19 % 172,167 % 75,25 % 16,(-91) % 66,(-62) % 37,(-175) % 167,127 % 27,180 % 173,155 % 153,97 % 60,29 % 47,(-17) % 6,65 % 28,(-193) % 187,(-42) % 17,97 % 54,(-154) % 199,88 % 135,183 % 196,16 % 47,(-1) % 14,53 % 3,(-159) % 196,(-179) % 178,(-65) % 94,(-24) % 1,4 % 1,(-19) % 97,(-56) % 27,41 % 9,165 % 196,(-78) % 41,58 % 91,(-18) % 151,165 % 188,175 % 58,(-78) % 61,(-50) % 63,(-33) % 62,(-151) % 78,(-49) % 135,(-164) % 107,(-53) % 37,(-189) % 107,135 % 58,(-16) % 89,(-17) % 96,(-41) % 70,(-20) % 27,27 % 28,2 % 21,(-64) % 49,(-153) % 80,115 % 148,(-74) % 27,79 % 26,(-146) % 145,(-10) % 9,(-1) % 4,1 % 6,122 % 149,6 % 1,(-47) % 79,5 % 174,77 % 24,68 % 93,167 % 135,(-111) % 191,6 % 29,49 % 4,141 % 16,44 % 127,(-30) % 73,7 % 46,111 % 106,53 % 32,51 % 112,(-97) % 91,(-31) % 149,(-23) % 1,(-158) % 33,15 % 44,(-100) % 1,(-182) % 93,(-13) % 6,5 % 19,110 % 83,171 % 97,(-31) % 127,(-9) % 4,(-193) % 38,(-136) % 151,174 % 61,(-196) % 41,(-80) % 99,(-3) % 5,29 % 11,(-114) % 1,(-83) % 127,(-109) % 15,(-31) % 27,61 % 172,(-69) % 13,48 % 23,194 % 115,7 % 5,(-72) % 35,(-183) % 184,173 % 112,19 % 1,(-131) % 118,(-88) % 37,155 % 21,78 % 173,61 % 19,81 % 100,(-83) % 30,138 % 49,167 % 171,45 % 97,40 % 163,(-40) % 161,(-79) % 106,(-24) % 191,43 % 126,(-119) % 54,(-169) % 193,(-65) % 73,11 % 23,(-130) % 77,91 % 163,109 % 114,(-171) % 178,110 % 39,53 % 66,(-61) % 11,52 % 19,(-85) % 116,23 % 53,(-58) % 153,67 % 37,80 % 157,171 % 59,200 % 179,(-127) % 200,(-73) % 32,(-138) % 179,(-42) % 107,134 % 65,1 % 29,(-144) % 31,(-82) % 1,155 % 32,(-71) % 127,(-47) % 10,10 % 69,(-187) % 45,(-24) % 19,(-197) % 20,(-47) % 106,41 % 113,(-47) % 127,(-57) % 194,(-162) % 125,72 % 31,(-12) % 49,58 % 81,(-121) % 157,66 % 163,(-127) % 52,77 % 60,148 % 71,13 % 51,(-191) % 97,(-4) % 3,109 % 101,(-22) % 13,22 % 21,(-48) % 169,123 % 193,72 % 73,(-111) % 95,(-26) % 49,88 % 119,(-113) % 102,2 % 3,(-1) % 36,127 % 76,92 % 111,(-17) % 6,(-62) % 89,(-113) % 197,(-45) % 49,(-34) % 87,3 % 5,194 % 1,103 % 70,147 % 13,(-32) % 97,51 % 176,(-2) % 135,(-199) % 128,(-191) % 121,92 % 55,53 % 43,14 % 151,(-130) % 191,5 % 24,(-100) % 51,(-19) % 34,(-73) % 132,78 % 17,11 % 38,(-125) % 26,36 % 53,(-1) % 11,(-99) % 40,179 % 75,(-181) % 91,157 % 87,123 % 124,100 % 57,103 % 74,176 % 7,(-7) % 24,155 % 17,163 % 150,147 % 151,193 % 145,(-142) % 111,(-89) % 121,(-3) % 1,7 % 48,5 % 16,51 % 50,(-19) % 35,13 % 32,(-155) % 144,(-19) % 12,(-107) % 134,24 % 43,(-38) % 27,(-13) % 97,93 % 37,138 % 121,(-3) % 2,56 % 45,88 % 93,89 % 45,(-199) % 25,114 % 97,(-78) % 17,(-121) % 57,(-27) % 14,1 % 7,(-26) % 41,(-182) % 115,58 % 177,(-17) % 30,19 % 189,(-47) % 179,(-181) % 174,(-104) % 49,17 % 121,79 % 53,(-184) % 13,(-15) % 86,26 % 3,43 % 155,6 % 5,(-83) % 93,107 % 147,193 % 153,(-195) % 173,(-89) % 123,(-87) % 89,177 % 73,(-21) % 37,(-46) % 93,(-153) % 133,17 % 176,(-194) % 37,69 % 28,(-127) % 165,(-95) % 1,97 % 133,(-125) % 76,(-5) % 1,(-160) % 89,197 % 181,3 % 11,169 % 136,(-197) % 26,104 % 31,(-174) % 37,(-61) % 87,(-165) % 158,11 % 3,(-29) % 153,(-176) % 57,29 % 151,8 % 137,141 % 44,(-4) % 19,55 % 124,(-163) % 183,(-11) % 6,(-135) % 184,(-85) % 61,(-75) % 56,40 % 1,(-5) % 17,(-73) % 8,28 % 125,(-27) % 11,68 % 73,(-43) % 14,41 % 42,48 % 1,(-32) % 153,(-23) % 105,173 % 195,(-133) % 128,89 % 75,98 % 115,(-61) % 31,27 % 119,(-29) % 17,37 % 13,(-77) % 172,160 % 169,(-183) % 50,(-24) % 25,(-65) % 152,25 % 32,13 % 116,(-55) % 74,(-117) % 124,60 % 61,(-7) % 4,(-85) % 174,(-147) % 61,48 % 65,(-2) % 5,(-117) % 112,74 % 169,(-9) % 37,(-15) % 74,(-92) % 149,47 % 162,(-61) % 93,(-28) % 95,(-86) % 9,91 % 15,132 % 107,(-39) % 88,(-60) % 127,165 % 98,9 % 65,13 % 21,173 % 125,(-154) % 127,132 % 197,21 % 37,36 % 13,69 % 74,46 % 39,(-133) % 6,3 % 1,11 % 10,(-4) % 89,125 % 3,9 % 13,107 % 132,(-65) % 132,(-99) % 115,(-187) % 95,(-23) % 3,65 % 166,121 % 34,(-163) % 43,23 % 80,(-17) % 23,7 % 2,(-82) % 3,145 % 57,(-37) % 78,(-166) % 33,9 % 28,(-19) % 27,(-7) % 12,(-141) % 152,116 % 81,(-164) % 181,200 % 179,(-71) % 158,5 % 2,62 % 187,(-172) % 105,(-144) % 35,(-93) % 52,2 % 5,(-185) % 21]++rat_400_simple :: [Rational]+rat_400_simple = [(-41) % 43,3 % 19,2 % 65,(-11) % 62,(-13) % 3,17 % 10,1 % 22,(-79) % 39,9 % 31,(-3) % 10,3 % 4,17 % 49,(-54) % 95,30 % 47,(-20) % 13,43 % 39,(-17) % 50,(-19) % 24,59 % 31,26 % 7,11 % 13,29 % 25,1 % 7,29 % 62,(-5) % 59,17 % 71,(-77) % 30,(-12) % 7,53 % 94,(-1) % 2,(-7) % 11,4 % 7,5 % 7,(-18) % 31,(-81) % 82,(-47) % 46,1 % 1,11 % 80,15 % 46,(-3) % 17,(-25) % 2,(-9) % 1,(-9) % 10,(-7) % 8,(-9) % 16,(-31) % 6,8 % 3,36 % 1,35 % 41,(-13) % 16,(-9) % 10,71 % 97,(-3) % 1,(-40) % 43,45 % 88,76 % 61,(-4) % 13,(-3) % 10,(-5) % 2,19 % 3,(-3) % 1,94 % 61,(-94) % 85,(-17) % 67,(-29) % 22,(-1) % 24,70 % 37,0 % 1,(-96) % 49,35 % 83,(-5) % 1,(-98) % 27,77 % 10,22 % 31,4 % 1,(-15) % 91,29 % 71,(-3) % 26,(-63) % 10,(-89) % 86,0 % 1,(-51) % 10,0 % 1,(-2) % 7,(-56) % 39,3 % 14,79 % 82,46 % 45,79 % 14,(-35) % 57,58 % 21,(-8) % 5,17 % 16,44 % 39,0 % 1,8 % 23,4 % 93,3 % 2,(-17) % 9,32 % 5,47 % 9,3 % 1,(-17) % 44,(-83) % 3,(-11) % 27,(-5) % 1,7 % 41,49 % 68,(-98) % 57,25 % 12,62 % 87,1 % 1,47 % 96,(-3) % 8,40 % 11,(-5) % 1,81 % 65,3 % 11,17 % 30,86 % 39,(-24) % 79,2 % 21,10 % 57,93 % 61,87 % 68,11 % 19,(-2) % 7,5 % 1,(-93) % 80,5 % 36,14 % 27,(-1) % 5,5 % 1,(-38) % 3,(-99) % 94,(-6) % 65,(-30) % 17,(-100) % 69,31 % 17,71 % 46,(-46) % 49,(-8) % 25,41 % 6,51 % 44,(-31) % 59,70 % 47,81 % 47,(-59) % 9,(-75) % 29,69 % 64,6 % 79,(-13) % 3,32 % 1,48 % 1,15 % 13,(-25) % 78,(-39) % 92,25 % 21,86 % 47,19 % 2,100 % 81,25 % 68,55 % 73,21 % 52,(-13) % 1,28 % 67,(-60) % 13,15 % 52,(-44) % 61,22 % 27,(-49) % 45,(-31) % 39,(-29) % 25,(-67) % 50,14 % 15,(-29) % 2,97 % 58,16 % 97,(-23) % 74,(-91) % 22,39 % 2,(-49) % 81,(-65) % 61,71 % 76,11 % 2,(-99) % 35,79 % 77,91 % 33,(-1) % 2,82 % 75,62 % 27,61 % 20,40 % 43,47 % 26,(-33) % 32,(-83) % 40,(-1) % 8,(-13) % 15,(-97) % 56,(-6) % 17,39 % 92,39 % 89,(-83) % 37,1 % 22,3 % 1,(-12) % 11,49 % 30,(-36) % 53,19 % 20,26 % 29,(-61) % 44,12 % 49,(-39) % 82,83 % 53,21 % 79,(-74) % 49,(-6) % 1,7 % 10,45 % 43,(-3) % 4,5 % 18,17 % 4,38 % 75,40 % 29,1 % 2,(-90) % 29,(-71) % 43,(-75) % 22,(-43) % 17,79 % 90,19 % 68,(-46) % 49,81 % 83,20 % 31,21 % 2,54 % 47,1 % 10,71 % 51,11 % 59,(-51) % 35,(-15) % 13,97 % 59,(-7) % 9,(-19) % 4,1 % 27,(-37) % 38,90 % 41,(-71) % 50,(-2) % 31,(-11) % 43,33 % 10,(-4) % 77,(-33) % 100,29 % 43,(-21) % 13,(-84) % 85,2 % 1,(-17) % 11,(-11) % 32,(-35) % 99,41 % 55,94 % 73,10 % 17,0 % 1,(-17) % 48,(-96) % 77,(-37) % 91,(-73) % 97,44 % 3,21 % 1,(-59) % 17,(-79) % 36,46 % 41,35 % 39,(-17) % 31,(-43) % 9,27 % 34,4 % 27,(-99) % 38,25 % 69,(-1) % 2,(-37) % 66,53 % 66,(-33) % 37,(-44) % 87,83 % 37,(-17) % 8,39 % 10,49 % 20,(-25) % 3,33 % 28,35 % 24,8 % 19,(-89) % 63,(-19) % 43,92 % 99,(-41) % 34,(-93) % 41,(-47) % 45,(-14) % 93,(-51) % 47,35 % 93,(-8) % 3,11 % 93,69 % 76,95 % 36,(-45) % 28,85 % 22,25 % 2,(-29) % 74,33 % 70,(-41) % 3,32 % 33,16 % 27,(-16) % 93,17 % 14,1 % 20,(-44) % 3,79 % 39,9 % 35,89 % 95,(-22) % 17,2 % 3,46 % 9,(-5) % 27,6 % 31,(-52) % 57,69 % 73,(-92) % 67,32 % 1,(-61) % 48,61 % 15,38 % 7,7 % 20,(-41) % 19,3 % 16,(-1) % 8,15 % 74,(-9) % 7,28 % 25,(-29) % 12,(-25) % 61,2 % 1,6 % 91,93 % 83,20 % 37,98 % 99,(-35) % 18,(-27) % 5,42 % 5,67 % 27,(-49) % 32,27 % 49,(-28) % 15,(-35) % 16,3 % 64,1 % 1,(-24) % 29,73 % 35,(-26) % 81,(-6) % 89,(-67) % 24,(-1) % 1,(-16) % 69,100 % 47,3 % 29,(-74) % 27,(-59) % 19,(-83) % 85,19 % 20,(-86) % 59,(-58) % 19,7 % 8,91 % 31,97 % 34,13 % 37,(-40) % 9,(-19) % 2,(-83) % 3,37 % 61,3 % 37,(-49) % 69,52 % 9,1 % 39,1 % 75,(-7) % 9,(-33) % 25,56 % 79,20 % 59,39 % 34,(-21) % 10,(-77) % 20,11 % 14,(-46) % 99,11 % 14,20 % 19,87 % 13,14 % 3,25 % 57,2 % 23]
+ bench/unipol-div.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE DataKinds #-}+module Main where+import Algebra.Ring.Polynomial (OrderedPolynomial)+import Algebra.Ring.Polynomial.Univariate+import Criterion.Main+import Data.Char (toLower)+import Data.List (intercalate)+import qualified Data.Map as M+import Data.Proxy (Proxy (..))+import Data.Sized.Builtin (singleton)+import Data.Typeable+import Numeric.Field.Fraction+import qualified Test.QuickCheck as QC+import Utils ()++x :: Unipol (Fraction Integer)+x = var 0++mkSimpleEnv :: Int -> IO (Unipol (Fraction Integer), Unipol (Fraction Integer))+mkSimpleEnv n = return (x ^ n - 1, x - 1)++fromOP :: OrderedPolynomial (Fraction Integer) Grevlex 1+ -> Unipol (Fraction Integer)+fromOP = injectVars++fromCoeffVec :: CoeffRing r => [r] -> Unipol r+fromCoeffVec = polynomial' . M.fromList . zip [singleton n | n <- [0..]]++genPoly :: Int -> IO (Unipol (Fraction Integer))+genPoly len = QC.generate $ fromCoeffVec <$> QC.vectorOf len QC.arbitrary++genPair l r = do+ (f, g) <- (,) <$> genPoly l <*> genPoly r+ let path = intercalate "-" ["bench/results/unipol-div-", show l, "-", show r]+ ++ ".txt"+ writeFile path $ unlines [show f, show g]+ return (f, g)++main :: IO ()+main = do+ defaultMain $+ [ bgroup "(x^n-1)%(x-1)"+ [ env (mkSimpleEnv n) $ \ ~(f, g) ->+ bgroup (show n)+ [bench "naive" $ nf (uncurry divModUnipol) (f, g)+ ,bench "mult" $ nf (uncurry divModUnipol) (f, g)+ ]+ | n <- [1,4,8,16] ++ [50,100,500,1000,10000]+ ]+ , bgroup "random" $+ [ env (genPair l r) $ \ ~(f, g) ->+ bgroup (show l ++ " % " ++ show r)+ [bench "naive" $ nf (uncurry divModUnipol) (f, g)+ ,bench "mult" $ nf (uncurry divModUnipolByMult) (f, g)+ ]+ | (l, r) <- [(5,2), (10,5), (100,50),(200,100),(500,250)]+ ]+ ]
+ bench/unipol-mult.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE DataKinds #-}+module Main where+import Algebra.Ring.Polynomial (OrderedPolynomial)+import Algebra.Ring.Polynomial.Univariate+import Criterion.Main+import Data.Char (toLower)+import Data.List (intercalate)+import qualified Data.Map as M+import Data.Proxy (Proxy (..))+import Data.Sized.Builtin (singleton)+import Data.Typeable+import Numeric.Field.Fraction+import qualified Test.QuickCheck as QC+import Utils ()++x :: Unipol Integer+x = var 0++allCoeffOne :: Int -> Unipol Integer+allCoeffOne n = sum [x ^ i | i <- [0..n]]++mkSimpleEnv :: Int -> IO (Unipol Integer, Unipol Integer)+mkSimpleEnv n = return (x - 1, allCoeffOne n)++fromOP :: OrderedPolynomial (Fraction Integer) Grevlex 1+ -> Unipol (Fraction Integer)+fromOP = injectVars++showProxyType :: Typeable a => Proxy a -> String+showProxyType pxy =+ let str = show $ typeRep pxy+ in if str == "Fraction Integer"+ then "rational"+ else map toLower str++fromCoeffVec :: CoeffRing r => [r] -> Unipol r+fromCoeffVec = polynomial' . M.fromList . zip [singleton n | n <- [0..]]++genPoly :: (Typeable r, CoeffRing r, QC.Arbitrary r)+ => Proxy r -> Int -> IO (Unipol r)+genPoly _ len = QC.generate $ fromCoeffVec <$> QC.vectorOf len QC.arbitrary++genPair pxy l r = do+ (f, g) <- (,) <$> genPoly pxy l <*> genPoly pxy r+ let path = intercalate "-" ["bench/results/unipol-mult", showProxyType pxy, show l, show r]+ ++ ".txt"+ writeFile path $ unlines [show f, show g]+ return (f, g)++int :: Proxy Integer+int = Proxy++rat :: Proxy (Fraction Integer)+rat = Proxy++main :: IO ()+main = do+ defaultMain $+ [ bgroup "(x-1)(x^n+...+x+1)"+ [ env (mkSimpleEnv n) $ \ ~(f, g) ->+ bgroup (show n)+ [bench "naive" $ nf (uncurry naiveMult) (f, g)+ ,bench "karatsuba" $ nf (uncurry karatsuba) (f, g)+ ]+ | n <- [1,4,8,16] ++ [50,100,500,1000,10000]+ ]+ , bgroup "(x^n+...+x+1)^2"+ [ env (return (allCoeffOne n, allCoeffOne n)) $ \ ~(f, g) ->+ bgroup (show n)+ [bench "naive" $ nf (uncurry naiveMult) (f, g)+ ,bench "karatsuba" $ nf (uncurry karatsuba) (f, g)+ ]+ | n <- [1,4,8,16] ++ [50,100,500,1000,10000]+ ]+ , bgroup "random" $+ [ env (genPair int l r) $ \ ~(f, g) ->+ bgroup ("Integer: " ++ show l ++ " x " ++ show r)+ [bench "naive" $ nf (uncurry naiveMult) (f, g)+ ,bench "karatsuba" $ nf (uncurry karatsuba) (f, g)+ ]+ | (l, r) <- [(5,5), (10,10), (100,100),(1000,1000)]+ ] +++ [ env (genPair rat l r) $ \ ~(f, g) ->+ bgroup ("Rational: " ++ show l ++ " x " ++ show r)+ [bench "naive" $ nf (uncurry naiveMult) (f, g)+ ,bench "karatsuba" $ nf (uncurry karatsuba) (f, g)+ ]+ | (l, r) <- [(5,5), (10,10), (100,100),(1000,1000)]+ ]+ ]
computational-algebra.cabal view
@@ -1,44 +1,879 @@--- Initial computational-algebra.cabal generated by cabal init. For --- further documentation, see http://haskell.org/cabal/users-guide/+name: computational-algebra+version: 0.4.0.0+cabal-version: >=1.10+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: (C) Hiromi ISHII 2013+maintainer: konn.jinro_at_gmail.com+homepage: https://github.com/konn/computational-algebra+synopsis: Well-kinded computational algebra library, currently supporting Groebner basis.+description:+ Dependently-typed computational algebra library for Groebner basis.+category: Math+author: Hiromi ISHII+tested-with: GHC ==8.0.1+extra-source-files:+ README.md+ examples/*.hs+ tests/*.hs+ bench/*.hs+ share/*.hs+ data/conway.txt -name: computational-algebra-version: 0.3.0.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-extra-source-files: README.md, examples/*.hs-build-type: Simple-cabal-version: >=1.8 source-repository head- Type: git- Location: git://github.com/konn/computational-algebra.git+ type: git+ location: git://github.com/konn/computational-algebra.git +flag examples+ default: False+ library- exposed-modules: Algebra.Algorithms.Groebner- , Algebra.Algorithms.Groebner.Monomorphic- , Algebra.Ring.Noetherian- , Algebra.Ring.Polynomial- , Algebra.Ring.Polynomial.Monomorphic- , Algebra.Ring.Polynomial.Parser- , Algebra.Internal- other-modules: Monomorphic- build-depends: base >= 2.0 && < 5- , algebra == 3.*- , tagged >= 0.4 && < 1- , lens == 3.*- , containers >= 0.4 && < 0.6- , peggy == 0.3.*- , monad-loops >= 0.3 && <0.5- , heaps == 0.2.*- , type-natural == 0.0.3.*- , sized-vector == 0.0.*- , singletons >= 0.8- , equational-reasoning == 0.0.*- if impl(ghc >= 7.6.1)- build-depends: monomorphic == 0.0.*+ exposed-modules:+ Algebra.Algorithms.ChineseRemainder+ Algebra.Algorithms.Groebner+ Algebra.Algorithms.PrimeTest+ Algebra.Algorithms.ZeroDim+ Algebra.Field.AlgebraicReal+ Algebra.Field.Finite+ Algebra.Field.Galois+ Algebra.Instances+ Algebra.Internal+ Algebra.LinkedMatrix+ Algebra.Matrix+ Algebra.Normed+ Algebra.Prelude+ Algebra.Prelude.Core+ Algebra.Ring.Ideal+ Algebra.Ring.Polynomial+ Algebra.Ring.Polynomial.Class+ Algebra.Ring.Polynomial.Factorise+ Algebra.Ring.Polynomial.Labeled+ Algebra.Ring.Polynomial.Monomial+ Algebra.Ring.Polynomial.Quotient+ Algebra.Ring.Polynomial.Univariate+ Algebra.Scalar+ build-depends:+ template-haskell >=2.11.0.0 && <2.12,+ MonadRandom >=0.1 && <0.5,+ algebraic-prelude ==0.1.*,+ algebra >=4.1 && <4.4,+ base >=4 && <4.10,+ semigroups >=0.15 && <0.19,+ containers ==0.5.*,+ convertible ==1.1.*,+ constraints >=0.3 && <0.9,+ deepseq >=1.3 && <1.5,+ equational-reasoning >=0.4.1.1 && <0.5,+ hashable >=1.1 && <1.3,+ heaps ==0.3.*,+ hmatrix >=0.16 && <0.18,+ matrix ==0.3.*,+ entropy >=0.3.7 && <0.4,+ lens >=4.13 && <4.15,+ monad-loops ==0.4.*,+ dlist >=0.8.0.2 && <0.9,+ monomorphic >=0.0.3 && <0.1,+ mtl >=2.1 && <2.3,+ reflection >=2 && <2.2,+ sized ==0.2.*,+ tagged >=0.7 && <0.9,+ hybrid-vectors >=0.1 && <0.3,+ text >=0.11 && <1.3,+ type-natural >=0.7.1 && <0.8,+ unamb ==0.2.*,+ unordered-containers ==0.2.*,+ vector >=0.10 && <0.12,+ parallel ==3.2.*,+ mono-traversable >=0.10 && <1.1,+ control-monad-loop ==0.1.*,+ primes >=0.2.1 && <0.3,+ singletons ==2.2.*,+ arithmoi >=0.4.3.0 && <0.5+ default-language: Haskell2010+ default-extensions: CPP DataKinds PolyKinds GADTs+ MultiParamTypeClasses TypeFamilies FlexibleContexts+ FlexibleInstances UndecidableInstances NoImplicitPrelude+ other-modules:+ Algebra.Algorithms.FGLM+ Algebra.Field.Galois.Conway+ Algebra.Field.Galois.Internal+ ghc-options: -O2 -Wall -Wno-unused-top-binds++executable groebner-prof+ main-is: groebner-prof.hs+ buildable: False+ build-depends:+ base >=4.9.0.0 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ deepseq >=1.4.2.0 && <1.5+ default-language: Haskell2010+ extensions: NoImplicitPrelude+ hs-source-dirs: share examples+ ghc-options: -Wall -prof -fprof-auto -threaded -O2++executable solve+ main-is: solve.hs+ buildable: False+ build-depends:+ semigroups >=0.15.2 && <0.19,+ constraints >=0.3 && <0.9,+ algebra >=4.1 && <4.4,+ base >=4 && <4.10,+ type-natural >=0.7.1.2 && <0.8,+ computational-algebra >=0.4.0.0 && <0.5,+ random >=1.0 && <1.2,+ hmatrix >=0.17.0.2 && <0.18,+ matrix ==0.3.*,+ sized >=0.2.1.0 && <0.3,+ vector >=0.10 && <0.12,+ convertible ==1.1.*,+ lens >=3.9 && <4.15,+ MonadRandom >=0.1 && <0.5+ hs-source-dirs: share examples+ ghc-options: -caf-all -auto-all -rtsopts -O2 -threaded++executable algebraic+ main-is: algebraic.hs+ buildable: False+ build-depends:+ base >=4.9.0.0 && <4.10,+ algebraic-prelude >=0.1.0.1 && <0.2,+ computational-algebra >=0.4.0.0 && <0.5+ default-language: Haskell2010+ hs-source-dirs: examples+ ghc-options: -Wall -O2 -threaded++executable ipsolve+ main-is: ipsolve.hs+ buildable: False+ build-depends:+ semigroups >=0.15.2 && <0.19,+ parallel ==3.2.*,+ constraints >=0.3 && <0.9,+ algebra >=4.1 && <4.4,+ equational-reasoning >=0.2 && <0.5,+ reflection >=1.4 && <2.2,+ base >=4 && <4.10,+ type-natural >=0.7.1.2 && <0.8,+ computational-algebra >=0.4.0.0 && <0.5,+ random >=1.0 && <1.2,+ hmatrix >=0.17.0.2 && <0.18,+ matrix ==0.3.*,+ sized >=0.2.1.0 && <0.3,+ vector >=0.10 && <0.12,+ convertible ==1.1.*,+ lens >=3.9 && <4.15,+ MonadRandom >=0.1 && <0.5,+ singletons ==2.2.*+ hs-source-dirs: share examples+ ghc-options: -caf-all -auto-all -rtsopts -O2 -threaded++executable faugere-prof+ main-is: faugere-prof.hs+ buildable: False+ build-depends:+ criterion >=0.8.1.0 && <1.2,+ semigroups >=0.15.2 && <0.19,+ constraints >=0.3 && <0.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ type-natural >=0.7.1.2 && <0.8,+ computational-algebra >=0.4.0.0 && <0.5,+ random >=1.0 && <1.2,+ hmatrix >=0.17.0.2 && <0.18,+ matrix ==0.3.*,+ sized >=0.2.1.0 && <0.3,+ vector >=0.10 && <0.12,+ convertible ==1.1.*,+ lens >=3.9 && <4.15,+ deepseq >=1.3 && <1.5,+ MonadRandom >=0.1 && <0.5+ hs-source-dirs: share examples+ ghc-options: -caf-all -auto-all -rtsopts -O2 -threaded++executable hensel-prof+ main-is: hensel-prof.hs+ buildable: False+ build-depends:+ criterion >=0.8.1.0 && <1.2,+ semigroups >=0.15.2 && <0.19,+ constraints >=0.3 && <0.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ type-natural >=0.7.1.2 && <0.8,+ computational-algebra >=0.4.0.0 && <0.5,+ random >=1.0 && <1.2,+ hmatrix >=0.17.0.2 && <0.18,+ matrix ==0.3.*,+ sized >=0.2.1.0 && <0.3,+ vector >=0.10 && <0.12,+ convertible ==1.1.*,+ lens >=3.9 && <4.15,+ deepseq >=1.3 && <1.5,+ MonadRandom >=0.1 && <0.5+ hs-source-dirs: share examples+ ghc-options: -caf-all -auto-all -rtsopts -O2 -threaded -eventlog++executable sandpit-poly+ main-is: sandpit-poly.hs+ buildable: False+ build-depends:+ semigroups >=0.15.2 && <0.19,+ constraints >=0.3 && <0.9,+ computational-algebra >=0.4.0.0 && <0.5,+ base >=4 && <4.10,+ type-natural >=0.7.1.2 && <0.8,+ algebra ==4.3.*,+ sized >=0.2.1.0 && <0.3+ hs-source-dirs: share examples++executable quotient+ main-is: quotient.hs+ buildable: False+ build-depends:+ semigroups >=0.15.2 && <0.19,+ constraints >=0.3 && <0.9,+ computational-algebra >=0.4.0.0 && <0.5,+ base >=4 && <4.10,+ type-natural >=0.7.1.2 && <0.8,+ algebra ==4.3.*,+ sized >=0.2.1.0 && <0.3,+ reflection >=2.1.2 && <2.2+ hs-source-dirs: share examples++test-suite test-multi-table+ type: exitcode-stdio-1.0+ main-is: multi-table.hs+ buildable: False+ build-depends:+ constraints >=0.3 && <0.9,+ HUnit >=1.2.5.2 && <1.4,+ QuickCheck >=2.6 && <2.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ hspec >=1.9.5 && <2.3,+ lazysmallcheck ==0.6.*,+ lens >=3.9 && <4.15,+ quickcheck-instances >=0.3.8 && <0.4,+ reflection >=1.4 && <2.2,+ sized >=0.2.1.0 && <0.3,+ smallcheck >=1.1.1 && <1.2,+ tagged >=0.7 && <0.9,+ test-framework >=0.8.0.3 && <0.9,+ test-framework-hunit >=0.3.0.1 && <0.4,+ transformers >=0.3 && <0.6,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ equational-reasoning >=0.2 && <0.5+ hs-source-dirs: tests share+ other-modules:+ Utils+ ghc-options: -Wall -threaded+test-suite singular-test+ type: exitcode-stdio-1.0+ main-is: SingularTest.hs+ buildable: False+ build-depends:+ algebra ==4.3.*,+ constraints >=0.3 && <0.9,+ HUnit >=1.3.1.2 && <1.4,+ MonadRandom >=0.1 && <0.5,+ QuickCheck >=2.6 && <2.9,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ deepseq >=1.3 && <1.5,+ hspec >=2.2.4 && <2.3,+ monomorphic >=0.0.3 && <0.1,+ smallcheck >=1.1.1 && <1.2,+ test-framework >=0.8.1.1 && <0.9,+ test-framework-hunit >=0.3.0.2 && <0.4,+ vector >=0.10 && <0.12,+ equational-reasoning >=0.2 && <0.5,+ quickcheck-instances >=0.3.8 && <0.4,+ type-natural >=0.7.1.2 && <0.8,+ sized >=0.2.1.0 && <0.3,+ reflection >=2.1.2 && <2.2,+ tagged >=0.8.5 && <0.9,+ lens ==4.14.*,+ matrix >=0.3.5.0 && <0.4,+ text >=1.2.2.1 && <1.3,+ singletons ==2.2.*+ hs-source-dirs: tests share+ other-modules:+ Utils+ SingularBridge+ ghc-options: -Wall -threaded+test-suite monomial-order-test+ type: exitcode-stdio-1.0+ main-is: monomials.hs+ buildable: False+ build-depends:+ constraints >=0.3 && <0.9,+ HUnit >=1.3.1.2 && <1.4,+ MonadRandom >=0.1 && <0.5,+ QuickCheck >=2.6 && <2.9,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ deepseq >=1.3 && <1.5,+ hspec >=2.2.4 && <2.3,+ monomorphic >=0.0.3 && <0.1,+ smallcheck >=1.1.1 && <1.2,+ test-framework >=0.8.1.1 && <0.9,+ test-framework-hunit >=0.3.0.2 && <0.4,+ vector >=0.10 && <0.12,+ equational-reasoning >=0.2 && <0.5,+ sized >=0.2.1.0 && <0.3+ hs-source-dirs: tests share+ other-modules:+ Utils+ ghc-options: -Wall -threaded+test-suite linear-test+ type: exitcode-stdio-1.0+ main-is: linear.hs+ build-depends:+ constraints >=0.3 && <0.9,+ HUnit >=1.3.1.2 && <1.4,+ MonadRandom >=0.1 && <0.5,+ QuickCheck >=2.6 && <2.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ deepseq >=1.3 && <1.5,+ hspec >=2.2.4 && <2.3,+ lens >=3.9 && <4.15,+ monomorphic >=0.0.3 && <0.1,+ quickcheck-instances >=0.3.12 && <0.4,+ reflection >=1.4 && <2.2,+ sized >=0.2.1.0 && <0.3,+ smallcheck >=1.1.1 && <1.2,+ tagged >=0.7 && <0.9,+ test-framework >=0.8.1.1 && <0.9,+ test-framework-hunit >=0.3.0.2 && <0.4,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ equational-reasoning >=0.2 && <0.5,+ matrix ==0.3.*+ hs-source-dirs: tests share+ other-modules:+ Utils+ ghc-options: -Wall -threaded+test-suite matrix-test+ type: exitcode-stdio-1.0+ main-is: matrix.hs+ buildable: False+ build-depends:+ constraints >=0.3 && <0.9,+ HUnit >=1.3.1.2 && <1.4,+ MonadRandom >=0.1 && <0.5,+ QuickCheck >=2.6 && <2.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ deepseq >=1.3 && <1.5,+ hspec >=2.2.4 && <2.3,+ lens >=3.9 && <4.15,+ monomorphic >=0.0.3 && <0.1,+ quickcheck-instances >=0.3.12 && <0.4,+ reflection >=1.4 && <2.2,+ sized >=0.2.1.0 && <0.3,+ smallcheck >=1.1.1 && <1.2,+ tagged >=0.7 && <0.9,+ test-framework >=0.8.1.1 && <0.9,+ test-framework-hunit >=0.3.0.2 && <0.4,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ matrix ==0.3.*,+ equational-reasoning >=0.2 && <0.5+ hs-source-dirs: tests share+ other-modules:+ Utils+ ghc-options: -Wall -threaded+test-suite specs+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-depends:+ constraints >=0.3 && <0.9,+ HUnit >=1.3.1.2 && <1.4,+ MonadRandom >=0.1 && <0.5,+ QuickCheck >=2.6 && <2.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ deepseq >=1.3 && <1.5,+ hspec >=2.2.4 && <2.3,+ lens >=3.9 && <4.15,+ monomorphic >=0.0.3 && <0.1,+ quickcheck-instances >=0.3.12 && <0.4,+ reflection >=1.4 && <2.2,+ sized >=0.2.1.0 && <0.3,+ smallcheck >=1.1.1 && <1.2,+ tagged >=0.7 && <0.9,+ test-framework >=0.8.1.1 && <0.9,+ test-framework-hunit >=0.3.0.2 && <0.4,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ convertible >=1.1.1.0 && <1.2,+ equational-reasoning >=0.2 && <0.5,+ process >=1.1 && <1.5,+ text >=0.11 && <1.3,+ singletons ==2.2.*,+ matrix ==0.3.*+ hs-source-dirs: tests share+ other-modules:+ Utils+ UnivariateSpec+ GroebnerSpec+ ZeroDimSpec+ QuotientSpec+ PolynomialSpec+ SingularBridge+ ghc-options: -Wall -threaded+test-suite new-div-test+ type: exitcode-stdio-1.0+ main-is: division.hs+ buildable: False+ build-depends:+ constraints >=0.3 && <0.9,+ HUnit >=1.3.1.2 && <1.4,+ MonadRandom >=0.1 && <0.5,+ QuickCheck >=2.6 && <2.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ deepseq >=1.3 && <1.5,+ hspec >=2.2.4 && <2.3,+ lens >=3.9 && <4.15,+ monomorphic >=0.0.3 && <0.1,+ quickcheck-instances >=0.3.12 && <0.4,+ reflection >=1.4 && <2.2,+ smallcheck >=1.1.1 && <1.2,+ tagged >=0.7 && <0.9,+ test-framework >=0.8.1.1 && <0.9,+ test-framework-hunit >=0.3.0.2 && <0.4,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ equational-reasoning >=0.2 && <0.5,+ matrix ==0.3.*+ hs-source-dirs: tests share+ other-modules:+ Utils+ ghc-options: -Wall -threaded++benchmark unipol-bench+ type: exitcode-stdio-1.0+ main-is: unipol-bench.hs+ build-depends:+ constraints >=0.3 && <0.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ criterion >=0.8.1.0 && <1.2,+ deepseq >=1.3 && <1.5,+ parallel ==3.2.*,+ process >=1.1 && <1.5,+ singletons ==2.2.*,+ sized >=0.2.1.0 && <0.3,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ matrix ==0.3.*+ hs-source-dirs: bench share+ ghc-options: -O2 -threaded -rtsopts+benchmark normal-bench+ type: exitcode-stdio-1.0+ main-is: bench.hs+ build-depends:+ constraints >=0.3 && <0.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ criterion >=0.8.1.0 && <1.2,+ deepseq >=1.3 && <1.5,+ parallel ==3.2.*,+ process >=1.1 && <1.5,+ singletons ==2.2.*,+ sized >=0.2.1.0 && <0.3,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ matrix ==0.3.*+ hs-source-dirs: bench share+ other-modules:+ SingularBench+ ghc-options: -O2 -threaded -rtsopts+benchmark elimination-bench+ type: exitcode-stdio-1.0+ main-is: elimination-bench.hs+ buildable: False+ build-depends:+ constraints >=0.3 && <0.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ criterion >=0.8.1.0 && <1.2,+ deepseq >=1.3 && <1.5,+ parallel ==3.2.*,+ process >=1.1 && <1.5,+ singletons ==2.2.*,+ sized >=0.2.1.0 && <0.3,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ matrix ==0.3.*+ hs-source-dirs: bench share+ other-modules:+ SingularBench+ ghc-options: -O2 -threaded -rtsopts+benchmark quotient-bench-randomized+ type: exitcode-stdio-1.0+ main-is: quotient-bench-randomized.hs+ build-depends:+ constraints >=0.3 && <0.9,+ QuickCheck >=2.6 && <2.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ criterion >=0.8.1.0 && <1.2,+ deepseq >=1.3 && <1.5,+ lens >=3.9 && <4.15,+ parallel ==3.2.*,+ process >=1.1 && <1.5,+ quickcheck-instances >=0.3.12 && <0.4,+ reflection >=1.4 && <2.2,+ singletons ==2.2.*,+ smallcheck >=1.1.1 && <1.2,+ sized >=0.2.1.0 && <0.3,+ tagged >=0.7 && <0.9,+ transformers >=0.3 && <0.6,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ matrix ==0.3.*,+ equational-reasoning >=0.2 && <0.5,+ monomorphic >=0.0.3 && <0.1+ hs-source-dirs: bench share+ other-modules:+ SingularBench+ Utils+ ghc-options: -O2 -threaded -rtsopts+benchmark monomial-order-bench+ type: exitcode-stdio-1.0+ main-is: monomials.hs+ buildable: False+ build-depends:+ constraints >=0.3 && <0.9,+ QuickCheck >=2.6 && <2.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ criterion >=0.8.1.0 && <1.2,+ deepseq >=1.3 && <1.5,+ lens >=3.9 && <4.15,+ monomorphic >=0.0.3 && <0.1,+ parallel ==3.2.*,+ process >=1.1 && <1.5,+ quickcheck-instances >=0.3.12 && <0.4,+ random >=1.0 && <1.2,+ reflection >=1.4 && <2.2,+ singletons ==2.2.*,+ sized >=0.2.1.0 && <0.3,+ smallcheck >=1.1.1 && <1.2,+ tagged >=0.7 && <0.9,+ transformers >=0.3 && <0.6,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ matrix ==0.3.*+ hs-source-dirs: bench share+ other-modules:+ SingularBench+ Utils+ ghc-options: -O2 -threaded -rtsopts+benchmark linear-bench+ type: exitcode-stdio-1.0+ main-is: linear.hs+ buildable: False+ build-depends:+ constraints >=0.3 && <0.9,+ HUnit >=1.3.1.2 && <1.4,+ MonadRandom >=0.1 && <0.5,+ QuickCheck >=2.6 && <2.9,+ algebra ==4.3.*,+ sized >=0.2.1.0 && <0.3,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ criterion >=0.8.1.0 && <1.2,+ deepseq >=1.3 && <1.5,+ hspec >=2.2.4 && <2.3,+ lens >=3.9 && <4.15,+ monomorphic >=0.0.3 && <0.1,+ parallel ==3.2.*,+ process >=1.1 && <1.5,+ quickcheck-instances >=0.3.12 && <0.4,+ reflection >=1.4 && <2.2,+ smallcheck >=1.1.1 && <1.2,+ tagged >=0.7 && <0.9,+ test-framework >=0.8.1.1 && <0.9,+ test-framework-hunit >=0.3.0.2 && <0.4,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ equational-reasoning >=0.2 && <0.5,+ matrix ==0.3.*,+ monomorphic >=0.0.3 && <0.1+ hs-source-dirs: bench share+ other-modules:+ Utils+ ghc-options: -O2 -threaded -rtsopts+benchmark division-bench+ type: exitcode-stdio-1.0+ main-is: division.hs+ buildable: False+ build-depends:+ constraints >=0.3 && <0.9,+ HUnit >=1.3.1.2 && <1.4,+ MonadRandom >=0.1 && <0.5,+ QuickCheck >=2.6 && <2.9,+ algebra ==4.3.*,+ sized >=0.2.1.0 && <0.3,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ criterion >=0.8.1.0 && <1.2,+ deepseq >=1.3 && <1.5,+ hspec >=2.2.4 && <2.3,+ lens >=3.9 && <4.15,+ monomorphic >=0.0.3 && <0.1,+ parallel ==3.2.*,+ process >=1.1 && <1.5,+ quickcheck-instances >=0.3.12 && <0.4,+ reflection >=1.4 && <2.2,+ smallcheck >=1.1.1 && <1.2,+ tagged >=0.7 && <0.9,+ test-framework >=0.8.1.1 && <0.9,+ test-framework-hunit >=0.3.0.2 && <0.4,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ equational-reasoning >=0.2 && <0.5,+ matrix ==0.3.*,+ monomorphic >=0.0.3 && <0.1+ hs-source-dirs: bench share+ other-modules:+ Utils+ ghc-options: -O2 -threaded -rtsopts+benchmark sugar-paper-bench+ type: exitcode-stdio-1.0+ main-is: sugar-paper.hs+ build-depends:+ constraints >=0.3 && <0.9,+ HUnit >=1.3.1.2 && <1.4,+ sized >=0.2.1.0 && <0.3,+ MonadRandom >=0.1 && <0.5,+ QuickCheck >=2.6 && <2.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ criterion >=0.8.1.0 && <1.2,+ deepseq >=1.3 && <1.5,+ hspec >=2.2.4 && <2.3,+ lens >=3.9 && <4.15,+ monomorphic >=0.0.3 && <0.1,+ parallel ==3.2.*,+ process >=1.1 && <1.5,+ quickcheck-instances >=0.3.12 && <0.4,+ reflection >=1.4 && <2.2,+ smallcheck >=1.1.1 && <1.2,+ tagged >=0.7 && <0.9,+ test-framework >=0.8.1.1 && <0.9,+ test-framework-hunit >=0.3.0.2 && <0.4,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ equational-reasoning >=0.2 && <0.5,+ matrix ==0.3.*,+ monomorphic >=0.0.3 && <0.1+ hs-source-dirs: bench share+ other-modules:+ Utils+ ghc-options: -O2 -threaded -rtsopts+benchmark solve-bench+ type: exitcode-stdio-1.0+ main-is: solve.hs+ build-depends:+ constraints >=0.3 && <0.9,+ HUnit >=1.3.1.2 && <1.4,+ sized >=0.2.1.0 && <0.3,+ MonadRandom >=0.1 && <0.5,+ QuickCheck >=2.6 && <2.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ criterion >=0.8.1.0 && <1.2,+ deepseq >=1.3 && <1.5,+ hspec >=2.2.4 && <2.3,+ lens >=3.9 && <4.15,+ monomorphic >=0.0.3 && <0.1,+ parallel ==3.2.*,+ process >=1.1 && <1.5,+ quickcheck-instances >=0.3.12 && <0.4,+ reflection >=1.4 && <2.2,+ smallcheck >=1.1.1 && <1.2,+ tagged >=0.7 && <0.9,+ test-framework >=0.8.1.1 && <0.9,+ test-framework-hunit >=0.3.0.2 && <0.4,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ random >=1.0 && <1.2,+ equational-reasoning >=0.2 && <0.5,+ matrix ==0.3.*+ hs-source-dirs: bench share+ other-modules:+ Utils+ ghc-options: -O2 -threaded -rtsopts+benchmark coercion-bench+ type: exitcode-stdio-1.0+ main-is: coercion.hs+ buildable: False+ build-depends:+ constraints >=0.3 && <0.9,+ HUnit >=1.3.1.2 && <1.4,+ sized >=0.2.1.0 && <0.3,+ MonadRandom >=0.1 && <0.5,+ QuickCheck >=2.6 && <2.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ criterion >=0.8.1.0 && <1.2,+ deepseq >=1.3 && <1.5,+ hspec >=2.2.4 && <2.3,+ lens >=3.9 && <4.15,+ monomorphic >=0.0.3 && <0.1,+ parallel ==3.2.*,+ process >=1.1 && <1.5,+ quickcheck-instances >=0.3.12 && <0.4,+ reflection >=1.4 && <2.2,+ smallcheck >=1.1.1 && <1.2,+ tagged >=0.7 && <0.9,+ test-framework >=0.8.1.1 && <0.9,+ test-framework-hunit >=0.3.0.2 && <0.4,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ random >=1.0 && <1.2,+ equational-reasoning >=0.2 && <0.5,+ matrix ==0.3.*+ hs-source-dirs: bench share+ other-modules:+ Utils+ ghc-options: -Wall -O2 -threaded -rtsopts+benchmark faugere4-bench+ type: exitcode-stdio-1.0+ main-is: faugere4.hs+ build-depends:+ constraints >=0.3 && <0.9,+ HUnit >=1.3.1.2 && <1.4,+ sized >=0.2.1.0 && <0.3,+ QuickCheck >=2.6 && <2.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ criterion >=0.8.1.0 && <1.2,+ deepseq >=1.3 && <1.5,+ hspec >=2.2.4 && <2.3,+ lens >=3.9 && <4.15,+ monomorphic >=0.0.3 && <0.1,+ parallel ==3.2.*,+ process >=1.1 && <1.5,+ quickcheck-instances >=0.3.12 && <0.4,+ reflection >=1.4 && <2.2,+ smallcheck >=1.1.1 && <1.2,+ tagged >=0.7 && <0.9,+ test-framework >=0.8.1.1 && <0.9,+ test-framework-hunit >=0.3.0.2 && <0.4,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ random >=1.0 && <1.2,+ equational-reasoning >=0.2 && <0.5,+ matrix ==0.3.*+ hs-source-dirs: bench share+ other-modules:+ Utils+ ghc-options: -Wall -O2 -threaded -rtsopts+benchmark unipol-mult-bench+ type: exitcode-stdio-1.0+ main-is: unipol-mult.hs+ build-depends:+ constraints >=0.3 && <0.9,+ HUnit >=1.3.1.2 && <1.4,+ sized >=0.2.1.0 && <0.3,+ QuickCheck >=2.6 && <2.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ criterion >=0.8.1.0 && <1.2,+ deepseq >=1.3 && <1.5,+ hspec >=2.2.4 && <2.3,+ lens >=3.9 && <4.15,+ monomorphic >=0.0.3 && <0.1,+ parallel ==3.2.*,+ process >=1.1 && <1.5,+ quickcheck-instances >=0.3.12 && <0.4,+ reflection >=1.4 && <2.2,+ smallcheck >=1.1.1 && <1.2,+ tagged >=0.7 && <0.9,+ test-framework >=0.8.1.1 && <0.9,+ test-framework-hunit >=0.3.0.2 && <0.4,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ random >=1.0 && <1.2,+ equational-reasoning >=0.2 && <0.5,+ matrix ==0.3.*+ hs-source-dirs: bench share+ other-modules:+ Utils+ ghc-options: -Wall -O2 -threaded -rtsopts+benchmark unipol-div-bench+ type: exitcode-stdio-1.0+ main-is: unipol-div.hs+ build-depends:+ constraints >=0.3 && <0.9,+ HUnit >=1.3.1.2 && <1.4,+ sized >=0.2.1.0 && <0.3,+ QuickCheck >=2.6 && <2.9,+ algebra ==4.3.*,+ base >=4 && <4.10,+ computational-algebra >=0.4.0.0 && <0.5,+ containers ==0.5.*,+ criterion >=0.8.1.0 && <1.2,+ deepseq >=1.3 && <1.5,+ hspec >=2.2.4 && <2.3,+ lens >=3.9 && <4.15,+ monomorphic >=0.0.3 && <0.1,+ parallel ==3.2.*,+ process >=1.1 && <1.5,+ quickcheck-instances >=0.3.12 && <0.4,+ reflection >=1.4 && <2.2,+ smallcheck >=1.1.1 && <1.2,+ tagged >=0.7 && <0.9,+ test-framework >=0.8.1.1 && <0.9,+ test-framework-hunit >=0.3.0.2 && <0.4,+ type-natural >=0.7.1.2 && <0.8,+ vector >=0.10 && <0.12,+ random >=1.0 && <1.2,+ equational-reasoning >=0.2 && <0.5,+ matrix ==0.3.*+ hs-source-dirs: bench share+ other-modules:+ Utils+ ghc-options: -Wall -O2 -threaded -rtsopts
+ data/conway.txt view
@@ -0,0 +1,52 @@+allConwayPolynomials := [+[2,1,[1,1]],+[2,2,[1,1,1]],+[2,3,[1,1,0,1]],+[2,4,[1,1,0,0,1]],+[2,5,[1,0,1,0,0,1]],+[2,6,[1,1,0,1,1,0,1]],+[2,7,[1,1,0,0,0,0,0,1]],+[2,8,[1,0,1,1,1,0,0,0,1]],+[2,9,[1,0,0,0,1,0,0,0,0,1]],+[2,10,[1,1,1,1,0,1,1,0,0,0,1]],+[3,1,[1,1]],+[3,2,[2,2,1]],+[3,3,[1,2,0,1]],+[3,4,[2,0,0,2,1]],+[3,5,[1,2,0,0,0,1]],+[3,6,[2,2,1,0,2,0,1]],+[3,7,[1,0,2,0,0,0,0,1]],+[3,8,[2,2,2,0,1,2,0,0,1]],+[3,9,[1,1,2,2,0,0,0,0,0,1]],+[3,10,[2,1,0,0,2,2,2,0,0,0,1]],+[5,1,[3,1]],+[5,2,[2,4,1]],+[5,3,[3,3,0,1]],+[5,4,[2,4,4,0,1]],+[5,5,[3,4,0,0,0,1]],+[5,6,[2,0,1,4,1,0,1]],+[5,7,[3,3,0,0,0,0,0,1]],+[5,8,[2,4,3,0,1,0,0,0,1]],+[5,9,[3,1,0,2,0,0,0,0,0,1]],+[5,10,[2,1,4,2,3,3,0,0,0,0,1]],+[7,1,[4,1]],+[7,2,[3,6,1]],+[7,3,[4,0,6,1]],+[7,4,[3,4,5,0,1]],+[7,5,[4,1,0,0,0,1]],+[7,6,[3,6,4,5,1,0,1]],+[7,7,[4,6,0,0,0,0,0,1]],+[7,8,[3,2,6,4,0,0,0,0,1]],+[7,9,[4,6,0,1,6,0,0,0,0,1]],+[7,10,[3,3,2,1,4,1,1,0,0,0,1]],+[11,1,[9,1]],+[11,2,[2,7,1]],+[11,3,[9,2,0,1]],+[11,4,[2,10,8,0,1]],+[11,5,[9,0,10,0,0,1]],+[11,6,[2,7,6,4,3,0,1]],+[11,7,[9,4,0,0,0,0,0,1]],+[11,8,[2,7,1,7,7,0,0,0,1]],+[11,9,[9,8,9,0,0,0,0,0,0,1]],+[11,10,[2,6,6,10,8,7,0,0,0,0,1]],+0];
+ examples/algebraic.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE DataKinds, NoImplicitPrelude, OverloadedLabels #-}+module Main where+import Algebra.Field.AlgebraicReal+import Algebra.Prelude+import Algebra.Ring.Polynomial.Univariate++f :: Unipol Rational+f = 8 - 16 * #x + 12* #x^2 - 4* #x^3 + #x^4++main :: IO ()+main = do+ print f+ print $ complexRoots f
− examples/bench.hs
@@ -1,99 +0,0 @@-{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}-{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings, PolyKinds #-}-{-# LANGUAGE QuasiQuotes, TemplateHaskell, UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}-import Algebra.Algorithms.Groebner.Monomorphic-import Algebra.Ring.Polynomial.Monomorphic-import Control.DeepSeq-import Control.Parallel.Strategies-import Criterion.Main-import SingularBench--x, y, z, w, s, a, b, c :: Polynomial Rational-[x, y, z, w, s, a, b, c] = map (injectVar . flip Variable Nothing) "xyzwSabc"--instance NFData Variable where- rnf (Variable x y) = rnf x `seq` rnf y `seq` ()--instance NFData (Polynomial Rational) where- rnf (Polynomial dic) = rnf dic--i1, i2, i3, i4 :: [Polynomial Rational]-i1 = [x^2 + y^2 + z^2 - 1, x^2 + y^2 + z^2 - 2*x, 2*x -3*y - z]-i2 = [x^2 * y - 2*x*y - 4*z - 1, z-y^2, x^3 - 4*z*y]-i3 = [ 2 * s - a * y, b^2 - (x^2 + y^2), c^2 - ( (a-x) ^ 2 + y^2)- ]-i4 = [ z^5 + y^4 + x^3 - 1, z^3 + y^3 + x^2 - 1]--main :: IO ()-main = do- ideal1 <- return $! (i1 `using` rdeepseq)- ideal2 <- return $! (i2 `using` rdeepseq)- ideal3 <- return $! (i3 `using` rdeepseq)- ideal4 <- return $! (i4 `using` rdeepseq)- defaultMain $ [bgroup "lex01"- [ bench "simple" $ nf (simpleBuchbergerWith Lex) ideal1- , bench "relprime" $ nf (primeTestBuchbergerWith Lex) ideal1- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Lex) ideal1- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Lex) ideal1- ]- ,bgroup "grlex01"- [ bench "simple" $ nf (simpleBuchbergerWith Grlex) ideal1- , bench "relprime" $ nf (primeTestBuchbergerWith Grlex) ideal1- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grlex) ideal1- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grlex) ideal1- ]- ,bgroup "grevlex01"- [ bench "simple" $ nf (simpleBuchbergerWith Grevlex) ideal1- , bench "relprime" $ nf (primeTestBuchbergerWith Grevlex) ideal1- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grevlex) ideal1- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grevlex) ideal1- ]- ,bgroup "grlex02"- [ bench "simple" $ nf (simpleBuchbergerWith Grlex) ideal2- , bench "relprime" $ nf (primeTestBuchbergerWith Grlex) ideal2- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grlex) ideal2- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grlex) ideal2- ]- ,bgroup "grevlex02"- [ bench "simple" $ nf (simpleBuchbergerWith Grevlex) ideal2- , bench "relprime" $ nf (primeTestBuchbergerWith Grevlex) ideal2- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grevlex) ideal2- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grevlex) ideal2- -- , bench "singular" $ nfIO (singularWith Grevlex ideal2)- ]- ,bgroup "lex03"- [ bench "simple" $ nf (simpleBuchbergerWith Lex) ideal3- , bench "relprime" $ nf (primeTestBuchbergerWith Lex) ideal3- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Lex) ideal3- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Lex) ideal3- -- , bench "singular" $ nfIO (singularWith Lex ideal3)- ]- ,bgroup "grlex03"- [ bench "simple" $ nf (simpleBuchbergerWith Grlex) ideal3- , bench "relprime" $ nf (primeTestBuchbergerWith Grlex) ideal3- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grlex) ideal3- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grlex) ideal3- -- , bench "singular" $ nfIO (singularWith Grlex ideal3)- ]- ,bgroup "grevlex03"- [ bench "simple" $ nf (simpleBuchbergerWith Grevlex) ideal3- , bench "relprime" $ nf (primeTestBuchbergerWith Grevlex) ideal3- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grevlex) ideal3- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grevlex) ideal3- ]- ,bgroup "grlex04"- [ bench "simple" $ nf (simpleBuchbergerWith Grlex) ideal4- , bench "relprime" $ nf (primeTestBuchbergerWith Grlex) ideal4- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grlex) ideal4- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grlex) ideal4- -- , bench "singular" $ nfIO (singularWith Grlex ideal4)- ]- ,bgroup "grevlex04"- [ bench "simple" $ nf (simpleBuchbergerWith Grevlex) ideal4- , bench "relprime" $ nf (primeTestBuchbergerWith Grevlex) ideal4- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grevlex) ideal4- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grevlex) ideal4- -- , bench "singular" $ nfIO (singularWith Grevlex ideal4)- ]- ]
− examples/elimination-bench.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings, PolyKinds #-}-{-# LANGUAGE TemplateHaskell, UndecidableInstances #-}-import Algebra.Algorithms.Groebner.Monomorphic-import Algebra.Internal-import Algebra.Ring.Polynomial (eliminationOrder, weightedEliminationOrder)-import Algebra.Ring.Polynomial.Monomorphic-import Control.DeepSeq-import Control.Parallel.Strategies-import Criterion.Main-import Criterion.Types-import Numeric.Algebra (LeftModule (..))-import qualified Numeric.Algebra as NA--x, y, z, w, s, a, b, c, t, u, v :: Polynomial Rational-[x, y, z, w, s, a, b, c, t, u, v, x', y'] = map (injectVar . flip Variable Nothing) "xyzwsabctuvXY"--instance NFData Variable where- rnf (Variable x y) = rnf x `seq` rnf y `seq` ()--instance NFData (Polynomial Rational) where- rnf (Polynomial dic) = rnf dic--i1, i2, i3, i4 :: [Polynomial Rational]-i1 = [x - (t + u), y - (t^2 + 2*t*u), z - (t^3 + 3*t^2*u)]-i2 = [t^2 + x^2+y^2+z^2, t^2 + 2*x^2 - x*y -z^2, t+ y^3-z^3]-i3 = [ 2 * s - a * y', b^2 - (x'^2 + y'^2), c^2 - ( (a-x') ^ 2 + y'^2)- ]-i4 = [ x - (3*u + 3*u*v^2 - u^3), y - (3*v + 3*u^2*v - v^3), z - (3*u^2 - 3*v^2)]--mkTestCase :: Sing n => String -> [Polynomial Rational] -> SNat n -> Benchmark-mkTestCase name ideal nth =- bgroup name [ bench "lex" $ nf (calcGroebnerBasisWith Lex) ideal- , bench "product" $ nf (calcGroebnerBasisWith (eliminationOrder nth)) ideal- , bench "weight" $ nf (calcGroebnerBasisWith (weightedEliminationOrder nth)) ideal- ]--main :: IO ()-main = do- ideal1 <- return $! (i1 `using` rdeepseq)- ideal2 <- return $! (i2 `using` rdeepseq)- ideal3 <- return $! (i3 `using` rdeepseq)- ideal4 <- return $! (i4 `using` rdeepseq)- [var_x, var_y, var_t] <- return $! (map (flip Variable Nothing) "xyt" `using` rdeepseq)- defaultMain $ [ mkTestCase "heron" ideal3 sTwo- , mkTestCase "implicit01" ideal2 sOne- , mkTestCase "implicit03" ideal1 sTwo- , mkTestCase "implicit04" ideal4 sTwo- ]-
+ examples/faugere-prof.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE DataKinds, NoImplicitPrelude #-}+module Main where+import Algebra.Algorithms.Faugere4+import Algebra.Prelude+import Control.DeepSeq++main :: IO ()+main = faugere4Modular optimalStrategy ideal3 `deepseq` return ()++ideal3 :: Ideal (Polynomial (Fraction Integer) 3)+ideal3 = toIdeal [2*x^2*y^5*z^5 - 5%3*x^3*y*z^7 - 3*x^2*z^8,4%3*x*y^3*z^4 - x*y,-3*x^4*y^2*z]+ where+ [x,y,z] = vars
+ examples/groebner-prof.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE DataKinds, NoImplicitPrelude #-}+module Main where+import Algebra.Algorithms.Groebner+import Algebra.Prelude+import Control.DeepSeq++i :: Ideal (Polynomial Rational 5)+i = toIdeal+ [35 * y^4 - 30*x*y^2 - 210*y^2*z + 3*x^2 + 30*x*z - 105*z^2 +140*y*t - 21*u+ ,5*x*y^3 - 140*y^3*z - 3*x^2*y + 45*x*y*z - 420*y*z^2 + 210*y^2*t -25*x*t + 70*z*t + 126*y*u+ ]+ where [t,u,x,y,z] = vars+++main :: IO ()+main = calcGroebnerBasis i `deepseq` return ()
+ examples/hensel-prof.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DataKinds #-}+module Main where+import Algebra.Algorithms.Faugere4+import Algebra.LinkedMatrix+import Algebra.Prelude+import Control.Exception (evaluate)++main :: IO ()+main = do+ _ <- evaluate $ faugere4Modular optimalStrategy (cyclic (sing :: SNat 4))+ return ()++testCase :: Matrix (Fraction Integer)+testCase = fromLists [[0,0,0,0,0,0,0,0,0,1,1,1,1,0,0,0,1,0,0]+ ,[0,0,0,0,0,0,1,1,1,0,0,1,0,0,0,1,0,0,0]+ ,[0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,0]+ ,[0,0,0,0,0,1,0,0,0,0,1,-1,0,-1,1,0,-1,0,0]+ ,[0,0,0,0,1,1,0,1,0,0,1,0,0,0,1,0,0,0,0]+ ,[1,1,0,1,0,0,1,0,0,0,0,1,0,0,0,0,0,0,0]+ ,[1,0,1,0,1,0,0,0,0,1,0,1,0,0,0,0,0,0,0]+ ]
+ examples/ipsolve.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE BangPatterns, CPP, DataKinds, ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses, NoImplicitPrelude, RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Main where+import Algebra.Algorithms.Groebner+import Algebra.Instances ()+import Algebra.Prelude+import Control.Applicative ((<$>))+import Control.Lens (ix, makeLenses, view, (&), (.~))+import Data.Reflection+import Data.Singletons.Prelude (SList)+import Data.Singletons.Prelude.List+import qualified Data.Sized.Builtin as V++newtype IsOrder_ n = IsOrder_ { cmp :: Monomial n -> Monomial n -> Ordering }+data ReifiedOrder a = ReifiedOrder++retrieveOrder :: Proxy (ReifiedOrder a) -> Proxy a+retrieveOrder Proxy = Proxy++instance Reifies a (IsOrder_ n) => IsOrder n (ReifiedOrder a) where+ cmpMonomial pxy = cmp $ reflect (retrieveOrder pxy)++instance Reifies a (IsOrder_ n) => IsMonomialOrder n (ReifiedOrder a)++type IPOrder n vs = ProductOrder n (1 + Length vs)+ Grevlex+ (ProductOrder 1 (Length vs) Grevlex (WeightOrder vs Grevlex))+ipOrder :: SNat n -> SList vs -> IPOrder n vs+ipOrder n vs =+ ProductOrder n (sOne %:+ sLength vs)+ Grevlex+ (ProductOrder sOne (sLength vs) Grevlex (WeightOrder vs Proxy))++toMonomial :: forall k n ord .+ (KnownNat n, IsMonomialOrder (n + 1 + k) ord)+ => Sing k -> Monomial n -> OrderedPolynomial (Fraction Integer) ord (S n :+ k)+toMonomial k ds =+ withKnownNat k $+ withKnownNat (sSucc (sing :: SNat n) %:+ k) $+ let !c = foldl' (\a b -> if b < 0 then a + abs b else a) 0 ds+ in toPolynomial' (1,+ -- coerce (symmetry $ sAndPlusOne (V.sLength ds)) $+ V.map (+c) ds `V.append` V.singleton c `V.append` V.replicate' 0)++calcCost :: Sized' n Int -> Sized' m Int -> Int+calcCost ns ms = sum $ V.zipWith (*) ns ms++costCmp :: Sing m -> Sized' n Int -> Monomial m -> Monomial m -> Ordering+costCmp _ cost ns ms =+ comparing (calcCost cost) ns ms <> grevlex ns ms++toReifiedOrder :: Proxy m -> ReifiedOrder m+toReifiedOrder Proxy = ReifiedOrder++-- | Solve integer programming problem with general signature.+solveIP' :: forall n m . (KnownNat n, KnownNat m)+ => Sized' n Int -- ^ cost vector+ -> Sized' m (Sized' n Int) -- ^ constraint matrix+ -> Sized' m Int -- ^ constraint+ -> Maybe (Sized' n Int) -- ^ answer+solveIP' c mat b =+ let n = sing :: SNat n+ m = sing :: SNat m+ vlen = sSucc m %:+ n+ in withKnownNat (sSucc m) $+ reify (IsOrder_ $ costCmp n c) $ \pxy ->+ withWitness (plusLeqL (sSucc m) n) $+ withKnownNat vlen $+ let ord = ProductOrder (sSucc m) n Grevlex (toReifiedOrder pxy)+ !b' = toMonomial n b+ as = map (toMonomial n) $+ V.toList $ sequenceA mat+ (xsw, ys) = splitAt (sNatToInt m+1) (vars' ord vlen)+ gs = calcGroebnerBasis $ toIdeal $ product xsw - one : zipWith (-) ys as+ ans = b' `modPolynomial` gs+ (cond, solution) = V.splitAt (sSucc m) $ getMonomial $ leadingMonomial ans+ in if all (== 0) cond+ then Just $ coerceLength (plusMinus' (sSucc m) n) solution+ else Nothing++vars' :: IsPolynomial poly => (MOrder poly) -> SNat (Arity poly) -> [poly]+vars' _ _ = vars++data Cnstr n = (:<=) { _lhs :: Sized' n Int, _rhs :: Int }+ | (:>=) { _lhs :: Sized' n Int, _rhs :: Int }+ | (:==) { _lhs :: Sized' n Int, _rhs :: Int }+ deriving (Show, Eq, Ord)++infix 4 :<=, :>=, :==++data IPProblem n m = IPProblem { objectCnstr :: Sized' n Int+ , cnstrs :: Sized' m (Cnstr n)+ } deriving (Show, Eq)+makeLenses ''Cnstr++solveCnstrs :: forall n m. (KnownNat m, KnownNat n) => IPProblem n m -> Maybe (Sized' n Int)+solveCnstrs ipp =+ let sn = sing :: SNat n+ sm = sing :: SNat m+ (obj, mat, vec) = extractProblem $ nfProblem ipp+ in withWitness (plusLeqL sn sm) $+ withKnownNat (sn %:+ sm) $+ V.take (sing :: SNat n) <$> solveIP' obj mat vec++extractProblem :: IPProblem n m -> (Sized' n Int, Sized' m (Sized' n Int), Sized' m Int)+extractProblem (IPProblem obj css) = (obj, V.map (view lhs) css, V.map (view rhs) css)++nfProblem :: forall n m . KnownNat m => IPProblem n m -> IPProblem (n :+ m) m+nfProblem (IPProblem obj css) =+ IPProblem (obj `V.append` V.replicate (sing :: SNat m) 0)+ (nfCnstrs css)++ordVec :: SNat n -> Sized' n (V.Ordinal n)+ordVec n = generate n id++nfCnstrs :: forall n m. (KnownNat m)+ => Sized' m (Cnstr n) -> Sized' m (Cnstr (n :+ m))+nfCnstrs css = V.zipWithSame conv css (ordVec (sing :: SNat m))+ where+ conv (lh :<= r) nth = (lh `V.append` (V.replicate (sing :: SNat m) 0 & ix nth .~ 1)) :== r+ conv (lh :>= r) nth = (lh `V.append` (V.replicate (sing :: SNat m) 0 & ix nth .~ -1)) :== r+ conv (lh :== r) _ = (lh `V.append` V.replicate (sing :: SNat m) 0) :== r++testC :: Sized' 4 Int+testM :: Sized' 2 (Sized' 4 Int)+testB :: Sized' 2 Int+(testC, testM, testB) =+ (1000 :< 1 :< 1 :< 100 :< NilL,+ (3 :< -2 :< 1 :< -1 :< NilL) :< (4 :< 1 :< -1 :< 0 :< NilL) :< NilL,+ -1 :< 5 :< NilL)++data Rect = Rect { _height :: Int, _width :: Int+ } deriving (Read, Show, Eq, Ord)+makeLenses ''Rect++data Design = Design { _frame :: Rect+ , _pictures :: [Rect]+ } deriving (Read, Show, Eq, Ord)+makeLenses ''Design++data Department = Department { _area :: Int+ , _aspect :: Int+ , _maxSide :: Int+ , _minSide :: Int+ } deriving (Read, Show, Eq, Ord)++data SomeIPProblem = forall n m. SomeIPProblem (IPProblem n m)++designConstraint :: Design -> SomeIPProblem+designConstraint = undefined++main :: IO ()+main = act++act :: IO ()+act = print $ solveIP' testC testM testB
examples/monomorphic.hs view
@@ -7,9 +7,9 @@ import Algebra.Ring.Polynomial.Parser import Data.Either import Data.List (intercalate)-import Data.Ratio import qualified Data.Text as T import Numeric.Algebra+import Numeric.Field.Fraction import Prelude hiding (Fractional (..), Integral (..), (*),
− examples/poly-02.hs
@@ -1,12 +0,0 @@-{-# LANGUAGE DataKinds, OverloadedStrings, PolyKinds #-}-module Main where-import Algebra.Algorithms.Groebner-import Algebra.Internal-import Algebra.Ring.Noetherian-import Algebra.Ring.Polynomial--x, y :: OrderedPolynomial Rational Lex Two-[x, y] = genVars sTwo--main :: IO ()-main = print $ reduceMinimalGroebnerBasis $ minimizeGroebnerBasis $ simpleBuchberger $ toIdeal [x^2*y-1,x^3-y^2-x]
examples/polymorphic.hs view
@@ -1,47 +1,49 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}-{-# LANGUAGE ConstraintKinds, NoImplicitPrelude, TypeOperators #-}+{-# LANGUAGE ConstraintKinds, DataKinds, NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLabels, TypeOperators #-} module Example where import Algebra.Algorithms.Groebner-import Algebra.Internal-import Algebra.Ring.Noetherian-import Algebra.Ring.Polynomial-import Data.Ratio-import Data.Type.Natural hiding (one, zero)-import Numeric.Algebra-import Prelude hiding (Fractional (..), Integral (..),- Num (..), (^), (^^))+import Algebra.Prelude+import Algebra.Ring.Polynomial.Labeled 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+x, y, f, f1, f2 :: Polynomial (Ratio Integer) 2+x = var 0+y = var 1+f = x^2 * y + x * y^2 + y^2 f1 = x * y - 1-f2 = y^^2 - 1+f2 = y^2 - 1 type LexPolynomial r n = OrderedPolynomial r Lex n+type XYABCS = (LabPolynomial (Polynomial (Ratio Integer) 6) '["x", "y", "a", "b", "c", "S"])+type ABCS = (LabPolynomial (Polynomial (Ratio Integer) 4) '["a", "b", "c", "S"]) -heronIdeal :: Ideal (Polynomial (Ratio Integer) (Three :+: Three))-heronIdeal = toIdeal [ 2 * s - a * y- , b^^2 - (x^^2 + y^^2)- , c^^2 - ( (a-x) ^^ 2 + y^^2)+s :: ABCS+s = var 3++heronIdeal :: Ideal XYABCS+heronIdeal = toIdeal [ 2 * s - #a * #y+ , #b^2 - (#x^2 + #y^2)+ , #c^2 - ( (#a - #x) ^ 2 + #y^2) ] where- [x, y, a, b, c, s] = genVars (sThree %+ sThree)+ s = last vars+ -- Due to the current limitation of @OverloadedLabels@ extension,+ -- we cannot use label starting with a CAPITAL LETTER.+ -- so we have to do this. main :: IO () main = do putStrLn $ unwords ["(" ++ show (x + 1) ++ ")^2", "="- , 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 $ 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:"@@ -53,15 +55,22 @@ 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 $ sTwo `thEliminationIdeal` heronIdeal- putStrLn "In equation above, X_1, X_2, X_3 and X_4 stands for a, b, c and S, respectively."+ print $ toABCSIdeal (sTwo `thEliminationIdeal` heronIdeal) 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." putStrLn ""- putStrLn "Let's use nother elimination type. We choose Grevlex × Grevlex: "- print $ thEliminationIdealWith (eliminationOrder sTwo) sTwo heronIdeal+ putStrLn "Let's use nother elimination type. We choose Grevlex x Grevlex: "+ print $ toABCSIdeal $+ thEliminationIdealWith (eliminationOrder sTwo sFour) sTwo heronIdeal putStrLn "And weighted order:"- print $ thEliminationIdealWith (weightedEliminationOrder sTwo) sTwo heronIdeal+ print $ toABCSIdeal $+ thEliminationIdealWith (weightedEliminationOrder sTwo) sTwo heronIdeal +toABCSIdeal :: Ideal (OrderedPolynomial (Fraction Integer) Grevlex (6 :-. 2)) -> Ideal (LabPolynomial (Polynomial (Ratio Integer) 4) '["a", "b", "c", "S"])+toABCSIdeal = mapIdeal (flip asTypeOf s . injectVars) +sFour :: SNat 4+sFour = sing +sTwo :: SNat 2+sTwo = sing
+ examples/quotient.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DataKinds, FlexibleContexts, NoImplicitPrelude #-}+{-# LANGUAGE NoMonomorphismRestriction, PolyKinds #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+module Main ( module Algebra.Algorithms.Groebner+ , module Main+ ) where+import Algebra.Algorithms.Groebner+import Algebra.Prelude hiding ((/))+import Algebra.Ring.Polynomial.Quotient+import Numeric.Field.Fraction as F++default (Integer)++x, y :: Polynomial (Fraction Integer) 2+[x, y] = vars++(/) :: Integer -> Integer -> (Fraction Integer)+p / q = p F.% q+++fromRight :: Either t t1 -> t1+fromRight (Right a) = a+fromRight _ = error "fromRight"++main :: IO ()+main = do+ let f = y^4 * x+ 3*x^3 - y^4 -3*x^2+ g = x^2*y-2*x^2+ h = 2*y^4*x - x^3 - 2*y^4 +x^2+ ideal = toIdeal [f, g, h]+ r = reifyQuotient ideal $ \ii ->+ let Just bs = standardMonomials' ii+ tbl = [ [p*q | q <- bs] | p <- bs]+ in (map quotRepr bs, map (map quotRepr) tbl)+ print r++ let ideal2 = [(-26522079073807/3789408304503) .*. x^20 - (45981059324371/6069538029208) .*. x^18 + (87120042561463/371075270539) .*. y^18 + (79291926719113/9049615744576) .*. (x^8 * x^7)+ ,(-51798333070002/2209756160027) .*. y^21 - (74815570129865/7910242500601) .*. y^2+ ,(88733941750461/7841330684716) .*. y^32 - (42199913575574/5828711194795) .*. x^19 - (71276557990061/9562339937814) .*. y^14+ ,(-31510669207222/5962081412485) .*. (x^21 * x^27) - (36222490648769/8305690306244) .*. (x^16 * x^22) - (7233172975215/829632241931) .*. (x^14 * x^23) - (3805361578555/167149832969) .*. y^32 + (69415740054815/6652687446689) .*. y^29 + (7752028007245/3200657266301) .*. (x^11 * x^16) - (19808984350455/4059069629924) .*. x^19 - (65045682499208/4121663815257) .*. (x^15 * x^4) - (15986236131409/1581470273329) .*. x^7+ ,(6739930354481/646188839176) .*. (x^27 * x^12) + (3332373494769/455527457959) .*. (x^19 * x^19) + (8664121226147/56503077513) .*. (x^9 * x^26) + (7484145267923/6252920124858) .*. y^25 + (14388640369417/1948009422683) .*. (x^6 * x^18) + (31709851046421/2064507686732) .*. (x^15 * x^3) - (25628590194323/2964425883134) .*. (x^4 * x^14) + (49473826041010/2299762404251) .*. x^17 - (85383428250299/8861518460758) .*. (x^5 * x^3)+ ]+ f2 = (80554074773357/4347721547917) .*. (x^30 * y^14) - (42677827243839/6070945287334) .*. (x^28 * y^14) - (644551542381/356632156135) .*. (x^9 * y^32) + (82812585264442/1694267049817) .*. (x^32 * y^8) + (13143129720339/1541218520317) .*. y^28 + (35169339928528/3273364681879) .*. (x^14 * y^12) + (6016316529539/857674706980) .*. y^13 - (31839563822059/2132443079266) .*. x^11 - injectCoeff (13611257149310/7379272303073)+ g2 = (71897304622813/8341793645760) .*. (x^30 * y^11) - (16418454876309/1094197015679) .*. (x^20 * y^9) - (369944330392/960955134031) .*. (x^10 * y^12) + (32278788235340/40762635223) .*. y+ print $ calcGroebnerBasis (toIdeal ideal2) -- $ reflect >>> vBasis &&& multTable
examples/sandpit-poly.hs view
@@ -1,37 +1,62 @@-{-# LANGUAGE DataKinds, OverlappingInstances, PolyKinds #-}+{-# LANGUAGE DataKinds, MultiWayIf, NoImplicitPrelude, PolyKinds #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}-module Main (module Algebra.Algorithms.Groebner, module Algebra.Ring.Polynomial- , module Data.Ratio, module Main, module Algebra.Internal+module Main ( module Algebra.Algorithms.Groebner+ , module Main ) where import Algebra.Algorithms.Groebner-import Algebra.Internal-import Algebra.Ring.Noetherian-import Algebra.Ring.Polynomial-import Data.Ratio-import qualified Numeric.Algebra as NA--u, v, x, y, z :: Polynomial Rational (S (S Three))-[u, v, x, y, z] = genVars (sS (sS sThree))--(.+), (.*), (.-) :: Polynomial Rational (S Three) -> Polynomial Rational (S Three) -> Polynomial Rational (S Three)-(.+) = (NA.+)-(.*) = (NA.*)-(.-) = (NA.-)--infixl 6 .+, .--infixl 7 .*+import Algebra.Prelude+import Algebra.Ring.Polynomial.Univariate (Unipol)+import Data.Maybe (isJust)+import Data.Maybe (fromJust)+import Data.Maybe (fromMaybe)+import qualified Data.Sized.Builtin as SV+import Numeric.Decidable.Zero (isZero) -(^^^) :: Polynomial Rational (S Three) -> NA.Natural -> Polynomial Rational (S Three)-(^^^) = NA.pow+u, v, x, y, z :: Polynomial (Fraction Integer) 5+[u, v, x, y, z] = vars fromRight :: Either t t1 -> t1 fromRight (Right a) = a fromRight _ = error "fromRight"-{--parse :: String -> Polynomial Rational-parse = fromRight . parsePolyn--} -main :: IO ()-main = print $ thEliminationIdealWith (eliminationOrder sTwo) sTwo $- toIdeal [x - (3*u + 3*u*v^2 - u^3), y - (3*v + 3*u^2*v - v^3), z - (3*u^2 - 3*v^2)]++main, act :: IO ()+main = act+act = do+ print (var 0 ^ 51245 :: Unipol Integer)+ let n = thEliminationIdeal sTwo $+ toIdeal [x - (3*u + 3*u*v^2 - u^3), y - (3*v + 3*u^2*v - v^3), z - (3*u^2 - 3*v^2)]+ return ()+ where sTwo = sing :: Sing 2 ; sThree = sing :: Sing 3++findDifference :: (Eq r, Field r)+ => [Polynomial r 1] -> (r, r, [r], Int)+findDifference = go 0+ where+ go n [f] =+ let ans = fromMaybe zero $ findRoot f+ sol = eval (SV.singleton ans) f+ in (ans, sol, [sol], n)+ go n xs =+ let ds = zipWith (-) xs (tail xs)+ rs = map findRoot ds+ ans = fromJust $ head rs+ sol = eval (SV.singleton ans) $ head xs+ in if isJust (head rs) && all (== head rs) rs+ then (ans, sol, [sol], n)+ else case go (n+1) (zipWith (-) (tail xs) xs) of+ (a, d, ss, k) -> (a, d, eval (SV.singleton a) (head xs) : ss, k)++findRoot :: (Eq r, Field r, DecidableZero r) => Polynomial r 1 -> Maybe r+findRoot f+ = if | totalDegree' f == 1 ->+ Just $ negate $ coeff one f / leadingCoeff f+ | isZero f -> Just zero+ | otherwise -> Nothing+++++++
− examples/sandpit.hs
@@ -1,44 +0,0 @@-module Main (module Algebra.Algorithms.Groebner.Monomorphic, module Algebra.Ring.Polynomial- {- , module Algebra.Ring.Polynomial.Parser-} , module Algebra.Ring.Polynomial.Monomorphic- , module Data.Ratio, module Main, module Algebra.Internal- ) where-import Algebra.Algorithms.Groebner.Monomorphic-import Algebra.Internal-import Algebra.Ring.Polynomial (Grevlex (..), Grlex (..),- Lex (..), ProductOrder (..),- WeightOrder (..),- WeightProxy (..),- eliminationOrder,- weightedEliminationOrder)-import Algebra.Ring.Polynomial.Monomorphic--- import Algebra.Ring.Polynomial.Parser-import Data.Ratio-import qualified Numeric.Algebra as NA--var_x, var_y, var_z, var_t, var_u :: Variable-[var_c, var_s, var_x, var_y, var_z, var_t, var_u] = map (flip Variable Nothing) "csxyztu"--x, y, z, t, u :: Polynomial Rational-[c, s, x, y, z, t, u] = map injectVar [var_c, var_s, var_x, var_y, var_z, var_t, var_u]--(.+), (.*), (.-) :: Polynomial Rational -> Polynomial Rational -> Polynomial Rational-(.+) = (NA.+)-(.*) = (NA.*)-(.-) = (NA.-)--infixl 6 .+, .--infixl 7 .*--(^^^) :: Polynomial Rational -> NA.Natural -> Polynomial Rational-(^^^) = NA.pow--fromRight :: Either t t1 -> t1-fromRight (Right a) = a--{--parse :: String -> Polynomial Rational-parse = fromRight . parsePolyn--}--main :: IO ()-main = print $ eliminate [var_s, var_c] [x-c^3, y-s^3, c^2+s^2-1]
+ examples/site-example.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses, NoImplicitPrelude #-}+{-# LANGUAGE NoMonomorphismRestriction, QuasiQuotes, TypeOperators #-}+module Main where+import Algebra.Algorithms.Groebner+import Algebra.Field.Finite+import Algebra.Prelude+import Data.Type.Ordinal.Builtin++-- | 0-th variable of polynomial ring with at least one variable.+-- Variables are 0-origin.+x :: (KnownNat n, CoeffRing r, IsMonomialOrder n order, (0 :< n) ~ 'True)+ => OrderedPolynomial r order n+x = var [od|0|]++-- | 1-st variable of polynomial ring with at least two variable.+y :: (KnownNat n, CoeffRing r, IsMonomialOrder n order, (1 :< n) ~ 'True)+ => OrderedPolynomial r order n+y = var [od|1|]++-- | The last variable of+z :: Polynomial Rational 3+z = var [od|2|]++-- | f in QQ[x,y,z]+f :: OrderedPolynomial Rational Grevlex 3+f = 1%2*x*y^2 + y^2++-- | map f to the F_5[x,y,z], where F_5 = ZZ/5ZZ+f' :: Polynomial (F 5) 3+f' = mapCoeff (\r -> fromInteger (numerator r) / fromInteger (denominator r) ) f++-- | ideal of QQ[x,y,a,b,c,s]+heron :: Ideal (OrderedPolynomial Rational Lex 6)+heron = toIdeal [ 2 * s - a * y+ , b^2 - (x^2 + y^2)+ , c^2 - ((a - x)^2 + y^2)+ ]+ where+ -- | Get the last four variables of QQ[x,y,a,b,c,s]+ [_, _, a, b, c, s] = vars++main :: IO ()+main = act++act = do+ print f+ print f'+ print $ x * f'^2+ print $ calcGroebnerBasis heron+ -- print $ f' * 5 + f -- ^ Type error!
+ examples/solve.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses, NoImplicitPrelude, PolyKinds #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+module Main (module Algebra.Algorithms.Groebner, module Algebra.Prelude+ , module Main+ ) where+import Algebra.Algorithms.Groebner+import Algebra.Algorithms.ZeroDim+import Algebra.Ring.Ideal+import Algebra.Ring.Polynomial.Quotient+import Algebra.Prelude+import Control.Monad.Random hiding (fromList)+import Data.Complex+import Data.Convertible+import Data.List (find, nub, partition, sortBy)+import qualified Data.Matrix as M+import qualified Data.Sized.Builtin as SV+import qualified Data.Vector as V+import Debug.Trace+import qualified Numeric.LinearAlgebra as LA+import qualified Prelude as P++tr :: Show a => a -> a+tr a = trace (show a) a++x, y, z :: Polynomial (Fraction Integer) 3+[x, y, z] = vars++seed :: Polynomial (Fraction Integer) 3+seed = -412742019532366985 * x -7641395389638504101 * y + 4362835172800530323 * z++seedMat :: LA.Matrix Double+seedMat = LA.fromLists $ map (map toDouble) $ reifyQuotient eqn02 $ \pxy -> matrixRep (modIdeal' pxy seed)++toDouble :: Fractional a => Fraction Integer -> a+toDouble rat = fromIntegral (numerator rat) P./ fromIntegral (denominator rat)++fromRight :: Either t t1 -> t1+fromRight (Right a) = a+fromRight _ = error "fromRight"++printLvl :: Show a => Int -> a -> IO ()+printLvl lvl = putStrLn . unlines . map (replicate lvl '\t' ++) . lines . show++eqn01 :: Ideal (Polynomial (Fraction Integer) 3)+eqn01 = toIdeal [x^2 - 2*x*z + 5, x*y^2+y*z+1, 3*y^2 - 8*x*z]++eqn02 :: Ideal (Polynomial (Fraction Integer) 3)+eqn02 =+ toIdeal [x^2 + 2*y^2 - y - 2*z+ ,x^2 - 8*y^2 + 10*z - 1+ ,x^2 - 7*y*z+ ]++eqn03 :: Ideal (Polynomial (Fraction Integer) 3)+eqn03 = toIdeal [x^2 + y^2 + z^2 - 2*x+ ,x^3 - y*z - x+ ,x - y + 2*z+ ]++jdeal :: Ideal (Polynomial (Fraction Integer) 3)+jdeal = toIdeal [x*y + z - x*z, x^2 - z, 2*x^3 - x^2 * y * z - 1]+++vs :: [V.Vector (Fraction Integer)]+vs = reifyQuotient eqn03 $ \pxy -> map (vectorRep . modIdeal' pxy) [var 0 ^ i | i <- [0..6::Natural]]++mat :: M.Matrix (Fraction Integer)+mat = fromCols $ take 4 vs++fromCols :: [V.Vector a] -> M.Matrix a+fromCols = foldr1 (M.<|>) . map M.colVector++findUnivar :: (CoeffRing r, IsMonomialOrder n ord, KnownNat n)+ => OrderedPolynomial r ord n -> Maybe (Ordinal n)+findUnivar poly =+ let os = enumOrdinal (sArity' poly)+ ms = map snd $ getTerms poly+ in find (\a -> all (`isPowerOf` (leadingMonomial (var a `asTypeOf` poly))) ms) os++toCoeffList :: (CoeffRing r, KnownNat n, IsMonomialOrder n ord) => Ordinal n -> OrderedPolynomial r ord n -> [r]+toCoeffList on f =+ let v = var on `asTypeOf` f+ in [ coeff (leadingMonomial $ v ^ i) f | i <- [0.. fromIntegral (totalDegree' f)]]++showSols :: (KnownNat n, IsMonomialOrder n order, Convertible a Double)+ => Double -> Ideal (OrderedPolynomial a order n) -> [Sized n1 (Complex Double)] -> IO ()+showSols err eqn sols = do+ let (rs, is) = partition (all ((<err).P.abs.imagPart)) $ map SV.toList sols+ subs a b c = generators $+ mapIdeal (magnitude . substWith (*) (SV.unsafeFromList' [a, b, c]) . mapCoeff toComplex)+ eqn+ showCase [a,b,c] = print (a, b, c) >> putStr "\terror: ">> print (maximum $ subs a b c)+ putStrLn $ "- " ++ show (length rs) ++ " real solution(s):"+ mapM_ showCase $ sortBy (comparing $ map magnitude) rs+ putStrLn $ "- " ++ show (length is) ++ " imaginary solution(s):"+ mapM_ showCase $ sortBy (comparing $ map magnitude) is+ let errs = concatMap (\ [a,b,c] -> subs a b c) $ rs ++ is+ putStrLn $ "- maximum error: " ++ show (maximum errs)+ putStrLn $ "- minimum error: " ++ show (minimum errs)+ putStrLn $ "- average error: " ++ show (sum errs P./ fromIntegral (length errs))++main :: IO ()+main = do+ putStrLn "---- solving equation system"+ let err = 1e-10+ putStrLn "< naive method"+ showSols err eqn01 $ solve' err eqn01+ putStrLn "\n< randomized method"+ showSols err eqn01 =<< evalRandIO (solveM eqn01)+ putStrLn "\n< companion characteristics"+ showSols err eqn01 $ solveViaCompanion err eqn01+ putStrLn "\n< univariate spanning"+ showSols err eqn01 $ solve' err eqn01++ putStrLn "\n\n---- exercise 8"+ putStrLn "< Solving 1-6"+ putStrLn "< Naive Method: "+ showSols err eqn02 $ nub $ solve' err eqn02+ putStrLn "\n< new method"+ showSols err eqn02 =<< evalRandIO (solveM eqn02)++ putStrLn "\n< Solving 1-7"+ putStrLn "< Naive Method: "+ showSols err eqn03 $ nub $ solve' err eqn03+ putStrLn "\n< new method"+ showSols err eqn03 =<< evalRandIO (solveM eqn03)+ putStrLn "\n\n---- FGLM Algorithm"+ print $ fglm jdeal+ print $ calcGroebnerBasisWith Lex jdeal+ print $ univPoly 0 jdeal+ print $ univPoly 1 jdeal+ print $ univPoly 2 jdeal+ return ()++substIdeal :: IsMonomialOrder 3 order+ => [OrderedPolynomial (Fraction Integer) Grevlex 3]+ -> Ideal (OrderedPolynomial (Fraction Integer) order 3)+ -> Ideal (OrderedPolynomial (Fraction Integer) Grevlex 3)+substIdeal = mapIdeal . substWith (.*.) . SV.unsafeFromList'++toComplex :: Convertible r Double => r -> Complex Double+toComplex = (:+ 0) . convert
− examples/sugar-bench.hs
@@ -1,54 +0,0 @@-{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}-{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings, PolyKinds #-}-{-# LANGUAGE QuasiQuotes, TemplateHaskell, UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}-import Algebra.Algorithms.Groebner.Monomorphic-import Algebra.Ring.Polynomial.Monomorphic-import Control.DeepSeq-import Control.Parallel.Strategies-import Criterion.Main--x, y, z, w, s, a, b, c :: Polynomial Rational-[x, y, z, w, s, a, b, c] = map (injectVar . flip Variable Nothing) "xyzwSabc"--instance NFData Variable where- rnf (Variable x y) = rnf x `seq` rnf y `seq` ()--instance NFData (Polynomial Rational) where- rnf (Polynomial dic) = rnf dic--i1, i2, i3, i4 :: [Polynomial Rational]-i1 = [x^2 + y^2 + z^2 - 1, x^2 + y^2 + z^2 - 2*x, 2*x -3*y - z]-i2 = [x^2 * y - 2*x*y - 4*z - 1, z-y^2, x^3 - 4*z*y]-i3 = [ 2 * s - a * y, b^2 - (x^2 + y^2), c^2 - ( (a-x) ^ 2 + y^2)- ]-i4 = [ z^5 + y^4 + x^3 - 1, z^3 + y^3 + x^2 - 1]--mkTestCases :: (Eq r, Show a, r ~ Rational) => a -> [Polynomial r] -> [Benchmark]-mkTestCases num ideal = [ mkTC ("lex0" ++ show num) ideal Lex- , mkTC ("grlex0" ++ show num) ideal Grlex- , mkTC ("grevlex0" ++ show num) ideal Grevlex- ]--mkTC :: (r ~ Rational, IsMonomialOrder ord) => String -> [Polynomial r] -> ord -> Benchmark-mkTC name ideal ord =- bgroup name [ bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy ord) ideal- , bench "syz+grevsel" $ nf (syzygyBuchbergerWithStrategy GrevlexStrategy ord) ideal- , bench "syz+grad" $ nf (syzygyBuchbergerWithStrategy GradedStrategy ord) ideal- , bench "syz+sugar" $ nf (syzygyBuchbergerWithStrategy (SugarStrategy NormalStrategy) ord) ideal- , bench "syz+grsugar" $ nf (syzygyBuchbergerWithStrategy (SugarStrategy GradedStrategy) ord) ideal- ]--main :: IO ()-main = do- ideal1 <- return $! (i1 `using` rdeepseq)- ideal2 <- return $! (i2 `using` rdeepseq)- ideal3 <- return $! (i3 `using` rdeepseq)- ideal4 <- return $! (i4 `using` rdeepseq)- defaultMain $ concat $- [ mkTestCases 1 ideal1- , [mkTC "grlex02" ideal2 Grlex, mkTC "grevlex02" ideal2 Grevlex]- , mkTestCases 3 ideal3- , [mkTC "grlex04" ideal4 Grlex, mkTC "grevlex04" ideal4 Grevlex]- ]-
− examples/sugar-paper.hs
@@ -1,68 +0,0 @@-{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}-{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings, PolyKinds #-}-{-# LANGUAGE QuasiQuotes, TemplateHaskell, UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}-import Algebra.Algorithms.Groebner.Monomorphic-import Algebra.Ring.Polynomial.Monomorphic-import Algebra.Ring.Polynomial.Parser-import Control.DeepSeq-import Control.Parallel.Strategies-import Criterion.Main--x, y, z, w, s, a, b, c :: Polynomial Rational-[x, y, z, w, s, a, b, c, t] = map (injectVar . flip Variable Nothing) "xyzwSabct"--instance NFData Variable where- rnf (Variable x y) = rnf x `seq` rnf y `seq` ()--instance NFData (Polynomial Rational) where- rnf (Polynomial dic) = rnf dic--parse x = case parsePolyn x of- Right y -> y- Left er -> error $ show er--i1, i2, i3, i4 :: [Polynomial Rational]-i1 = map parse ["yw - 1/2 zw + tw"- ,"-2/7 uw^2 + 10/7 vw^2 - 20/7 w^3 + tu - 5tv + 10tw"- ,"2/7 yw^2 - 2/7 zw^2 + 6/7 tw^2 - yt + zt - 3t^2"- ,"-2v^3 + 4uvw + 5v^2w - 6uw^2 - 7vw^2 + 15w^3 + 42yv"- ,"-14zv - 63yw + 21zw - 42tw + 147x"- ,"-9/7uw^3 + 45/7vw^3 - 135/7w^4 + 2zv^2 - 2tv^2 - 4zuw+10tuw - 2zvw - 28tvw + 4zw^2 + 86tw^2 - 42yz+14z^2 + 42yt - 14zt - 21xu + 105xv - 315xw"- ,"6/7yw^3 - 9/7zw^3 + 36/7tw^3 - 2zv^2 - 4ytw + 6ztw - 24t^2w\- \+ 4xuw + 2xvw - 4xw^2 + 56xy - 35xz + 84xt"- ,"2uvw - 6v^2w - uw^2 + 13vw^2 - 5w^3 + 14yw - 28tw"- ,"u^2w - 3uvw + 5uw^2 + 14yw - 28tw"- ,"-2zuw - 2tuw + 4yvw + 6zvw - 2tvw - 16yw^2 - 10 zw^2 + 22tw^2 + 42xw"- ,"28/3yuw + 8/3zuw - 20/3tuw - 88/3yvw - 8zvw\- \+68/3tvw + 52yw^2 + 40/3zw^2 - 44tw^2 - 84xw"- ,"-4yzw + 10ytw + 8ztw - 20t^2w + 12xuw - 30xvw + 15xw^2"- ,"-1 y^2w + 1/2 yzw + ytw - ztw + 2 t^2 w - 3xuw + 6xvw - 3xw^2"- , "8xyw - 4xzw + 8xtw"- ]-i2 = map parse ["35y^4 - 30xy^2 - 210y^2z + 3x^2 + 30xz - 105z^2 +140yt - 21u"- ,"5xy^3 - 140y^3z - 3x^2y + 45xyz - 420yz^2 + 210y^2t -25xt + 70zt + 126yu"- ]-i3 = [ x^31 - x^6 - x- y, x^8 - z, x^10 -t]-i4 = [ w+x+y+z, w*x+x*y+y*z+z*w, w*x*y + x*y*z + y*z*w + z*w*x, w*x*y*z]--mkTestCases :: (Eq r, Show a, r ~ Rational) => a -> [Polynomial r] -> [Benchmark]-mkTestCases num ideal = [ mkTC ("lex0" ++ show num) ideal Lex- , mkTC ("grevlex0" ++ show num) ideal Grevlex- ]--mkTC :: (r ~ Rational, IsMonomialOrder ord) => String -> [Polynomial r] -> ord -> Benchmark-mkTC name ideal ord =- bgroup name [ bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy ord) ideal- , bench "syz+sugar" $ nf (syzygyBuchbergerWithStrategy (SugarStrategy NormalStrategy) ord) ideal- ]--main :: IO ()-main = do- ideal1 <- return $! (i1 `using` rdeepseq)- ideal2 <- return $! (i2 `using` rdeepseq)- ideal3 <- return $! (i3 `using` rdeepseq)- ideal4 <- return $! (i4 `using` rdeepseq)- defaultMain $ concat (zipWith mkTestCases [1..] [ideal2, ideal4])- ++ [mkTC "grevlex03" ideal3 Grevlex]-
− examples/sugar.hs
@@ -1,99 +0,0 @@-{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}-{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings, PolyKinds #-}-{-# LANGUAGE QuasiQuotes, TemplateHaskell, UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}-import Algebra.Algorithms.Groebner.Monomorphic-import Algebra.Ring.Polynomial.Monomorphic-import Control.DeepSeq-import Control.Parallel.Strategies-import Criterion.Main-import SingularBench--x, y, z, w, s, a, b, c :: Polynomial Rational-[x, y, z, w, s, a, b, c] = map (injectVar . flip Variable Nothing) "xyzwSabc"--instance NFData Variable where- rnf (Variable x y) = rnf x `seq` rnf y `seq` ()--instance NFData (Polynomial Rational) where- rnf (Polynomial dic) = rnf dic--i1, i2, i3, i4 :: [Polynomial Rational]-i1 = [x^2 + y^2 + z^2 - 1, x^2 + y^2 + z^2 - 2*x, 2*x -3*y - z]-i2 = [x^2 * y - 2*x*y - 4*z - 1, z-y^2, x^3 - 4*z*y]-i3 = [ 2 * s - a * y, b^2 - (x^2 + y^2), c^2 - ( (a-x) ^ 2 + y^2)- ]-i4 = [ z^5 + y^4 + x^3 - 1, z^3 + y^3 + x^2 - 1]--main :: IO ()-main = do- ideal1 <- return $! (i1 `using` rdeepseq)- ideal2 <- return $! (i2 `using` rdeepseq)- ideal3 <- return $! (i3 `using` rdeepseq)- ideal4 <- return $! (i4 `using` rdeepseq)- defaultMain $ [bgroup "lex01"- [ bench "simple" $ nf (simpleBuchbergerWith Lex) ideal1- , bench "relprime" $ nf (primeTestBuchbergerWith Lex) ideal1- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Lex) ideal1- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Lex) ideal1- ]- ,bgroup "grlex01"- [ bench "simple" $ nf (simpleBuchbergerWith Grlex) ideal1- , bench "relprime" $ nf (primeTestBuchbergerWith Grlex) ideal1- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grlex) ideal1- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grlex) ideal1- ]- ,bgroup "grevlex01"- [ bench "simple" $ nf (simpleBuchbergerWith Grevlex) ideal1- , bench "relprime" $ nf (primeTestBuchbergerWith Grevlex) ideal1- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grevlex) ideal1- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grevlex) ideal1- ]- ,bgroup "grlex02"- [ bench "simple" $ nf (simpleBuchbergerWith Grlex) ideal2- , bench "relprime" $ nf (primeTestBuchbergerWith Grlex) ideal2- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grlex) ideal2- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grlex) ideal2- ]- ,bgroup "grevlex02"- [ bench "simple" $ nf (simpleBuchbergerWith Grevlex) ideal2- , bench "relprime" $ nf (primeTestBuchbergerWith Grevlex) ideal2- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grevlex) ideal2- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grevlex) ideal2- -- , bench "singular" $ nfIO (singularWith Grevlex ideal2)- ]- ,bgroup "lex03"- [ bench "simple" $ nf (simpleBuchbergerWith Lex) ideal3- , bench "relprime" $ nf (primeTestBuchbergerWith Lex) ideal3- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Lex) ideal3- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Lex) ideal3- -- , bench "singular" $ nfIO (singularWith Lex ideal3)- ]- ,bgroup "grlex03"- [ bench "simple" $ nf (simpleBuchbergerWith Grlex) ideal3- , bench "relprime" $ nf (primeTestBuchbergerWith Grlex) ideal3- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grlex) ideal3- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grlex) ideal3- -- , bench "singular" $ nfIO (singularWith Grlex ideal3)- ]- ,bgroup "grevlex03"- [ bench "simple" $ nf (simpleBuchbergerWith Grevlex) ideal3- , bench "relprime" $ nf (primeTestBuchbergerWith Grevlex) ideal3- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grevlex) ideal3- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grevlex) ideal3- ]- ,bgroup "grlex04"- [ bench "simple" $ nf (simpleBuchbergerWith Grlex) ideal4- , bench "relprime" $ nf (primeTestBuchbergerWith Grlex) ideal4- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grlex) ideal4- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grlex) ideal4- -- , bench "singular" $ nfIO (singularWith Grlex ideal4)- ]- ,bgroup "grevlex04"- [ bench "simple" $ nf (simpleBuchbergerWith Grevlex) ideal4- , bench "relprime" $ nf (primeTestBuchbergerWith Grevlex) ideal4- , bench "syzygy" $ nf (syzygyBuchbergerWithStrategy NormalStrategy Grevlex) ideal4- , bench "syz+sugar" $ nf (syzygyBuchbergerWith Grevlex) ideal4- -- , bench "singular" $ nfIO (singularWith Grevlex ideal4)- ]- ]
@@ -0,0 +1,20 @@+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module HspecSmallCheck where+import Control.Applicative+import Data.IORef+import Test.Hspec.Core+import Test.SmallCheck+import Test.SmallCheck.Drivers++property :: Testable IO a => a -> Property IO+property = test++instance Example (Property IO) where+ evaluateExample p c _ = do+ counter <- newIORef 0+ let hook _ = do+ modifyIORef counter succ+ n <- readIORef counter+ paramsReportProgress c (n, 0)+ maybe Success (Fail . ppFailure) <$> smallCheckWithHook (paramsSmallCheckDepth c) hook p
@@ -0,0 +1,67 @@+{-# LANGUAGE ViewPatterns #-}+module SequenceMonomial (Monomial(), MonomialOrder, length, viewl+ , totalDegree, viewr, lex, graded, revlex, grlex, grevlex, fromList) where+import Control.DeepSeq+import Data.Foldable+import Data.Monoid+import Data.Ord+import Data.Sequence (Seq)+import qualified Data.Sequence as S+import Prelude hiding (length, lex, sum)++length :: Monomial -> Int+length = S.length . getSeq++fromList :: [Int] -> Monomial+fromList xs = Monomial (S.fromList xs) (sum xs)++viewl :: Monomial -> ViewL+viewl (Monomial sq deg) =+ case S.viewl sq of+ S.EmptyL -> EmptyL+ x S.:< xs -> x :< Monomial xs (deg - x)++viewr :: Monomial -> ViewR+viewr (Monomial sq deg) =+ case S.viewr sq of+ S.EmptyR -> EmptyR+ xs S.:> x -> Monomial xs (deg - x) :> x++data ViewL = EmptyL | Int :< Monomial deriving (Read, Show, Eq, Ord)+data ViewR = EmptyR | Monomial :> Int deriving (Read, Show, Eq, Ord)++data Monomial = Monomial { getSeq :: Seq Int+ , totalDegree :: !Int+ } deriving (Read, Show, Eq, Ord)++instance NFData Monomial where+ rnf (Monomial sq deg) = rnf sq `seq` rnf deg `seq` ()++type MonomialOrder = Monomial -> Monomial -> Ordering++-- | Lexicographical order. This *is* a monomial order.+lex :: MonomialOrder+lex (viewl -> EmptyL) (viewl -> EmptyL) = EQ+lex (viewl -> x :< xs) (viewl -> y :< ys) = x `compare` y <> xs `lex` ys+{-# INLINE lex #-}++-- | Reversed lexicographical order. This is *not* a monomial order.+revlex :: Monomial -> Monomial -> Ordering+revlex (viewr -> xs :> x) (viewr -> ys :> y) = y `compare` x <> xs `revlex` ys+revlex (viewr -> EmptyR) (viewr -> EmptyR) = EQ+{-# INLINE revlex #-}++-- | Convert ordering into graded one.+graded :: (Monomial -> Monomial -> Ordering) -> (Monomial -> Monomial -> Ordering)+graded cmp xs ys = comparing totalDegree xs ys <> cmp xs ys+{-# INLINE graded #-}++-- | Graded lexicographical order. This *is* a monomial order.+grlex :: MonomialOrder+grlex = graded lex+{-# INLINE grlex #-}++-- | Graded reversed lexicographical order. This *is* a monomial order.+grevlex :: MonomialOrder+grevlex = graded revlex+{-# INLINE grevlex #-}
@@ -0,0 +1,123 @@+{-# LANGUAGE GADTs, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses, ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+module SingularBridge (singIdealFun, singPolyFun) where+import Algebra.Internal+import Algebra.Ring.Ideal+import Algebra.Ring.Polynomial hiding (lex)++import Control.Applicative+import Data.Char+import Data.List+import Data.Maybe (fromMaybe, mapMaybe)+import qualified Data.Text as T+import Numeric+import Numeric.Field.Fraction+import System.IO.Unsafe+import System.Process++class IsStrongMonomialOrder ord => SingularOrder ord where+ singularOrder :: p ord -> String++instance SingularOrder Lex where+ singularOrder _ = "lp"++instance SingularOrder Grevlex where+ singularOrder _ = "dp"++idealProgram :: forall ord n. (SingularOrder ord, KnownNat n)+ => String+ -> Ideal (OrderedPolynomial (Fraction Integer) ord n)+ -> String+idealProgram fun ideal =+ withStrongMonomialOrder (Proxy :: Proxy ord) (sing :: SNat n) $+ let vars = generate sing $ \i -> "x(" ++ show (fromEnum i) ++ ")"+ istr = intercalate ", " $ map (showPolynomialWith vars 5) $ generators ideal+ in (++";") $ intercalate ";\n"++ [ "LIB \"primdec.lib\""+ , "LIB \"f5_library.lib\""+ , "ring R = 0,(x(0.." ++ show (sNatToInt (sing :: SNat n) - 1) ++ "))," ++ singularOrder (Proxy :: Proxy ord)+ , "ideal I = " ++ istr+ , "option(redSB)"+ , "print(" ++ fun ++ "(I))"+ , "exit"+ ]++singular :: String -> IO String+singular code = readProcess "singular" ["-q"] code++readSingularIdeal :: (KnownNat n, IsStrongMonomialOrder ord)+ => SNat n -> Proxy ord -> String -> [OrderedPolynomial (Fraction Integer) ord n]+readSingularIdeal n p (T.pack -> code) =+ mapMaybe (readSingularPoly n p . T.unpack) $ map (\a -> fromMaybe a $ T.stripSuffix "," a) $ T.lines code++readSingularPoly :: (KnownNat n, IsStrongMonomialOrder ord)+ => SNat n -> Proxy ord -> String -> Maybe (OrderedPolynomial (Fraction Integer) ord n)+readSingularPoly n pxy code =+ withStrongMonomialOrder pxy n $+ case [p | (p, xs) <- readPoly code, all isSpace xs] of+ (p:_) -> Just p+ _ -> Nothing+ where+ readPoly st = do+ (t, rest) <- readTerm st+ readPoly' rest t++ readPoly' st acc = do ("+", st') <- lex st+ (t, rest) <- readTerm st'+ readPoly' rest (acc + t)+ <|> do ("-", st') <- lex st+ (t, rest) <- readTerm st'+ readPoly' rest (acc - t)+ <|> return (acc, st)++ readCoeff st = do+ (modify, st') <- do { ("-", roo) <- lex st ; return (negate, roo) } <|> return (id, st)+ (num, rest) <- readDec st'+ (a, foo) <- lex rest+ case a of+ "/" -> do+ (den, rest') <- readDec foo+ return (injectCoeff $ modify $ num % den, rest')+ _ -> return (injectCoeff $ modify $ num % 1, rest)++ readTerm st = do+ (a, rest) <- readFactor st+ (ts, gomi) <- readTerm' rest+ return (product (a : ts), gomi)+ readTerm' st = do ("*", st') <- lex st+ (a, rest) <- readFactor st'+ (as, gomi) <- readTerm' rest+ return (a: as, gomi)+ <|> return ([], st)++ readFactor st = readCoeff st <|> readVar st++ readVar st = do+ ("x", '(':rest) <- lex st+ (nstr, ')':mpow) <- lex rest+ (nth, "") <- readDec nstr+ (power, gomi) <- do ("^", rst'') <- lex mpow+ (pow, gomi) <- readDec rst''+ return (pow :: Integer, gomi)+ <|> return (1, mpow)+ return (var (toEnum nth) ^ power, gomi)++singIdealFun :: forall ord n. (SingularOrder ord, KnownNat n)+ => String -> Ideal (OrderedPolynomial (Fraction Integer) ord n) -> Ideal (OrderedPolynomial (Fraction Integer) ord n)+singIdealFun fun ideal =+ withStrongMonomialOrder (Proxy :: Proxy ord) (sing :: SNat n) $+ unsafePerformIO $ do+ ans <- singular $ idealProgram fun ideal+ return $ toIdeal $ readSingularIdeal (sing :: SNat n) (Proxy :: Proxy ord) ans++singPolyFun :: forall ord n. (SingularOrder ord, KnownNat n)+ => String+ -> Ideal (OrderedPolynomial (Fraction Integer) ord n)+ -> OrderedPolynomial (Fraction Integer) ord n+singPolyFun fun ideal = unsafePerformIO $ do+ ans <- singular $ idealProgram fun ideal+ let Just p = readSingularPoly (sing :: SNat n) (Proxy :: Proxy ord) ans+ return p
@@ -0,0 +1,253 @@+{-# LANGUAGE CPP, DataKinds, DeriveGeneric, FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances, GADTs, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures, MultiParamTypeClasses, RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}+module Utils (ZeroDimIdeal(..), polyOfDim, arbitraryRational,homogPolyOfDim,arbVecOfSum,+ arbitrarySolvable, zeroDimOf, zeroDimG, unaryPoly, stdReduced,+ quotOfDim, isNonTrivial, Equation(..), liftSNat, checkForArity,+ MatrixCase(..), idealOfDim) where+import Algebra.Field.Finite+import qualified Algebra.Field.Finite as F+import Algebra.Internal+import Algebra.Ring.Ideal+import Algebra.Ring.Polynomial hiding (Positive)+import Algebra.Ring.Polynomial.Quotient+import Algebra.Ring.Polynomial.Univariate+import Control.Lens hiding ((:<))+import Control.Monad+import Data.List (sortBy)+import qualified Data.List as L+import qualified Data.Map as M+import qualified Data.Matrix as M hiding (fromList)+import Data.Ord+import Data.Reflection+import Data.Sized.Builtin hiding (head, length, map,+ sortBy, (++))+import qualified Data.Sized.Builtin as SV+import Data.Type.Monomorphic+import qualified Data.Type.Monomorphic as M+import qualified Data.Vector as V+import Numeric.Algebra (DecidableZero)+import Numeric.Algebra (Ring)+import qualified Numeric.Algebra as NA+import Numeric.Domain.Euclidean (Euclidean)+import Numeric.Field.Fraction+import Test.QuickCheck+import qualified Test.QuickCheck as QC+import Test.QuickCheck.Instances ()+import Test.SmallCheck.Series+import qualified Test.SmallCheck.Series as SC++newtype ZeroDimIdeal n = ZeroDimIdeal { getIdeal :: Ideal (Polynomial (Fraction Integer) n)+ } deriving (Show, Eq, Ord)++(%.) :: Euclidean a => a -> SC.Positive a -> Fraction a+a %. SC.Positive b = a % b++-- * Instances for SmallCheck.+instance (KnownNat n, Monad m) => Serial m (Monomial n) where+ series =+ case zeroOrSucc (sing :: SNat n) of+ IsZero -> cons0 SV.empty+ IsSucc n -> withKnownNat n $ SV.cons <$> (SC.getNonNegative <$> series) <*> series++instance (Ord k, Serial m k, Serial m v) => Serial m (M.Map k v) where+ series = M.fromList <$> series++instance KnownNat n => Arbitrary (F n) where+ arbitrary = QC.elements (F.elements Proxy)++instance (Monad m, Serial m (Monomial n)) => Serial m (OrderedMonomial ord n) where+ series = newtypeCons OrderedMonomial++instance (Eq r, CoeffRing r, KnownNat n, IsMonomialOrder n ord,+ Serial m r, Serial m (Monomial n))+ => Serial m (OrderedPolynomial r ord n) where+ series = cons2 (curry toPolynomial) \/ cons2 (NA.+)++instance (Ord r, Ring r, Serial m r) => Serial m (Ideal r) where+ series = newtypeCons toIdeal++instance (CoeffRing r, Arbitrary r) => Arbitrary (Unipol r) where+ arbitrary = fromCoeffVec <$> QC.listOf QC.arbitrary+ where+ fromCoeffVec = polynomial' . M.fromList . L.zip [singleton n | n <- [0..]]++genUnipol :: (CoeffRing r, Arbitrary r) => Int -> IO (Unipol r)+genUnipol len = QC.generate $ fromCoeffVec <$> QC.vectorOf len QC.arbitrary+ where+ fromCoeffVec = polynomial' . M.fromList . L.zip [singleton n | n <- [0..]]++appendLM :: (Fraction Integer) -> Monomial 2 -> Polynomial (Fraction Integer) 2 -> Polynomial (Fraction Integer) 2+appendLM coef lm = _Wrapped %~ M.insert (OrderedMonomial lm) coef++xPoly :: Monad m => SC.Series m (Polynomial (Fraction Integer) 2)+xPoly = do+ (series SC.>< series) >>- \(c, d) ->+ series >>- \p -> do+ guard $ (leadingMonomial p) < (OrderedMonomial (d :< 0 :< NilL))+ return $ appendLM c (d :< 0 :< NilL) p++yPoly :: Monad m => SC.Series m (Polynomial (Fraction Integer) 2)+yPoly = do+ (series SC.>< series) >>- \(c, d) ->+ series >>- \p -> do+ guard $ leadingMonomial p < OrderedMonomial (d :< 0 :< NilL)+ return $ appendLM c (0 :< d :< NilL) p++instance Monad m => Serial m (ZeroDimIdeal 2) where+ series = do+ (f, g, ideal) <- (,,) <$> xPoly <~> yPoly <~> series+ return $ ZeroDimIdeal $ f `addToIdeal` g `addToIdeal` ideal++instance (Euclidean i, Integral i, Serial m i) => Serial m (Fraction i) where+ series = pairToRatio <$> series+ where+ pairToRatio (n, SC.Positive d) = n % d+instance (CoSerial m i) => CoSerial m (Fraction i) where+ coseries rs = (. ratioToPair) <$> coseries rs+ where+ ratioToPair r = (numerator r, denominator r)++arbVecOfSum :: SNat n -> Int -> Gen (Monomial n)+arbVecOfSum n k =+ case zeroOrSucc n of+ IsZero | k == 0 -> QC.elements [SV.empty]+ | otherwise -> fail "Empty list with positive sum"+ IsSucc m -> withKnownNat m $ do+ l <- QC.elements [0..abs k]+ (l :<) <$> arbVecOfSum m (abs k - l)++-- * Instances for QuickCheck.+instance KnownNat n => Arbitrary (Monomial n) where+ arbitrary = arbVec++arbVec :: forall n. KnownNat n => Gen (Monomial n)+arbVec = SV.unsafeFromList len . map abs <$> vectorOf (sNatToInt len) arbitrarySizedBoundedIntegral+ where+ len = sing :: SNat n++instance (Arbitrary (Monomial n)) => Arbitrary (OrderedMonomial ord n) where+ arbitrary = OrderedMonomial <$> arbitrary++instance (KnownNat n, IsMonomialOrder n ord)+ => Arbitrary (OrderedPolynomial (Fraction Integer) ord n) where+ arbitrary = polynomial . M.fromList <$> listOf1 ((,) <$> arbitrary <*> arbitraryRational)++instance (KnownNat n, IsMonomialOrder n ord)+ => Arbitrary (HomogPoly (Fraction Integer) ord n) where+ arbitrary = do+ deg <- QC.elements [2, 3, 4]+ HomogPoly . polynomial . M.fromList <$>+ listOf1 ((,) <$> (OrderedMonomial <$> arbVecOfSum (sing :: SNat n) deg) <*> arbitraryRational)++instance (Num r, Ord r, Ring r, Arbitrary r) => Arbitrary (Ideal r) where+ arbitrary = toIdeal . map QC.getNonZero . QC.getNonEmpty <$> arbitrary++instance (KnownNat n) => Arbitrary (ZeroDimIdeal n) where+ arbitrary = zeroDimG++instance (NA.Field (Coefficient poly),+ IsOrderedPolynomial poly,+ Reifies ideal (QIdeal poly),+ Arbitrary poly)+ => Arbitrary (Quotient poly ideal) where+ arbitrary = modIdeal <$> arbitrary++polyOfDim :: SNat n -> QC.Gen (Polynomial (Fraction Integer) n)+polyOfDim sn = withKnownNat sn arbitrary++newtype HomogPoly r ord n = HomogPoly { getHomogPoly :: OrderedPolynomial r ord n }++homogPolyOfDim :: SNat n -> QC.Gen (Polynomial (Fraction Integer) n)+homogPolyOfDim sn = withKnownNat sn $ getHomogPoly <$> arbitrary++idealOfDim :: SNat n -> QC.Gen (Ideal (Polynomial (Fraction Integer) n))+idealOfDim sn = withKnownNat sn arbitrary++quotOfDim :: (KnownNat n, Reifies ideal (QIdeal (OrderedPolynomial (Fraction Integer) Grevlex n)))+ => Proxy ideal -> QC.Gen (Quotient (OrderedPolynomial (Fraction Integer) Grevlex n) ideal)+quotOfDim _ = arbitrary++genLM :: forall n. SNat n -> QC.Gen [Polynomial (Fraction Integer) n]+genLM m = withKnownNat m $ case zeroOrSucc m of+ IsZero -> return []+ IsSucc n -> withKnownNat n $ do+ fs <- map (coerce (plusComm sOne n) . shiftR sOne) <$> genLM n+ QC.NonNegative deg <- arbitrary+ coef <- arbitraryRational `suchThat` (/= 0)+ xf <- arbitrary :: QC.Gen (Polynomial (Fraction Integer) n)+ let xlm = OrderedMonomial $ fromListWithDefault (sSucc n) 0 [deg + 1]+ f = xf & _Wrapped %~ M.insert xlm coef . M.filterWithKey (\k _ -> k < xlm)+ return $ f : fs++zeroDimOf :: SNat n -> QC.Gen (ZeroDimIdeal n)+zeroDimOf sn = withKnownNat sn $ do+ fs <- genLM sn+ i0 <- arbitrary+ return $ ZeroDimIdeal $ toIdeal $ fs ++ i0++zeroDimG :: forall n. (KnownNat n) => QC.Gen (ZeroDimIdeal n)+zeroDimG = do+ fs <- genLM (sing :: SNat n)+ i0 <- arbitrary+ return $ ZeroDimIdeal $ toIdeal $ fs ++ i0++arbitraryRational :: QC.Gen (Fraction Integer)+arbitraryRational = do+ a <- QC.arbitrarySizedIntegral+ b <- QC.arbitrarySizedIntegral+ `suchThat` \b -> gcd a b == 1 && b /= 0+ return $ a % abs b++isNonTrivial :: KnownNat n => ZeroDimIdeal n -> Bool+isNonTrivial (ZeroDimIdeal ideal) = reifyQuotient ideal $ maybe False ((>0).length) . standardMonomials'++data Equation = Equation { coefficients :: [[(Fraction Integer)]]+ , answers :: [(Fraction Integer)]+ } deriving (Show, Eq, Ord)++newtype MatrixCase a = MatrixCase { getMatrix :: [[a]]+ } deriving (Read, Show, Eq, Ord)++instance Arbitrary (Fraction Integer) where+ arbitrary = arbitraryRational++instance (Eq a, Num a, Arbitrary a) => Arbitrary (MatrixCase a) where+ arbitrary = flip suchThat (any (any (/= 0)) . getMatrix) $ sized $ \len -> do+ a <- resize len $ listOf1 arbitrary+ as <- listOf (vector $ length a)+ return $ MatrixCase $ a : as++instance Arbitrary Equation where+ arbitrary = do+ MatrixCase as <- arbitrary+ v <- vector $ length as+ return $ Equation as v++arbitrarySolvable :: Gen Equation+arbitrarySolvable = do+ MatrixCase as <- arbitrary+ v <- vector $ length $ head as+ return $ Equation as (V.toList $ M.getCol 1 $ M.fromLists as * M.colVector (V.fromList v))++liftSNat :: (forall n. KnownNat (n :: Nat) => Sing n -> Property) -> Integer -> Property+liftSNat f i =+ case M.promote i of+ Monomorphic sn -> withKnownNat sn $ f sn++unaryPoly :: SNat n -> Ordinal n -> Gen (Polynomial (Fraction Integer) n)+unaryPoly ar (OLt sm) = do+ f <- polyOfDim sOne+ withKnownNat ar $ withKnownNat (sm %:+ sOne) $+ return $ scastPolynomial ar $ shiftR sm f++checkForArity :: [Integer] -> (forall n. KnownNat (n :: Nat) => Sing n -> Property) -> Property+checkForArity as test = forAll (QC.elements as) $ liftSNat test++stdReduced :: (CoeffRing r, KnownNat n, NA.Field r, IsMonomialOrder n order)+ => [OrderedPolynomial r order n] -> [OrderedPolynomial r order n]+stdReduced ps = sortBy (comparing leadingMonomial) $+ map (\f -> injectCoeff (NA.recip $ leadingCoeff f) NA.* f) ps
+ tests/Faugere5Spec-disabled.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+module Faugere5Spec where+import Algebra.Algorithms.Faugere5+import Algebra.Algorithms.Groebner+import Algebra.Prelude (KnownNat, SNat, SingI (..), (%))+import Algebra.Ring.Ideal+import Algebra.Ring.Polynomial+import Data.List (sort)+import Numeric.Field.Fraction (Fraction)+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Utils++spec :: Spec+spec = do+ describe "f5Original" $ modifyMaxSize (const 10) $ modifyMaxSuccess (const 100) $ do+ it "computes Groebner basis for homogeneous ideals (regression)" $ do+ all (\i -> sort (calcGroebnerBasis i) == generators (f5Original i)) testCases+ it "computes Groebner basis for homogeneous ideals (random)" $ do+ checkForArity [2..3] prop_computesGroebner++prop_computesGroebner :: KnownNat n => SNat n -> Property+prop_computesGroebner sdim =+ forAll (sized $ \size -> vectorOf size (homogPolyOfDim sdim)) $ \ideal ->+ let answer = sort $ calcGroebnerBasis $ toIdeal ideal+ gs = generators $ f5Original $ toIdeal ideal+ in gs == answer++testCases :: [Ideal (OrderedPolynomial (Fraction Integer) Grevlex 3)]+testCases = map toIdeal+ [[-8%5 *x^2 + 2*x *y - 3%2 *y^2+ ,-1%2 *x^2 + 7%3 *x *y+ ,2%7 *x^3 + 1%7 *x^2 *y + 7%6 *x *y^2 + 5*y^3 - 3%4 *y *z^2+ ,5%8 *x^2 + 4%5 *y^2+ ,-4%5 *x^2 - 3%7 *y *z+ ,-3%7 *x^2 + 8*x *y - 3%4 *y^2 + 8%7 *x *z - 8%11 *z^2+ ,-4%5 *x^2 *z - 7%2 *x *z^2+ ,-3%5 *x^2 - 8%5 *x *y + 8%5 *y^2 + 2*y *z - 5%6 *z^2]+ {-+ ,[-3%4 *x *y + 1%2 *x *z - 3%2 *z^2+ ,3*x^3 - 2*x *y *z+ ,-1%4 *x^2 - 5*x *y + y^2 + 4%3 *x *z+ ,-4%5 *x^3 - 5%4 *x^2 *y + 4*y *z^2+ ,-2%3 *x^2 - 4%3 *y *z]+ -} -- this should converge (according to singular implementation),+ -- but seems not with my implementation...+ ,[4%5 *x^2 *y *z - 5%3 *x^2 *z^2+ ,5%2 *x^4 - 4%5 *x^3 *y+ ,3%5 *x^4 - 3%2 *x^2 *y^2 + 3%5 *x^2 *y *z + 3%5 *y *z^3+ ,-5%4 *x^3 - 4%3 *y^3 + 3%7 *y *z^2]+ ,[-5*x^3 *y + 3%2 *x^2 *z^2 - 5%4 *y^2 *z^2 + 5%4 *z^4+ ,4%5 *x^3 + 3*x *y^2 - 4*x^2 *z + 4%7 *y^2 *z+ ,-1%4 *x^4 - 4%3 *x^3 *y - x^2 *y *z+ ,-2%5 *x *y,-5%3 *x^3],+ [-2%5 *x^2 *z + 8%5 *x *z^2,-3*x^4 - y^4 + 7%4 *x *y^2 *z + 5%7 *x^2 *z^2 - 8*y^2 *z^2 - 3%5 *z^4,3%7 *x *y - 7%8 *x *z,-1%4 *x^2 + 6%7 *x *z + 2%9 *y *z + 2%7 *z^2,-1%6 *x^3 - 1%4 *x^2 *y - 8%3 *x *y *z + 8%5 *x *z^2,-6%5 *x *y^3 + 1%8 *x^3 *z + 1%7 *x^2 *y *z,7%4 *x^4 + 7%4 *x^2 *z^2,-1%6 *x^3 *y + 4%7 *x^2 *y *z]+ ,[x^2*z^2-5%6*y^2*z^2+5%6*z^4, x^3, x^2*z-1%7*y^2*z, x*y, y^3*z, y^2*z^2-35%29*z^4, y*z^4, x*z^4,z^6]]+ where+ [x,y,z] = vars+
+ tests/GroebnerSpec.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE DataKinds, ExplicitNamespaces, GADTs, PatternSynonyms #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+module GroebnerSpec where+import Algebra.Algorithms.Groebner+import Algebra.Internal (pattern (:<), KnownNat,+ pattern NilL, SNat)+import Algebra.Ring.Ideal+import Algebra.Ring.Polynomial+import Control.Monad+import qualified Data.Foldable as F+import Data.List (delete)+import qualified Data.Sized.Builtin as SV+import Data.Type.Monomorphic+import Numeric.Field.Fraction (Fraction)+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Utils++asGenListOf :: Gen [a] -> a -> Gen [a]+asGenListOf = const++spec :: Spec+spec = do+ describe "divModPolynomial" $ modifyMaxSize (const 25) $ modifyMaxSuccess (const 100) $ do+ prop "remainder cannot be diveided by any denoms (ternary)" $+ checkForArity [1..4] prop_indivisible+ prop "satisfies a_i f_i /= 0 ==> deg(f) >= deg (a_i f_i)" $+ checkForArity [1..4] prop_degdecay+ prop "divides correctly" $+ checkForArity [1..4] prop_divCorrect+ describe "calcGroebnerBasis" $ modifyMaxSize (const 4) $ modifyMaxSuccess (const 50) $ do+ prop "passes S-test" $+ checkForArity [2..3] prop_passesSTest+ prop "divides all original generators" $ do+ checkForArity [2..3] prop_groebnerDivsOrig+ it "generates the same ideal as original" $ do+ pendingWith "need example"+ it "contains the original ideal" $ checkForArity [1..3] $ \ari ->+ forAll (idealOfDim ari) $ \i ->+ forAll (vectorOf (length $ generators i) $ polyOfDim ari) $ \fs ->+ let f = sum $ zipWith (*) fs (generators i)+ gs = calcGroebnerBasis i+ in f `modPolynomial` gs == 0+ it "produces minimal basis" $ do+ checkForArity [2..3] prop_isMinimal+ it "produces reduced basis" $ do+ checkForArity [2..3] prop_isReduced+ describe "isIdealMember" $ do+ it "determins membership correctly" $ do+ pendingWith "need example"+ describe "intersection" $ modifyMaxSize (const 3) $ modifyMaxSuccess (const 50) $ do+ it "can calculate correctly" $ do+ checkForArity [2..3] prop_intersection+ it "can solve test-cases correctly" $ do+ forM_ ics_binary $ \(IC i j ans) ->+ intersection (toIdeal i :< toIdeal j :< NilL) `shouldBe` toIdeal ans++prop_intersection :: KnownNat n => SNat n -> Property+prop_intersection sdim =+ forAll (idealOfDim sdim) $ \ideal ->+ forAll (idealOfDim sdim) $ \jdeal ->+ forAll (polyOfDim sdim) $ \f ->+ (f `isIdealMember` ideal && f `isIdealMember` jdeal)+ == f `isIdealMember` (intersection $ ideal :< jdeal :< NilL)++prop_isMinimal :: KnownNat n => SNat n -> Property+prop_isMinimal sdim =+ forAll (idealOfDim sdim) $ \ideal ->+ let gs = calcGroebnerBasis ideal+ in all ((== 1) . leadingCoeff) gs &&+ all (\f -> all (\g -> not $ leadingMonomial g `divs` leadingMonomial f) (delete f gs)) gs++prop_isReduced :: KnownNat n => SNat n -> Property+prop_isReduced sdim =+ forAll (idealOfDim sdim) $ \ideal ->+ let gs = calcGroebnerBasis ideal+ in all ((== 1) . leadingCoeff) gs &&+ all (\f -> all (\g -> all (\(_, m) -> not $ leadingMonomial g `divs` m) $ getTerms f) (delete f gs)) gs++prop_passesSTest :: KnownNat n => SNat n -> Property+prop_passesSTest sdim =+ forAll (sized $ \size -> vectorOf size (polyOfDim sdim)) $ \ideal ->+ let gs = calcGroebnerBasis $ toIdeal ideal+ in all ((== 0) . (`modPolynomial` gs)) [sPolynomial f g | f <- gs, g <- gs, f /= g]++prop_groebnerDivsOrig :: KnownNat n => SNat n -> Property+prop_groebnerDivsOrig sdim =+ forAll (elements [3..15]) $ \count ->+ forAll (vectorOf count (polyOfDim sdim)) $ \ideal ->+ let gs = calcGroebnerBasis $ toIdeal ideal+ in all ((== 0) . (`modPolynomial` gs)) ideal++prop_divCorrect :: KnownNat n => SNat n -> Property+prop_divCorrect sdim =+ forAll (polyOfDim sdim) $ \poly ->+ forAll (idealOfDim sdim) $ \ideal ->+ let dvs = generators ideal+ (qds, r) = poly `divModPolynomial` dvs+ in poly == sum (map (uncurry (*)) qds) + r++prop_indivisible :: KnownNat n => SNat n -> Property+prop_indivisible sdim =+ forAll (polyOfDim sdim) $ \poly ->+ forAll (idealOfDim sdim) $ \ideal ->+ let dvs = generators ideal+ (_, r) = changeOrder Grevlex poly `divModPolynomial` dvs+ in r /= 0 ==> all (\f -> all (\(_, m) -> not $ leadingMonomial f `divs` m) $ getTerms r) dvs++prop_degdecay :: KnownNat n => SNat n -> Property+prop_degdecay sdim =+ forAll (polyOfDim sdim) $ \poly ->+ forAll (idealOfDim sdim) $ \ideal ->+ let dvs = generators ideal+ (qs, _) = poly `divModPolynomial` dvs+ in all (\(a, f) -> (a * f == 0) || (leadingMonomial poly >= leadingMonomial (a * f))) qs++data IntersectCase r ord n = IC [OrderedPolynomial r ord n] [OrderedPolynomial r ord n] [OrderedPolynomial r ord n]++ics_binary :: [IntersectCase (Fraction Integer) Grevlex 2]+ics_binary =+ let [x, y] = F.toList allVars+ in [IC [x*y] [y] [x*y]]
+ tests/PolynomialSpec.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+module PolynomialSpec where+import Algebra.Algorithms.Groebner+import Algebra.Algorithms.ZeroDim+import Algebra.Internal+import Algebra.Ring.Ideal+import Algebra.Ring.Polynomial+import qualified Data.Matrix as M+import Data.Type.Monomorphic+import qualified Data.Vector as V+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Utils++asGenListOf :: Gen [a] -> a -> Gen [a]+asGenListOf = const++spec :: Spec+spec = do+ return ()++prop_passesSTest :: SNat n -> Property+prop_passesSTest sdim = withKnownNat sdim $+ forAll (elements [3..15]) $ \count ->+ forAll (vectorOf count (polyOfDim sdim)) $ \ideal ->+ let gs = calcGroebnerBasis $ toIdeal ideal+ in all ((== 0) . (`modPolynomial` gs)) [sPolynomial f g | f <- gs, g <- gs, f /= g]++prop_groebnerDivsOrig :: SNat n -> Property+prop_groebnerDivsOrig sdim =+ withKnownNat sdim $+ forAll (elements [3..15]) $ \count ->+ forAll (vectorOf count (polyOfDim sdim)) $ \ideal ->+ let gs = calcGroebnerBasis $ toIdeal ideal+ in all ((== 0) . (`modPolynomial` gs)) ideal++prop_divCorrect :: SNat n -> Property+prop_divCorrect sdim =+ withKnownNat sdim $+ forAll (polyOfDim sdim) $ \poly ->+ forAll (idealOfDim sdim) $ \ideal ->+ let dvs = generators ideal+ (qds, r) = poly `divModPolynomial` dvs+ in poly == sum (map (uncurry (*)) qds) + r++prop_indivisible :: SNat n -> Property+prop_indivisible sdim =+ withKnownNat sdim $+ forAll (polyOfDim sdim) $ \poly ->+ forAll (idealOfDim sdim) $ \ideal ->+ let dvs = generators ideal+ (_, r) = changeOrder Grevlex poly `divModPolynomial` dvs+ in r /= 0 ==> all (\f -> all (\(_, m) -> not $ leadingMonomial f `divs` m) $ getTerms r) dvs++prop_degdecay :: SNat n -> Property+prop_degdecay sdim =+ withKnownNat sdim $+ forAll (polyOfDim sdim) $ \poly ->+ forAll (idealOfDim sdim) $ \ideal ->+ let dvs = generators ideal+ (qs, _) = poly `divModPolynomial` dvs+ in all (\(a, f) -> (a * f == 0) || (leadingMonomial poly >= leadingMonomial (a * f))) qs++rank :: (Ord r, Fractional r) => M.Matrix r -> Int+rank mat =+ let Just (u, _, _, _,_, _) = M.luDecomp' mat+ in V.foldr (\a acc -> if a /= 0 then acc + 1 else acc) (0 :: Int) $ M.getDiag u
+ tests/QuotientSpec.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+module QuotientSpec where+import Algebra.Algorithms.Groebner+import Algebra.Internal+import Algebra.Ring.Ideal+import Algebra.Ring.Polynomial+import Algebra.Ring.Polynomial.Quotient++import qualified Data.Matrix as M+import Data.Type.Monomorphic+import qualified Data.Vector as V+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Utils++asGenListOf :: Gen [a] -> a -> Gen [a]+asGenListOf = const++spec :: Spec+spec = do+ return ()++prop_passesSTest :: SNat n -> Property+prop_passesSTest sdim =+ withKnownNat sdim $+ forAll (elements [3..15]) $ \count ->+ forAll (vectorOf count (polyOfDim sdim)) $ \ideal ->+ let gs = calcGroebnerBasis $ toIdeal ideal+ in all ((== 0) . (`modPolynomial` gs)) [sPolynomial f g | f <- gs, g <- gs, f /= g]++prop_groebnerDivsOrig :: SNat n -> Property+prop_groebnerDivsOrig sdim =+ withKnownNat sdim $+ forAll (elements [3..15]) $ \count ->+ forAll (vectorOf count (polyOfDim sdim)) $ \ideal ->+ let gs = calcGroebnerBasis $ toIdeal ideal+ in all ((== 0) . (`modPolynomial` gs)) ideal++prop_divCorrect :: SNat n -> Property+prop_divCorrect sdim =+ withKnownNat sdim $+ forAll (polyOfDim sdim) $ \poly ->+ forAll (idealOfDim sdim) $ \ideal ->+ let dvs = generators ideal+ (qds, r) = poly `divModPolynomial` dvs+ in poly == sum (map (uncurry (*)) qds) + r++prop_indivisible :: SNat n -> Property+prop_indivisible sdim =+ withKnownNat sdim $+ forAll (polyOfDim sdim) $ \poly ->+ forAll (idealOfDim sdim) $ \ideal ->+ let dvs = generators ideal+ (_, r) = changeOrder Grevlex poly `divModPolynomial` dvs+ in r /= 0 ==> all (\f -> all (\(_, m) -> not $ leadingMonomial f `divs` m) $ getTerms r) dvs++prop_degdecay :: SNat n -> Property+prop_degdecay sdim =+ withKnownNat sdim $+ forAll (polyOfDim sdim) $ \poly ->+ forAll (idealOfDim sdim) $ \ideal ->+ let dvs = generators ideal+ (qs, _) = poly `divModPolynomial` dvs+ in all (\(a, f) -> (a * f == 0) || (leadingMonomial poly >= leadingMonomial (a * f))) qs++rank :: (Ord r, Fractional r) => M.Matrix r -> Int+rank mat =+ let Just (u, _, _, _,_, _) = M.luDecomp' mat+ in V.foldr (\a acc -> if a /= 0 then acc + 1 else acc) (0 :: Int) $ M.getDiag u
+ tests/SingularTest.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Main where+import Algebra.Algorithms.Groebner+import Algebra.Prelude+import Algebra.Ring.Ideal+import SingularBridge+import Test.QuickCheck+import Utils++main :: IO ()+main = quickCheck $ checkForArity [2..3] $ \sarity ->+ forAll (sized $ \size -> vectorOf (size+2) (homogPolyOfDim sarity)) $ \ideal ->+ let i = filter ((/= 0) . totalDegree' ) ideal+ in not (null i) ==> isGroebnerBasis (singIdealFun "basis_c" (toIdeal i))+
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tests/UnivariateSpec.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DataKinds, ExplicitNamespaces, GADTs, PatternSynonyms #-}+{-# OPTIONS_GHC -fno-warn-unused-imports -Wno-type-defaults #-}+module UnivariateSpec where+import Algebra.Algorithms.Groebner+import Algebra.Field.Finite+import Algebra.Internal (pattern (:<), KnownNat,+ pattern NilL, SNat)+import Algebra.Ring.Polynomial (OrderedPolynomial)+import Algebra.Ring.Polynomial.Univariate+import Control.Monad+import qualified Data.Foldable as F+import Data.List (delete)+import qualified Data.Sized.Builtin as SV+import Data.Type.Monomorphic+import Numeric.Decidable.Zero+import Numeric.Field.Fraction (Fraction)+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Utils++asGenListOf :: Gen [a] -> a -> Gen [a]+asGenListOf = const++toOP :: Unipol Integer -> OrderedPolynomial Integer Grevlex 1+toOP = injectVars++liftMult :: Unipol Integer -> Unipol Integer -> Unipol Integer+liftMult f g =+ let (f', g') = (toOP f, toOP g)+ in injectVars (f' * g')++spec :: Spec+spec = do+ describe "naiveMult" $ do+ prop "Works as expected" $ \f g ->+ (f `naiveMult` g) == (f `liftMult` g)+ describe "karatsuba" $ do+ prop "Works as expected" $ \f g ->+ (karatsuba f g) == (f `liftMult` g)+ describe "divModUnipolByMult" $ do+ prop "remainder has degree smaller than divisor" $ \f g ->+ (totalDegree' f > 0 && totalDegree' g > 0) ==>+ let (q, r) = divModUnipolByMult f (g :: Unipol (F 5))+ in totalDegree' r < totalDegree' g+ prop "divides correctly" $ \f g ->+ not (isZero g) ==>+ let (q, r) = divModUnipolByMult f (g :: Unipol (F 5))+ in q * g + r == f+ it "passes regression tests" $ do+ mapM_ (\((a,b),(c,d)) -> divModUnipolByMult a b `shouldBe` (c, d))+ divModUnipolCases+ describe "divModUnipol" $ do+ prop "remainder has degree smaller than divisor" $ \f g ->+ totalDegree' f > 0 && totalDegree' g > 0 ==>+ let (q, r) = divModUnipol f (g :: Unipol (F 5))+ in totalDegree' r < totalDegree' g+ prop "divides correctly" $ \f g ->+ not (isZero g) ==>+ let (q, r) = divModUnipol f (g :: Unipol (F 5))+ in q * g + r == f++divModUnipolCases :: [((Unipol (F 5), Unipol (F 5)), (Unipol (F 5), Unipol (F 5)))]+divModUnipolCases =+ [((3*x^57 + x^56 + x^55 + 2*x^52 + 2*x^51 + 4*x^50 + x^49 + 4*x^48 + 3*x^47 + 4*x^46 + 3*x^45 + 3*x^44 + 3*x^42 + 3*x^41 + x^40 + x^39 + 2*x^38 + 3*x^37 + x^36 + 2*x^35 + 4*x^34 + 3*x^33 + 4*x^32 + 3*x^31 + x^30 + 3*x^28 + x^26 + x^25 + 3*x^24 + x^22 + 4*x^21 + 3*x^20 + 2*x^19 + 4*x^18 + 4*x^17 + 2*x^16 + x^15 + 3*x^13 + 2*x^12 + x^11 + x^10 + 4*x^9 + 4*x^8 + 2*x^7 + x^6 + 2*x^5 + 4*x^4 + 2*x^3 + 2*x^2 + 3*x + 4, 3*x^19 +2*x^18 +4*x^17 +3*x^16 +4*x^13 +3*x^12 + x^11 +4*x^10 +2*x^8 +2*x^7 +2*x^6 +4*x^4 +2*x^3 +4*x^2 +3*x + 2),(x^38 +3*x^37 +2*x^36 +2*x^35 +3*x^34 +4*x^33 +4*x^32 +2*x^31 +2*x^30 +3*x^29 +2*x^28 +3*x^26 + x^25 + x^24 +3*x^23 +2*x^22 +2*x^20 +3*x^18 +2*x^17 +3*x^16 +4*x^15 + x^14 +4*x^13 +3*x^12 +2*x^11 +3*x^10 +2*x^9 +4*x^7 +3*x^5 +2*x^4 +3*x^3 +2*x^2 + x + 2,2*x^18 +4*x^17 +3*x^16 +2*x^15 +4*x^14 +4*x^12 +2*x^11 +4*x^10 +3*x^8 + x^6 +3*x^4 +2*x^3 +2*x^2))]+ where x = var 0
+ tests/ZeroDimSpec.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DataKinds, GADTs, RankNTypes, TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+module ZeroDimSpec where+import Algebra.Algorithms.Groebner+import Algebra.Algorithms.ZeroDim+import Algebra.Internal+import Algebra.Ring.Ideal+import Algebra.Ring.Polynomial+import Algebra.Ring.Polynomial.Quotient+import Algebra.Internal++import Control.Monad+import Control.Monad.Random+import Data.Complex+import Data.Convertible (convert)+import qualified Data.Matrix as M+import Data.Maybe+import Data.Type.Monomorphic+import Data.Type.Ordinal+import qualified Data.Vector as V+import qualified Data.Sized.Builtin as SV+import Numeric.Field.Fraction (Fraction, (%))+import SingularBridge+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck hiding (promote)+import Utils++asGenListOf :: Gen [a] -> a -> Gen [a]+asGenListOf = const++spec :: Spec+spec = parallel $ do+ describe "solveLinear" $ do+ it "solves data set correctly" $+ forM_ linSet $ \set ->+ solveLinear (M.fromLists $ inputMat set) (V.fromList $ inputVec set)+ `shouldBe` Just (V.fromList $ answer set)+ prop "solves any solvable cases" $+ forAll (resize 10 arbitrary) $ \(MatrixCase ms) ->+ let mat = M.fromLists ms :: M.Matrix (Fraction Integer)+ in rank mat == M.ncols mat ==>+ forAll (vector (length $ head ms)) $ \v ->+ let ans = M.getCol 1 $ mat * M.colVector (V.fromList v)+ in solveLinear mat ans == Just (V.fromList v)+ it "cannot solve unsolvable cases" $ do+ pendingWith "need example"+ describe "univPoly" $ modifyMaxSuccess (const 50) $ modifyMaxSize (const 4) $ do+ prop "produces elimination ideal's monic generator" $ do+ checkForArity [2..4] prop_univPoly+ describe "radical" $ do+ it "really computes radical" $ do+ pendingWith "We can verify correctness by comparing with singular, but it's not quite smart way..."+{-+ checkForArity [2..4] $ \sdim ->+ forAll (zeroDimOf sdim) $ \(ZeroDimIdeal ideal) ->+ stdReduced (generators $ radical ideal) == calcGroebnerBasis (singIdealFun "radical" ideal)+ -- pendingWith "I couldn't formulate the spec for radical without existentials :-("+-}+ describe "fglm" $ modifyMaxSuccess (const 25) $ modifyMaxSize (const 3) $ do+ prop "computes monomial basis" $+ checkForArity [2..4] $ \sdim ->+ case zeroOrSucc sdim of+ IsZero -> error "impossible"+ IsSucc k ->+ withWitness (lneqSucc k) $ withWitness (lneqZero k) $+ withKnownNat k $+ forAll (zeroDimOf sdim) $ \(ZeroDimIdeal ideal) ->+ let base =+ reifyQuotient (mapIdeal (changeOrder Lex) ideal) $ \ii ->+ map quotRepr $ fromJust $ standardMonomials' ii+ in stdReduced (snd $ fglm ideal) == stdReduced base+ prop "computes lex base" $ do+ checkForArity [2..4] $ \sdim ->+ case zeroOrSucc sdim of+ IsZero -> error "impossible"+ IsSucc k -> withKnownNat k $+ withWitness (lneqSucc k) $+ withWitness (lneqZero k) $+ forAll (zeroDimOf sdim) $ \(ZeroDimIdeal ideal) ->+ stdReduced (fst $ fglm ideal)+ == stdReduced (calcGroebnerBasisWith Lex ideal)+ prop "returns lex base in descending order" $+ checkForArity [2..4] $ \sdim ->+ case zeroOrSucc sdim of+ IsZero -> error "impossible"+ IsSucc k -> withKnownNat k $+ case (lneqSucc k, lneqZero k) of+ (Witness, Witness) ->+ forAll (zeroDimOf sdim) $ \(ZeroDimIdeal ideal) ->+ isDescending (map leadingMonomial $ fst $ fglm ideal)+ describe "solve'" $ modifyMaxSuccess (const 50) $ modifyMaxSize (const 4) $ do+ it "solves equation with admissible error" $ do+ checkForArity [2..4] $ prop_isApproximateZero 1e-10 (solve' 1e-10)+ -- describe "solve''" $ modifyMaxSuccess (const 50) $ modifyMaxSize (const 4) $ do+ -- it "solves equation with admissible error" $ do+ -- checkForArity [2..4] $ prop_isApproximateZero 1e-5 (solve'' 1e-10)+ describe "solveViaCompanion" $ modifyMaxSuccess (const 50) $ modifyMaxSize (const 4) $ do+ it "solves equation with admissible error" $ do+ checkForArity [2..4] $ prop_isApproximateZero 1e-5 (solveViaCompanion 1e-10)+ describe "solveM" $ modifyMaxSuccess (const 50) $ modifyMaxSize (const 4) $ do+ prop "solves equation with admissible error" $ \seed ->+ let gen = mkStdGen seed+ in checkForArity [2..4] $ prop_isApproximateZero 1e-10 (\t -> evalRand (solveM t) gen)++isDescending :: Ord a => [a] -> Bool+isDescending xs = and $ zipWith (>=) xs (drop 1 xs)++prop_isApproximateZero :: KnownNat n+ => Double+ -> (forall m. ((0 :< m) ~ 'True, KnownNat m) =>+ Ideal (Polynomial (Fraction Integer) m) -> [Sized m (Complex Double)])+ -> SNat n -> Property+prop_isApproximateZero err solver sn =+ case zeroOrSucc sn of+ IsSucc k -> withKnownNat k $ forAll (zeroDimOf sn) $ \(ZeroDimIdeal ideal) ->+ (case lneqZero k of+ Witness ->+ let anss = solver ideal+ mul r d = convert r * d+ in all (\as -> all ((<err) . magnitude . substWith mul as) $ generators ideal) anss) :: Bool++prop_univPoly :: KnownNat n => SNat n -> Property+prop_univPoly sdim =+ forAll (zeroDimOf sdim) $ \(ZeroDimIdeal ideal) ->+ let ods = enumOrdinal sdim+ in conjoin $ flip map ods $ \nth ->+ let gen = univPoly nth ideal+ in forAll (unaryPoly sdim nth) $ \f ->+ (f `modPolynomial` [gen] == 0) == (f `isIdealMember` ideal)++rank :: (Ord r, Fractional r) => M.Matrix r -> Int+rank mat =+ let Just (u, _, _, _,_, _) = M.luDecomp' mat+ in V.foldr (\a acc -> if a /= 0 then acc + 1 else acc) (0 :: Int) $ M.getDiag u++data TestSet = TestSet { inputMat :: [[Fraction Integer]]+ , inputVec :: [Fraction Integer]+ , answer :: [Fraction Integer]+ } deriving (Show, Eq, Ord)++linSet :: [TestSet]+linSet =+ [TestSet+ [[1 ,0 ,0 ,0 ,0 ]+ ,[0 ,(-2) ,(-2) ,(-2) ,(-2) ]+ ,[0 ,0 ,3 % 2,0 ,(-1) % 2]+ ,[0 ,0 ,0 ,0 ,(-5) % 2]+ ,[0 ,1 ,1 ,1 ,1 ]+ ,[0 ,0 ,(-2) ,1 ,(-1) ]+ ]+ [0 ,(-2) ,19 % 5,14 % 5,1 ,0 ]+ [0 ,(-81) % 25,54 % 25,16 % 5,(-28) % 25]+ ]+
+ tests/division.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+module Main where+import Algebra.Algorithms.Groebner+import Algebra.Ring.Ideal+import Algebra.Ring.Polynomial+import Data.Type.Monomorphic+import Data.Type.Natural hiding (one, promote, zero)+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck hiding (promote)+import Utils++main :: IO ()+main = hspec $ do+ describe "divModPolynomial'" $ do+ prop "quotient cannot be diveided by any denoms (ternary)" $+ checkForArity [3] prop_indivisible+ prop "satisfies a_i f_i /= 0 ==> deg(f) >= deg (a_i f_i)" $+ checkForArity [3] prop_degdecay+ prop "divides correctly" $+ checkForArity [3] prop_divCorrect++prop_divCorrect :: SingI n => SNat n -> Property+prop_divCorrect sdim =+ forAll (polyOfDim sdim) $ \poly ->+ forAll (idealOfDim sdim) $ \ideal ->+ let dvs = take 5 $ generators ideal+ (qds, r) = poly `divModPolynomial'` dvs+ in poly == sum (map (uncurry (*)) qds) + r++prop_indivisible :: SingI n => SNat n -> Property+prop_indivisible sdim =+ forAll (polyOfDim sdim) $ \poly ->+ forAll (idealOfDim sdim) $ \ideal ->+ let dvs = take 5 $ generators ideal+ (_, r) = changeOrder Grevlex poly `divModPolynomial'` dvs+ in r /= 0 ==> all (\f -> all (\(_, m) -> not $ leadingMonomial f `divs` m) $ getTerms r) dvs++prop_degdecay :: SingI n => SNat n -> Property+prop_degdecay sdim =+ forAll (polyOfDim sdim) $ \poly ->+ forAll (idealOfDim sdim) $ \ideal ->+ let dvs = take 5 $ generators ideal+ (qs, _) = poly `divModPolynomial'` dvs+ in all (\(a, f) -> (a * f == 0) || (leadingMonomial poly >= leadingMonomial (a * f))) qs
+ tests/linear.hs view
@@ -0,0 +1,33 @@+module Main where+import qualified Data.Matrix as M+import qualified Data.Vector as V+import Numeric.Field.Fraction (Fraction)+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Utils++main :: IO ()+main = hspec $ do+ describe "luDecomp'" $ do+ prop "works correctly" $ prop_luDecomp+ return ()++prop_luDecomp :: Property+prop_luDecomp = forAll (resize 10 arbitrary) $ \(MatrixCase ms) ->+ let m = M.fromLists ms :: M.Matrix (Fraction Integer)+ Just (u,l,p,q,_,_) = M.luDecomp' m+ in collect (minimum $ map (minimum . map abs) ms) $ collect (M.ncols m, M.nrows m) $+ p * m * q == l * u && isUpperTriangle u && isLowerTriangle l && M.diagProd l == 1++isLowerTriangle :: (Num r, Eq r) => M.Matrix r -> Bool+isLowerTriangle m = all (\i -> all (\j -> m M.! (i, j) == 0) [i+1..M.ncols m]) [1..M.nrows m]++isUpperTriangle :: (Num r, Eq r) => M.Matrix r -> Bool+isUpperTriangle m = all (\i -> all (\j -> m M.! (i, j) == 0) [1..min (i-1) (M.ncols m)]) [1..M.nrows m]++rank :: (Eq r, Num r, Ord r, Fractional r) => M.Matrix r -> Int+rank mat =+ let Just (u, _, _, _,_, _) = M.luDecomp' mat+ in V.foldr (\a acc -> if a /= 0 then acc + 1 else acc) (0 :: Int) $ M.getDiag u+
+ tests/matrix.hs view
@@ -0,0 +1,28 @@+module Main where+import Algebra.Algorithms.ZeroDim+import Algebra.Ring.Polynomial.Quotient+import qualified Data.Matrix as M+import Data.Type.Monomorphic (liftPoly)+import Data.Type.Natural+import qualified Data.Vector as V+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Utils++main :: IO ()+main = hspec $ do+ describe "matRepr'" $ do+ prop "coincids with matrixRep" $ checkForArity [1..3] prop_matrixRep+ return ()++prop_matrixRep :: SingI n => SNat n -> Property+prop_matrixRep sn =+ forAll arbitrary $ \(ZeroDimIdeal ideal) ->+ forAll (polyOfDim sn) $ \poly ->+ reifyQuotient ideal $ \pxy ->+ let f = modIdeal' pxy poly+ in matrixRep f == matToLists (matRepr' f)++matToLists :: M.Matrix a -> [[a]]+matToLists mat = [ V.toList $ M.getRow i mat | i <- [1..M.nrows mat] ]
+ tests/monomials.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE NoMonomorphismRestriction, RankNTypes, ViewPatterns #-}+module Main where+import qualified Algebra.Ring.Polynomial as P+import Data.Type.Monomorphic+import qualified HspecSmallCheck as SC+import qualified SequenceMonomial as S+import Test.Hspec+import qualified Test.Hspec.QuickCheck as QC+import qualified Test.QuickCheck as QC+import qualified Test.SmallCheck as SC+import qualified Test.SmallCheck.Series as SC++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "Monomial orderings" $ do+ QC.prop "coincides on lex (random)" $ compQC P.lex S.lex+ QC.prop "coincides on revlex (random)" $ compQC P.revlex S.revlex+ QC.prop "coincides on grlex (random)" $ compQC P.grlex S.grlex+ QC.prop "coincides on grevlex (random)" $ compQC P.grevlex S.grevlex+ it "coincides on lex (exhaustive)" $ SC.property $ compSC P.lex S.lex+ it "coincides on revlex (exhaustive)" $ SC.property $ compSC P.revlex S.revlex+ it "coincides on grlex (exhaustive)" $ SC.property $ compSC P.grlex S.grlex+ it "coincides on grevlex (exhaustive)" $ SC.property $ compSC P.grevlex S.grevlex++compQC :: P.MonomialOrder -> S.MonomialOrder -> QC.Property+compQC pol sq =+ QC.forAll (QC.listOf $ QC.resize 100 QC.arbitrarySizedBoundedIntegral) $ \m1 ->+ QC.forAll (QC.listOf $ QC.resize 100 QC.arbitrarySizedBoundedIntegral) $ \m2 ->+ let len = max (length m1) (length m2)+ n1 = m1 ++ replicate (len - length m1) 0 :: [Int]+ n2 = m2 ++ replicate (len - length m2) 0 :: [Int]+ in withPolymorhic len $ \sn ->+ pol (P.fromList sn $ map fromIntegral n1) (P.fromList sn $ map fromIntegral n2)+ == sq (S.fromList $ map fromIntegral n1) (S.fromList $ map fromIntegral n2)++compSC :: Monad m => P.MonomialOrder -> S.MonomialOrder -> SC.Property m+compSC pol sq =+ SC.forAll $ \(map (fromIntegral . SC.getNonNegative) -> m1) (map (fromIntegral . SC.getNonNegative) -> m2) ->+ let len = max (length m1) (length m2)+ n1 = m1 ++ replicate (len - length m1) 0+ n2 = m2 ++ replicate (len - length m2) 0+ in withPolymorhic len $ \sn ->+ pol (P.fromList sn n1) (P.fromList sn n2) == sq (S.fromList n1) (S.fromList n2)+
+ tests/multi-table.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE DataKinds, NoMonomorphismRestriction, OverloadedStrings #-}+module Main where+import Algebra.Ring.Ideal+import Algebra.Ring.Polynomial+import Algebra.Ring.Polynomial.Quotient+import Data.Type.Natural+import Test.Hspec+import qualified Test.Hspec.QuickCheck as QC+import Test.QuickCheck (Arbitrary (..))+import qualified Test.QuickCheck as QC+import Utils++main :: IO ()+main = hspec spec++i1 :: Ideal (OrderedPolynomial (Fraction Integer) Lex Two)+i1 = toIdeal []++spec :: Spec+spec = do+ describe "Table multiplication" $ do+ it "coincides with ordinary multiplication" $ QC.property prop01++prop01 :: QC.Property+prop01 =+ QC.forAll (QC.resize 4 arbitrary `QC.suchThat` isNonTrivial) $ \(ZeroDimIdeal ideal) ->+ QC.forAll (QC.resize 6 $ polyOfDim sThree) $ \f -> QC.forAll (QC.resize 6 $ polyOfDim sThree) $ \g ->+ withQuotient ideal (modIdeal f * modIdeal g)+ == withQuotient ideal (multWithTable (modIdeal f) (modIdeal g))