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