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

(→[http://projecteuler.net/index.php?section=problems&id=87 Problem 87]: restore simpler solution) |
Henrylaxen (talk | contribs) (solutions to 81,82,83 using Data.Graph.Inductive) |
||

Line 34: | Line 34: | ||

print$problem_81 f |
print$problem_81 f |
||

</haskell> |
</haskell> |
||

+ | |||

+ | I am offering this solution not because it is particularly |
||

+ | brilliant, but because it introduces the wonderful fgl Graph |
||

+ | Library written my 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 |
||

+ | |||

+ | <haskell> |
||

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

+ | |||

+ | 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..(rows-1)], j<-[0..(cols-1)]] |
||

+ | 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 = map (\x -> (x,spTree (ijI x) gr)) from |
||

+ | distance (i,j) = getDistance (ijI (i,j)) |
||

+ | distances = concatMap (\x -> map (\y -> ((fst x,y), |
||

+ | (distance y (snd x)) + mx (fst x))) to) spTrees |
||

+ | in foldl1 (\x y -> if snd x < snd y then x else y) 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..(rows-1)]] |
||

+ | lastColumn = [(i,(rows-1)) | i<-[0..(rows-1)]] |
||

+ | topLeft = [(0,0)] |
||

+ | bottomRight = [(rows-1,cols-1)] |
||

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

+ | |||

+ | |||

+ | </haskell> |
||

+ | |||

+ | |||

== [http://projecteuler.net/index.php?section=problems&id=82 Problem 82] == |
== [http://projecteuler.net/index.php?section=problems&id=82 Problem 82] == |

## Revision as of 18:39, 27 April 2008

## Contents

## 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
main=do
f<-readFile "matrix.txt"
print$problem_81 f
```

I am offering this solution not because it is particularly brilliant, but because it introduces the wonderful fgl Graph Library written my 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

```
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)
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..(rows-1)], j<-[0..(cols-1)]]
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 = map (\x -> (x,spTree (ijI x) gr)) from
distance (i,j) = getDistance (ijI (i,j))
distances = concatMap (\x -> map (\y -> ((fst x,y),
(distance y (snd x)) + mx (fst x))) to) spTrees
in foldl1 (\x y -> if snd x < snd y then x else y) 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..(rows-1)]]
lastColumn = [(i,(rows-1)) | i<-[0..(rows-1)]]
topLeft = [(0,0)]
bottomRight = [(rows-1,cols-1)]
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)
```

## 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
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
```

## 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
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
```

## Problem 84

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

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

## 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..]))
```

## Problem 87

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

Solution:

```
import List
problem_87 = length expressible
where limit = 50000000
squares = takeWhile (<limit) (map (^2) primes)
cubes = takeWhile (<limit) (map (^3) primes)
fourths = takeWhile (<limit) (map (^4) primes)
choices = [[s,c,f] | s <- squares, c <- cubes, f <- fourths]
unique = map head . group . sort
expressible = filter (<limit) . unique . map sum $ choices
```

## Problem 88

Exploring minimal product-sum 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
```

## 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")]
```

## 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
```