In today’s Programming Praxis exercise we have to implement a Binary Search Tree. Let’s get started, shall we?

We need two imports:

import Control.Monad import System.Random

The data structure is your run-of-the-mill binary tree.

data BTree k v = Node k v (BTree k v) (BTree k v) | Empty

Finding an element is pretty straightforward. Just keep taking the correct branch until we exhaust the tree or find what we want.

find :: (k -> k -> Ordering) -> k -> BTree k v -> Maybe v find _ _ Empty = Nothing find cmp k (Node k' v' l r) = case cmp k k' of EQ -> Just v' LT -> find cmp k l GT -> find cmp k r

Inserting works the same way as find: move to the correct position and insert or replace the new value.

insert :: (k -> k -> Ordering) -> k -> v -> BTree k v -> BTree k v insert _ k v Empty = Node k v Empty Empty insert cmp k v (Node k' v' l r) = case cmp k k' of EQ -> Node k v l r LT -> Node k' v' (insert cmp k v l) r GT -> Node k' v' l (insert cmp k v r)

Since the deletion algorithm calls for a random number, delete is an IO action. You can consider using unsafePerformIO to hide this (I did in my first draft), but I decided to stick with the honest, safer (though less convenient) version. Alternatively you could accept the occasional imbalance and just always start on the left.

delete :: (k -> k -> Ordering) -> k -> BTree k v -> IO (BTree k v) delete _ _ Empty = return Empty delete cmp k t@(Node k' v' l r) = case cmp k k' of EQ -> fmap (flip deroot t . (== 0)) $ randomRIO (0,1 :: Int) LT -> fmap (flip (Node k' v') r) $ delete cmp k l GT -> fmap ( Node k' v' l) $ delete cmp k r

For the deroot function we use a slightly different approach than the Scheme version. I’m not sure how that version deals with the case of one of the two branches being empty, but here they are explicitly included in the patterns. The rot-left and rot-right functions are rewritten as patterns.

deroot :: Bool -> BTree k v -> BTree k v deroot _ Empty = Empty deroot _ (Node _ _ l Empty) = l deroot _ (Node _ _ Empty r) = r deroot True (Node k v l (Node rk rv rl rr)) = Node rk rv (deroot False $ Node k v l rl) rr deroot _ (Node k v (Node lk lv ll lr) r) = Node lk lv ll (deroot True $ Node k v lr r)

Converting the search tree to a list is trivial.

toList :: BTree k v -> [(k, v)] toList Empty = [] toList (Node k v l r) = toList l ++ (k, v) : toList r

And, as always, a test to see if everything is working correctly:

main :: IO () main = do let t = foldr (uncurry $ insert compare) Empty $ [(n, n) | n <- [4,1,3,5,2]] print $ toList t print $ find compare 3 t print $ find compare 9 t print . toList =<< foldM (flip $ delete compare) t [4,2,3,5,1]