data MinHeap kv = MinHeapEmpty
                  | MinHeapLeaf !kv
                  | MinHeapNode !kv {-# UNPACK #-} !Int !(MinHeap a) !(MinHeap a)
  deriving (Show, Eq)

emptyPQ :: MinHeap kv
emptyPQ = MinHeapEmpty

isEmptyPQ :: PriorityQ kv -> Bool
isEmptyPQ Mt = True
isEmptyPQ _  = False

sizePQ :: (Ord kv) => MinHeap kv -> Int
sizePQ MinHeapEmpty = 0
sizePQ (MinHeapLeaf _) = 1
sizePQ (MinHeapNode _ cnt _ _) = cnt

peekMinPQ :: MinHeap kv -> Maybe kv
peekMinPQ MinHeapEmpty = Nothing
peekMinPQ (MinHeapLeaf v) = Just v
peekMinPQ (MinHeapNode v _ _ _) = Just v

pushPQ :: (Ord kv) => kv -> MinHeap kv -> MinHeap kv
pushPQ kv pq = insert kv 0 pq where -- insert element, keeping the tree balanced
  insert kv _ MinHeapEmpty = MinHeapLeaf kv
  insert kv _ (MinHeapLeaf vv) = if kv <= vv
      then MinHeapNode kv 2 (MinHeapLeaf vv) MinHeapEmpty
      else MinHeapNode vv 2 (MinHeapLeaf kv) MinHeapEmpty
  insert kv msk (MinHeapNode vv cc ll rr) = if kv <= vv
      then if nmsk >= 0
        then MinHeapNode kv nc (insert vv nmsk ll) rr
        else MinHeapNode kv nc ll (insert vv nmsk rr)
      else if nmsk >= 0
        then MinHeapNode vv nc (insert kv nmsk ll) rr
        else MinHeapNode vv nc ll (insert kv nmsk rr)
    where nc = cc + 1
          nmsk = if msk /= 0 then msk `shiftL` 1 -- walk path to next
                 else let s = floor $ (log $ fromIntegral nc) / log 2 in
                      (nc `shiftL` ((finiteBitSize cc) - s)) .|. 1 --never 0 again

siftdown :: (Ord kv) => kv -> Int -> MinHeap kv -> MinHeap kv -> MinHeap kv
siftdown kv cnt lft rght = replace cnt lft rght where
  replace cc ll rr = case rr of -- adj to put kv in current left/right
    MinHeapEmpty -> -- means left is a MinHeapLeaf
      case ll of { (MinHeapLeaf vl) ->
        if kv <= vl
          then MinHeapNode kv 2 ll MinHeapEmpty
          else MinHeapNode vl 2 (MinHeapLeaf kv) MinHeapEmpty }
    MinHeapLeaf vr ->
      case ll of
        MinHeapLeaf vl -> if vl <= vr
          then if kv <= vl then MinHeapNode kv cc ll rr
               else MinHeapNode vl cc (MinHeapLeaf kv) rr
          else if kv <= vr then MinHeapNode kv cc ll rr
               else MinHeapNode vr cc ll (MinHeapLeaf kv)
        MinHeapNode vl ccl lll rrl -> if vl <= vr
          then if kv <= vl then MinHeapNode kv cc ll rr
               else MinHeapNode vl cc (replace ccl lll rrl) rr
          else if kv <= vr then MinHeapNode kv cc ll rr
               else MinHeapNode vr cc ll (MinHeapLeaf kv)
    MinHeapNode vr ccr llr rrr -> case ll of
      (MinHeapNode vl ccl lll rrl) -> -- right is node, so is left
        if vl <= vr then
          if kv <= vl then MinHeapNode kv cc ll rr
          else MinHeapNode vl cc (replace ccl lll rrl) rr
        else if kv <= vr then MinHeapNode kv cc ll rr
             else MinHeapNode vr cc ll (replace ccr llr rrr)

replaceMinPQ :: (Ord kv) => a -> MinHeap kv -> MinHeap kv
replaceMinPQ _ MinHeapEmpty = MinHeapEmpty
replaceMinPQ kv (MinHeapLeaf _) = MinHeapLeaf kv
replaceMinPQ kv (MinHeapNode _ cc ll rr) = siftdown kv cc ll rr where

deleteMinPQ :: (Ord kv) => MinHeap kv -> MinHeap kv
deleteMinPQ MinHeapEmpty = MinHeapEmpty -- remove min keeping tree balanced
deleteMinPQ pq = let (dkv, npq) = delete 0 pq in
                 replaceMinPQ dkv npq where
  delete _ (MinHeapLeaf vv) = (vv, MinHeapEmpty)
  delete msk (MinHeapNode vv cc ll rr) =
      if rr == MinHeapEmpty -- means left is MinHeapLeaf
        then case ll of (MinHeapLeaf vl) -> (vl, MinHeapLeaf vv)
      else if nmsk >= 0 -- means only deal with left
             then let (dv, npq) = delete nmsk ll in
                  (dv, MinHeapNode vv (cc - 1) npq rr)
             else let (dv, npq) = delete nmsk rr in
                  (dv, MinHeapNode vv (cc - 1) ll npq)
    where nmsk = if msk /= 0 then msk `shiftL` 1 -- walk path to last
                 else let s = floor $ (log $ fromIntegral cc) / log 2 in
                      (cc `shiftL` ((finiteBitSize cc) - s)) .|. 1 --never 0 again

adjustPQ :: (Ord kv) => (kv -> kv) -> MinHeap kv -> MinHeap kv
adjustPQ f pq = adjust pq where -- applies function to every element and reheapifies
  adjust MinHeapEmpty = MinHeapEmpty
  adjust (MinHeapLeaf v) = MinHeapLeaf (f v)
  adjust (MinHeapNode vv cc ll rr) = siftdown (f vv) cc (adjust ll) (adjust rr)

fromListPQ :: (Ord kv) => [kv] -> MinHeap kv
-- fromListPQ = foldl (flip pushPQ) MinHeapEmpty -- O(n log n) time; slow
fromListPQ [] = MinHeapEmpty -- O(n) time using "adjust id" which is O(n)
fromListPQ xs = let (_, pq) = build 1 xs in pq where
  sz = length xs
  szd2 = sz `div` 2
  build _ [] = ([], MinHeapEmpty)
  build lvl (x:xs') = if lvl > szd2 then (xs', MinHeapLeaf x)
                      else let nlvl = lvl + lvl in
                           let (xrl, pql) = build nlvl xs' in
                           let (xrr, pqr) = if nlvl >= sz
                                 then (xrl, MinHeapEmpty) -- no right leaf
                                 else build (nlvl + 1) xrl in
                           let cnt = sizePQ pql + sizePQ pqr + 1 in
                           (xrr, siftdown x cnt pql pqr)

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

toListPQ :: (Ord kv) => MinHeap kv -> [kv]
toListPQ = unfoldr f where
  f MinHeapEmpty = Nothing
  f pq = popMinPQ pq

sortPQ :: (Ord kv) => [kv] -> [kv]
sortPQ ls = toListPQ $ fromListPQ ls