Personal tools

Euler problems/81 to 90

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
Line 5: Line 5:
 
<haskell>
 
<haskell>
 
import Data.List (unfoldr)
 
import Data.List (unfoldr)
+
columns s = unfoldr f s
+
columns s =
  +
unfoldr f s
 
where
 
where
f [] = Nothing
+
f [] = Nothing
f xs = Just $ (\(a,b) -> (read a, drop 1 b)) $ break (==',') xs
+
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 p' nl
+
nextLine pl (n:nl) =
  +
nextLine p' nl
 
where
 
where
p' = nextCell (head pl) pl n
+
p' = nextCell (head pl) pl n
nextCell _ [] [] = []
+
nextCell _ [] [] = []
nextCell pc (p:pl) (n:nl) = pc' : nextCell pc' pl nl
+
nextCell pc (p:pl) (n:nl) =
where pc' = n + min p pc
+
pc' : nextCell pc' pl nl
+
where pc' = n + min p pc
minSum (p:nl) = last $ nextLine p' nl
+
  +
minSum (p:nl) =
  +
last $ nextLine p' nl
 
where
 
where
p' = firstLine p
+
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 48:
 
<haskell>
 
<haskell>
 
import Array (Array, listArray, bounds, inRange, assocs, (!))
 
import Array (Array, listArray, bounds, inRange, assocs, (!))
import qualified Data.Map as M (fromList, Map, foldWithKey, lookup, null, delete, insert, empty, update)
+
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 68:
 
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 77:
 
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 86:
 
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 101:
 
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
+
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 115:
 
| 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 124:
 
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 137:
 
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 143:
 
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 150:
 
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 217:
 
g p = [ n*p | n <- [p,p+2..]]
 
g p = [ n*p | n <- [p,p+2..]]
 
groups=1000000
 
groups=1000000
problem_87 n= length expressible
+
problem_87 n=
where limit =groups+n*groups
+
length expressible
max =n*groups
+
where
squares = takeWhile (<limit) (map (^2) primes)
+
limit =groups+n*groups
cubes = takeWhile (<limit) (map (^3) primes)
+
max =n*groups
fourths = takeWhile (<limit) (map (^4) primes)
+
squares = takeWhile (<limit) (map (^2) primes)
choices = [sm| s <- squares, c <- cubes, f <- fourths,let sm=s+c+f,sm>max,sm<=limit]
+
cubes = takeWhile (<limit) (map (^3) primes)
unique = map head . group . sort
+
fourths = takeWhile (<limit) (map (^4) primes)
expressible = unique choices
+
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
 
google num
 
=if (num>49)
 
=if (num>49)

Revision as of 05:12, 6 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
main=do
    f<-readFile "matrix.txt"
    print$problem_81 f

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

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