import Data.Array
import Data.Tree
import Control.Monad.Trans.State
import qualified Data.Set as S

bfs :: Ord a => (a -> [a]) -> S.Set a -> [S.Set a]
bfs getNexts vs= evalState (explore vs) S.empty
  where
    explore ts = do
      seen <- get
      let ts' = S.difference ts seen
      if S.null ts' then return [] else do
        put (S.union seen ts')
        (ts':) <$> (explore $ S.fromList $ concatMap getNexts $ S.elems ts')


dfs :: Ord a => (a -> [a]) -> [a] -> [Tree a]
dfs getNexts vs = evalState (explore vs) S.empty
  where
    explore [] = return []
    explore (v:vs) = do
      seen <- get
      if v `S.member` seen then explore vs else do
        put (S.insert v seen)
        (:) <$> (Node v <$> explore (getNexts v)) <*> explore vs

import qualified Data.Heap as H
import Data.Heap (Entry (Entry))
import qualified Data.IntMap.Strict as IM
import Data.Array

dijkstra :: Array Int [(Int, Int)] -> Int -> Int -> IM.IntMap Int
dijkstra g n v0 = go (Just (Entry 0 v0, H.empty)) IM.empty (IM.fromList $ (v0, 0) : [(k, maxBound :: Int) | k <- [2 .. n]]) where
  go Nothing _ dist = dist
  go (Just (Entry currentCost i, q)) done dist
    | IM.member i done = go (H.uncons q) done dist
    | otherwise = go (H.uncons q') done' dist' 
      where
        done' = IM.insert i currentCost done
        dist' = foldl (\acc (j, cost) -> IM.insertWith min j (currentCost + cost) acc) dist $ g ! i
        q' = foldl (\acc (j, cost) -> H.insert (Entry (currentCost + cost) j) acc) q $ g ! i

-- 経路復元が必要な時
dijkstra' :: Array Int [(Int, Int)] -> Int -> Int -> IM.IntMap (Int,Int)
dijkstra' g n v0 = go (Just (Entry 0 v0, H.empty)) IM.empty (IM.fromList $ (v0, (0,0)) : [(k, ((maxBound :: Int), -1)) | k <- [2 .. n]]) where
  go Nothing _ dist = dist
  go (Just (Entry currentCost i, q)) done dist
    | IM.member i done = go (H.uncons q) done dist
    | otherwise = go (H.uncons q') done' dist' 
      where
        done' = IM.insert i currentCost done
        q' = foldl (\acc (j, cost) -> H.insert (Entry (currentCost + cost) j) acc) q $ g ! i
        dist' = foldl (\acc (j, cost) -> 
          if currentCost + cost < fst (acc IM.! j) then IM.insert j (currentCost + cost, i) acc else acc) dist $ g ! i

let dist  =  dijkstra graph n 1
let ans = unfoldr (\i -> if i == 0 then Nothing else Just ( i, snd (dist IM.! i))) n

pair (f, g) x = (f x, g x)
cross (f, g) (x, y) = (f x, g y)

newtype Fix f = In { out :: f (Fix f) }
 
newtype Cofree f a = Cf { unCf :: (a, f (Cofree f a)) }
extract :: Cofree f t -> t
extract = fst . unCf
sub :: Functor f => Cofree f a -> f (Cofree f a)
sub = snd . unCf

newtype Free f a = Fr { unFr :: Either a (f (Free f a)) }
inject :: a -> Free f a
inject = Fr . Left
 
cata :: Functor f => (f a -> a) -> Fix f -> a
cata phi = phi . fmap (cata phi) . out
ana :: Functor f => (a -> f a) -> a -> Fix f
ana psi = In . fmap (ana psi) . psi
hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
hylo phi psi = cata phi . ana psi -- phi . fmap (hylo phi psi) . psi
para :: Functor f => (f (Fix f, t) -> t) -> Fix f -> t
para phi = phi . fmap (pair (id, para phi)) . out
histo :: Functor f => (f (Cofree f t) -> t) -> Fix f -> t
histo phi = extract . cata (Cf . pair (phi, id)) 
futu :: Functor f => (t -> f (Free f t)) -> t -> Fix f
futu psi = ana (uncurry either (psi, id) . unFr) . inject
chrono :: Functor f => (f (Cofree f b) -> b) -> (a -> f (Free f a)) -> a -> b
chrono phi psi = histo phi . futu psi
dyna :: Functor f => (f (Cofree f b) -> b) -> (a -> f a) -> a -> b
dyna f g = chrono f (fmap inject . g) -- histo f . ana g

data NatF r =
    ZeroF
  | SuccF r
  deriving (Show, Functor)

type Nat = Fix NatF


intToNat :: Int -> Nat
intToNat = ana phi where
  phi 0 = ZeroF
  phi n = SuccF (n-1)

natToInt :: Nat -> Int
natToInt = cata phi where
  phi ZeroF = 0
  phi (SuccF x) = x + 1



compress :: Num a1 => NatF (Cofree NatF a2) -> a1
compress ZeroF = 0
compress (SuccF x) = 1 + compress y where
  y = sub x

solve :: Array Int Int -> Int -> (Int, [Int])
solve hs = dyna phi psi where
  psi 1 = ZeroF
  psi n = SuccF (n-1)

  phi ZeroF = (0, [1])
  phi (SuccF (Cf (_, ZeroF))) = (abs (hs ! 2 - hs ! 1), [2,1])
  phi cur@(SuccF x) = if d1 < d2 then (d1, i:path1) else (d2, i:path2) where
    i = compress cur + 1
    (f1, path1) = extract x 
    (f2, path2) = case sub x of
      ZeroF   -> (0, [1])
      SuccF y -> extract y 
    d1 = f1 + abs (hs ! i - hs ! (i-1))
    d2 = f2 + abs (hs ! i - hs ! (i-2))

solve ::  Array Int Int -> Int -> Array (Int, Int) Int
solve hs n = runST $ do
  memo <-  newArray ((1,0), (n,1)) 0 :: ST s (STUArray s (Int, Int) Int)
  writeArray memo (2,0) $ abs (hs ! 2 - hs ! 1)
  writeArray memo (2,1) 1
  forM_ [3..n] $ \i -> do
    f1 <- readArray memo ((i-1), 0)
    f2 <- readArray memo ((i-2), 0)
    let d1 = f1 + abs (hs ! i - hs ! (i-1))
    let d2 = f2 + abs (hs ! i - hs ! (i-2))
    if d1 < d2
      then do
        writeArray memo (i,0) (d1)
        writeArray memo (i,1) (i-1)
      else do
        writeArray memo (i,0) (d2)
        writeArray memo (i,1) (i-2)
  freeze memo


solve':: Array Int Int -> Int -> Array Int (Int,Int)
solve' hs n =  memo where
  memo = listArray (1,n)  $  (0,0) : (abs (hs ! 2 - hs ! 1) , 1) : [ if fst d1 < fst d2 then d1 else d2 | i <- [3..n], let d1 = (fst (memo ! (i-1)) + abs (hs ! i - hs ! (i-1)), i-1), let d2 = (fst (memo ! (i-2)) +  abs (hs ! i - hs ! (i-2)), i-2)]

knapsack :: Int ->  [(Int,Int)] -> (Int,Int) -> [(Int,Int)]
knapsack w dp (wi,vi) = merge (dropWhile ((w<) . fst) $ map (\(w',v') -> (w'+wi, v'+vi)) dp) dp 
  where merge xxs@(x:xs) yys@(y:ys) = case compare (fst x) (fst y) of
          LT -> if snd x < snd y then y : merge xxs ys  else merge xxs ys
          EQ -> if snd x > snd y then x : merge xs ys else y : merge xs ys
          GT -> if snd x > snd y then x : merge xs yys else merge xs yys
        merge [] ys = ys
        merge xs [] = xs

let ans = maximum $ map snd  $ foldl (knapsack w) [(0,0)] $ wvs

knapsack :: Array Int (Int,Int) -> Int -> Int -> Array (Int,Int) Int
knapsack wvs n w =  runST $ do
  memo <- newArray ((0,0),(w,n)) (-1)  :: ST s (STUArray s (Int,Int) Int)
  writeArray memo (0,0) 0
  forM_ [1..n] $ \i -> do
    forM_ [0..w] $ \j -> do
      if (j >= fst (wvs!i)) then do
        f1 <- readArray memo (j, (i-1))
        f2 <- readArray memo (( j - fst (wvs!i)), (i-1))
        if f2 == -1 then do
          writeArray memo (j, i) f1
        else do
          writeArray memo (j, i) $ max f1 (f2 + snd (wvs!i))
      else do
        f1 <- readArray memo (j, (i-1))
        writeArray memo (j, i) f1
  freeze memo
let table = knapsack wvs n w
let ans =  maximum $ map (\i -> table!(i,n)) [0..w]

knapsack :: Array Int (Int,Int) -> Int -> Int -> Int-> UArray (Int,Int) Int
knapsack wvs n w vmax=  runST $ do
  memo <- newArray ((0,0),(vmax,n)) (10^15)  :: ST s (STUArray s (Int,Int) Int)
  writeArray memo (0,0) 0
  forM_ [1..n] $ \i -> do
    forM_ [0..vmax] $ \v -> do
       f1 <- readArray memo (v, (i-1))
       if (v >= snd (wvs!i)) then do
         f2 <- readArray memo (( v - snd (wvs!i)), (i-1))
         writeArray memo (v, i) $ min f1 (f2 + fst (wvs!i))
       else do
         writeArray memo (v, i) f1
  freeze memo

import qualified Data.Vector.Unboxed as U
data ListF a r =
    NilF
  | ConsF a r
  deriving (Show, Functor)

knapsack'' wvs n w = dyna phi psi n where
  psi 0 = NilF 
  psi i = ConsF (wvs ! i) (i-1) 
 
  phi (ConsF (cw, cv) (Cf (_, NilF))) =  U.generate (w+1) (bool 0 cv . (cw==))
  phi (ConsF (cw, cv) x) =  U.zipWith max prev vec
    where
      prev = extract x
      vec = U.replicate cw 0 U.++ U.map (+cv) prev

lcs :: Array Int Char -> Array Int Char -> Int -> Int -> Int
lcs xs ys n m = runST $ do
  memo <- newArray ((0,0),(n,m)) 0 :: ST s (STUArray s (Int,Int) Int)
  forM_ [1..n] $ \i -> do
    forM_ [1..m] $ \j -> do
      if xs!i == ys!j then do
        f1 <- readArray memo (i-1, j-1)
        writeArray memo (i,j) $ f1+1
      else do
        f2 <- readArray memo (i-1, j)
        f3 <- readArray memo (i, j-1)
        writeArray memo (i,j) $ max f2 f3
  readArray memo (n,m)

lcsDyna :: Eq a => ([a], [a]) -> [a]
lcsDyna (cs, cs') =
  let n = length cs
   in dyna (g n) f (cs, cs')
  where
  f ([],   [])   = F []     []     Nothing
  f ([],   b:bs) = F []     (b:bs) (Just (cs, bs))
  f (a:as, bs)   = F (a:as) bs     (Just (as, bs))
  g _ (F _      _      Nothing)  = []
  g _ (F []     _      _)        = []
  g _ (F _      []     _)        = []
  g n (F (a:as) (b:bs) (Just x)) =
    let x1 = extract x
        x2 = extract $ iterate pi x !! n
        x3 = extract $ iterate pi x !! (n + 1)
    in if a == b then a:x3 else (if length x1 > length x2 then x1 else x2)
  pi (Cf (_ , F _ _ (Just y))) = y

lcs' s1 s2 = dyna a g (s1, s2) where
  g ([ ], [ ]) = NilF
  g (x , y) = if null y then ConsF (x , y) (tail x , s2) else ConsF (x , y) (x , tail y)

  a NilF = 0
  a (ConsF (x , y) table)
    | null x || null y = 0
    | head x == head y = index table (offset 1 1) + 1
    | otherwise = max (index table (offset 1 0))
    (index table (offset 0 1))
  index t 0 = extract t
  index (Cf (_,ConsF _ t')) n = index t' (n-1)

  offset n m = n * (length s2 + 1) + m - 1

editDistance :: Array Int Char -> Array Int Char -> Int -> Int -> Int
editDistance xs ys n m = runST $ do
  memo <- newArray ((0,0),(n,m)) 0 :: ST s (STUArray s (Int,Int) Int)
  forM_ [0..n] $ \i -> do
    writeArray memo (i,0) i
  forM_ [0..m] $ \j -> do
    writeArray memo (0,j) j
  forM_ [1..n] $ \i -> do
    forM_ [1..m] $ \j -> do
      if xs!i == ys!j then do
        f1 <- readArray memo (i-1, j-1)
        writeArray memo (i,j) $ f1
      else do
        f2 <- readArray memo (i-1, j)
        f3 <- readArray memo (i, j-1)
        f4 <- readArray memo (i-1, j-1)
        writeArray memo (i,j) $ 1 + minimum [f2,f3,f4]
  readArray memo (n,m)

knapsack :: (Array Int (Int,Int), Int, Int)  -> Int
knapsack (wvs, n, w) = runST $ do 
  memo <- newArray ((0,1), (w,n)) (-1) :: ST s (STUArray s (Int,Int) Int)
  go (w,1) memo where
    go p memo
      | isTrivial p = return 0
      | otherwise = do
        res <- readArray memo p
        if res /= -1 then return res
        else do
          ret <- maximum <$> mapM (\(s, sp) -> (+s) <$> go sp memo) (subproblems p)
          writeArray memo p ret
          return ret

    isTrivial (w,i) = i > n
    subproblems (w,i) 
      | w >= w1 = [(v1, (w-w1, i+1)), (0, (w, i+1))]
      | otherwise = [(0, (w, i+1))]
      where (w1,v1) = wvs!i


lcs:: (Array Int Char,Array Int Char, Int, Int)  -> Int
lcs (xs, ys, n, m) = runST $ do 

  memo <- newArray ((0,0), (n,m)) (-1) :: ST s (STUArray s (Int,Int) Int)
  writeArray memo (0,0) 0

  go (1,1) memo where
    go p memo
      | isTrivial p = return 0
      | otherwise = do
        res <- readArray memo p
        if res /= -1 then return res
        else do
          ret <- maximum <$> mapM (\(s, sp) -> (+s) <$> go sp memo) (subproblems p)
          writeArray memo p ret
          return ret

    isTrivial (i,j) = i > n || j > m
    subproblems (i,j) 
      | x == y = [(1, (i+1, j+1))]
      | otherwise = [(0, (i+1, j)), (0, (i, j+1))]
      where x = xs!i
            y = ys!j


blockgame :: (Array Int (Int,Int), Int)  -> Int
blockgame (pas, n) = runST $ do 
  memo <- newArray ((1,1), (n,n)) (-1) :: ST s (STUArray s (Int,Int) Int)
  go (1,n) memo where
    go p memo
      | isTrivial p = return 0
      | otherwise = do
        res <- readArray memo p
        if res /= -1 then return res
        else do
          ret <- maximum <$> mapM (\(s, sp) -> (+s) <$> go sp memo) (subproblems p)
          writeArray memo p ret
          return ret

    isTrivial (l,r) = l == r
    subproblems (l, r) = [(v1, (l+1, r)), (v2, (l, r-1))]
      where
        (p1,a1) = pas!l
        (p2,a2) = pas!r
        v1 = if l <= p1 && p1 <= r then a1 else 0
        v2 = if l <= p2 && p2 <= r then a2 else 0

editDistance :: (Array Int Char,Array Int Char, Int, Int)  -> Int
editDistance (xs, ys, n, m) = runST $ do 
  memo <- newArray ((1,1), (n+1,m+1)) (-1) :: ST s (STUArray s (Int,Int) Int)
  go (1,1) memo where
    go p memo
      | isTrivial p = return 0
      | otherwise = do
        res <- readArray memo p
        if res /= -1 then return res
        else do
          ret <- minimum <$> mapM (\(s, sp) -> (+s) <$> go sp memo) (subproblems p)
          writeArray memo p ret
          return ret

    isTrivial (i,j) = i >n && j>m
    subproblems (i,j) 
      | i > n = [(1, (i, j+1))]
      | j > m = [(1, (i+1, j))]
      | x == y = [(0, (i+1, j+1))]
      | otherwise = [(1, (i+1, j+1)), (1, (i+1, j)), (1, (i, j+1))]
      where x = xs!i 
            y = ys!j 

dungeon1 :: (Array Int Int,Array Int Int, Int) -> Int
dungeon1 (as, bs, n) = runST $ do 
  memo <- newArray (1,n) (-1) :: ST s (STUArray s Int Int)
  go n memo where
    go p memo
      | isTrivial p = return 0
      | otherwise = do
        res <- readArray memo p
        if res /= -1 then return res
        else do
          ret <- minimum <$> mapM (\(s, sp) -> (+s) <$> go sp memo) (subproblems p)
          writeArray memo p ret
          return ret
    isTrivial p = p <= 1
    subproblems p 
      | p == 2 = [(as ! 2, 1)]
      | otherwise = [(as ! p, p-1), (bs ! p, p-2)]

dungeon2 :: (Array Int Int, Int) -> Int
dungeon2 (hs, n) = runST $ do 
  memo <- newArray (1,n) (-1) :: ST s (STUArray s Int Int)
  go n memo where
    go p memo
      | isTrivial p = return 0
      | otherwise = do
        res <- readArray memo p
        if res /= -1 then return res
        else do
          ret <- minimum <$> mapM (\(s, sp) -> (+s) <$> go sp memo) (subproblems p)
          writeArray memo p ret
          return ret
    isTrivial p = p <= 1 
    subproblems p 
      | p == 2 = [(abs (hs ! 2 - hs ! 1), 1)]
      | otherwise = [(abs (hs ! p - hs ! (p-1)), p-1), (abs (hs ! p - hs ! (p-2)), p-2)]
   

search :: (a -> a -> Maybe a) -> (a -> Bool) -> a -> a -> (a,a)
search mid p = go
  where
    go l r = case mid l r of
      Nothing -> (l,r)
      Just m
        | p m       -> go l m
        | otherwise -> go m r

binary :: Integral a => a -> a -> Maybe a
binary l r
  | r - l > 1 = Just ( (l + r) `div` 2)
  | otherwise = Nothing

continuous :: (Fractional a, Ord a) => a -> a -> a -> Maybe a
continuous eps l r
  | r - l > eps = Just ( l + (r-l) / 2)
  | otherwise = Nothing

 search binary (\x -> k <= (foldl (\sum cur -> x `div` cur+ sum) 0 as)) 1 (10^9+1)

search (continuous 0.001) (\x -> x**3+x > n ) 0 50

shakutori p op invOp identity as = go as as 0 identity
  where
    go lls@(l:ls) [] len res = len : (go ls [] (len-1) (invOp res l))
    go lls@(l:ls) rrs@(r:rs) len res
      | p l r res = go lls rs (len + 1) (op res r)
      | len == 0 = 0:(go ls rs 0 identity)
      | otherwise =  len : (go ls rrs (len-1) (invOp res l))
    go _ _ _ _ = []

let ans = shakutori (\l r res -> res *r <= k) (*) div 1 as
print $ maximum ans

let ans = shakutori (\l r res -> res + r <= k) (+) (-) 0 as
print $ sum ans

let ans = shakutori (\l r res -> res < r) max (\res l -> if res == l then minBound else res) minBound as
print $ sum ans

let ans = shakutori (\l r res -> r- l <=k ) (+) (-) 0 as
print $ sum $ map (\x-> x-1) ans

let ans = shakutori (\l r res ->not (S.member r res)) (flip S.insert) (flip S.delete) S.empty as
print $ maximum ans

let ans = shakutori (\l r (a,b) -> a+r == b.|.r) (\(a,b) l -> (a+l, b.|.l)) (\(a,b) l -> (a-l ,b.&.complement l)) (0,0) as
print $ sum $ ans

exgcd :: Integral a => a -> a -> (a, a, a)
exgcd a b = f $ go a b 1 0 0 1
  where
    go r0 r1 s0 s1 t0 t1
      | r1 == 0   = (r0, s0, t0)
      | otherwise = go r1 r2 s1 s2 t1 t2
      where
        (q, r2) = r0 `divMod` r1
        s2 = s0 - q*s1
        t2 = t0 - q*t1
    f (g,u,v)
      | g < 0 = (-g, -u, -v)
      | otherwise = (g,u,v)

{-# LANGUAGE DataKinds,ScopedTypeVariables,KindSignatures #-}
import GHC.TypeNats ( KnownNat, Nat, natVal )
import Data.Proxy ( Proxy(..) )
import Data.Ratio ( denominator, numerator )

newtype IntMod (m :: Nat) = IntMod Integer deriving (Eq,Show)

instance KnownNat m => Num (IntMod m) where
  IntMod x + IntMod y = fromInteger $ x + y
  IntMod x - IntMod y = fromInteger $ x - y
  IntMod x * IntMod y = fromInteger $ x * y
  negate (IntMod x) =  fromInteger $ negate x
  abs a = a
  signum _ = 1
  fromInteger x =  IntMod $ x `mod` (fromIntegral $ natVal (Proxy :: Proxy m))

instance KnownNat m => Fractional (IntMod m) where
  recip a@(IntMod x) = fromInteger r where
    (_, r, _) = exgcd x (fromIntegral $ natVal (Proxy :: Proxy m))
  fromRational x = fromInteger $ numerator x `div` denominator x

instance KnownNat m => Bounded (IntMod m) where
  minBound = IntMod 0
  maxBound = IntMod $ fromIntegral $ natVal (Proxy :: Proxy m) - 1

instance KnownNat m => Enum (IntMod m) where
  toEnum = fromInteger . toInteger
  fromEnum (IntMod x) = fromInteger x

instance KnownNat m => Ord (IntMod m) where
  IntMod x <= IntMod y = x <= y

power a n = go a n 1
  where
    go _ 0 res = res
    go a n res
      | even n = go (a*a) (n `div` 2) res
      | otherwise = go a (n-1) (res*a)

exgcd :: Integral a => a -> a -> (a, a, a)
exgcd a b = f $ go a b 1 0 0 1
  where
    go r0 r1 s0 s1 t0 t1
      | r1 == 0   = (r0, s0, t0)
      | otherwise = go r1 r2 s1 s2 t1 t2
      where
        (q, r2) = r0 `divMod` r1
        s2 = s0 - q*s1
        t2 = t0 - q*t1
    f (g,u,v)
      | g < 0 = (-g, -u, -v)
      | otherwise = (g,u,v)

import qualified Data.Heap as H

-- @gotoki_no_joe
primes :: [Int]
primes = 2 : 3 : sieve q0 [5,7..]
  where
    q0 = H.insert (H.Entry 9 6) H.empty
    sieve queue xxs@(x:xs) =
      case compare np x of
        LT ->     sieve queue1 xxs
        EQ ->     sieve queue1  xs
        GT -> x : sieve queue2  xs
      where
        H.Entry np p2 = H.minimum queue
        queue1 = H.insert (H.Entry (np+p2) p2) $ H.deleteMin queue
        queue2 = H.insert (H.Entry (x * x) (x * 2)) queue

isPrime :: Int -> Bool
isPrime n = all ((/=0) . (mod n))  $ takeWhile ((<= n) . (^2)) primes

import Data.Array.ST
import Control.Monad.ST

type UnionFind s = STUArray s Int Int

newUnionFind :: Int -> ST s (UnionFind s) 
newUnionFind n = newArray (1,n) (-1)

root :: Int -> UnionFind s -> ST s Int
root x uf = do 
  p <- readArray uf x
  if p < 0 then return x 
  else do
    p' <- root p uf
    writeArray uf x p'
    return p'

isSame :: Int -> Int -> UnionFind s -> ST s Bool
isSame x y uf = (==) <$> root x uf <*> root y uf

unite :: Int -> Int -> UnionFind s -> ST s (UnionFind s)
unite x y uf = do
  rx <- root x uf
  ry <- root y uf
  if rx == ry then return uf else do
    px <- readArray uf rx
    py <- readArray uf ry
    if px <= py then do 
      writeArray uf rx (px + py)
      writeArray uf ry rx
      return uf
    else do
      writeArray uf ry (px + py)
      writeArray uf rx ry
      return uf

kruskal :: Int -> [((Int,Int),Int)] -> [((Int,Int),Int)]
kruskal n edges = runST $ do
  uf <- newUnionFind n
  foldM (\res e@((a,b),c) -> do
    is_same <- isSame a b uf
    if is_same then return res 
    else do
      unite a b uf
      return $ e:res
    ) [] $ sortOn snd edges

dfs [] g = []
dfs (v:vs) (c & g') = v: dfs (scc c ++ vs) g'
dfs (v:vs) g = dfs vs g

import Data.Graph.Inductive.Query.DFS (isConnected)
 let g = mkGraph (zip [1..n] $ repeat ()) $ map (\(x,y) -> (x,y,())) es :: Gr () ()
 let ans = isConnected  g

dfsPath :: Graph gr => gr a b -> Node -> Node -> (Maybe [Node], gr a b)
dfsPath g start goal = go [start] g
  where 
    go [] g = (Nothing, g)
    go _ g | isEmpty g = (Nothing, g)
    go (v:vs) g = case match v g of
      (Nothing,g') -> go vs g'
      (Just c,g') -> 
        if v == goal then (pure [v] , g')
        else case (go (neighbors' c ) g') of
          (Nothing, g'') -> go vs g''
          (Just path, g'') -> (pure (v:path) , g'')

let ans = fromJust $ fst $ dfsPath g 1 n

simplePath :: Eq a => a -> Tree a  -> Maybe [a]
simplePath goal (Node v ts) = go v ts
  where
    go v [] = if v == goal then Just [v] else Nothing
    go v (t:ts) = case simplePath goal t of
      Nothing -> go v ts
      Just path -> Just (v:path)

 let ans = fromJust $ simplePath n $ head $ udff [1] g

ulevel :: (Graph gr) => Node -> gr a b -> [(Node,Int)]
ulevel v = uleveln (queuePut (v,0) mkQueue)

uleveln :: (Graph gr, Num b1) => Queue (Node, b1) -> gr a b2 -> [(Node, b1)]
uleveln q g | queueEmpty q || isEmpty g = []
        | otherwise                 =
        case match v g of
          (Just c, g')  -> (v,j):uleveln (queuePutList (zip (neighbors' c) (repeat (j+1))) q') g'
          (Nothing, g') -> uleveln q' g'
          where ((v,j),q') = queueGet q

let ans =  accumArray max (-1) (1,n) $ ulevel 1 g
mapM_ (\i -> putStrLn $ show $ ans ! i ) [1..n]