1
\$\begingroup\$

I wrote a (max) heap in Haskell which is balanced after every (public) operation. Not based on any documentation. Focus is on:

  • speed, that is the right time-complexities (not necessarily optimal);
  • easy to understand, so no Maybe's, Monads or symbols a beginner is unfamiliar with.
         ******* 4
         *
 ******* 6
 *       *
 *       ******* 2
 *
 8
 *
 *       ******* 3
 *       *
 ******* 7
         *
         *       *******
         *       *
         ******* 5
                 *
                 ******* 1

Would like it to be reviewed.

module Heap (insert, 
             size, 
             deleteMax, 
             getMax, 
             fromList, 
             toList, 
             isEmpty,
             empty,
             singleton,
             member) where


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


-- Insert an element to the heap.   
insert :: Ord a => a -> Heap a -> Heap a
insert x Empty     = Node x 1 Empty Empty
insert x (Node t n l r)
    | x >  t && size l > size r    = Node x (n + 1) l (insert t r)
    | x >  t                       = Node x (n + 1) (insert t l) r 
    | x <= t && size l > size r    = Node t (n + 1) l (insert x r) 
    | x <= t                       = Node t (n + 1) (insert x l) r  


-- Checks if a heap is empty. 
isEmpty :: Ord a => Heap a -> Bool
isEmpty Empty = True
isEmpty _     = False 


-- Gives the empty heap. 
empty :: Ord a => Heap a
empty = Empty 


-- Creates a heap from a list. 
fromList :: Ord a => [a] -> Heap a
fromList ls = foldr insert Empty ls      


-- Checks if an element is a member of the heap. 
member :: Ord a => a -> Heap a -> Bool
member x Empty         = False
member x (Node t _ l r) 
    | x >= t           = x == t 
    | otherwise        = member x l || member x r 


-- Turns the heap into a list. 
toList :: Ord a => Heap a -> [a]
toList Empty          = []
toList (Node t _ l r) = (t : toList l) ++ (toList r)


-- Deletes an element from a heap which doesn't have any 
-- smaller elements in a left or right heap. The mentioned
-- element together with the new heap are returned.  
deleteBottom :: Ord a => Heap a -> (a, Heap a)
deleteBottom (Node t _ Empty Empty) = (t, Empty)
deleteBottom (Node t n l r)
    | size l < size r         = (x1, Node t (n - 1) l r')  
    | otherwise               = (x2, Node t (n - 1) l' r)
    where
    (x1, r')   = deleteBottom r 
    (x2, l')   = deleteBottom l 


-- Delete the largest element in the heap. The largest element
-- together with the new heap are returned. 
-- Doesn't check for non-emptiness, therefore unsafe.  
deleteMax :: Ord a => Heap a -> (a, Heap a)
deleteMax (Node t _ Empty Empty) = (t, Empty) 
deleteMax (Node t n l r)         = (t, merge x l' r') 
    where
    (x, Node _ _ l' r')   = deleteBottom (Node t n l r)


-- Create a heap from a single element. 
singleton :: Ord a => a -> Heap a
singleton x = insert x Empty


-- An element x and two heaps A and B for which holds:
--    |size A - size B| <= 1. 
-- Returns a new heap where x, A and B are glued together. 
merge :: Ord a => a -> Heap a -> Heap a -> Heap a
merge x Empty Empty      = singleton x
merge x (Node t _ Empty Empty) Empty 
    | x < t              = Node t 2 (singleton x) Empty 
    | otherwise          = Node x 2 (singleton t) Empty   
merge x Empty (Node t _ Empty Empty)  
    | x < t              = Node t 2 Empty (singleton x)  
    | otherwise          = Node x 2 Empty (singleton t)
merge x (Node t n l r) (Node t' n' l' r')
    | x >= t && x >= t'  = Node x new_n (Node t n l r) (Node t' n' l' r')
    | t >= x && t >= t'  = Node t new_n (merge x l r) (Node t' n' l' r') 
    | otherwise          = Node t' new_n (Node t n l r) (merge x l' r') 
    where
    new_n   = 1 + n + n' 


-- Returns the number of elements in a heap. 
size :: Ord a => Heap a -> Int
size Empty              = 0
size (Node _ n _ _)     = n 


-- Get the largest element in a non-empty heap.
-- Doesn't check for non-emptiness, therefore unsafe.  
getMax :: Ord a => Heap a -> a
getMax (Node t _ _ _) = t


instance (Show a) => Show (Heap a) where
    show tr = ((++) "\n" . unlines . snd . toLines) tr

        where

        toLines :: (Show a) => Heap a -> (Int, [String])
        toLines Empty                   = (0, [""])
        toLines (Node t _ Empty Empty)  = (0, [" " ++ show t])
        toLines (Node t _ l r)          = (ln + 1, lv_new ++ [" *"] ++ [" " ++ show t] ++ [" *"] ++ rv_new)
            where
            (il, lv)    = toLines l
            (ir, rv)    = toLines r
            ln          = length lv
            rn          = length rv
            lv_sub      = (replicate il "        ") ++ [" *******"] ++ (replicate (ln - il) " *      ")
            rv_sub      = (replicate ir " *      ") ++ [" *******"] ++ (replicate (rn - ir) "        ")
            lv_new      = zipWith (++) lv_sub lv
            rv_new      = zipWith (++) rv_sub rv
\$\endgroup\$
  • 1
    \$\begingroup\$ Welcome to Code Review. Is there a specific reason why you don't want to use Maybe and therefore get partial functions? Also, is that Show instance intended? \$\endgroup\$ – Zeta Jan 21 at 22:19

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.