На этом шаге мы приведем примеры работы с такими деревьями средствами языка Haskell.
Приведем ряд примеров, иллюстрирующих работу с красно-черными деревьями с помощью конструкций языка Haskell.
Пример 1. Демонстрация функции, возвращающей чёрную высоту красно-чёрного дерева, определённой по левой ветви исходного дерева tree.
Раскрыть/скрыть текст примера.
-- Демонстрация функции, возвращающей чёрную высоту -- красно-чёрного дерева, определённой по левой ветви -- исходного дерева tree ------------------------ import TreeRB hBlack:: RBTree -> Integer hBlack tree | tree == (NIL ('B')) = 0 | (snd (root tree) == 'B' || snd (root tree) == 'R') && left tree == (NIL ('B')) && right tree == (NIL ('B')) = 1 | (snd (root tree) == 'B' || snd (root tree) == 'R') && left tree /= (NIL ('B')) && snd (root (left tree)) == 'B' = 1 + hBlack (left tree) | snd (root tree) == 'B' && left tree /= (NIL ('B')) && snd (root (left tree)) == 'R' = 1 + hBlack (left tree) | True = hBlack (left tree) ------------------------------------------------------ -- Неудачные тестовые примеры -------------------------------- test = hBlack (NIL ('B')) == 0 && hBlack (Node (1,'B') (NIL ('B')) (NIL ('B'))) == 1 && hBlack (Node (1,'R') (NIL ('B')) (NIL ('B'))) == 1 && hBlack (Node (5,'B') (Node (3,'B') (NIL ('B')) (NIL ('B'))) (Node (6,'B') (NIL ('B')) (NIL ('B')))) == 2 && hBlack (Node (5,'R') (Node (3,'B') (NIL ('B')) (NIL ('B'))) (Node (6,'B') (NIL ('B')) (NIL ('B')))) == 2 && hBlack (Node (5,'B') (Node (3,'B') (NIL ('B')) (NIL ('B'))) (Node (10,'R') (Node (8,'B') (Node (7,'R') (NIL ('B')) (NIL ('B'))) (NIL ('B'))) (Node (11,'B') (NIL ('B')) (NIL ('B'))))) == 2 && hBlack (Node (5,'R') (Node (3,'B') (NIL ('B')) (NIL ('B'))) (Node (8,'B') (Node (7,'R') (NIL ('B')) (NIL ('B'))) (NIL ('B')))) == 2 && hBlack (Node (10,'B') (Node (3,'B') (Node (2,'B') (NIL ('B')) (NIL ('B'))) (Node (8,'R') (Node (5,'B') (Node (1,'R') (NIL ('B')) (NIL ('B'))) (NIL ('B'))) (Node (9,'B') (NIL ('B')) (NIL ('B'))))) (Node (13,'B') (Node (12,'B') (NIL ('B')) (NIL ('B'))) (Node (18,'R') (Node (15,'B') (Node (14,'R') (NIL ('B')) (NIL ('B'))) (NIL ('B'))) (Node (19,'B') (NIL ('B')) (NIL ('B')))))) == 3
Пример 2. Демонстрация различных ситуаций, возникающих в красно-чёрных деревьях при добавлении и удалении вершин.
Раскрыть/скрыть текст примера.
-- Демонстрация различных ситуаций, возникающих -- в красно-чёрных деревьях при добавлении и уда- -- лении вершин --------------- import TreeRB ------------------------- test = writeFile "Output" ("Дерево:\n " ++ (drawTree t1 0) ++ "\n\n" ++ "Добавление красной вершины " ++ show v1 ++ ": " ++ "\n\n" ++ "Красный предок, чёрный дядя: \n\n" ++ (drawTree a1 0) ++ "\n\n" ++ "Исправление нарушения свойства " ++ "красного узла: " ++ "\n\n" ++ (drawTree rb1 0) ++ "\n\n" ++ "Повторное применение функции: \n"++ (drawTree rb1' 0) ++ "\n\n" ++ " ----------------------------------------\n" ++ "Дерево:\n " ++ (drawTree t1 0) ++ "\n\n" ++ "Добавление красной вершины " ++ show v2 ++ ": " ++ "\n\n" ++ "Красный предок, чёрный дядя: \n\n" ++ (drawTree a2 0) ++ "\n\n" ++ "Исправление нарушения свойства " ++ "красного узла: " ++ "\n\n" ++ (drawTree rb2 0) ++ "\n\n" ) where ------------------------------- -- Красный предок, чёрный дядя. -- (а) ------------------------------- t1 = Node (5,'B') (Node (1,'R') (NIL ('B')) (NIL ('B'))) (NIL ('B')) v1 = (-1) a1 = addTree v1 'R' t1 rb1 = rb_Ins1 a1 v1 rb1' = rb_Ins1 rb1 v1 --------------------- -- (б) ------- v2 = 3 a2 = addTree v2 'R' t1 rb2 = rb_Ins1 a2 v2
В приведенных примерах используется библиотека для работы с красно-чёрными деревьями. Ее текст приведен ниже.
Раскрыть/скрыть текст библиотеки.
-- Библиотека для работы с красно-чёрными деревьями. -- -- Автор программы: И.А.Кудрявцева (05-06.11.2010) -- -- Автор псевдокода операции вставки узла в красно-чёрное -- дерево и восстановления красно-чёрных свойств дерева -- после удаления узла [Кормен,Лейзерсон,Ривест,1999] ----------------------------------------------------- module TreeRB (RBTree (..), rb_Ins, rb_Ins1, rb_Del, rb_Del1, chng_Clr, root, left, right, addTree, ud, delete, srch, search, subst, srch_G, srch_D, srch_B, srch_Nl, srch_Nr, srch_U, rot_Right, rot_Left, rotInTree, drawTree, outTree) where data RBTree = NIL (Char) | Node (Integer,Char) (RBTree) (RBTree) deriving Eq ------------------------------------------------------------------- -- rb_Ins - функция возвращает красно-чёрное дерево поиска tree, -- в которое добавлен указанный узел s -------------------------------------------------- rb_Ins:: RBTree -> Integer -> RBTree rb_Ins tree s = subst func (root func) (fst (root func),'B') where func = rb_Ins1 (addTree s 'R' tree) s ----------------------------------------------------------------- -- rb_Ins1 - функция возвращает бинарное дерево поиска tree с -- NIL-узлами, в которое добавлен указанный узел s -- и которое может обладать всеми свойствами красно- -- чёрного дерева ------------------------------------- rb_Ins1:: RBTree -> Integer -> RBTree rb_Ins1 tree s | s == fst (root tree) || snd (root (search (fst (srch_D s tree)) tree)) == 'B' = tree | (fst (srch_D s tree) < fst (srch_G s tree) || fst (srch_D s tree) > fst (srch_G s tree)) && (pSrch_U s tree) && snd (root (search (fst (srch_U s tree)) tree)) == 'R' = rb_Ins1 (chng_Clr (chng_Clr (chng_Clr tree (fst (srch_D s tree)) 'B') (fst (srch_G s tree)) 'R') (fst (srch_U s tree)) 'B') (fst (srch_G s tree)) | (fst (srch_D s tree) < fst (srch_G s tree) && s > fst (srch_D s tree)) || (fst (srch_D s tree) > fst (srch_G s tree) && s < fst (srch_D s tree)) = rb_Ins1 (rotInTree s tree) (fst (srch_D s tree)) | True = rb_Ins1 (rotInTree (fst (srch_D s tree)) (chng_Clr (chng_Clr tree (fst (srch_D s tree)) 'B') (fst (srch_G s tree)) 'R')) s ------------------------------------------------------------------- -- rb_Del - функция возвращает красно-чёрное дерево поиска Tree, -- из которого удалён указанный узел S -------------------------------------------------- rb_Del:: RBTree -> Integer -> RBTree rb_Del tree s | tree == (NIL ('B')) || not (srch s tree) = tree | snd (root (search s tree)) == 'R' && (left (search s tree) == (NIL ('B')) || right (search s tree) == (NIL ('B'))) = delete s tree | right (search s tree) == (NIL ('B')) && left (search s tree) == (NIL ('B')) = delete s (rb_Del1 tree s) | True = delete s (rb_Del1 tree predicat) where predicat | right (search s tree) == (NIL ('B')) = fst (root (left (search s tree))) | True = fst (ud (right (search s tree))) ------------------------------------------------------------------- -- rb_Del1 - функция возвращает сбалансированное красно-чёрное -- дерево после удаления узла x -------------------------------------------- rb_Del1:: RBTree -> Integer -> RBTree rb_Del1 tree x | x == fst (root tree) || snd (root (search x tree)) == 'R' = subst tree (root (search x tree)) (x,'B') | not (pSrch_B x tree) = tree | (x < fst (srch_D x tree) || x > fst (srch_D x tree)) && snd (root (search (fst (srch_B x tree)) tree)) == 'R' = rb_Del1 (rotInTree (fst (srch_B x tree)) (chng_Clr (chng_Clr tree (fst (srch_D x tree)) 'R') (fst (srch_B x tree)) 'B')) x | (x < fst (srch_D x tree) || x > fst (srch_D x tree)) && snd (root (search (fst (srch_B x tree)) tree)) == 'B' && ((not (pSrch_Nl x tree) && not (pSrch_Nr x tree)) || (snd (root (search (fst (srch_Nl x tree)) tree)) == 'B'&& snd (root (search (fst (srch_Nr x tree)) tree)) == 'B')) = (rb_Del1 (chng_Clr tree (fst (srch_B x tree)) 'R') (fst (srch_D x tree))) | x < fst (srch_D x tree) && snd (root (search (fst (srch_Nr x tree)) tree)) == 'B' = rb_Del1 (rotInTree (fst (srch_Nl x tree)) (chng_Clr (chng_Clr tree (fst (srch_B x tree)) 'R') (fst (srch_Nl x tree)) 'B')) x | x < fst (srch_D x tree) = rotInTree (fst (srch_B x tree)) (chng_Clr (chng_Clr (chng_Clr tree (fst (srch_D x tree)) 'B') (fst (srch_B x tree)) (snd (root (search (fst (srch_D x tree)) tree)))) (fst (srch_Nr x tree)) 'B') ---------------------------------------------------- -- "Зеркальное" отражение двух предыдущих условий ---------------------------------------------------- | x > fst (srch_D x tree) && snd (root (search (fst (srch_Nl x tree)) tree)) == 'B' = rb_Del1 (rotInTree (fst (srch_Nr x tree)) (chng_Clr (chng_Clr tree (fst (srch_B x tree)) 'R') (fst (srch_Nr x tree)) 'B')) x | True = rotInTree (fst (srch_B x tree)) (chng_Clr (chng_Clr (chng_Clr tree (fst (srch_D x tree)) 'B') (fst (srch_B x tree)) (snd (root (search (fst (srch_D x tree)) tree)))) (fst (srch_Nl x tree)) 'B') ----------------------------------------------------------------- -- chng_Clr - функция возвращает копию бинарного дерева поиска -- tree с NIL-узлами с изменением цвета указанной -- вершины ---------------------------------------------- chng_Clr:: RBTree -> Integer -> Char -> RBTree chng_Clr tree v clr_V | tree == (NIL ('B')) || srch v tree == False = tree | True = subst tree (root (search v tree)) (v,clr_V) ----------------------------------------------------------- -- Функция возвращает ключ корня бинарного дерева поиска -- Tree с NIL-узлами ------------------------------- root:: RBTree -> (Integer,Char) root (NIL ('B')) = error "Корень дерева отсутствует!" root (Node a l r) = a ---------------------------------------------------------------- -- Функция возвращает левое поддерево бинарного дерева поиска -- Tree с NIL-узлами ----------------------- left:: RBTree -> RBTree left (NIL ('B')) = (NIL ('B')) left (Node a l r) = l ----------------------------------------------------------------- -- Функция возвращает правое поддерево бинарного дерева поиска -- Tree с NIL-узлами ------------------------ right:: RBTree -> RBTree right (NIL ('B')) = (NIL ('B')) right (Node a l r) = r --------------------------------------------------------- -- Функция добавляет элемент с ключом S и цветом Color -- в бинарное дерево поиска Tree с NIL-узлами ------------------------------------------------ addTree:: Integer -> Char -> RBTree -> RBTree addTree s color tree | tree == (NIL ('B')) = (Node (s,color) (NIL ('B')) (NIL ('B'))) | s == (fst (root tree)) = tree | s < (fst (root tree)) = (Node (root tree) (addTree s color (left tree)) (right tree)) | True = (Node (root tree) (left tree) (addTree s color (right tree))) ------------------------------------------------------------------- -- Функция удаляет узел с ключом S из бинарного дерева поиска -- Tree с NIL-узлами. -- Место удаляемой вершины занимает вершина, ключ которой яв- -- ляется следующим по порядку (в смысле по ряду целых чисел) -- ключей вершин дерева. -- Функции delete и ud повторяют соответствующие рекурсивные -- процедуры Н.Вирта [1985], написанные на языке программиро- -- вания Pascal, с небольшими изменениями -------------------------------------------- delete:: Integer -> RBTree -> RBTree delete s tree | tree == (NIL ('B')) = (NIL ('B')) | s < (fst (root tree)) = (Node (root tree) (delete s (left tree)) (right tree)) | s > (fst (root tree)) = (Node (root tree) (left tree) (delete s (right tree))) | (right tree) == (NIL ('B')) = left tree | (left tree) == (NIL ('B')) = right tree | True = (Node (ud (right tree)) (left tree) (delete (fst (ud (right tree))) (right tree))) --------------------------------------------------- -- Вспомогательная функция для функции delete. -- Возвращает узел с минимальным ключом непустого бинарного -- дерева поиска Tree с NIL-узлами ------------------------------------- ud:: RBTree -> (Integer,Char) ud tree | (left tree) == (NIL ('B')) = root tree | True = ud (left tree) ------------------------------------------------------- -- Предикат, устанавливающий, имеется ли элемент s в -- бинарном дереве поиска tree с NIL-узлами ---------------------------------------------- srch:: Integer -> RBTree -> Bool srch s tree | tree==(NIL ('B')) = False | s==fst (root tree) = True | True = srch s (left tree) || srch s (right tree) ------------------------------------------------------------ -- Функция, осуществляющая поиск в бинарном дереве tree с -- NIL-узлами элемент с ключом s: в случае успеха функция -- возвращает поддерево дерева tree, в котором узел с клю- -- чом s является корнем; в противном случае - (NIL ('B')) ------------------------------------------------------------- search:: Integer -> RBTree -> RBTree search s tree | tree == (NIL ('B')) = (NIL ('B')) | s == (fst (root tree)) = tree | s < (fst (root tree)) = search s (left tree) | True = search s (right tree) ----------------------------------------------------------------- -- Демонстрация функции, производящей замену в бинарном дереве -- tree всех вхождений узла a на узел b ------------------------------------------------------------ subst:: RBTree -> (Integer,Char) -> (Integer,Char) -> RBTree subst tree a b | tree == (NIL ('B')) = (NIL ('B')) | root tree == a = (Node b (subst (left tree) a b) (subst (right tree) a b)) | True = (Node (root tree) (subst (left tree) a b) (subst (right tree) a b)) -------------------------------------------------------------------- -- pSrch_G - предикат, определяющий, имеется ли вершина "дедушка" -- для заданной вершины s бинарного дерева поиска tree -- с NIL-узлами ----------------------------------- pSrch_G:: Integer -> RBTree -> Bool pSrch_G s tree | not (pSrch_D s tree) = False | True = pSrch_D (fst (srch_D s tree)) tree --------------------------------------------------------------- -- Функция, возвращающая узел "дедушка" для заданной вершины -- s бинарного дерева поиска tree с NIL-узлами ------------------------------------------------- srch_G:: Integer -> RBTree -> (Integer,Char) srch_G s tree | tree == (NIL ('B')) || not (srch s tree) = error "Вершина 'дедушка' не найдена!" | left (left tree) /= (NIL ('B')) && s == fst (root (left (left tree))) || right (left tree) /= (NIL ('B')) && s == fst (root (right (left tree))) || left (right tree) /= (NIL ('B')) && s == fst (root (left (right tree))) || right (right tree) /= (NIL ('B')) && s == fst (root (right (right tree))) = root tree | srch s (left tree) = srch_G s (left tree) | True = srch_G s (right tree) ------------------------------------------------------------------- -- pSrch_D - предикат, определяющий, имеется ли вершина "отец" -- для заданной вершины s бинарного дерева поиска tree -- с NIL-узлами ----------------------------------- pSrch_D:: Integer -> RBTree -> Bool pSrch_D s tree | tree == (NIL ('B')) = False | True = not (s == fst (root tree) || not (srch s tree)) ------------------------------------------------------------------ -- srch_D - функция, возвращающая узел "отец" для заданной вер- -- шины s бинарного дерева поиска tree с NIL-узлами --------------------------------------------------------------- srch_D:: Integer -> RBTree -> (Integer,Char) srch_D s tree | tree == (NIL ('B')) || s == fst (root tree) || not (srch s tree) = error "Вершина 'отец' не найдена!" | (left tree) /= (NIL ('B')) && s == fst (root (left tree)) || (right tree) /= (NIL ('B')) && s == fst (root (right tree)) = root tree | s < fst (srch_G s tree) = root (left (search (fst (srch_G s tree)) tree)) | True = root (right (search (fst (srch_G s tree)) tree)) ------------------------------------------------------------------- -- pSrch_B - предикат, определяющий, имеется ли вершина "брат" -- для заданной вершины s бинарного дерева поиска tree -- с NIL-узлами ----------------------------------- pSrch_B:: Integer -> RBTree -> Bool pSrch_B s tree | not (pSrch_D s tree) = False | True = not (left (search (fst (srch_D s tree)) tree) == (NIL ('B')) || right (search (fst (srch_D s tree)) tree) == (NIL ('B'))) ------------------------------------------------------------------ -- srch_B - функция, возвращающая узел "брат" для заданной вер- -- шины s бинарного дерева поиска tree с NIL-узлами --------------------------------------------------------------- srch_B:: Integer -> RBTree -> (Integer,Char) srch_B s tree | not (pSrch_B s tree) = error "Вершина 'брат' не найдена!" | s < fst (srch_D s tree) = root (right (search (fst (srch_D s tree)) tree)) | True = root (left (search (fst (srch_D s tree)) tree)) -------------------------------------------------------------------- -- pSrch_Nl - предикат, определяющий, имеется ли вершина "пле- -- мянник" (слева) для заданной вершины s бинарного -- дерева поиска tree с NIL-узлами ------------------------------------------------ pSrch_Nl:: Integer -> RBTree -> Bool pSrch_Nl s tree | not (pSrch_B s tree) = False | True = not (left (search (fst (srch_B s tree)) tree) == (NIL ('B'))) ------------------------------------------------------------------ -- srch_Nl - функция, возвращающая узел "племянник" (слева) для -- заданной вершины s бинарного дерева поиска tree с -- NIL-узлами --------------------------------------------- srch_Nl:: Integer -> RBTree -> (Integer,Char) srch_Nl s tree | not (pSrch_Nl s tree) = error "Вершина 'племянник (левый)' не найдена!" | True = root (left (search (fst (srch_B s tree)) tree)) ------------------------------------------------------------------- -- pSrch_Nr - предикат, определяющий, имеется ли вершина "пле- -- мянник" (справа) для заданной вершины s бинарного -- дерева поиска tree с NIL-узлами ------------------------------------------------ pSrch_Nr:: Integer -> RBTree -> Bool pSrch_Nr s tree | not (pSrch_B s tree) = False | True = not (right (search (fst (srch_B s tree)) tree) == (NIL ('B'))) ----------------------------------------------------------------- -- srch_Nr - функция, возвращающая узел "племянник" (справа) -- для заданной вершины s бинарного дерева поиска -- tree с NIL-узлами --------------------------------------------- srch_Nr:: Integer -> RBTree -> (Integer,Char) srch_Nr s tree | not (pSrch_Nr s tree) = error "Вершина 'племянник (правый)' не найдена!" | True = root (right (search (fst (srch_B s tree)) tree)) ------------------------------------------------------------------- -- pSrch_U - предикат, определяющий, имеется ли вершина "дядя" -- для заданной вершины s бинарного дерева поиска -- tree с NIL-узлами ----------------------------------- pSrch_U:: Integer -> RBTree -> Bool pSrch_U s tree | not (pSrch_G s tree) = False | True = not (left (search (fst (srch_G s tree)) tree) == (NIL ('B')) || right (search (fst (srch_G s tree)) tree) == (NIL ('B'))) ------------------------------------------------------------------ -- srch_U - функция, возвращающая узел "дядя" для заданной вер- -- шины s бинарного дерева поиска Tree с NIL-узлами --------------------------------------------------------------- srch_U:: Integer -> RBTree -> (Integer,Char) srch_U s tree | not (pSrch_U s tree) = error "Вершина 'дядя' не найдена!" | s < fst (srch_G s tree) = root (right (search (fst (srch_G s tree)) tree)) | True = root (left (search (fst (srch_G s tree)) tree)) ------------------------------------------------------------------- -- rot_Right - функция, моделирующая операцию "ротация вправо" -- в бинарном дереве поиска tree с NIL-узлами ------------------------------------------------------------ rot_Right:: RBTree -> RBTree rot_Right tree | tree == (NIL ('B')) || left tree == (NIL ('B')) = tree | True = (Node (root (left tree)) (left (left tree)) (Node (root tree) (right (left tree)) (right tree))) --------------------------------------------------------------- -- rot_Left - функция, моделирующая операцию "ротация влево" -- в бинарном дереве поиска tree с NIL-узлами ------------------------------------------------------------ rot_Left:: RBTree -> RBTree rot_Left tree | tree == (NIL ('B')) || right tree == (NIL ('B')) = tree | True = (Node (root (right tree)) (Node (root tree) (left tree) (left (right tree))) (right (right tree))) ---------------------------------------------------------------- -- rotInTree - функция, возвращающая преобразованное числовое -- бинарное дерево поиска tree с NIL-узлами в ре- -- зультате операции ротации, производимой над -- частью дерева, поднимая узел s на уровень выше ---------------------------------------------------------------- rotInTree:: Integer -> RBTree -> RBTree rotInTree s tree | tree == (NIL ('B')) = (NIL ('B')) | fst (root tree) == s = tree | (left tree) /= (NIL ('B')) && fst (root (left tree)) == s = rot_Right tree | (right tree) /= (NIL ('B')) && fst (root (right tree)) == s = (rot_Left tree) | True = (Node (root tree) (rotInTree s (left tree)) (rotInTree s (right tree))) -------------------------------------------------------------- -- drawTree - функция изображения дерева поиска tree в виде -- строки символов; -- L - накапливающий параметр, значение которого -- при первоначальном обращении равно 0 ----------------------------------------------------- drawTree:: RBTree -> Int -> String drawTree tree l | tree==NIL ('B') = "" | otherwise = (drawTree (right tree) (l+1)) ++ "\n" ++ (replicate (l*3) ' ') ++ show (fst (root tree)) ++ "(" ++ [snd (root tree)] ++ ")" ++ (drawTree (left tree) (l+1)) ---------------------------------------------------------- -- outTree - функция для изображения дерева поиска tree -- на экране дисплея --------------------------------- outTree:: RBTree -> IO() outTree tree = putStr ((drawTree tree 0) ++ "\n") ---------------------------------------------------------------- -- Реализация типа RBTree для представления бинарных деревьев -- поиска в виде списков, т.е. представление типа RBTree в -- качестве экземпляра класса Show ---------------------------------- instance Show RBTree where show (NIL ('B')) = "nil(B)" show (Node a (NIL ('B')) (NIL ('B'))) = "(" ++ show (fst a) ++ "(" ++ [snd a] ++ ")" ++ " nil(B)" ++ " nil(B)" ++ ")" show (Node a l r) = "(" ++ show (fst a) ++ "(" ++ [snd a] ++ ")" ++ " " ++ show l ++ " " ++ show r ++ ")"
На следующем шаге мы приведем перечень задач для самостоятельного решения.
