Posts Tagged ‘structure’

Programming Praxis – Binary Search Tree

March 5, 2010

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]

Programming Praxis – Growable Arrays

October 16, 2009

Due to another conference (can’t they distribute them a bit more evenly around the year?) I won’t be here for the next three exercises.

In today’s Programming Praxis we’re going to implement a growable array, which is a data structure with logarithmic access where elements can be added without needing reallocation. Basically it’s little more than a binary tree. Let’s get started.

We’ll use a fairly standard binary tree for our data structure:

data Grow a = Empty | Grow { val :: a, l :: Grow a, r:: Grow a }

Next, we want a function that handles taking the correct branches, since we don’t want to have to repeat ourselves.

walk :: (Int -> Grow a -> b) -> Int -> Grow a -> b
walk f i = f (div i 2) . if even i then l else r

We also define another convenience function that handles updating the tree. Unfortunately Haskell doesn’t have first class records yet, so there is some duplication of logic here.

modify :: Grow a -> (Int -> Grow a -> Grow a) -> Int -> Grow a -> Grow a
modify d _ _ Empty         = d
modify _ f i g | even i    = g { l = walk f i g }
               | otherwise = g { r = walk f i g }

Now for the three functions we had to implement: get, put and hirem. Thanks to walk and modify, these are all fairly trivial.

get :: Int -> Grow a -> Maybe a
get _ Empty = Nothing
get 1 g     = Just $ val g
get i g     = walk get i g

put :: Int -> a -> Grow a -> Grow a
put 1 x Empty = Grow x Empty Empty
put 1 x g     = g { val = x }
put i x g     = modify (error "array out of bounds") (`put` x) i g

hirem :: Int -> Grow a -> Grow a
hirem 1 = const Empty
hirem i = modify Empty hirem i

And of course we have to test if we made any mistakes:

main :: IO ()
main = do let arr = foldl (flip (uncurry put)) Empty $ zip [1..]
                    ["alfa", "bravo", "charlie", "delta",
                     "echo", "foxtrot", "golf"]
          print $ get 7 arr
          print $ get 12 arr
          print . get 7 $ hirem (size arr) arr
       where size Empty = 0
             size g     = 1 + size (l g) + size (r g)

Looks like everything is working correctly. See you guys in two weeks!