Project Euler 解答

Project Euler Problem 081

Project Euler Problem 081

import Control.Monad import Control.Monad.ST import Data.List import Data.Array.ST import Data.STRef import System.IO.Unsafe input :: String input = unsafePerformIO $ readFile "081matrix.txt" lin :: [String] lin = lines input ss :: [[Integer]] ss = map (\x -> read ("["++x++"]") :: [Integer]) lin untilM :: Monad m => (a -> Bool) -> (a -> m a) -> a -> m a untilM p f x | p x = return x | otherwise = f x >>= untilM p f sol1 :: [[Integer]] -> Integer sol1 mat = runST ( do{ asum <- newSTRef 0; ar <- newListArray ((1,1),(h,w)) $ msum mat :: ST s (STArray s (Int,Int) Integer); br <- newArray ((1,1),(h,w)) (0,0) :: ST s (STArray s (Int,Int) (Int,Int)); cr <- newListArray ((1,1),(h,w)) $ msum mat :: ST s (STArray s (Int,Int) Integer); sequence_ [ do{ left <- readArray ar (1,j-1); cur <- readArray ar (1,j); writeArray ar (1,j) (left+cur); writeArray br (1,j) (1,j-1); } | j<-[2..w]]; sequence_ [ do{ up <- readArray ar (i-1,j); cur <- readArray ar (i,j); if j==1 then do{writeArray ar (i,j) (up+cur); writeArray br (i,j) (i-1,j); } else do{ left <- readArray ar (i,j-1); if up < left then do{writeArray ar (i,j) (cur + up); writeArray br (i,j) (i-1,j);} else do{writeArray ar (i,j) (cur + left); writeArray br (i,j) (i,j-1);} } } | i<-[2..h],j<-[1..w]]; untilM (==(0,0)) (\cur -> do{ val <- readArray cr cur; next <- readArray br cur; modifySTRef asum (+val); return next;}) (w,h); ret <- readSTRef asum; return ret}) where h = length mat w = length $ head mat --427337 ok ans1 :: Integer ans1 = sol1 ss main :: IO () main = print ans1 ans2 :: Integer ans2 = last $ foldl' l2 (l1 (head ss)) (tail ss) where l1 [x] = [x] l1 (x:y:ys) = x:l1 (x+y:ys) l2 (x:xs) (y:ys) = c : l3 xs (c:ys) where c = x +y l3 [] _ = [] l3 (x:xs) (y:z:zs) = c : l3 xs (c:zs) where c = z + min x y ans3 :: Integer ans3 = last $ foldl' l2 (l1 (head ss)) (tail ss) where l1 l = ll where ll = head l : zipWith (+) (tail l) ll l2 (x:xs) (y:ys) = c : l3 xs (c:ys) where c = x +y l3 [] _ = [] l3 (x:xs) (y:z:zs) = c : l3 xs (c:zs) where c = z + min x y ans4 :: Integer ans4 = last $ foldl' f (scanl1(+) $ head ss) (tail ss) where f (x:xs) (y:ys) = c:imp xs (c:ys) where c = x+y imp (x:xs) (y:z:zs) = d : imp xs (d:zs) where d = z + min x y imp x y = x ++ y

since 2013