Euler problems/81 to 90

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

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

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

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

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

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

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

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

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