Binary heap (with typeclass abstraction)

bheap.hs

{-# LANGUAGE FlexibleInstances #-}
--{-# LANGUAGE AllowAmbiguousTypes #-} -- ??

import PrettyT
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Control.Monad
import Control.Applicative
-- data Btree a = Empty | Node a (Btree a) (Btree a) deriving Show

 --In a complete binary tree every level, except possibly the last, is completely filled,
 -- and all nodes in the last level are as far left as possible.
 -- It can have between 1 and 2h nodes at the last level h

-- left child = 2*i | lc = 2*pi => pi = lc /2
-- right child = 2*i+1 | rc = 2*pi+1 => pi = (rc - 1) / 2

-- https://www.youtube.com/watch?v=PWL68hPTwxQ
-- converts tree
ct :: (Ord k, Ord n, HCont c) => c k n -> Btree (k,n)
ct c = ctb 1 c where
                    ctb :: (Ord k, Ord n, HCont c) => Int -> c k n -> Btree (k,n)
                    ctb i c | len_ c == 0 = Empty
                            | otherwise = Node (c ! i) lt rt where
                                                                lt = if len_ c >= (2*i) then ctb (2*i) c else Empty
                                                                rt = if len_ c >= (2*i+1) then ctb (2*i+1) c else Empty
-- https://en.wikipedia.org/wiki/Binary_heap
-- A binary heap is binary tree with two additional constraints:
-- 1. Shape property: a binary heap is a complete binary tree
-- 2. Heap property: the key stored in each node is (>=) than all children

-- [3,1,2,4] -> [3,4,2,1] -> [4,3,2,1]

heapify_up :: (Ord k, Ord n, HCont c) => c k n -> Int -> c k n
heapify_up c i | i == 1 = c
               | (c ! pi) >= (c ! i) = c
               | otherwise = heapify_up (swp_ pi i c) pi
                                                        where
                                                          pi = if odd i then (i - 1) `div` 2 else i `div` 2


ins :: (Ord k, Ord n, HCont c) => c k n -> (k,n) -> c k n
ins c (k,n) = heapify_up (append_ k n c) ((len_ c)+1)


bhl :: (Ord k, Ord n, HCont c) => [(k,n)] -> c k n
bhl l = foldl ins empty_ l
--bfl :: (Ord k, Ord n, HCont c) => [(k,n)] -> Btree (k,n)
--bfl l = ct $ bhl l

--  printt $ ct $ (bhl [(1,'a'),(2,'b'),(3,'c'),(3,'d'),(1,'x')] :: CArr Int Char)
-- printt $ ct $ snd $ fromJust $ emax (bhl [(1,'a'),(2,'b'),(3,'c'),(3,'d'),(1,'x'),(11,'z')] :: CArr Int Char)


upd_to_lt :: (Ord k, Ord n, HCont c) => n -> k -> c k n -> c k n
upd_to_lt n k c = fst $ heapify_down (c',i) where i = get_i_by_n c n
                                                  c' = set_ i (k,n) c


upd_to_gt :: (Ord k, Ord n, HCont c) => n -> k -> c k n -> c k n
upd_to_gt n k c = heapify_up c' i where i = get_i_by_n c n
                                        c' = set_ i (k,n) c

heapify_down :: (Ord k, Ord n, HCont c) => (c k n, Int) -> (c k n, Int)
heapify_down (c, i) | ni == i = ns
                    | otherwise = heapify_down ns
                    where
                          ns@(nl, ni) = fromJust $ (do ln <- le; rn <- re; if (e>=ln) && (e>=rn) then Just (c,i) else Nothing) <|>
                                   (do ln <- le; rn <- re; if (e>=ln) && (e<rn) then Just (swp_ i re_i c, re_i) else Nothing) <|>
                                   (do ln <- le; rn <- re; if (e<ln) && (e>=rn) then Just (swp_ i le_i c, le_i) else Nothing) <|>
                                   (do ln <- le; rn <- re; if (e<ln) && (e<rn) then if ln>rn then Just (swp_ i le_i c, le_i) else Just (swp_ i re_i c, re_i) else Nothing) <|>
                                   (do ln <- le; if (e>=ln) then Just (c,i) else Nothing) <|>
                                   (do rn <- re; if (e>=rn) then Just (c,i) else Nothing) <|>
                                   (do ln <- le; if (e<ln) then Just (swp_ i le_i c, le_i) else Nothing)  <|>
                                   (do rn <- re; if (e<rn) then Just (swp_ i re_i c, re_i) else Nothing)  <|>
                                   Just (c,i) -- no left and right elems
                                    where
                                     le_i = 2*i
                                     re_i = 2*i+1
                                     e = fst (c ! i)
                                     le = c `get_` le_i
                                     re = c `get_` re_i

--
emax :: (Ord k, Ord n, HCont c) => c k n -> Maybe ((k,n),c k n)
emax c = do (mx,c) <- extr_last_ (swp_ 1 (len_ c) c)
            return $ (mx,fst $ heapify_down (c,1))

(!!!) :: [a] -> Int -> Maybe a
(!!!) xs i
        | (i> -1) && (length xs > i) = Just (xs!!i)
        | otherwise = Nothing

-- printt $ bfl $ snd $ emax $ bhl [7,1,2,3,5,4,1,3,9]

-- Abstract container for binary heap with keys of type k and values of type n (n - identify nodes)
-- IMPORTANT : ASSUME N is uniq
class HCont c where
  empty_ :: c k n
  len_ :: c k n -> Int
  append_ :: Ord n => k -> n -> c k n -> c k n
  -- get_by_n :: Ord n => c k n -> n -> k
  get_i_by_n :: Ord n => c k n -> n -> Int
  (!) :: c k n -> Int -> (k,n)
  get_ :: c k n -> Int -> Maybe k
  set_ :: Ord n => Int -> (k,n) -> c k n -> c k n
  swp_ :: Ord n => Int -> Int -> c k n -> c k n
  extr_last_ :: Ord n => c k n -> Maybe ((k,n),c k n)
  -- rem_last_ (swp_ 1 len c)

  swp_ i1 i2 l = set_ i2 v1 (set_ i1 v2 l) where v1 = l ! i1
                                                 v2 = l ! i2


data CArr k n = CArr [(k,n)] (M.Map n Int) deriving Show

instance HCont CArr where
  empty_ = CArr [] M.empty
  len_ (CArr l _) = length l
  append_ k v (CArr l m) = CArr l1 m1 where l1 = l ++ [(k,v)]
                                            m1 = M.insert v (length l) m
  -- get_by_n (CArr l m) n = fst $ l !! (fromJust (M.lookup n m))
  get_i_by_n (CArr _ m) n = (fromJust (M.lookup n m))+1
  (!) (CArr l m) i = l !! (i-1)
  get_ (CArr l m) i = fst <$> (l !!! (i-1))
  set_ i (k,n) (CArr l m) = CArr l1 m1 where l1 = take (i-1) l ++ [(k,n)] ++ drop (i - 1 + 1) l
                                             m1 = M.insert n (i-1) m



  extr_last_ c@(CArr l m) | (length l) < 1 = Nothing
                          | otherwise = Just $ ((k,n),CArr l1 m1) where m1 = M.delete n m
                                                                        l1 = init l
                                                                        (k,n) = c ! (len_ c)



x = append_ 1 'b' (append_ 1 'a' (empty_ :: CArr Int Char))

-- the first Map as simple array, the second maps "nodes -> index of first"
data CArrM k n = CArrM (M.Map Int (k,n)) (M.Map n Int) deriving Show

-- both implementation as CArr or CArrM can be used, CArrM - faster

-- operates at log N time, we can use HashMap instance to operate O(1) time
instance HCont CArrM where
  empty_ = CArrM M.empty M.empty
  len_ (CArrM m1 _) = M.size m1
  append_ k v (CArrM lm m) = CArrM lm1 m1 where lm1 = M.insert last_i (k,v) lm
                                                m1 = M.insert v last_i m  -- node -> index
                                                last_i = (M.size lm) + 1
  get_i_by_n (CArrM _ m) n = (fromJust (M.lookup n m))
  (!) (CArrM lm _) i = fromJust (M.lookup i lm)
  get_ (CArrM lm _) i = fst <$> (M.lookup i lm)
  set_ i (k,n) (CArrM lm m) = CArrM l1 m1 where l1 = M.insert i (k,n) lm
                                                m1 = M.insert n i m
  extr_last_ c@(CArrM lm m) | (M.size lm) < 1 = Nothing
                            | otherwise = Just $ ((k,n),CArrM l1 m1) where m1 = M.delete n m
                                                                           l1 = M.delete last_i lm
                                                                           (k,n) = c ! (len_ c)
                                                                           last_i = len_ c

y = append_ 1 'b' (append_ 1 'a' (empty_ :: CArrM Int Char))

--
--  -- https://stackoverflow.com/questions/25191659/why-is-haskell-missing-obvious-typeclasses
--  -- https://hackage.haskell.org/package/ixset-1.1.1.1/docs/Data-IxSet.html