packages feed

polynom (empty) → 0.1.0.0

raw patch · 7 files changed

+224/−0 lines, 7 filesdep +algebradep +basedep +base-unicode-symbolssetup-changed

Dependencies added: algebra, base, base-unicode-symbols, clist, containers, peano, smallcheck, tasty, tasty-smallcheck, transformers

Files

+ Data/Polynom.hs view
@@ -0,0 +1,3 @@+module Data.Polynom (Polynom, fromList, degree, content, primPart, formalDiff) where++import Data.Polynom.Impl
+ Data/Polynom/Impl.hs view
@@ -0,0 +1,93 @@+module Data.Polynom.Impl where++import Control.Applicative+import Control.Category.Unicode+import Data.Bool+import Data.Foldable (Foldable (foldr), all)+import Data.Function (($), on)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Monoid+import Data.Ord+import Data.Traversable+import Numeric.Algebra+import Numeric.Decidable.Zero+import Numeric.Domain.Euclidean hiding (degree)+import Numeric.Partial.Group+import Numeric.Semiring.Integral+import Util++-- | Polynomial in monomial exponents @α@ over coefficients @a@+newtype Polynom α a = Polynom (Map α a)++instance (Ord α, Monoidal a) => Additive (Polynom α a) where+    Polynom as + Polynom bs = Polynom (Map.unionWith (+) as bs)++instance (Ord α, Monoidal a, Abelian a) => Abelian (Polynom α a)++instance (Ord α, Monoidal a, Idempotent a) => Idempotent (Polynom α a)++instance {-# INCOHERENT #-} (Ord α, Monoidal a, Semiring a) => LeftModule a (Polynom α a) where+    n .* Polynom cs = Polynom ((n *) <$> cs)++instance {-# INCOHERENT #-} (Ord α, Monoidal a, Semiring a) => RightModule a (Polynom α a) where+    Polynom cs *. n = Polynom ((n *) <$> cs)++instance {-# INCOHERENT #-} (Ord α, Monoidal a, LeftModule b a) => LeftModule b (Polynom α a) where+    n .* Polynom cs = Polynom ((n .*) <$> cs)++instance {-# INCOHERENT #-} (Ord α, Monoidal a, RightModule b a) => RightModule b (Polynom α a) where+    Polynom cs *. n = Polynom ((*. n) <$> cs)++instance (Ord α, Monoidal a) => Monoidal (Polynom α a) where+    zero = Polynom Map.empty++instance (Ord α, Group a) => Group (Polynom α a) where+    negate (Polynom cs) = Polynom (negate <$> cs)++instance (Ord α, Semigroup α, Monoidal a, Semiring a) => Multiplicative (Polynom α a) where+    Polynom as * Polynom bs = fromList $+        (liftA2 (\ (α, a) (β, b) -> (α<>β, a*b)) `on` Map.assocs) as bs++instance (Ord α, Semigroup α, Abelian α, Monoidal a, Commutative a, Semiring a) => Commutative (Polynom α a)++instance (Ord α, Monoid α, Monoidal a, Unital a, Semiring a) => Unital (Polynom α a) where+    one = Polynom (Map.singleton mempty one)++instance (Ord α, DecidableZero a) => DecidableZero (Polynom α a) where+    isZero (Polynom cs) = all isZero cs++instance (Ord α, Semigroup α, Monoidal a, Semiring a) => Semiring (Polynom α a)++instance (Ord α, Semigroup α, Monoidal a, IntegralSemiring a) => IntegralSemiring (Polynom α a)++-- | Compute the /degree/ of a polynomial, the maximum total exponent of any monomial.+degree :: (Foldable p, Ord α, Monoidal α, DecidableZero a) => Polynom (p α) a -> Maybe α+degree (Polynom cs) = foldr (max ∘ Just ∘ sum) Nothing ((Map.keys ∘ Map.filter (not ∘ isZero)) cs)++-- | Compute the content of a polynomial over a unique factorization domain @a@.+--   The /content/ of such a polynomial is defined as the unit normal GCD of its coefficients.+content :: (Euclidean a) => Polynom α a -> a+content (Polynom cs) = gcd' (foldr (:) [] cs)++-- | Compute the primitive part of a polynomial over a unique factorization domain @a@.+--   A polynomial over a unique factorization domain is called /primitive/ if its coefficients+--   are all unit normal and pairwise coprime. The /primitive part/ of a polynomial @p@ is @q@+--   where @p = content p * q@.+primPart :: (Euclidean a) => Polynom α a -> Polynom α a+primPart p@(Polynom cs) = Polynom ((`quot` content p) <$> cs)++-- | Differentiate a polynomial. Each component of the given monomial exponent is how many times+--   to differentiate the polynomial by that variable.+formalDiff :: (Ord (p Natural), Applicative p, Traversable p, Abelian a, LeftModule Natural a) =>+    p Natural -> Polynom (p Natural) a -> Polynom (p Natural) a+formalDiff α (Polynom cs) = fromList [(γ, foldr (.*) b (liftA2 facQuot β γ))+                                        | (β, b) <- Map.assocs cs,+                                          Just γ <- [traverse2 pminus β α]]+  where facQuot n m = product [m+1..n]++fromList :: (Ord α, Abelian a) => [(α, a)] -> Polynom α a+fromList = Polynom ∘ Map.fromListWith (+)++type Semigroup = Monoid
+ LICENSE view
@@ -0,0 +1,5 @@+© Unix year 45 (Strake = M Farkas-Dyck)++Leave to use, copy, modify, and distribute this work for any purpose is hereby granted if the above copyright notice and this license are included.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Util.hs view
@@ -0,0 +1,15 @@+module Util where++import Control.Applicative+import Control.Category+import Control.Category.Unicode+import Data.Function (flip)+import Data.Traversable++traverse2 :: (Traversable t, Applicative t, Applicative p) =>+    (a -> b -> p c) -> t a -> t b -> p (t c)+traverse2 f xs ys = sequenceA (liftA2 f xs ys)++infixr 9 &+(&) :: Category cat => cat a b -> cat b c -> cat a c+(&) = flip (∘)
+ polynom.cabal view
@@ -0,0 +1,33 @@+name:                polynom+version:             0.1.0.0+synopsis:            Polynomial types and operations+license:             OtherLicense+license-file:        LICENSE+author:              M Farkas-Dyck+maintainer:          strake888@gmail.com+category:            Math+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Data.Polynom+  other-modules:       Data.Polynom.Impl, Util+  default-extensions:  NoImplicitPrelude, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, ConstraintKinds+  other-extensions:    UndecidableInstances+  build-depends:       base >=4.8 && <4.9, base-unicode-symbols >=0.2 && <0.3, algebra >=4.2 && <4.3, containers >=0.5 && <0.6+  default-language:    Haskell2010+  ghc-options:         -Wall++test-suite test+  type:                exitcode-stdio-1.0+  main-is:             test.hs+  default-extensions:  NoImplicitPrelude, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, ConstraintKinds, DataKinds+  build-depends:       base >=4.8 && <4.9, base-unicode-symbols >=0.2 && <0.3, algebra >=4.2 && <4.3, containers >=0.5 && <0.6,+                       transformers >=0.4 && <0.5, peano >=0.1 && <0.2, clist >=0.1 && <0.2,+                       tasty >= 0.11 && <0.12, smallcheck >=1.1 && <1.2, tasty-smallcheck >=0.8 && <0.9+  default-language:    Haskell2010+  ghc-options:         -threaded -with-rtsopts=-N++source-repository head+  type:                git+  location:            https://github.com/strake/polynom.hs
+ test.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving, DeriveFunctor, DeriveTraversable, UndecidableInstances #-}++import Prelude (IO, Integer, Show, toEnum, fromEnum, enumFromTo)+import Control.Applicative+import Control.Category+import Control.Category.Unicode+import Control.Monad+import Control.Monad.Trans.Class+import Data.Bool+import Data.CList+import Data.Eq+import Data.Foldable hiding (sum)+import Data.Function (($), flip)+import qualified Data.List as List+import Data.Monoid+import Data.Ord+import Data.Traversable+import Numeric.Algebra+import Numeric.Decidable.Zero+import Test.SmallCheck.Series+import Test.Tasty+import Test.Tasty.SmallCheck++import Data.Polynom.Impl+import Data.Polynom.Show ()++instance (Serial m α, Serial m a, Ord α, Abelian a, DecidableZero a) => Serial m (Polynom α a) where+    series = series >>- \ (ListSet αs) ->+             fromList ∘ List.zip αs <$>+             mapS id (series <$ αs) `suchThat` foldl (pure (not ∘ isZero)) True+      where mapS f = List.foldr (\ x ys -> (:) <$> f x <~> ys) (pure [])++suchThat :: Monad m => Series m a -> (a -> Bool) -> Series m a+suchThat s p = s >>= liftA2 (bool empty) pure p++newtype ListSet a = ListSet [a] deriving (Show)+instance (Serial m a) => Serial m (ListSet a) where+    series = getDepth >>= lift ∘ flip listM series >>=+             foldr ((<|>) ∘ pure ∘ ListSet) empty ∘ List.inits++instance Monad m => Serial m Natural where+    series = generate $ flip List.take [0..]++newtype Monom n a = Monom (CList n a) deriving (Functor, Foldable, Traversable, Eq, Ord, Show)++deriving instance Applicative (CList n) => Applicative (Monom n)++instance Monad m => Serial m (Monom Zero Natural) where+    series = pure (Monom Nil)++instance (Monad m, Serial m (Monom n Natural)) => Serial m (Monom (Succ n) Natural) where+    series = enumFromTo 0 ∘ toEnum <$> getDepth >>-+             foldr (\/) empty ∘ fmap (\ k ->+                                      (\ (Monom ks) -> Monom (k:.ks)) <$>+                                      localDepth (+ negate (fromEnum k)) series)++instance (Applicative (CList n), Monoidal a) => Monoid (Monom n a) where+    mempty = Monom (pure zero)+    Monom αs `mappend` Monom βs = Monom (liftA2 (+) αs βs)++main :: IO ()+main = defaultMain $+    testGroup "root"+    [testProperty "Distributivity" $ \ p q r ->+     isZero (p*r + q*r - (p + q)*r :: P2 Integer),+     testGroup "Differentiation"+     [testProperty "Linearity" $ \ α p q ->+      isZero (formalDiff α p + formalDiff α q - formalDiff α (p + q) :: P2 Integer),+      testProperty "Product Rule" $ \ p q ->+      flip all (Monom <$> [1:.0:.Nil, 0:.1:.Nil]) $ \ α ->+      isZero (formalDiff α (p*q) - formalDiff α p*q - p*formalDiff α q :: P2 Integer)]]++type P2 = Polynom (Monom (Succ (Succ Zero)) Natural)