Personal tools

Euler problems/181 to 190

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
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] ==

Revision as of 23:09, 23 February 2008

1 Problem 181

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

Solution: This was my code, published here without my permission nor any attribution, shame on whoever put it here. Daniel.is.fischer

2 Problem 182

RSA encryption.

Solution:

fun a1 b1 =
    sum [ e |
    e <- [2..a*b-1],
    gcd e (a*b) == 1,
    gcd (e-1) a == 2,
    gcd (e-1) b == 2
    ]
    where
    a=a1-1
    b=b1-1
problem_182=fun 1009 3643

3 Problem 183

Maximum product of parts.

Solution:

pmax x a=a*(log x-log a)
tofloat x=encodeFloat  x 0
fun x=
    div n1 $gcd n1 x
    where
    e=exp 1
    n=floor(fromInteger x/e)
    n1=snd.maximum$[(b,a)|a<-[n..n+1],let b=pmax (tofloat x) (tofloat a)]
n `splitWith` p = doSplitWith 0 n
	where doSplitWith s t
		| p `divides` t = doSplitWith (s+1) (t `div` p)
		| otherwise     = (s, t)
d `divides` n = n `mod` d == 0
funD x
    |is25 k=(-x)
    |otherwise =x
    where 
    k=fun x
is25 x
    |s==1=True
    |otherwise=False
    where
    s=snd(splitWith (snd (splitWith x 2)) 5)
problem_183 =sum[funD a|a<- [5..10000]]