Difference between revisions of "Euler problems/81 to 90"
Jump to navigation
Jump to search
Marypoppins (talk | contribs) |
|||
| Line 1: | Line 1: | ||
| + | Do them on your own! |
||
| − | == [http://projecteuler.net/index.php?section=problems&id=81 Problem 81] == |
||
| − | 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!