|
|
| Line 2: |
Line 2: |
| | Investigating in how many ways objects of two different colours can be grouped. | | Investigating in how many ways objects of two different colours can be grouped. |
| | | | |
| − | Solution: | + | Solution: This was my code, published here without my permission nor any attribution, shame on whoever put it here. [[User:Daniel.is.fischer|Daniel.is.fischer]] |
| − | <haskell>
| |
| − | 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>
| |
| | | | |
| | == [http://projecteuler.net/index.php?section=problems&id=182 Problem 182] == | | == [http://projecteuler.net/index.php?section=problems&id=182 Problem 182] == |