# Euler problems/181 to 190

(Difference between revisions)

## 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

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