diff --git a/Algebra/Algorithms/ChineseRemainder.hs b/Algebra/Algorithms/ChineseRemainder.hs new file mode 100644 --- /dev/null +++ b/Algebra/Algorithms/ChineseRemainder.hs @@ -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 + diff --git a/Algebra/Algorithms/FGLM.hs b/Algebra/Algorithms/FGLM.hs new file mode 100644 --- /dev/null +++ b/Algebra/Algorithms/FGLM.hs @@ -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) diff --git a/Algebra/Algorithms/Groebner.hs b/Algebra/Algorithms/Groebner.hs --- a/Algebra/Algorithms/Groebner.hs +++ b/Algebra/Algorithms/Groebner.hs @@ -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] diff --git a/Algebra/Algorithms/Groebner/Monomorphic.hs b/Algebra/Algorithms/Groebner/Monomorphic.hs deleted file mode 100644 --- a/Algebra/Algorithms/Groebner/Monomorphic.hs +++ /dev/null @@ -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 diff --git a/Algebra/Algorithms/PrimeTest.hs b/Algebra/Algorithms/PrimeTest.hs new file mode 100644 --- /dev/null +++ b/Algebra/Algorithms/PrimeTest.hs @@ -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 + diff --git a/Algebra/Algorithms/ZeroDim.hs b/Algebra/Algorithms/ZeroDim.hs new file mode 100644 --- /dev/null +++ b/Algebra/Algorithms/ZeroDim.hs @@ -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 (( 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!" diff --git a/Algebra/Field/AlgebraicReal.hs b/Algebra/Field/AlgebraicReal.hs new file mode 100644 --- /dev/null +++ b/Algebra/Field/AlgebraicReal.hs @@ -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 diff --git a/Algebra/Field/Finite.hs b/Algebra/Field/Finite.hs new file mode 100644 --- /dev/null +++ b/Algebra/Field/Finite.hs @@ -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' #-} diff --git a/Algebra/Field/Galois.hs b/Algebra/Field/Galois.hs new file mode 100644 --- /dev/null +++ b/Algebra/Field/Galois.hs @@ -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 diff --git a/Algebra/Field/Galois/Conway.hs b/Algebra/Field/Galois/Conway.hs new file mode 100644 --- /dev/null +++ b/Algebra/Field/Galois/Conway.hs @@ -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 +-- . +conwayFile :: FilePath -> DecsQ +conwayFile fp = do + dat <- tail . init . lines <$> runIO (readFile fp) + addConwayPolynomials $ concatMap parseLine dat diff --git a/Algebra/Field/Galois/Internal.hs b/Algebra/Field/Galois/Internal.hs new file mode 100644 --- /dev/null +++ b/Algebra/Field/Galois/Internal.hs @@ -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 #-} + |] diff --git a/Algebra/Instances.hs b/Algebra/Instances.hs new file mode 100644 --- /dev/null +++ b/Algebra/Instances.hs @@ -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 diff --git a/Algebra/Internal.hs b/Algebra/Internal.hs --- a/Algebra/Internal.hs +++ b/Algebra/Internal.hs @@ -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 diff --git a/Algebra/LinkedMatrix.hs b/Algebra/LinkedMatrix.hs new file mode 100644 --- /dev/null +++ b/Algebra/LinkedMatrix.hs @@ -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) diff --git a/Algebra/Matrix.hs b/Algebra/Matrix.hs new file mode 100644 --- /dev/null +++ b/Algebra/Matrix.hs @@ -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 .) diff --git a/Algebra/Normed.hs b/Algebra/Normed.hs new file mode 100644 --- /dev/null +++ b/Algebra/Normed.hs @@ -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) diff --git a/Algebra/Prelude.hs b/Algebra/Prelude.hs new file mode 100644 --- /dev/null +++ b/Algebra/Prelude.hs @@ -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 diff --git a/Algebra/Prelude/Core.hs b/Algebra/Prelude/Core.hs new file mode 100644 --- /dev/null +++ b/Algebra/Prelude/Core.hs @@ -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 diff --git a/Algebra/Ring/Ideal.hs b/Algebra/Ring/Ideal.hs new file mode 100644 --- /dev/null +++ b/Algebra/Ring/Ideal.hs @@ -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 diff --git a/Algebra/Ring/Noetherian.hs b/Algebra/Ring/Noetherian.hs deleted file mode 100644 --- a/Algebra/Ring/Noetherian.hs +++ /dev/null @@ -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 diff --git a/Algebra/Ring/Polynomial.hs b/Algebra/Ring/Polynomial.hs --- a/Algebra/Ring/Polynomial.hs +++ b/Algebra/Ring/Polynomial.hs @@ -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) diff --git a/Algebra/Ring/Polynomial/Class.hs b/Algebra/Ring/Polynomial/Class.hs new file mode 100644 --- /dev/null +++ b/Algebra/Ring/Polynomial/Class.hs @@ -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` diff --git a/Algebra/Ring/Polynomial/Factorise.hs b/Algebra/Ring/Polynomial/Factorise.hs new file mode 100644 --- /dev/null +++ b/Algebra/Ring/Polynomial/Factorise.hs @@ -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 diff --git a/Algebra/Ring/Polynomial/Labeled.hs b/Algebra/Ring/Polynomial/Labeled.hs new file mode 100644 --- /dev/null +++ b/Algebra/Ring/Polynomial/Labeled.hs @@ -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' #-} diff --git a/Algebra/Ring/Polynomial/Monomial.hs b/Algebra/Ring/Polynomial/Monomial.hs new file mode 100644 --- /dev/null +++ b/Algebra/Ring/Polynomial/Monomial.hs @@ -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 #-} diff --git a/Algebra/Ring/Polynomial/Monomorphic.hs b/Algebra/Ring/Polynomial/Monomorphic.hs deleted file mode 100644 --- a/Algebra/Ring/Polynomial/Monomorphic.hs +++ /dev/null @@ -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 diff --git a/Algebra/Ring/Polynomial/Parser.hs b/Algebra/Ring/Polynomial/Parser.hs deleted file mode 100644 --- a/Algebra/Ring/Polynomial/Parser.hs +++ /dev/null @@ -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" diff --git a/Algebra/Ring/Polynomial/Quotient.hs b/Algebra/Ring/Polynomial/Quotient.hs new file mode 100644 --- /dev/null +++ b/Algebra/Ring/Polynomial/Quotient.hs @@ -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 #-} diff --git a/Algebra/Ring/Polynomial/Univariate.hs b/Algebra/Ring/Polynomial/Univariate.hs new file mode 100644 --- /dev/null +++ b/Algebra/Ring/Polynomial/Univariate.hs @@ -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 diff --git a/Algebra/Scalar.hs b/Algebra/Scalar.hs new file mode 100644 --- /dev/null +++ b/Algebra/Scalar.hs @@ -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 diff --git a/Monomorphic.hs b/Monomorphic.hs deleted file mode 100644 --- a/Monomorphic.hs +++ /dev/null @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,47 +1,57 @@ Computational Algebra Library ============================== +[![Build Status](https://travis-ci.org/konn/computational-algebra.png?branch=master)](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/) diff --git a/bench/SingularBench.hs b/bench/SingularBench.hs new file mode 100644 --- /dev/null +++ b/bench/SingularBench.hs @@ -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 + diff --git a/bench/bench.hs b/bench/bench.hs new file mode 100644 --- /dev/null +++ b/bench/bench.hs @@ -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) + ] + ] diff --git a/bench/coercion.hs b/bench/coercion.hs new file mode 100644 --- /dev/null +++ b/bench/coercion.hs @@ -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 + ] + ] diff --git a/bench/division.hs b/bench/division.hs new file mode 100644 --- /dev/null +++ b/bench/division.hs @@ -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, ( 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 +-} diff --git a/bench/elimination-bench.hs b/bench/elimination-bench.hs new file mode 100644 --- /dev/null +++ b/bench/elimination-bench.hs @@ -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 + ] + diff --git a/bench/faugere4.hs b/bench/faugere4.hs new file mode 100644 --- /dev/null +++ b/bench/faugere4.hs @@ -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) + ] + ] diff --git a/bench/linear.hs b/bench/linear.hs new file mode 100644 --- /dev/null +++ b/bench/linear.hs @@ -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 + ] diff --git a/bench/monomials.hs b/bench/monomials.hs new file mode 100644 --- /dev/null +++ b/bench/monomials.hs @@ -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' + ] diff --git a/bench/quotient-bench-randomized.hs b/bench/quotient-bench-randomized.hs new file mode 100644 --- /dev/null +++ b/bench/quotient-bench-randomized.hs @@ -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 + ] diff --git a/bench/solve.hs b/bench/solve.hs new file mode 100644 --- /dev/null +++ b/bench/solve.hs @@ -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' diff --git a/bench/sugar-bench.hs b/bench/sugar-bench.hs new file mode 100644 --- /dev/null +++ b/bench/sugar-bench.hs @@ -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] + ] + diff --git a/bench/sugar-paper.hs b/bench/sugar-paper.hs new file mode 100644 --- /dev/null +++ b/bench/sugar-paper.hs @@ -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] + diff --git a/bench/sugar.hs b/bench/sugar.hs new file mode 100644 --- /dev/null +++ b/bench/sugar.hs @@ -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) + ] + ] diff --git a/bench/unipol-bench.hs b/bench/unipol-bench.hs new file mode 100644 --- /dev/null +++ b/bench/unipol-bench.hs @@ -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] diff --git a/bench/unipol-div.hs b/bench/unipol-div.hs new file mode 100644 --- /dev/null +++ b/bench/unipol-div.hs @@ -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)] + ] + ] diff --git a/bench/unipol-mult.hs b/bench/unipol-mult.hs new file mode 100644 --- /dev/null +++ b/bench/unipol-mult.hs @@ -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)] + ] + ] diff --git a/computational-algebra.cabal b/computational-algebra.cabal --- a/computational-algebra.cabal +++ b/computational-algebra.cabal @@ -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 diff --git a/data/conway.txt b/data/conway.txt new file mode 100644 --- /dev/null +++ b/data/conway.txt @@ -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]; diff --git a/examples/algebraic.hs b/examples/algebraic.hs new file mode 100644 --- /dev/null +++ b/examples/algebraic.hs @@ -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 diff --git a/examples/bench.hs b/examples/bench.hs deleted file mode 100644 --- a/examples/bench.hs +++ /dev/null @@ -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) - ] - ] diff --git a/examples/elimination-bench.hs b/examples/elimination-bench.hs deleted file mode 100644 --- a/examples/elimination-bench.hs +++ /dev/null @@ -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 - ] - diff --git a/examples/faugere-prof.hs b/examples/faugere-prof.hs new file mode 100644 --- /dev/null +++ b/examples/faugere-prof.hs @@ -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 diff --git a/examples/groebner-prof.hs b/examples/groebner-prof.hs new file mode 100644 --- /dev/null +++ b/examples/groebner-prof.hs @@ -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 () diff --git a/examples/hensel-prof.hs b/examples/hensel-prof.hs new file mode 100644 --- /dev/null +++ b/examples/hensel-prof.hs @@ -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] + ] diff --git a/examples/ipsolve.hs b/examples/ipsolve.hs new file mode 100644 --- /dev/null +++ b/examples/ipsolve.hs @@ -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 diff --git a/examples/monomorphic.hs b/examples/monomorphic.hs --- a/examples/monomorphic.hs +++ b/examples/monomorphic.hs @@ -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 (..), (*), diff --git a/examples/poly-02.hs b/examples/poly-02.hs deleted file mode 100644 --- a/examples/poly-02.hs +++ /dev/null @@ -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] diff --git a/examples/polymorphic.hs b/examples/polymorphic.hs --- a/examples/polymorphic.hs +++ b/examples/polymorphic.hs @@ -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 diff --git a/examples/quotient.hs b/examples/quotient.hs new file mode 100644 --- /dev/null +++ b/examples/quotient.hs @@ -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 diff --git a/examples/sandpit-poly.hs b/examples/sandpit-poly.hs --- a/examples/sandpit-poly.hs +++ b/examples/sandpit-poly.hs @@ -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 + + + + + + + diff --git a/examples/sandpit.hs b/examples/sandpit.hs deleted file mode 100644 --- a/examples/sandpit.hs +++ /dev/null @@ -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] diff --git a/examples/site-example.hs b/examples/site-example.hs new file mode 100644 --- /dev/null +++ b/examples/site-example.hs @@ -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! diff --git a/examples/solve.hs b/examples/solve.hs new file mode 100644 --- /dev/null +++ b/examples/solve.hs @@ -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 ((> 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 diff --git a/examples/sugar-bench.hs b/examples/sugar-bench.hs deleted file mode 100644 --- a/examples/sugar-bench.hs +++ /dev/null @@ -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] - ] - diff --git a/examples/sugar-paper.hs b/examples/sugar-paper.hs deleted file mode 100644 --- a/examples/sugar-paper.hs +++ /dev/null @@ -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] - diff --git a/examples/sugar.hs b/examples/sugar.hs deleted file mode 100644 --- a/examples/sugar.hs +++ /dev/null @@ -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) - ] - ] diff --git a/share/HspecSmallCheck.hs b/share/HspecSmallCheck.hs new file mode 100644 --- /dev/null +++ b/share/HspecSmallCheck.hs @@ -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 diff --git a/share/SequenceMonomial.hs b/share/SequenceMonomial.hs new file mode 100644 --- /dev/null +++ b/share/SequenceMonomial.hs @@ -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 #-} diff --git a/share/SingularBridge.hs b/share/SingularBridge.hs new file mode 100644 --- /dev/null +++ b/share/SingularBridge.hs @@ -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 diff --git a/share/Utils.hs b/share/Utils.hs new file mode 100644 --- /dev/null +++ b/share/Utils.hs @@ -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 diff --git a/tests/Faugere5Spec-disabled.hs b/tests/Faugere5Spec-disabled.hs new file mode 100644 --- /dev/null +++ b/tests/Faugere5Spec-disabled.hs @@ -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 + diff --git a/tests/GroebnerSpec.hs b/tests/GroebnerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/GroebnerSpec.hs @@ -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]] diff --git a/tests/PolynomialSpec.hs b/tests/PolynomialSpec.hs new file mode 100644 --- /dev/null +++ b/tests/PolynomialSpec.hs @@ -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 diff --git a/tests/QuotientSpec.hs b/tests/QuotientSpec.hs new file mode 100644 --- /dev/null +++ b/tests/QuotientSpec.hs @@ -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 diff --git a/tests/SingularTest.hs b/tests/SingularTest.hs new file mode 100644 --- /dev/null +++ b/tests/SingularTest.hs @@ -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)) + diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/UnivariateSpec.hs b/tests/UnivariateSpec.hs new file mode 100644 --- /dev/null +++ b/tests/UnivariateSpec.hs @@ -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 diff --git a/tests/ZeroDimSpec.hs b/tests/ZeroDimSpec.hs new file mode 100644 --- /dev/null +++ b/tests/ZeroDimSpec.hs @@ -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 (( 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] + ] + diff --git a/tests/division.hs b/tests/division.hs new file mode 100644 --- /dev/null +++ b/tests/division.hs @@ -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 diff --git a/tests/linear.hs b/tests/linear.hs new file mode 100644 --- /dev/null +++ b/tests/linear.hs @@ -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 + diff --git a/tests/matrix.hs b/tests/matrix.hs new file mode 100644 --- /dev/null +++ b/tests/matrix.hs @@ -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] ] diff --git a/tests/monomials.hs b/tests/monomials.hs new file mode 100644 --- /dev/null +++ b/tests/monomials.hs @@ -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) + diff --git a/tests/multi-table.hs b/tests/multi-table.hs new file mode 100644 --- /dev/null +++ b/tests/multi-table.hs @@ -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))