Euler problems/81 to 90

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

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)

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

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

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

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)

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

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

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