Skip to content

Instantly share code, notes, and snippets.

# yamaguchiyuto/btree.hs Last active Jan 7, 2018

Haskell B-tree implementation
 data Tree a = Nil Int | Leaf Int [a] | Node Int [a] [Tree a] deriving Show find :: (Ord a, Eq a) => Tree a -> a -> Bool find (Nil _) _ = False find (Leaf _ []) _ = False find (Leaf m (k:ks)) x | x == k = True | x < k = False | x > k = find (Leaf m ks) x find (Node _ [] (t:ts)) x = find t x find (Node m (k:ks) (t:ts)) x | x == k = True | x < k = find t x | x > k = find (Node m ks ts) x insert :: (Ord a, Eq a) => Tree a -> a -> Tree a insert t x = if is_full t then insert_non_full (split t) x else insert_non_full t x insert_non_full :: (Ord a, Eq a) => Tree a -> a -> Tree a insert_non_full (Nil m) x = Leaf m [x] insert_non_full (Leaf m []) x = Leaf m [x] insert_non_full l@(Leaf m keys@(k:ks)) x | x == k = l | x < k = Leaf m (x:keys) | x > k = Leaf m (k:new_ks) where Leaf _ new_ks = insert_non_full (Leaf m ks) x insert_non_full (Node m [] (t:ts)) x = if is_full t then insert_non_full (split t) x else Node m [] [(insert_non_full t x)] insert_non_full n@(Node m keys@(k:ks) trees@(t:ts)) x | x == k = n | x < k = if is_full t then insert_non_full (Node m (newK:k:ks) (newT1:newT2:ts)) x else Node m keys ((insert_non_full t x):ts) | x > k = Node m (k:new_ks) (t:new_ts) where Node _ new_ks new_ts = insert_non_full (Node m ks ts) x Node _ [newK] [newT1, newT2] = split t split :: (Ord a, Eq a) => Tree a -> Tree a split (Leaf m keys) = Node m [k] [Leaf m k1, Leaf m k2] where k1 = first_half keys k:k2 = last_half keys split (Node m keys trees) = Node m [k] [Node m k1 t1, Node m k2 t2] where k1 = first_half keys k:k2 = last_half keys t1 = first_half trees t2 = last_half trees first_half :: [a] -> [a] first_half xs = take (div (length xs) 2) xs last_half :: [a] -> [a] last_half xs = drop (div (length xs) 2) xs is_full :: (Ord a, Eq a) => Tree a -> Bool is_full (Nil m) = False is_full (Leaf m ks) | length ks == (2 * m - 1) = True | otherwise = False is_full (Node m ks _) | length ks == (2 * m - 1) = True | otherwise = False delete :: (Ord a, Eq a) => Tree a -> a -> Tree a delete (Nil _) _ = error "Underflow" delete (Leaf _ []) _ = error "Underflow" delete n@(Node m [k] [t1, t2]) x = if is_few t1 && is_few t2 then delete_non_few (merge k t1 t2) x else delete_non_few n x delete n x = delete_non_few n x is_few :: (Ord a, Eq a) => Tree a -> Bool is_few (Nil _) = False is_few (Leaf m keys) | length keys == (m - 1) = True | otherwise = False is_few (Node m keys _) | length keys == (m - 1) = True | otherwise = False delete_non_few :: (Ord a, Eq a) => Tree a -> a -> Tree a delete_non_few l@(Leaf _ _) x = delete_leaf l x delete_non_few n@(Node m [k] [t1, t2]) x | x == k = delete_here n x | x < k = delete_middle n x | x > k = delete_last n x delete_non_few n@(Node m (k:ks) (t:t_next:ts)) x | x == k = delete_here n x | x < k = delete_middle n x | x > k = Node m (k:new_ks) (t:new_ts) where Node _ new_ks new_ts = delete_non_few (Node m ks (t_next:ts)) x delete_leaf :: (Ord a, Eq a) => Tree a -> a -> Tree a delete_leaf l@(Leaf m (k:ks)) x | x == k = Leaf m ks | x < k = l | x > k = Leaf m (k:new_ks) where Leaf _ new_ks = delete_leaf (Leaf m ks) x delete_here :: (Ord a, Eq a) => Tree a -> a -> Tree a delete_here (Node m (k:ks) (t1:t2:ts)) x = if is_few t1 && is_few t2 then Node m ks ((delete_non_few (merge k t1 t2) x):ts) else if is_few t1 then Node m ((get_min t2):ks) (t1:(delete_min t2):ts) else Node m ((get_max t1):ks) ((delete_max t1):t2:ts) delete_middle :: (Ord a, Eq a) => Tree a -> a -> Tree a delete_middle (Node m (k:ks) (t1:t2:ts)) x = if is_few t1 && is_few t2 then Node m ks ((delete_non_few (merge k t1 t2) x):ts) else if is_few t1 then Node m (shifted_k:ks) ((delete_non_few shifted_t1 x):shifted_t2:ts) else Node m (k:ks) ((delete_non_few t1 x):t2:ts) where Node _ [shifted_k] [shifted_t1, shifted_t2] = shift_left k t1 t2 delete_last :: (Ord a, Eq a) => Tree a -> a -> Tree a delete_last (Node m [k] [t1, t2]) x = if is_few t2 && is_few t1 then Node m [] [delete_non_few (merge k t1 t2) x] else if is_few t2 then Node m [shifted_k] [shifted_t1, (delete_non_few shifted_t2 x)] else Node m [k] [t1, (delete_non_few t2 x)] where Node _ [shifted_k] [shifted_t1, shifted_t2] = shift_right k t1 t2 merge :: (Ord a, Eq a) => a -> Tree a -> Tree a -> Tree a merge k (Leaf m1 keys1) (Leaf _ keys2) = Leaf m1 (keys1 ++ [k] ++ keys2) merge k (Node m1 keys1 trees1) (Node _ keys2 trees2) = Node m1 (keys1 ++ [k] ++ keys2) (trees1 ++ trees2) shift_left :: (Ord a, Eq a) => a -> Tree a -> Tree a -> Tree a shift_left k (Leaf m keys1) (Leaf _ (k2:keys2)) = Node m [k2] [(Leaf m (keys1 ++ [k])), (Leaf m keys2)] shift_left k (Node m keys1 trees1) (Node _ (k2:keys2) (t2:trees2)) = Node m [k2] [(Node m (keys1 ++ [k]) (trees1 ++ [t2])), (Node m keys2 trees2)] shift_right :: (Ord a, Eq a) => a -> Tree a -> Tree a -> Tree a shift_right k (Leaf m keys1) (Leaf _ keys2) = Node m [last keys1] [(Leaf m (init keys1)), (Leaf m (k:keys2))] shift_right k (Node m keys1 trees1) (Node _ keys2 trees2) = Node m [last keys1] [(Node m (init keys1) (init trees1)), (Node m (k:keys2) ((last trees1):trees2))] get_min :: (Ord a, Eq a) => Tree a -> a get_min (Leaf _ keys) = head keys get_min (Node _ _ trees) = get_min (head trees) delete_min :: (Ord a, Eq a) => Tree a -> Tree a delete_min (Leaf m keys) = Leaf m (tail keys) delete_min (Node m keys (t:ts)) = Node m keys ((delete_min t):ts) get_max :: (Ord a, Eq a) => Tree a -> a get_max (Leaf _ keys) = last keys get_max (Node _ _ trees) = get_max (last trees) delete_max :: (Ord a, Eq a) => Tree a -> Tree a delete_max (Leaf m keys) = Leaf m (init keys) delete_max (Node m keys trees) = Node m keys ((init trees) ++ [delete_max (last trees)])
to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.