Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- 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
Add Comment
Please, Sign In to add comment