{-# OPTIONS_GHC -O2 -optc-O2 #-}
import Control.Monad
import Control.Monad.ST
import Data.Array.ST

type Buffer s = STUArray s Int Int

left :: Int -> Int
left ix = 2 * ix + 1

right :: Int -> Int
right ix = 2 * ix + 2

tryRead :: Int -> Int -> Buffer s -> ST s Int
tryRead ix n b = if ix < n
                 then readArray b ix
                 else return maxBound

heapify :: Int -> Int -> Buffer s -> ST s ()
heapify ix n b = do
  let lx = left ix
      rx = right ix
  iv <- readArray b ix
  lv <- tryRead lx n b
  rv <- tryRead rx n b
  if lv < rv && lv < iv
    then writeArray b ix lv >> writeArray b lx iv >> heapify lx n b
    else if rv < lv && rv < iv
         then writeArray b ix rv >> writeArray b rx iv >> heapify rx n b
         else return ()

heapSort :: [Int] -> [Int]
heapSort [] = []
heapSort xs = runST $ do
  let n = length xs
  b <- newListArray (0, n - 1) xs :: ST s (Buffer s)
  forM_ [(div n 2), (div n 2) - 1 .. 0] $ \i -> heapify i n b
  forM [n, n - 1 .. 1] $ \n -> do
    x  <- readArray b 0
    x' <- readArray b (n - 1)
    writeArray b 0 x'
    heapify 0 n b
    return x

main :: IO ()
main = do
  let n  = 1000000
      vs = [n, n - 1 .. 0]
  if (reverse vs) == heapSort vs
    then putStrLn "OK"
    else putStrLn "FAIL"