Personal tools

Euler problems/181 to 190

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
 
(add problem 181)
Line 4: Line 4:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_181 = undefined
+
import Data.Map ((!),Map)
 +
import qualified Data.Map as M
 +
import Data.List
 +
import Control.Monad
 +
 +
main :: IO ()
 +
main = do
 +
    let es = [40,60]
 +
        dg = sum es
 +
        mon = Mon dg es
 +
        Poly mp = partitionPol mon
 +
    print $ mp!mon
 +
 +
data Monomial
 +
    = Mon
 +
    { degree :: !Int
 +
    , expos :: [Int]
 +
    }
 +
 +
infixl 7 <*>, *>
 +
 +
(<*>) :: Monomial -> Monomial -> Monomial
 +
(Mon d1 e1) <*> (Mon d2 e2)
 +
    = Mon (d1+d2) (zipWithZ (+) e1 e2)
 +
 +
unit :: Monomial
 +
unit = Mon 0 []
 +
 +
(<<) :: Monomial -> Monomial -> Bool
 +
(Mon d1 e1) << (Mon d2 e2)
 +
    = d1 <= d2 && and (zipWithZ (<=) e1 e2)
 +
 +
upTo :: Monomial -> [Monomial]
 +
upTo (Mon 0 _) = [unit]
 +
upTo (Mon d es) =
 +
    sort $ go 0 [] es
 +
    where
 +
    go dg acc [] = return (Mon dg $ reverse acc)
 +
    go dg acc (n:ns) = do
 +
        k <- [0 .. n]
 +
        go (dg+k) (k:acc) ns
 +
 +
newtype Polynomial =
 +
    Poly { mapping :: (Map Monomial Integer) }
 +
        deriving (Eq, Ord)
 +
 +
(*>) :: Integer -> Monomial -> Polynomial
 +
n *> m = Poly $ M.singleton m n
 +
 +
----------------------------------------------------------------------------
 +
--                            The hard stuff                            --
 +
----------------------------------------------------------------------------
 +
 +
one :: Map Monomial Integer
 +
one = M.singleton unit 1
 +
 
 +
reciprocal :: Monomial -> Polynomial
 +
reciprocal m =
 +
    Poly . foldl' extend one . reverse . drop 1 . upTo $ m
 +
    where
 +
    extend mp mon =
 +
        M.filter (/= 0) $
 +
        foldl' (flip (uncurry $ M.insertWith' (+))) mp list
 +
        where
 +
        list = filter ((<< m) . fst) [(mon <*> mn, -c) |
 +
                                      (mn,c) <- M.assocs mp]
 +
 +
partitionPol :: Monomial -> Polynomial
 +
partitionPol m =
 +
    Poly . foldl' update one $ sliced m
 +
    where
 +
    Poly rec = reciprocal m
 +
    sliced mon = sortBy (comparing expos) . drop 1 $ upTo mon
 +
    comparing f x y = compare (f x) (f y)
 +
    update mp mon@(Mon d es)
 +
        | es /= ses = M.insert mon (mp!(Mon d ses)) mp
 +
        | otherwise = M.insert mon (negate clc) mp
 +
        where
 +
        ses = sort es
 +
        clc = sum $ do
 +
            mn@(Mon dg xs) <- sliced mon
 +
            let cmn = Mon (d-dg) (zipWithZ (-) es xs)
 +
            case M.lookup mn rec of
 +
                Nothing -> []
 +
                Just c  -> return $ c*(mp!(Mon (d-dg)
 +
                                        (zipWithZ (-) es xs)))
 +
 
 +
----------------------------------------------------------------------------
 +
--                          Auxiliary Functions                          --
 +
----------------------------------------------------------------------------
 +
 +
zipWithZ :: (Int -> Int -> a) -> [Int] -> [Int] -> [a]
 +
zipWithZ _ [] [] = []
 +
zipWithZ f [] ys = map (f 0) ys
 +
zipWithZ f xs [] = map (flip f 0) xs
 +
zipWithZ f (x:xs) (y:ys) = f x y:zipWithZ f xs ys
 +
 +
unknowns :: [String]
 +
unknowns = ['X':show i | i <- [1 .. ]]
 +
 +
instance Show Monomial where
 +
    showsPrec _ (Mon 0 _)  = showString "1"
 +
    showsPrec _ (Mon _ es) = foldr (.) id $ intersperse (showString "*") us
 +
        where
 +
        ps = filter ((/= 0) . snd) $ zip unknowns es
 +
        us = map (\(s,e) -> showString s . showString "^"
 +
                      . showParen (e < 0) (shows e)) ps
 +
 
 +
instance Eq Monomial where
 +
    (Mon d1 e1) == (Mon d2 e2)
 +
        = d1 == d2 && (d1 == 0 || e1 == e2)
 +
 +
instance Ord Monomial where
 +
    compare (Mon d1 e1) (Mon d2 e2)
 +
        = case compare d1 d2 of
 +
            EQ | d1 == 0  -> EQ
 +
              | otherwise -> compare e2 e1
 +
            other          -> other
 +
 +
instance Show Polynomial where
 +
    showsPrec p (Poly m)
 +
        = showP p . filter ((/= 0) . snd) $ M.assocs m
 +
 
 +
showP :: Int -> [(Monomial,Integer)] -> ShowS
 +
showP _ [] = showString "0"
 +
showP p cs =
 +
    showParen (p > 6) showL
 +
    where
 +
    showL = foldr (.) id $ intersperse (showString " + ") ms
 +
    ms = map (\(m,c) -> showParen (c < 0) (shows c)
 +
                        . showString "*" . shows m) cs
 +
 +
instance Num Polynomial where
 +
    (Poly m1) + (Poly m2) = Poly (M.filter (/= 0) $ addM m1 m2)
 +
    p1 - p2 = p1 + (negate p2)
 +
    (Poly m1) * (Poly m2) = Poly (mulM (M.assocs m1) (M.assocs m2))
 +
    negate (Poly m) = Poly $ M.map negate m
 +
    abs = id
 +
    signum = id
 +
    fromInteger n
 +
        | n == 0    = Poly (M.empty)
 +
        | otherwise = Poly (M.singleton unit n)
 +
 +
addM :: Map Monomial Integer -> Map Monomial Integer -> Map Monomial Integer
 +
addM p1 p2 =
 +
    foldl' (flip (uncurry (M.insertWith' (+)))) p1 $
 +
    M.assocs p2
 +
 +
mulM :: [(Monomial,Integer)] -> [(Monomial,Integer)] -> Map Monomial Integer
 +
mulM p1 p2 =
 +
    M.filter (/= 0) .
 +
    foldl' (flip (uncurry (M.insertWith' (+)))) M.empty $
 +
    liftM2 (\(e1,c1) (e2,c2) -> (e1 <*> e2,c1*c2)) p1 p2
 +
problem_181 = main
 
</haskell>
 
</haskell>

Revision as of 02:01, 12 February 2008

Problem 181

Investigating in how many ways objects of two different colours can be grouped.

Solution:

import Data.Map ((!),Map)
import qualified Data.Map as M
import Data.List
import Control.Monad
 
main :: IO ()
main = do
    let es = [40,60]
        dg = sum es
        mon = Mon dg es
        Poly mp = partitionPol mon
    print $ mp!mon
 
data Monomial
    = Mon
    { degree :: !Int
    , expos :: [Int]
    }
 
infixl 7 <*>, *>
 
(<*>) :: Monomial -> Monomial -> Monomial
(Mon d1 e1) <*> (Mon d2 e2)
    = Mon (d1+d2) (zipWithZ (+) e1 e2)
 
unit :: Monomial
unit = Mon 0 []
 
(<<) :: Monomial -> Monomial -> Bool
(Mon d1 e1) << (Mon d2 e2)
    = d1 <= d2 && and (zipWithZ (<=) e1 e2)
 
upTo :: Monomial -> [Monomial]
upTo (Mon 0 _) = [unit]
upTo (Mon d es) = 
    sort $ go 0 [] es
    where
    go dg acc [] = return (Mon dg $ reverse acc)
    go dg acc (n:ns) = do
        k <- [0 .. n]
        go (dg+k) (k:acc) ns
 
newtype Polynomial = 
    Poly { mapping :: (Map Monomial Integer) }
        deriving (Eq, Ord)
 
(*>) :: Integer -> Monomial -> Polynomial
n *> m = Poly $ M.singleton m n
 
----------------------------------------------------------------------------
--                             The hard stuff                             --
----------------------------------------------------------------------------
 
one :: Map Monomial Integer
one = M.singleton unit 1
 
reciprocal :: Monomial -> Polynomial
reciprocal m =
    Poly . foldl' extend one . reverse . drop 1 . upTo $ m
    where
    extend mp mon =
        M.filter (/= 0) $
        foldl' (flip (uncurry $ M.insertWith' (+))) mp list
        where
        list = filter ((<< m) . fst) [(mon <*> mn, -c) |
                                      (mn,c) <- M.assocs mp]
 
partitionPol :: Monomial -> Polynomial
partitionPol m =
    Poly . foldl' update one $ sliced m
    where
    Poly rec = reciprocal m
    sliced mon = sortBy (comparing expos) . drop 1 $ upTo mon
    comparing f x y = compare (f x) (f y)
    update mp mon@(Mon d es)
        | es /= ses = M.insert mon (mp!(Mon d ses)) mp
        | otherwise = M.insert mon (negate clc) mp
        where
        ses = sort es
        clc = sum $ do
            mn@(Mon dg xs) <- sliced mon
            let cmn = Mon (d-dg) (zipWithZ (-) es xs)
            case M.lookup mn rec of
                Nothing -> []
                Just c  -> return $ c*(mp!(Mon (d-dg)
                                        (zipWithZ (-) es xs)))
 
----------------------------------------------------------------------------
--                          Auxiliary Functions                           --
----------------------------------------------------------------------------
 
zipWithZ :: (Int -> Int -> a) -> [Int] -> [Int] -> [a]
zipWithZ _ [] [] = []
zipWithZ f [] ys = map (f 0) ys
zipWithZ f xs [] = map (flip f 0) xs
zipWithZ f (x:xs) (y:ys) = f x y:zipWithZ f xs ys
 
unknowns :: [String]
unknowns = ['X':show i | i <- [1 .. ]]
 
instance Show Monomial where
    showsPrec _ (Mon 0 _)  = showString "1"
    showsPrec _ (Mon _ es) = foldr (.) id $ intersperse (showString "*") us
        where
        ps = filter ((/= 0) . snd) $ zip unknowns es
        us = map (\(s,e) -> showString s . showString "^"
                       . showParen (e < 0) (shows e)) ps
 
instance Eq Monomial where
    (Mon d1 e1) == (Mon d2 e2)
        = d1 == d2 && (d1 == 0 || e1 == e2)
 
instance Ord Monomial where
    compare (Mon d1 e1) (Mon d2 e2)
        = case compare d1 d2 of
            EQ | d1 == 0   -> EQ
               | otherwise -> compare e2 e1
            other          -> other
 
instance Show Polynomial where
    showsPrec p (Poly m) 
        = showP p . filter ((/= 0) . snd) $ M.assocs m
 
showP :: Int -> [(Monomial,Integer)] -> ShowS
showP _ [] = showString "0"
showP p cs = 
    showParen (p > 6) showL
    where
    showL = foldr (.) id $ intersperse (showString " + ") ms
    ms = map (\(m,c) -> showParen (c < 0) (shows c)
                         . showString "*" . shows m) cs
 
instance Num Polynomial where
    (Poly m1) + (Poly m2) = Poly (M.filter (/= 0) $ addM m1 m2)
    p1 - p2 = p1 + (negate p2)
    (Poly m1) * (Poly m2) = Poly (mulM (M.assocs m1) (M.assocs m2))
    negate (Poly m) = Poly $ M.map negate m
    abs = id
    signum = id
    fromInteger n
        | n == 0    = Poly (M.empty)
        | otherwise = Poly (M.singleton unit n)
 
addM :: Map Monomial Integer -> Map Monomial Integer -> Map Monomial Integer
addM p1 p2 = 
    foldl' (flip (uncurry (M.insertWith' (+)))) p1 $
    M.assocs p2
 
mulM :: [(Monomial,Integer)] -> [(Monomial,Integer)] -> Map Monomial Integer
mulM p1 p2 = 
    M.filter (/= 0) .
    foldl' (flip (uncurry (M.insertWith' (+)))) M.empty $
    liftM2 (\(e1,c1) (e2,c2) -> (e1 <*> e2,c1*c2)) p1 p2
problem_181 = main