# Euler problems/81 to 90

### From HaskellWiki

Line 185: | Line 185: | ||

<haskell> | <haskell> | ||

import List | import List | ||

− | + | 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 | + | 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..]] | |

− | + | groups=1000000 | |

problem_87 n= length expressible | problem_87 n= length expressible | ||

− | where limit = | + | where limit =groups+n*groups |

− | max =n* | + | max =n*groups |

squares = takeWhile (<limit) (map (^2) primes) | squares = takeWhile (<limit) (map (^2) primes) | ||

cubes = takeWhile (<limit) (map (^3) primes) | cubes = takeWhile (<limit) (map (^3) primes) | ||

Line 209: | Line 210: | ||

unique = map head . group . sort | unique = map head . group . sort | ||

expressible = unique choices | expressible = unique choices | ||

− | + | google num | |

− | =if ( | + | =if (num>49) |

then return() | then return() | ||

− | else do appendFile "file.log" ((show$problem_87 | + | else do appendFile "file.log" ((show$problem_87 num) ++" "++ (show num)++"\n") |

− | + | google (num+1) | |

− | main= | + | main=google 0 |

+ | |||

+ | 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=((+0).read) $head$split ' ' x | ||

+ | problem_87a=do | ||

+ | x<-readFile "file.log" | ||

+ | print $sum$map sToInt $lines x | ||

</haskell> | </haskell> |

## Revision as of 06:22, 5 January 2008

## Contents |

## 1 Problem 81

Find the minimal path sum from the top left to the bottom right by moving right and down.

Solution:

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

## 2 Problem 82

Find the minimal path sum from the left column to the right column.

Solution:

problem_82 = undefined

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

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

## 4 Problem 84

In the game, Monopoly, find the three most popular squares when using two 4-sided dice.

Solution:

problem_84 = undefined

## 5 Problem 85

Investigating the number of rectangles in a rectangular grid.

Solution:

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) ]

## 6 Problem 86

Exploring the shortest path from one corner of a cuboid to another.

Solution:

problem_86 = undefined

## 7 Problem 87

Investigating numbers that can be expressed as the sum of a prime square, cube, and fourth power?

Solution:

import List 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..]] groups=1000000 problem_87 n= length expressible where limit =groups+n*groups max =n*groups squares = takeWhile (<limit) (map (^2) primes) cubes = takeWhile (<limit) (map (^3) primes) fourths = takeWhile (<limit) (map (^4) primes) choices = [sm| s <- squares, c <- cubes, f <- fourths,let sm=s+c+f,sm>max,sm<=limit] unique = map head . group . sort expressible = unique choices google num =if (num>49) then return() else do appendFile "file.log" ((show$problem_87 num) ++" "++ (show num)++"\n") google (num+1) main=google 0 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=((+0).read) $head$split ' ' x problem_87a=do x<-readFile "file.log" print $sum$map sToInt $lines x

## 8 Problem 88

Exploring minimal product-sum numbers for sets of different sizes.

Solution:

problem_88 = undefined

## 9 Problem 89

Develop a method to express Roman numerals in minimal form.

Solution:

problem_89 = undefined

## 10 Problem 90

An unexpected way of using two cubes to make a square.

Solution:

problem_90 = undefined