Euler problems/81 to 90

(Difference between revisions)

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
main=do
print\$problem_81 f```

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

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

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
main=do
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```

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
[(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 50 total=total
problem_87 n total=
problem_87 (n+1) (total+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
main=appendFile "p87.log"\$show\$problem_87 0 0```

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`