Personal tools

Euler problems/81 to 90

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
(Problem 81: Same algorithm, smaller and cleaner code)
 
(26 intermediate revisions by 11 users not shown)
Line 1: Line 1:
== [http://projecteuler.net/index.php?section=view&id=81 Problem 81] ==
+
== [http://projecteuler.net/index.php?section=problems&id=81 Problem 81] ==
 
Find the minimal path sum from the top left to the bottom right by moving right and down.
 
Find the minimal path sum from the top left to the bottom right by moving right and down.
   
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
import Data.List (unfoldr)
+
main = do
  +
file <- readFile "matrix.txt"
  +
print $ problem_82 file
   
columns s = unfoldr f s
+
problem_82 = minSum . map parse . lines
where
 
f [] = Nothing
 
f xs = Just $ (\(a,b) -> (read a, drop 1 b)) $ break (==',') xs
 
   
firstLine ls = scanl1 (+) ls
+
parse :: String -> [Int]
  +
parse = read . ('[':) . (++ "]")
   
nextLine pl [] = pl
+
minSum :: [[Int]] -> Int
nextLine pl (n:nl) = nextLine p' nl
+
minSum (x:xs) = last $ (foldl nextLine) (scanl1 (+) x) xs
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
+
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
  +
</haskell>
  +
  +
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.
  +
  +
<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, 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..(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 = [(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
 
where
p' = firstLine p
+
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_81 c = minSum $ map columns $ lines c
 
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=view&id=82 Problem 82] ==
+
== [http://projecteuler.net/index.php?section=problems&id=82 Problem 82] ==
 
Find the minimal path sum from the left column to the right column.
 
Find the minimal path sum from the left column to the right column.
   
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_82 = undefined
+
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, 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[minPathSum s (1,a)|a<-[1..80]]
  +
appendFile "p82.log"$show m
  +
  +
problem_82 = main
  +
</haskell>
  +
  +
Another concise approach:
  +
  +
<haskell>
  +
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
  +
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=view&id=83 Problem 83] ==
+
== [http://projecteuler.net/index.php?section=problems&id=83 Problem 83] ==
 
Find the minimal path sum from the top left to the bottom right by moving left, right, up, and down.
 
Find the minimal path sum from the top left to the bottom right by moving left, right, up, and down.
   
Line 37: Line 36:
 
<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 (unless)
 
import Control.Monad.State (State, execState, get, put)
 
import Control.Monad.State (State, execState, get, put)
import Data.Maybe (fromJust, fromMaybe)
+
import Data.Maybe (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 57: Line 57:
 
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 66: Line 66:
 
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 75: Line 75:
 
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 90: Line 90:
 
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 104: Line 104:
 
| v' < v = (i', v')
 
| v' < v = (i', v')
 
| otherwise = (i,v)
 
| otherwise = (i,v)
+
 
dijkstra :: State Queues ()
 
dijkstra :: State Queues ()
 
dijkstra = do
 
dijkstra = do
 
Q i o am <- get
 
Q i o am <- get
let (i', n) = extractMin i
+
let (i', (x,y)) = extractMin i
let o' = M.insert (fst n) (snd n) o
+
let o' = M.insert x y o
 
let i'' = updateNodes n am i'
 
let i'' = updateNodes n am i'
 
put $ Q i'' o' am
 
put $ Q i'' o' am
if M.null i'' then return () else dijkstra
+
unless (M.null i'') 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
 
where
 
where
ds = fromJust $ M.lookup i am
+
Just ds = M.lookup i am
 
f :: Path -> NodeMap -> NodeMap
 
f :: Path -> NodeMap -> NodeMap
 
f (A i' w) m = fromMaybe m val
 
f (A i' w) m = fromMaybe m val
Line 126: Line 126:
 
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 132: Line 132:
 
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 139: Line 139:
 
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>
   
== [http://projecteuler.net/index.php?section=view&id=84 Problem 84] ==
+
== [http://projecteuler.net/index.php?section=problems&id=84 Problem 84] ==
 
In the game, Monopoly, find the three most popular squares when using two 4-sided dice.
 
In the game, Monopoly, find the three most popular squares when using two 4-sided dice.
   
Solution:
+
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
  +
 
<haskell>
 
<haskell>
problem_84 = undefined
+
import Data.Array.IArray
</haskell>
+
import Data.List
  +
import Data.Ord
  +
import System.Random
   
== [http://projecteuler.net/index.php?section=view&id=85 Problem 85] ==
+
  +
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)
  +
  +
</haskell>
  +
== [http://projecteuler.net/index.php?section=problems&id=85 Problem 85] ==
 
Investigating the number of rectangles in a rectangular grid.
 
Investigating the number of rectangles in a rectangular grid.
   
Line 155: Line 168:
 
<haskell>
 
<haskell>
 
import List
 
import List
problem_85 = snd$head$sort
+
problem_85 = snd$minimum
 
[(k,a*b)|
 
[(k,a*b)|
 
a<-[1..100],
 
a<-[1..100],
Line 163: Line 176:
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=view&id=86 Problem 86] ==
+
== [http://projecteuler.net/index.php?section=problems&id=86 Problem 86] ==
 
Exploring the shortest path from one corner of a cuboid to another.
 
Exploring the shortest path from one corner of a cuboid to another.
   
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_86 = undefined
+
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..]))
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=view&id=87 Problem 87] ==
+
== [http://projecteuler.net/index.php?section=problems&id=87 Problem 87] ==
 
Investigating numbers that can be expressed as the sum of a prime square, cube, and fourth power?
 
Investigating numbers that can be expressed as the sum of a prime square, cube, and fourth power?
   
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
import List
+
import Data.Array.Unboxed
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]
+
takeMapPrimes :: Integer -> (Integer -> Integer) -> [Integer]
split = unfoldr . split'
+
takeMapPrimes u f = takeWhile (<u) . map f $ primes
 
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
 
   
  +
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 (<(50000000-a)) cubes,
  +
c <- takeWhile (<(50000000-a-b)) fourths,
  +
let t = a + b + c]
  +
  +
problem_87 :: Int
  +
problem_87 = length $ filter id $ elems expressible
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=view&id=88 Problem 88] ==
+
== [http://projecteuler.net/index.php?section=problems&id=88 Problem 88] ==
 
Exploring minimal product-sum numbers for sets of different sizes.
 
Exploring minimal product-sum numbers for sets of different sizes.
   
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_88 = undefined
+
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
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=view&id=89 Problem 89] ==
+
== [http://projecteuler.net/index.php?section=problems&id=89 Problem 89] ==
 
Develop a method to express Roman numerals in minimal form.
 
Develop a method to express Roman numerals in minimal form.
   
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_89 = undefined
+
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")]
 
</haskell>
 
</haskell>
   
== [http://projecteuler.net/index.php?section=view&id=90 Problem 90] ==
+
== [http://projecteuler.net/index.php?section=problems&id=90 Problem 90] ==
 
An unexpected way of using two cubes to make a square.
 
An unexpected way of using two cubes to make a square.
   
 
Solution:
 
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.
  +
 
<haskell>
 
<haskell>
problem_90 = undefined
+
-- 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
 
</haskell>
 
</haskell>

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..(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 = [(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..(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)

[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, 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[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 4-sided 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)*b-8000000)
    ]

[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 (<(50000000-a)) cubes,
                                                   c <- takeWhile (<(50000000-a-b)) fourths,
                                                   let t = a + b + c]
 
problem_87 :: Int
problem_87 = length $ filter id $ elems expressible

[edit] 8 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

[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