Euler problems/181 to 190
Jump to navigation
Jump to search
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.
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