Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Source code for Groebner bases implementation in Haskell
import Data.List (intercalate, foldl')
data Monom c a = M c [a] deriving (Eq)
newtype Polynom c a = P [Monom c a] deriving (Eq)
instance (Eq c, Ord a) => Ord (Monom c a) where
compare (M _ asl) (M _ asr) = compare asl asr
instance (Show a, Show c, Num a, Num c, Eq a, Eq c) => Show (Monom c a) where
show (M c as) = (if c == 1 then "" else show c) ++
(intercalate "" $ map showOne $ (filter (\(p,_) -> p /= 0) $ zip as [1..]))
where showOne (p,i) = "x" ++ (show i) ++ (if p == 1 then "" else "^" ++ (show p))
instance (Show a, Show c, Num a, Num c, Eq a, Eq c) => Show (Polynom c a) where
show (P ms) = intercalate " + " $ map show ms
lt :: Polynom c a -> Monom c a
lt (P as) = head as
zero :: (Num c, Eq c) => Monom c a -> Bool
zero (M c _) = c == 0
zeroP :: Polynom c a -> Bool
zeroP (P as) = null as
similar :: (Eq a) => Monom c a -> Monom c a -> Bool
similar (M _ asl) (M _ asr) = asl == asr
addSimilar :: (Num c) => Monom c a -> Monom c a -> Monom c a
addSimilar (M cl as) (M cr _) = M (cl+cr) as
mulMono :: (Num a, Num c) => Monom c a -> Monom c a -> Monom c a
mulMono (M cl asl) (M cr asr) = M (cl*cr) (zipWith (+) asl asr)
scale :: (Num c) => c -> Monom c a -> Monom c a
scale c' (M c as) = M (c*c') as
addPoly :: (Eq a, Eq c, Num c, Ord a) => Polynom c a -> Polynom c a -> Polynom c a
addPoly (P l) (P r) = P $ go l r
where
go [] [] = []
go as [] = as
go [] bs = bs
go (a:as) (b:bs) =
if similar a b then
if (zero $ addSimilar a b) then
go as bs
else
(addSimilar a b):(go as bs)
else
if a > b then
a:(go as (b:bs))
else
b:(go (a:as) bs)
mulPM :: (Ord a, Eq c, Num a, Num c) => Polynom c a -> Monom c a -> Polynom c a
mulPM(P as) m = P $ map (mulMono m) as
mulM :: (Eq c, Num c, Num a, Ord a) => Polynom c a -> Polynom c a -> Polynom c a
mulM l@(P ml) r@(P mr) = foldl' addPoly (P []) $ map (mulPM r) ml
dividable :: (Ord a) => Monom c a -> Monom c a -> Bool
dividable (M _ al) (M _ ar) = and $ zipWith (>=) al ar
divideM :: (Fractional c, Num a) => Monom c a -> Monom c a -> Monom c a
divideM (M cl al) (M cr ar) = M (cl/cr) (zipWith (-) al ar)
reducable :: (Ord a) => Polynom c a -> Polynom c a -> Bool
reducable l r = dividable (lt l) (lt r)
reduce :: (Eq c, Fractional c, Num a, Ord a) =>
Polynom c a -> Polynom c a -> Polynom c a
reduce l r = addPoly l r'
where r' = mulPM r (scale (-1) q)
q = divideM (lt l) (lt r)
reduceMany :: (Eq c, Fractional c, Num a, Ord a) =>
Polynom c a -> [Polynom c a] -> Polynom c a
reduceMany h fs = if reduced then reduceMany h' fs else h'
where (h', reduced) = reduceStep h fs False
reduceStep h (f:fs) r
| zeroP h = (h, r)
| otherwise = if reducable h f then
(reduce h f, True)
else
reduceStep h fs r
reduceStep h [] r = (h, r)
lcmM :: (Num c, Ord a) => Monom c a -> Monom c a -> Monom c a
lcmM (M cl al) (M cr ar) = M (cl*cr) (zipWith max al ar)
makeSPoly :: (Eq c, Fractional c, Num a, Ord a) =>
Polynom c a -> Polynom c a -> Polynom c a
makeSPoly l r = addPoly l' r'
where l' = mulPM l ra
r' = mulPM r la
lcm = lcmM (lt l) (lt r)
ra = divideM lcm (lt l)
la = scale (-1) $ divideM lcm (lt r)
checkOne :: (Eq c, Fractional c, Num a, Ord a) =>
Polynom c a -> [Polynom c a] -> [Polynom c a] -> [Polynom c a]
checkOne f checked@(c:cs) add = if zeroP s then
checkOne f cs add
else
s:(checkOne f cs (add ++ [s]))
where s = reduceMany (makeSPoly f c) (checked++add)
checkOne _ [] _ = []
makeGroebner :: (Eq c, Fractional c, Num a, Ord a) =>
[Polynom c a] -> [Polynom c a]
makeGroebner (b:bs) = build [b] bs
where build checked add@(a:as) = build (checked ++ [a]) (as ++ (checkOne a checked add))
build checked [] = checked
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.