Difference between revisions of "Euler problems/81 to 90"
Line 5: | Line 5: | ||
<haskell> |
<haskell> |
||
import Data.List (unfoldr) |
import Data.List (unfoldr) |
||
+ | |||
− | |||
− | columns s = |
+ | columns s = |
+ | unfoldr f s |
||
where |
where |
||
− | + | f [] = Nothing |
|
− | + | f xs = Just $ (\(a,b) -> (read a, drop 1 b)) $ break (==',') xs |
|
+ | |||
− | |||
firstLine ls = scanl1 (+) ls |
firstLine ls = scanl1 (+) ls |
||
+ | |||
− | |||
nextLine pl [] = pl |
nextLine pl [] = pl |
||
− | nextLine pl (n:nl) = |
+ | nextLine pl (n:nl) = |
⚫ | |||
where |
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 |
where |
||
− | + | p' = firstLine p |
|
+ | |||
− | |||
problem_81 c = minSum $ map columns $ lines c |
problem_81 c = minSum $ map columns $ lines c |
||
+ | main=do |
||
+ | f<-readFile "matrix.txt" |
||
+ | print$problem_81 f |
||
</haskell> |
</haskell> |
||
Line 45: | Line 52: | ||
<haskell> |
<haskell> |
||
import Array (Array, listArray, bounds, inRange, assocs, (!)) |
import Array (Array, listArray, bounds, inRange, assocs, (!)) |
||
− | import qualified Data.Map as M |
+ | import qualified Data.Map as M |
+ | (fromList, Map, foldWithKey, |
||
+ | lookup, null, delete, insert, empty, update) |
||
import Data.List (unfoldr) |
import Data.List (unfoldr) |
||
import Control.Monad.State (State, execState, get, put) |
import Control.Monad.State (State, execState, get, put) |
||
import Data.Maybe (fromJust, fromMaybe) |
import Data.Maybe (fromJust, fromMaybe) |
||
+ | |||
− | |||
type Weight = Integer |
type Weight = Integer |
||
+ | |||
− | |||
data Distance = D Weight | Infinity |
data Distance = D Weight | Infinity |
||
deriving (Show) |
deriving (Show) |
||
+ | |||
− | |||
instance Eq Distance where |
instance Eq Distance where |
||
(==) Infinity Infinity = True |
(==) Infinity Infinity = True |
||
(==) (D a) (D b) = a == b |
(==) (D a) (D b) = a == b |
||
(==) _ _ = False |
(==) _ _ = False |
||
+ | |||
− | |||
instance Ord Distance where |
instance Ord Distance where |
||
compare Infinity Infinity = EQ |
compare Infinity Infinity = EQ |
||
Line 65: | Line 74: | ||
compare (D _) Infinity = LT |
compare (D _) Infinity = LT |
||
compare (D a) (D b) = compare a b |
compare (D a) (D b) = compare a b |
||
+ | |||
− | |||
data (Eq n, Num w) => Arc n w = A {node :: n, weight :: w} |
data (Eq n, Num w) => Arc n w = A {node :: n, weight :: w} |
||
deriving (Show) |
deriving (Show) |
||
+ | |||
− | |||
type Index = (Int, Int) |
type Index = (Int, Int) |
||
type NodeMap = M.Map Index Distance |
type NodeMap = M.Map Index Distance |
||
Line 74: | Line 83: | ||
type Path = Arc Index Weight |
type Path = Arc Index Weight |
||
type PathMap = M.Map Index [Path] |
type PathMap = M.Map Index [Path] |
||
+ | |||
− | |||
data Queues = Q {input :: NodeMap, output :: NodeMap, pathMap :: PathMap} |
data Queues = Q {input :: NodeMap, output :: NodeMap, pathMap :: PathMap} |
||
deriving (Show) |
deriving (Show) |
||
+ | |||
− | |||
listToMatrix :: [[Weight]] -> Matrix |
listToMatrix :: [[Weight]] -> Matrix |
||
listToMatrix xs = listArray ((1,1),(cols,rows)) $ concat $ xs |
listToMatrix xs = listArray ((1,1),(cols,rows)) $ concat $ xs |
||
Line 83: | Line 92: | ||
cols = length $ head xs |
cols = length $ head xs |
||
rows = length xs |
rows = length xs |
||
+ | |||
− | |||
directions :: [Index] |
directions :: [Index] |
||
directions = [(0,-1), (0,1), (-1,0), (1,0)] |
directions = [(0,-1), (0,1), (-1,0), (1,0)] |
||
+ | |||
− | |||
add :: (Num a) => (a, a) -> (a, a) -> (a, a) |
add :: (Num a) => (a, a) -> (a, a) -> (a, a) |
||
add (a,b) (a', b') = (a+a',b+b') |
add (a,b) (a', b') = (a+a',b+b') |
||
+ | |||
− | |||
arcs :: Matrix -> Index -> [Path] |
arcs :: Matrix -> Index -> [Path] |
||
arcs a idx = do |
arcs a idx = do |
||
Line 98: | Line 107: | ||
else |
else |
||
fail "out of bounds" |
fail "out of bounds" |
||
+ | |||
− | |||
paths :: Matrix -> PathMap |
paths :: Matrix -> PathMap |
||
paths a = M.fromList $ map (\(idx,_) -> (idx, arcs a idx)) $ assocs a |
paths a = M.fromList $ map (\(idx,_) -> (idx, arcs a idx)) $ assocs a |
||
+ | |||
− | |||
nodes :: Matrix -> NodeMap |
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 :: NodeMap -> (NodeMap, (Index, Distance)) |
||
extractMin m = (M.delete (fst minNode) m, minNode) |
extractMin m = (M.delete (fst minNode) m, minNode) |
||
Line 112: | Line 123: | ||
| v' < v = (i', v') |
| v' < v = (i', v') |
||
| otherwise = (i,v) |
| otherwise = (i,v) |
||
+ | |||
− | |||
dijkstra :: State Queues () |
dijkstra :: State Queues () |
||
dijkstra = do |
dijkstra = do |
||
Line 121: | Line 132: | ||
put $ Q i'' o' am |
put $ Q i'' o' am |
||
if M.null i'' then return () else dijkstra |
if M.null i'' then return () else dijkstra |
||
+ | |||
− | |||
updateNodes :: (Index, Distance) -> PathMap -> NodeMap -> NodeMap |
updateNodes :: (Index, Distance) -> PathMap -> NodeMap -> NodeMap |
||
updateNodes (i, D d) am nm = foldr f nm ds |
updateNodes (i, D d) am nm = foldr f nm ds |
||
Line 134: | Line 145: | ||
return $ M.update (const $ Just $ D (d+w)) i' m |
return $ M.update (const $ Just $ D (d+w)) i' m |
||
else return m |
else return m |
||
+ | |||
− | |||
shortestPaths :: Matrix -> NodeMap |
shortestPaths :: Matrix -> NodeMap |
||
shortestPaths xs = output $ dijkstra `execState` (Q n M.empty a) |
shortestPaths xs = output $ dijkstra `execState` (Q n M.empty a) |
||
Line 140: | Line 151: | ||
n = nodes xs |
n = nodes xs |
||
a = paths xs |
a = paths xs |
||
+ | |||
− | |||
problem_83 :: [[Weight]] -> Weight |
problem_83 :: [[Weight]] -> Weight |
||
problem_83 xs = jd $ M.lookup idx $ shortestPaths matrix |
problem_83 xs = jd $ M.lookup idx $ shortestPaths matrix |
||
Line 147: | Line 158: | ||
idx = snd $ bounds matrix |
idx = snd $ bounds matrix |
||
jd (Just (D d)) = d |
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> |
</haskell> |
||
Line 201: | Line 225: | ||
g p = [ n*p | n <- [p,p+2..]] |
g p = [ n*p | n <- [p,p+2..]] |
||
groups=1000000 |
groups=1000000 |
||
− | problem_87 n= |
+ | problem_87 n= |
+ | length expressible |
||
⚫ | |||
+ | where |
||
⚫ | |||
⚫ | |||
⚫ | |||
⚫ | |||
⚫ | |||
− | + | squares = takeWhile (<limit) (map (^2) primes) |
|
⚫ | |||
− | choices = [sm| s <- squares, c <- cubes, f <- fourths,let sm=s+c+f,sm>max,sm<=limit] |
||
⚫ | |||
⚫ | |||
− | + | choices = [sm| |
|
+ | s <- squares, |
||
+ | c <- cubes, |
||
+ | f <- fourths, |
||
+ | let sm=s+c+f, |
||
+ | sm>max, |
||
+ | sm<=limit |
||
+ | ] |
||
⚫ | |||
+ | expressible = unique choices |
||
google num |
google num |
||
=if (num>49) |
=if (num>49) |
Revision as of 05:12, 6 January 2008
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
Problem 82
Find the minimal path sum from the left column to the right column.
Solution:
problem_82 = undefined
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.
Solution:
problem_84 = undefined
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:
problem_86 = undefined
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
Problem 88
Exploring minimal product-sum numbers for sets of different sizes.
Solution:
problem_88 = undefined
Problem 89
Develop a method to express Roman numerals in minimal form.
Solution:
problem_89 = undefined
Problem 90
An unexpected way of using two cubes to make a square.
Solution:
problem_90 = undefined