Euler problems/81 to 90
From HaskellWiki
(→Problem 81: Same algorithm, smaller and cleaner code) 

(16 intermediate revisions by 8 users not shown) 
Latest revision as of 03:07, 8 December 2011
Contents 
[edit] 1 Problem 81
Find the minimal path sum from the top left to the bottom right by moving right and down.
Solution:
main = do file < readFile "matrix.txt" print $ problem_82 file problem_82 = minSum . map parse . lines parse :: String > [Int] parse = read . ('[':) . (++ "]") minSum :: [[Int]] > Int minSum (x:xs) = last $ (foldl nextLine) (scanl1 (+) x) xs nextLine :: [Int] > [Int] > [Int] nextLine (p:pl) (n:nl) = scanl nextCell (p+n) (zip pl nl) where nextCell acc (prev, new) = new + min prev acc
I am offering this solution not because it is particularly brilliant, but because it introduces the wonderful fgl Graph Library written by Martin Erwig. Martin's Data.Graph.Inductive library allows you to solve problems 81,82, and 83 with exactly the same code, and best of all, little or no thinking. The idea is to convert the n by n matrix into an n^2 by n^2 graph whose edges depend on the allowed paths. Fortunately these graphs are very sparse, averaging only 4 edges per node. This allows us to use the Dijkstra algorithm to find the shortest path in a graph.
The only slightly dodgy bit is problem 82, where we must find the shortest path from the first column to the last column. In order to avoid recomputing the Dijkstra algorithm over and over again, you have to be a little careful in the order of evaluation. I used spTree function from Data.Graph.Inductive.Query.SP which generated the shortest path tree from a given initial node to all other nodes. I then map over this tree with the nodes of the graph that are in the last column. The tree only needs to be calculated once for each element in the first column, rather than for every pair (i,j). This reduces the running time by a factor of n. Henry Laxen  Apr. 27, 2008
Note that problem 82 may also be solved using a straightforward Dijkstra by adding an initial node A connected to all the nodes in the first column, and a final node B that all the nodes of the last column connect to, and then searching for a path from A to B.
import Data.Graph.Inductive import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Query.SP import Data.Graph.Inductive.Internal.RootPath import Data.List (unfoldr, minimumBy) import Data.Ord (comparing) type Matrix = [[Int]] type IJ = (Int, Int) connect81, connect82, connect83 :: [IJ] connect81 = [(1,0),(0,1)] connect82 = [(1,0),(1,0),(0,1)] connect83 = [(1,0),(0,1),(1,0),(0,1)] dimensions :: Matrix > IJ dimensions matrix = (length matrix, length (matrix!!0)) ijToindex :: Matrix > IJ > Int ijToindex matrix (i,j) = i*rows + j where (rows,cols) = dimensions matrix indexToij :: Matrix > Int > IJ indexToij matrix index = divMod index rows where (rows,cols) = dimensions matrix ijValid :: Matrix > [IJ] > [IJ] ijValid matrix ijs = filter f ijs where (rows,cols) = dimensions matrix f (i,j) = i >= 0 && i < rows && j >= 0 && j < cols ijPlus :: IJ > IJ > IJ ijPlus (i1,j1) (i2,j2) = ((i1+i2),(j1+j2)) mEdges :: Matrix > [IJ] > IJ > [(Int, Int, Int)] mEdges matrix connectL (i,j) = let ijs = ijValid matrix $ map (ijPlus (i,j)) connectL in map (\(x,y) > (ijToindex matrix (i,j), ijToindex matrix (x,y), matrix!!x!!y)) ijs mGraph :: Matrix > [IJ] > Gr IJ Int mGraph matrix connectL = let (rows,cols) = dimensions matrix ijs = [(i,j)  i<[0..(rows1)], j<[0..(cols1)]] mnodes = map (\(x,y) > (ijToindex matrix (x,y) ,(x,y))) ijs medges = concatMap (mEdges matrix connectL) ijs  Everything written above is leading up to this line,  namely transforming an m x n matrix into an mn x mn graph in mkGraph mnodes medges mSPlen :: Matrix > [IJ] > [IJ] > [IJ] > ((IJ, IJ), Int) mSPlen matrix connectL from to = let (rows,cols) = dimensions matrix mx (i,j) = matrix!!i!!j ijI = ijToindex matrix gr = mGraph matrix connectL spTrees = [(x,spTree (ijI x) gr)  x < from] distance (i,j) = getDistance (ijI (i,j)) distances = [((a,y), distance y b + mx a)  (a,b) < spTrees, y < to] in minimumBy (comparing snd) distances debug = False mName = if debug then "small_matrix.txt" else "matrix.txt" columns :: [Char] > [Int] columns s = unfoldr f s where f [] = Nothing f xs = Just $ (\(a,b) > (read a, drop 1 b)) $ break (==',') xs main = do f<readFile mName let matrix = map columns $ lines f (rows,cols) = dimensions matrix firstColumn = [(i,0)  i<[0..(rows1)]] lastColumn = [(i,(rows1))  i<[0..(rows1)]] topLeft = [(0,0)] bottomRight = [(rows1,cols1)] putStrLn $ "Problem 81: " ++ (show $ mSPlen matrix connect81 topLeft bottomRight) putStrLn $ "Problem 82: " ++ (show $ mSPlen matrix connect82 firstColumn lastColumn) putStrLn $ "Problem 83: " ++ (show $ mSPlen matrix connect83 topLeft bottomRight)
[edit] 2 Problem 82
Find the minimal path sum from the left column to the right column.
Solution:
import Data.List import qualified Data.Map as M import Data.Array import Data.Ord (comparing) 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 (comparing snd) $ 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, j1) 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[minPathSum s (1,a)a<[1..80]] appendFile "p82.log"$show m problem_82 = main
Another concise approach:
import Data.List main = do s < readFile "matrix.txt" let a = transpose . map (\x > read ("["++x++"]")) . lines $ s print $ minimum $ foldl1 (\u v > let l1 = (head u + head v) : zipWith3 (\x y z > x + min y z) (tail v) l1 (tail u) v' = reverse v l1' = reverse l1 l2 = head l1' : zipWith3 (\x y z > min x (y+z)) (tail l1') l2 (tail v') in reverse l2) a
[edit] 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 (unless) import Control.Monad.State (State, execState, get, put) import Data.Maybe (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', (x,y)) = extractMin i let o' = M.insert x y o let i'' = updateNodes n am i' put $ Q i'' o' am unless (M.null i'') dijkstra updateNodes :: (Index, Distance) > PathMap > NodeMap > NodeMap updateNodes (i, D d) am nm = foldr f nm ds where Just ds = 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
[edit] 4 Problem 84
In the game, Monopoly, find the three most popular squares when using two 4sided dice.
This may not be the shortest or the fastest implementation, but I hope it is one of the clearest. I have one comment about the experience of solving this problem that I would like to share with you. At first I thought I would have to make use of the Control.Monad.State library, but being relatively new to Haskell, I quickly found myself in the slough of type checker despond. It was then that I remembered that foldl/foldr can used instead of "State," and now I found myself in the celestial city of type checker heaven, with Haskell preventing me from making silly mistakes at every turn. HenryLaxen May 7, 2008
import Data.Array.IArray import Data.List import Data.Ord import System.Random data Squares = GO  A1  CC1  A2  T1  R1  B1  CH1  B2  B3  JAIL  C1  U1  C2  C3  R2  D1  CC2  D2  D3  FP  E1  CH2  E2  E3  R3  F1  F2  U2  F3  G2J  G1  G2  CC3  G3  R4  CH3  H1  T2  H2 deriving (Eq,Ord,Enum,Read,Show,Ix) type Roll = [Int] data Cards = GoTo Squares  R  U  Back3  Other deriving (Eq,Ord,Read,Show) type Deck = [Cards] data GameState = GameState { position :: Squares, doublesCount :: Int, chance :: [Cards], communityChest :: [Cards], history :: [Squares] } deriving (Eq,Ord,Read,Show) deckCommunityChest = [ GoTo JAIL, GoTo GO ] ++ replicate 14 Other deckChance = [ GoTo GO, GoTo JAIL, GoTo C1, GoTo E3, GoTo H2, GoTo R1] ++ [ R, U, Back3] ++ replicate 6 Other doubles :: Roll > Bool doubles r = r!!0 == r!!1 defaultGameState = GameState { position = GO, doublesCount = 0, chance = deckChance, communityChest = deckCommunityChest, history = [GO] } takeCard :: Deck > (Cards,Deck) takeCard (c:cs) = (card,deck) where card = c deck = cs ++ [card] nextR g = case position g of CH1 > R2 CH2 > R3 CH3 > R1 nextU g = case position g of CH1 > U1 CH2 > U2 CH3 > U1 doCommunityChest :: GameState > GameState doCommunityChest g = let (card,deck) = takeCard (communityChest g) rotate g = g {communityChest = deck } cases = case card of GoTo sq > g { position = sq } Other > g in rotate cases doChance :: GameState > GameState doChance g = let (card,deck) = takeCard (chance g) rotate g = g {chance = deck } cases = case card of GoTo sq > g { position = sq} R > g { position = nextR g } U > g { position = nextU g }  you might back up from CH3 to CC3 so checkForCards again Back3 > checkForCards (g { position = position (newPosition g (3))}) Other > g in rotate cases newPosition :: GameState > Int > GameState newPosition g n = g {position = toEnum $ (fromEnum (position g) + n) `mod` (fromEnum H2 + 1)} checkForCards :: GameState > GameState checkForCards g  (position g) `elem` [CH1, CH2, CH3] = doChance g  (position g) `elem` [CC1, CC2, CC3] = doCommunityChest g  otherwise = g travel :: GameState > [Int] > GameState travel g roll = let value = sum roll checkDoubles  doubles roll && doublesCount g == 2 = g { position = JAIL, doublesCount = 0 }  doubles roll = move $ g { doublesCount = (doublesCount g) + 1}  otherwise = move $ g { doublesCount = 0} move g = newPosition g value checkForJail g  (position g) == G2J = g { position = JAIL }  otherwise = g saveHistory g = g { history = (position g) : (history g) } in saveHistory $ checkForCards $ checkForJail $ checkDoubles game :: GameState > [Roll] > GameState  As an exercise in what a difference strictness can make  compare the performance of this with replacing foldl' by foldl game g rolls = foldl' (\x y > travel x y) g rolls statistics :: [Squares] > [(Squares, Float)] statistics history = let a = accumArray (+) 0 (GO,H2) (zip history (repeat 1)) :: Array Squares Int b = assocs a c = reverse $ sortBy (comparing snd) b (sq,cnt) = unzip c  wiki formatting bug, should be unzip c total = sum cnt stats = map (\x > ((fromIntegral x) / (fromIntegral total) * 100)) cnt in take 3 $ zip sq stats r = [[1,1],[2,2],[2,2],[4,4]] t = game defaultGameState r  useful for debugging pairs :: [a] > [[a]] pairs [] = [[]] pairs (x:y:xs) = [[x,y]] ++ (pairs xs) dieSides :: (Int,Int)  dieSides = (1,6) dieSides = (1,4) maxRolls = 100000 main = do seed < newStdGen let rolls = pairs (randomRs dieSides seed) stats = statistics (history (game defaultGameState (take maxRolls rolls))) result = map (fromEnum . fst) stats print (stats,result)
[edit] 5 Problem 85
Investigating the number of rectangles in a rectangular grid.
Solution:
import List problem_85 = snd$minimum [(k,a*b) a<[1..100], b<[1..100], let k=abs (a*(a+1)*(b+1)*b8000000) ]
[edit] 6 Problem 86
Exploring the shortest path from one corner of a cuboid to another.
Solution:
import Data.List isSquare x = (truncate $ sqrt $ fromIntegral x)^2 == x cube m = sum [ (a`div`2)  if a > m then (a  m 1) else 0 a < [1..2*m], isSquare ((a)^2 + m2) ] where m2 = m * m problem_86 = findIndex (>1000000) (scanl (+) 0 (map cube [1..]))
[edit] 7 Problem 87
Investigating numbers that can be expressed as the sum of a prime square, cube, and fourth power?
Solution:
import Data.Array.Unboxed takeMapPrimes :: Integer > (Integer > Integer) > [Integer] takeMapPrimes u f = takeWhile (<u) . map f $ primes squares = takeMapPrimes 50000000 (^2) cubes = takeMapPrimes 50000000 (^3) fourths = takeMapPrimes 50000000 (^4) expressible :: UArray Integer Bool expressible = accumArray () False (1, 50000000) [(t, True)  a < squares, b < takeWhile (<(50000000a)) cubes, c < takeWhile (<(50000000ab)) fourths, let t = a + b + c] problem_87 :: Int problem_87 = length $ filter id $ elems expressible
[edit] 8 Problem 88
Exploring minimal productsum numbers for sets of different sizes.
Solution:
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
[edit] 9 Problem 89
Develop a method to express Roman numerals in minimal form.
Solution:
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")]
[edit] 10 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.
 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