data PriorityQ k v = Mt
                     | Br !k v !(PriorityQ k v) !(PriorityQ k v)
  deriving (Eq, Ord, Read, Show)

emptyPQ :: PriorityQ k v
emptyPQ = Mt

isEmptyPQ :: PriorityQ k v -> Bool
isEmptyPQ Mt = True
isEmptyPQ _  = False

-- The size function isn't from the ML code, but an implementation was
-- suggested by Bertram Felgenhauer on Haskell Cafe, so it is included.

-- Return number of elements in the priority queue.
-- /O(log(n)^2)/
sizePQ :: PriorityQ k v -> Int
sizePQ Mt = 0
sizePQ (Br _ _ pl pr) = 2 * n + rest n pl pr where
  n = sizePQ pr
  -- rest n p q, where n = sizePQ q, and sizePQ p - sizePQ q = 0 or 1
  -- returns 1 + sizePQ p - sizePQ q.
  rest :: Int -> PriorityQ k v -> PriorityQ k v -> Int
  rest 0 Mt _ = 1
  rest 0 _  _ = 2
  rest n (Br _ _ ll lr) (Br _ _ rl rr) = case r of
      0 -> rest d ll rl -- subtree sizes: (d or d+1), d; d, d
      1 -> rest d lr rr -- subtree sizes: d+1, (d or d+1); d+1, d
    where m1 = n - 1
          d = m1 `shiftR` 1
          r = m1 .&. 1

peekMinPQ :: PriorityQ k v -> Maybe (k, v)
peekMinPQ Mt           = Nothing
peekMinPQ (Br k v _ _) = Just (k, v)

pushPQ :: Ord k => k -> v -> PriorityQ k v -> PriorityQ k v
pushPQ wk wv Mt           = Br wk wv Mt Mt
pushPQ wk wv (Br vk vv pl pr)
             | wk <= vk   = Br wk wv (pushPQ vk vv pr) pl
             | otherwise  = Br vk vv (pushPQ wk wv pr) pl

siftdown :: Ord k => k -> v -> PriorityQ k v -> PriorityQ k v -> PriorityQ k v
siftdown wk wv Mt _          = Br wk wv Mt Mt
siftdown wk wv (pl @ (Br vk vv _ _)) Mt
    | wk <= vk               = Br wk wv pl Mt
    | otherwise              = Br vk vv (Br wk wv Mt Mt) Mt
siftdown wk wv (pl @ (Br vkl vvl pll plr)) (pr @ (Br vkr vvr prl prr))
    | wk <= vkl && wk <= vkr = Br wk wv pl pr
    | vkl <= vkr             = Br vkl vvl (siftdown wk wv pll plr) pr
    | otherwise              = Br vkr vvr pl (siftdown wk wv prl prr)

replaceMinPQ :: Ord k => k -> v -> PriorityQ k v -> PriorityQ k v
replaceMinPQ wk wv Mt             = Mt
replaceMinPQ wk wv (Br _ _ pl pr) = siftdown wk wv pl pr

deleteMinPQ :: (Ord k) =>  PriorityQ k v -> PriorityQ k v
deleteMinPQ Mt             = Mt
deleteMinPQ (Br _ _ pr Mt) = pr
deleteMinPQ (Br _ _ pl pr) = let (k, v, npl) = leftrem pl in
                             siftdown k v pr npl where
  leftrem (Br k v Mt Mt)             = (k, v, Mt)
  leftrem (Br vk vv (Br k v _ _) Mt) = (k, v, Br vk vv Mt Mt)
  leftrem (Br vk vv pl pr)           = let (k, v, npl) = leftrem pl in
                                       (k, v, Br vk vv pr npl)

-- the following function has been added to the ML code to apply a function
--   to all the entries in the queue and reheapify in O(n) time
adjustPQ :: (Ord k) => (k -> v -> (k, v)) -> PriorityQ k v -> PriorityQ k v
adjustPQ f pq = adjust pq where -- applies function to every element and reheapifies
  adjust Mt               = Mt
  adjust (Br vk vv pl pr) = let (k, v) = f vk vv in
                            siftdown k v (adjust pl) (adjust pr)

fromListPQ :: (Ord k) => [(k, v)] -> PriorityQ k v
-- fromListPQ = foldl (flip pushPQ) Mt -- O(n log n) time; slow
fromListPQ [] = Mt -- O(n) time using adjust-from-bottom which is O(n)
fromListPQ xs = let (pq, _) = build (length xs) xs in pq where
  build 0 xs             = (Mt, xs)
  build lvl ((k, v):xs') = let (pl, xrl) = build (lvl `shiftR` 1) xs'
                               (pr, xrr) = build ((lvl - 1) `shiftR` 1) xrl in
                           (siftdown k v pl pr, xrr)

-- the following function has been added to merge two queues in O(m + n) time
--   where m and n are the sizes of the two queues
mergePQ :: (Ord k) => PriorityQ k v -> PriorityQ k v -> PriorityQ k v
mergePQ pq1 Mt = pq1 -- from concatenated "dumb" list
mergePQ Mt pq2 = pq2 -- in O(m + n) time where m,n are sizes pq1,pq2
mergePQ pq1 pq2 = fromListPQ (zipper pq1 $ zipper pq2 []) where
  zipper (Br wk wv Mt _) appndlst  = (wk, wv) : appndlst
  zipper (Br wk wv pl Mt) appndlst = (wk, wv) : zipper pl appndlst
  zipper (Br wk wv pl pr) appndlst = (wk, wv) : zipper pl (zipper pr appndlst)

popMinPQ :: (Ord k) => PriorityQ k v -> Maybe ((k, v), PriorityQ k v)
popMinPQ pq = case peekMinPQ pq of
                Nothing -> Nothing
                Just kv -> Just (kv, deleteMinPQ pq)

toListPQ :: (Ord k) => PriorityQ k v -> [(k, v)]
toListPQ Mt                  = [] -- unfoldr popMinPQ
toListPQ pq @ (Br vk vv _ _) = (vk, vv) : (toListPQ $ deleteMinPQ pq)

sortPQ :: (Ord k) => [(k, v)] -> [(k, v)]
sortPQ ls = toListPQ $ fromListPQ ls