{-# OPTIONS_GHC -O2 -optc-O2 #-}
module Main where

import Control.Monad
import Control.Monad.State
import Data.List (foldl1')

data Heap a = Leaf
            | Node Int a (Heap a) (Heap a)

weight :: (Ord a) => Heap a -> Int
weight Leaf = 0
weight (Node w _ _ _) = w

make :: (Ord a) => a -> Heap a -> Heap a -> Heap a
make x l r | wl < wr   = Node (wl + 1) x r l
           | otherwise = Node (wr + 1) x l r
  where wl = weight l
        wr = weight r

singleton :: (Ord a) => a -> Heap a
singleton x = Node 1 x Leaf Leaf

merge :: (Ord a) => Heap a -> Heap a -> Heap a
merge h1 Leaf = h1
merge Leaf h2 = h2
merge h1@(Node w1 x1 l1 r1) h2@(Node w2 x2 l2 r2)
  | x1 < x2   = make x1 l1 (merge r1 h2)
  | otherwise = make x2 (merge h1 l2) r2

extractMin :: (Ord a) => Heap a -> (a, Heap a)
extractMin Leaf = undefined
extractMin (Node _ x l r) = (x, merge l r)

heapSort :: (Ord a) => [a] -> [a]
heapSort [] = []
heapSort xs = fst . flip runState h . replicateM n $ state extractMin
  where n = length xs
        h = foldl1' merge $ map singleton xs

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