Difference between revisions of "Euler problems/81 to 90"

From HaskellWiki
Jump to: navigation, search
Line 1: Line 1:
== [http://projecteuler.net/index.php?section=problems&id=81 Problem 81] ==
+
Do them on your own!
Find the minimal path sum from the top left to the bottom right by moving right and down.
 
 
 
Solution:
 
<haskell>
 
import Data.List (unfoldr)
 
 
columns s =
 
    unfoldr f s
 
    where
 
    f [] = Nothing
 
    f xs = Just $ (\(a,b) -> (read a, drop 1 b)) $ break (==',') xs
 
 
firstLine ls = scanl1 (+) ls
 
 
nextLine pl [] = pl
 
nextLine pl (n:nl) =
 
    nextLine p' nl
 
    where
 
    p' = nextCell (head pl) pl n
 
    nextCell _ [] [] = []
 
    nextCell pc (p:pl) (n:nl) =
 
        pc' : nextCell pc' pl nl
 
        where pc' = n + min p pc
 
 
minSum (p:nl) =
 
    last $ nextLine p' nl
 
    where
 
    p' = firstLine p
 
 
problem_81 c = minSum $ map columns $ lines c
 
main=do
 
    f<-readFile "matrix.txt"
 
    print$problem_81 f
 
</haskell>
 
 
 
== [http://projecteuler.net/index.php?section=problems&id=82 Problem 82] ==
 
Find the minimal path sum from the left column to the right column.
 
 
 
Solution:
 
<haskell>
 
import Data.List
 
import qualified Data.Map as M
 
import Data.Array
 
 
 
minPathSum xs t=
 
    stepPath M.empty $ M.singleton t $ arr ! t
 
    where
 
    len = genericLength $ head xs
 
    ys = concat $ transpose xs
 
    arr = listArray ((1, 1), (len, len)) ys
 
    nil = ((0,0),0)
 
    stepPath ds as
 
        |fs2 p1==len =snd p1
 
        |fs2 p2==len =snd p2
 
        |fs2 p3==len =snd p3
 
        |otherwise=stepPath ds' as3
 
        where
 
        fs2=fst.fst
 
        ((i, j), cost) =
 
            minimumBy (\(_,a) (_,b) -> compare a b) $ M.assocs as
 
        tas = M.delete (i,j) as
 
        (p1, as1) = if i == len then (nil, tas) else check (i+1, j) tas
 
        (p2, as2) = if j == len then (nil, as1) else check (i, j+1) as1
 
        (p3, as3) = if j == 1  then (nil, as2) else check (i, j-1) as2
 
        check pos zs =
 
            if pos `M.member` tas || pos `M.member` ds
 
            then (nil, zs)
 
            else (entry, uncurry M.insert entry $ zs)
 
            where
 
            entry = (pos, cost + arr ! pos) 
 
        ds' = M.insert (i, j) cost ds
 
 
 
main=do
 
    let parse = map (read . ("["++) . (++"]")) . words
 
    a<-readFile "matrix.txt"
 
    let s=parse a
 
    let m=minimum[p|a<-[1..80],let p=minPathSum s (1,a)]
 
    appendFile "p82.log"$show m
 
 
 
problem_82 = main
 
</haskell>
 
 
 
== [http://projecteuler.net/index.php?section=problems&id=83 Problem 83] ==
 
Find the minimal path sum from the top left to the bottom right by moving left, right, up, and down.
 
 
 
Solution:
 
 
 
A very verbose solution based on the Dijkstra algorithm. Infinity could be represented by any large value instead of the data type Distance. Also, some equality and ordering tests are not really correct. To be semantically correct, I think infinity == infinity should not be True and infinity > infinity should fail. But for this script's purpose it works like this.
 
 
 
<haskell>
 
import Array (Array, listArray, bounds, inRange, assocs, (!))
 
import qualified Data.Map as M
 
    (fromList, Map, foldWithKey,
 
    lookup, null, delete, insert, empty, update)
 
import Data.List (unfoldr)
 
import Control.Monad.State (State, execState, get, put)
 
import Data.Maybe (fromJust, fromMaybe)
 
 
type Weight  = Integer
 
 
data Distance = D Weight | Infinity
 
    deriving (Show)
 
 
instance Eq Distance where
 
    (==) Infinity Infinity = True
 
    (==) (D a) (D b) = a == b
 
    (==) _ _ = False
 
 
instance Ord Distance where
 
    compare Infinity Infinity = EQ
 
    compare Infinity (D _) = GT
 
    compare (D _) Infinity = LT
 
    compare (D a) (D b) = compare a b
 
 
data (Eq n, Num w) => Arc n w = A {node :: n, weight :: w}
 
    deriving (Show)
 
 
type Index  = (Int, Int)
 
type NodeMap = M.Map Index Distance
 
type Matrix  = Array Index Weight
 
type Path    = Arc Index Weight
 
type PathMap  = M.Map Index [Path]
 
 
data Queues = Q {input :: NodeMap, output :: NodeMap, pathMap :: PathMap}
 
    deriving (Show)
 
 
listToMatrix :: [[Weight]] -> Matrix
 
listToMatrix xs = listArray ((1,1),(cols,rows)) $ concat $ xs
 
    where
 
        cols = length $ head xs
 
        rows = length xs
 
 
directions :: [Index]
 
directions = [(0,-1), (0,1), (-1,0), (1,0)]
 
 
add :: (Num a) => (a, a) -> (a, a) -> (a, a)
 
add (a,b) (a', b') = (a+a',b+b')
 
 
arcs :: Matrix -> Index -> [Path]
 
arcs a idx = do
 
    d <- directions
 
    let n = add idx d
 
    if (inRange (bounds a) n) then
 
        return $ A n (a ! n)
 
        else
 
            fail "out of bounds"
 
 
paths :: Matrix -> PathMap
 
paths a = M.fromList $ map (\(idx,_) -> (idx, arcs a idx)) $ assocs a
 
 
nodes :: Matrix -> NodeMap
 
nodes a =
 
    M.fromList $ (\((i,_):xs) -> (i, D (a ! (1,1))):xs) $
 
    map (\(idx,_) -> (idx, Infinity)) $ assocs a
 
 
extractMin :: NodeMap -> (NodeMap, (Index, Distance))
 
extractMin m = (M.delete (fst minNode) m, minNode)
 
    where
 
        minNode = M.foldWithKey mini ((0,0), Infinity) m
 
        mini i' v' (i,v)
 
            | v' < v    = (i', v')
 
            | otherwise = (i,v)
 
 
dijkstra :: State Queues ()
 
dijkstra = do
 
    Q i o am <- get
 
    let (i', n) = extractMin i
 
    let o' = M.insert (fst n) (snd n) o
 
    let i'' = updateNodes n am i'
 
    put $ Q i'' o' am
 
    if M.null i'' then return () else dijkstra
 
 
updateNodes :: (Index, Distance) -> PathMap -> NodeMap -> NodeMap
 
updateNodes (i, D d) am nm = foldr f nm ds
 
    where
 
        ds = fromJust $ M.lookup i am
 
        f :: Path -> NodeMap -> NodeMap
 
        f (A i' w) m = fromMaybe m val
 
            where
 
                val = do
 
                    v <- M.lookup i' m
 
                    if (D $ d+w) < v then
 
                        return $ M.update (const $ Just $ D (d+w)) i' m
 
                        else return m
 
 
shortestPaths :: Matrix -> NodeMap
 
shortestPaths xs = output $ dijkstra `execState` (Q n M.empty a)
 
    where
 
        n = nodes xs
 
        a = paths xs
 
 
problem_83 :: [[Weight]] -> Weight
 
problem_83 xs = jd $ M.lookup idx $ shortestPaths matrix
 
    where
 
        matrix = listToMatrix xs
 
        idx = snd $ bounds matrix
 
        jd (Just (D d)) = d
 
main=do
 
    f<-readFile "matrix.txt"
 
    let m=map sToInt $lines f
 
    print $problem_83 m
 
split :: Char -> String -> [String]
 
split = unfoldr . split'
 
 
split' :: Char -> String -> Maybe (String, String)
 
split' c l
 
    | null l = Nothing
 
    | otherwise = Just (h, drop 1 t)
 
    where (h, t) = span (/=c) l
 
sToInt x=map ((+0).read) $split ',' x
 
</haskell>
 
 
 
== [http://projecteuler.net/index.php?section=problems&id=84 Problem 84] ==
 
In the game, Monopoly, find the three most popular squares when using two 4-sided dice.
 
 
 
Solution:
 
<haskell>
 
problem_84 = undefined
 
</haskell>
 
 
 
== [http://projecteuler.net/index.php?section=problems&id=85 Problem 85] ==
 
Investigating the number of rectangles in a rectangular grid.
 
 
 
Solution:
 
<haskell>
 
import List
 
problem_85 = snd$head$sort
 
    [(k,a*b)|
 
    a<-[1..100],
 
    b<-[1..100],
 
    let k=abs (a*(a+1)*(b+1)*b-8000000)
 
    ]
 
</haskell>
 
 
 
== [http://projecteuler.net/index.php?section=problems&id=86 Problem 86] ==
 
Exploring the shortest path from one corner of a cuboid to another.
 
 
 
Solution:
 
<haskell>
 
problem_86 = undefined
 
</haskell>
 
 
 
== [http://projecteuler.net/index.php?section=problems&id=87 Problem 87] ==
 
Investigating numbers that can be expressed as the sum of a prime square, cube, and fourth power?
 
 
 
Solution:
 
<haskell>
 
diag ((a:as):bss) = a:merge as (diag bss)
 
map2 f as bs = [map (f a) bs | a<-as]
 
 
ordsums as bs = diag $ map2 (+) as bs
 
sums = foldr1 ordsums $ map2 (flip (^)) [4,3,2] primes
 
 
problem_87 =print$ length $ takeWhile (<50000000) sums
 
merge xs@(x:xt) ys@(y:yt) = case compare x y of
 
    LT -> x : (merge xt ys)
 
    EQ -> x : (merge xt yt)
 
    GT -> y : (merge xs yt)
 
   
 
diff  xs@(x:xt) ys@(y:yt) = case compare x y of
 
    LT -> x : (diff xt ys)
 
    EQ -> diff xt yt
 
    GT -> diff xs yt
 
 
primes, nonprimes :: [Int]
 
primes    = [2,3,5] ++ (diff [7,9..] nonprimes)
 
nonprimes = foldr1 f . map g $ tail primes
 
    where f (x:xt) ys = x : (merge xt ys)
 
          g p = [ n*p | n <- [p,p+2..]]
 
</haskell>
 
 
 
== [http://projecteuler.net/index.php?section=problems&id=88 Problem 88] ==
 
Exploring minimal product-sum numbers for sets of different sizes.
 
 
 
Solution:
 
<haskell>
 
import Data.List
 
import qualified Data.Set as S
 
import qualified Data.Map as M
 
 
primes = 2 : filter ((==1) . length . primeFactors) [3,5..] 
 
primeFactors n = factors n primes
 
  where factors n (p:ps) | p*p > n        = [n]
 
                        | n `mod` p == 0 = p : factors (n `div` p) (p:ps)
 
                        | otherwise      = factors n ps
 
isPrime n | n > 1    = (==1) . length . primeFactors $ n
 
          | otherwise = False
 
 
facts = concat . takeWhile valid . iterate facts' . (:[])
 
  where valid xs = length (head xs) > 1
 
        facts' = nub' . concatMap factsnext
 
        nub' = S.toList . S.fromList
 
        factsnext xs =
 
          let factsnext' [] = []
 
              factsnext' (y:ys) = map (form y) ys ++ factsnext' ys
 
              form a b = a*b : (delete b . delete a $ xs)
 
          in map sort . factsnext' $ xs       
 
 
problem_88 =  sum' . extract . scanl addks M.empty . filter (not . isPrime) $ [2..]
 
  where extract = head . dropWhile (\nm -> M.size nm < 11999)
 
        sum' = S.fold (+) 0 . S.fromList . M.elems
 
        addks nm n = foldl (addk n) nm . facts . primeFactors $ n
 
        addk n nm ps =
 
          let k = length ps + n - sum ps
 
              kGood = k > 1 && k < 12001 && k `M.notMember` nm
 
          in if kGood then M.insert k n nm else nm
 
</haskell>
 
 
 
== [http://projecteuler.net/index.php?section=problems&id=89 Problem 89] ==
 
Develop a method to express Roman numerals in minimal form.
 
 
 
Solution:
 
<haskell>
 
replace ([], _) zs = zs
 
replace _ [] = []
 
replace (xs, ys) zzs@(z:zs)
 
    | xs == lns = ys ++ rns
 
    | otherwise = z : replace (xs, ys) zs
 
    where
 
    (lns, rns) = splitAt (length xs) zzs
 
 
problem_89 =
 
    print . difference . words =<< readFile "roman.txt"
 
    where
 
    difference xs = sum (map length xs) - sum (map (length . reduce) xs)
 
    reduce xs = foldl (flip replace) xs [("DCCCC","CM"), ("CCCC","CD"),
 
                                        ("LXXXX","XC"), ("XXXX","XL"),
 
                                        ("VIIII","IX"), ("IIII","IV")]
 
</haskell>
 
 
 
== [http://projecteuler.net/index.php?section=problems&id=90 Problem 90] ==
 
An unexpected way of using two cubes to make a square.
 
 
 
Solution:
 
 
 
Basic brute force: generate all possible die combinations and check each one to see if we can make all the necessary squares. Runs very fast even for brute force.
 
 
 
<haskell>
 
-- all lists consisting of n elements from the given list
 
choose 0 _  = [[]]
 
choose _ [] = []
 
choose n (x:xs) =
 
    ( map ( x : ) ( choose ( n - 1 ) xs ) ) ++ ( choose n xs )
 
 
 
-- cross product helper function
 
cross f xs ys = [ f x y | x <- xs, y <- ys ]
 
 
 
-- all dice combinations
 
-- substitute 'k' for both '6' and '9' to make comparisons easier
 
dice = cross (,) ( choose 6 "012345k78k" ) ( choose 6 "012345k78k" )
 
 
 
-- can we make all square numbers from the two dice
 
-- again, substitute 'k' for '6' and '9'
 
makeSquares dice =
 
    all ( makeSquare dice ) [ "01", "04", "0k", "1k", "25", "3k", "4k", "k4", "81" ]
 
 
 
-- can we make this square from the two dice
 
makeSquare ( xs, ys ) [ d1,  d2 ] =
 
    ( ( ( d1 `elem` xs ) && ( d2 `elem` ys ) ) || ( ( d2 `elem` xs ) && ( d1 `elem` ys ) ) )
 
 
 
problem_90 =
 
    ( `div` 2 ) . -- because each die combinations will appear twice
 
    length .
 
    filter makeSquares
 
    $ dice
 
</haskell>
 

Revision as of 21:46, 29 January 2008

Do them on your own!