Красно-черные деревья

1. Каждый узел является красным или черным.
2. Корень дерева является черным.
3. Каждый лист дерева (nil) является черным.
4. Если узел — красный, то оба его дочерних узла — черные.
5. Для каждого узла все пути от него до листьев, являющихся потомками данного узла, содержат одно и то же количество черных узлов.

uses crt;

type
  string_20 = string[20]; { Это - тип данных, хранимых в КЧД }

  { Узел дерева }
  PTreeNode = ^TreeNode;
  TreeNode = object
  public
    constructor init(_s: string; _parent: PTreeNode);

  public
    Color: integer; { Цвет листа: 0 = Черный, 1 = Красный }
    left, right, parent,
    duplicates: PTreeNode; { Список дубликатов (не стал удалять, иногда это нужно) }

    data_string: string_20;
    deleted: boolean;      { Флаг для "ленивого" удаления }
  end;

  RBTree = object
  public
    constructor init;
    destructor done;

    function Search(s: string): integer;
    { Возвращает +1, если строка присутствует в дереве, и -1 если ее там нет }
    
    function SearchFirstMatch(s: string): PTreeNode;
    { Работает точно так же, как и Search, но возвращает указатель
       типа PTreeNode на первый подходящий элемент }
       
    procedure Insert(s: string);
    { Добавляет новый элемент в дерево }
    function InsertItem(s: string; node: PTreeNode): PTreeNode;

    function Remove(s: string): boolean;
    { Удаляет заданную строку }

    procedure LoadFromFile(fn: string); { Загружает дерево из текстового файла (не реализовано) }
    procedure SaveToFile(var f: text);  { Сохраняет дерево в текстовый файл }

    function LeftDepth: integer;  { Находит глубину левого поддерева }
    function RightDepth: integer; { Находит глубину правого поддерева }
    function NumberOfLeaves(p: PTreeNode): integer;
    { Находит число листьев в дереве }

  public
    root: PTreeNode;

  private
    procedure LeftRotation(node: PTreeNode);
    procedure RightRotation(node: PTreeNode);
    { "Ротации" (повороты), используемые при вставке для балансировки дерева }
    function TreeDepth(p: PTreeNode): integer;
    { Рекурсивная функция для нахождения глубины дерева, с корнем в P }

    procedure DeleteTree(p: PTreeNode);
    { Деструктор вызывает эту процедуру для удаления дерева }
    procedure SaveNode(level: integer;
              const node: PTreeNode; var f: text);
    { Рекурсивная процедура сохранения узла в тестовый файл F }
  end;


Const
  { Цвета для узлов }
  node_Red   = 1;
  node_Black = 0;

constructor TreeNode.init(_s: string; _parent: PTreeNode);
begin
  data_string := _s;
  left := nil; right := nil;
  parent := _parent; { Указатель на предка }

  Duplicates := nil; { Изначально у узла нет дубликатов }
  Color := node_Red; { Новые узлы становятся "Красными" }
  Deleted := False;  { Этот узел не удален }
end;

{
  Функция сравнения строк (ведомые пробелы не принимаются во внимание)
}
function compare(s1, s2: string): integer;

  procedure trim(var s: string);
  begin
    while s[length(s)] = ' ' do delete(s, length(s), 1);
  end;

begin

  trim(s1); trim(s2);
  if s1 < s2 then compare := -1
  else if s1 > s2 then compare := +1
       else compare := 0;

end;

constructor RBTree.init;
begin
  root := nil;
end;
destructor RBTree.done;
begin
  DeleteTree(Root);
  { DeleteTree освобождает динамическую память }
end;


procedure RBTree.DeleteTree(p: PTreeNode);
begin
  if p <> nil then begin
    DeleteTree(p^.Left);  { Удалить левое поддерево }
    DeleteTree(p^.Right); { Удалить правое поддерево }
    DeleteTree(p^.Duplicates);
    dispose(p);
  end;
  p := nil; { Узел более не используется }
end;

{
  При вставке элемента могут произойти 3 случая:
  1. Новый узел и его "дядя" - "Красные"
  2. Новый узел красный, "дядя" - "Черный", и узел - левый потомок
  3. Новый узел красный, "дядя" - "Черный", и узел - правый потомок
}
procedure RBTree.Insert(s: string);
{ Создает новый узел для хранения строки }
var
  node, node_2: PTreeNode;
begin
  node := InsertItem(s, root); { Вставить строку в дерево }

  if node = nil then exit; { Изменять дерево не нужно }

  while(node <> root) and (node^.parent^.color = node_Red) do begin

    { Проверяем, находится ли узел в левом поддереве }
    if node^.parent = node^.parent^.parent^.left then begin

      node_2 := node^.parent^.parent^.right; { Делаем node2 "дядей" нашего узла }
      
      { Если "дядя" красного цвета - это случай 1 }
      if (node_2 <> nil) and (node_2^.Color = node_Red) then begin
        node^.parent^.Color := node_Black; { Изменяем цвет "родителя" на черный }
        node_2^.Color := node_Black;       { Изменяем цвет "дяди" на черный }
        node^.Parent^.Parent^.Color := node_Red; { Делаем "дедушку" красным }
        node := node^.Parent^.Parent;            { Двигаемся к вершине дерева для проведения дополнительных исправлений }
      end
      else begin { "дядя" - черного цвета, случай 2 или 3 }
      
        if Node = Node^.Parent^.Right then begin { Проверяем на случай №3 }
          Node := Node^.Parent; { Узел - правый потомок, это как раз случай №3... }
          LeftRotation(Node);   { ... который требует левую "ротацию" }
        end;
        Node^.Parent^.Color := node_Black;       { Установка для случаев №2... }
        Node^.Parent^.Parent^.Color := node_Red; { ... и №3 }
        RightRotation(Node^.Parent^.Parent);
        
      end;

    end
    else begin { узел - в правом поддереве }

      node_2 := Node^.Parent^.Parent^.Left; { Делаем node2 "дядей" нашего узла }
      { Если "дядя" красного цвета - это случай 1 }
      if(node_2 <> nil) and (node_2^.Color = node_Red) then begin
        Node^.Parent^.Color := node_Black;       { Изменяем цвет "родителя" на черный }
        Node_2^.Color := node_Black;             { Изменяем цвет "дяди" на черный }
        Node^.Parent^.Parent^.Color := node_Red; { Делаем "дедушку" красным }
        Node := Node^.Parent^.Parent;            { Двигаемся к вершине дерева... }
      end
      else begin { "дядя" - "черный", случай №2 или №3 }

        { Проверяем на случай №3 ("лево" и "право" обменяны местами) }
        if Node = Node^.Parent^.Left then begin
          Node := Node^.Parent; { Узел - левый потомок, это как раз случай №3... }
          RightRotation(Node);  { ... который требует правую "ротацию" }
        end;
        Node^.Parent^.Color := node_Black;       { Установка для случаев №2... }
        Node^.Parent^.Parent^.Color := node_Red; { ... и №3 }
        LeftRotation(Node^.Parent^.Parent);
      end;

    end

  end;

  { По правилу КЧД корень дерева должен быть черным }
  Root^.Color := node_Black;
end;


function RBTree.InsertItem(s: string; node: PTreeNode): PTreeNode;
var
  comparison: integer;
  GreaterThanLeft, LessThanRight: boolean;
  T: PTreeNode;
begin

  if root = nil then begin

    root := new(PTreeNode, init(s, nil)); { устанавливаем корень }
    
    { По правилу КЧД корень дерева должен быть черным }
    root^.Color := node_Black;
    InsertItem := root; exit

  end;

  while True do begin

    comparison := compare(s, node^.data_string);

    if node^.Deleted then begin
      { Для начала проверим, является ли узел "удаленным".
        Если это так, то существует возможность использовать "удаленный" узел
        для хранения новой записи, если она должна будет находиться
        между двумя "потомками" }
      if node^.Left = nil then GreaterThanLeft := true
      else
        { (В случае, если compare() < 0): строка не больше чем левый потомок,
          поэтому "удаленный" узел не может использоваться для хранения новой записи }
        GreaterThanLeft := (compare(s, node^.left^.data_string) > 0);

      if node^.Right = nil then LessThanRight := true
      else
        { (В случае, если compare() < 0): строка не больше чем правый потомок,
          поэтому "удаленный" узел не может использоваться для хранения новой записи }
        LessThanRight := (compare(s, node^.right^.data_string) > 0);

      if GreaterThanLeft and LessThanRight then begin
        { "удаленный" узел может использоваться для хранения новой записи }
        node^.data_string := s;
        node^.Deleted := false; { удел больше "удаленным" не считать }
        InsertItem := nil; exit

        {
        возвращаем NIL, чтобы избежать "ротаций" дерева, т.к. элемент, значение
        которого было изменено, находится на своем месте
        }
      end;

    end;

    if comparison < 0 then begin
      { Если Left пусто, помещаем новый узел туда }
      if Node^.Left = nil then begin
        Node^.Left := new(PTreeNode, init(s, Node)); { Добавляем новый узел ... }
        InsertItem := Node^.Left;                    { ... как левого потомка }
        exit
      end
      else Node := Node^.Left; { Проверить левое поддерево }
    end

    else
      if comparison > 0 then begin
        { Если Right пусто, помещаем новый узел туда }
        if Node^.Right = nil then begin
          Node^.Right := new(PTreeNode, init(s, Node)); { Добавляем новый узел ... }
          InsertItem := Node^.Right;                    { ... как правого потомка }
          exit
        end
        else Node := Node^.Right; { Проверить правое поддерево }
      end
      else begin { узел - дубликат }

        T := node;
        { находим конец списка дубликатов }
        while(T^.Duplicates <> nil) do T := T^.Duplicates;
        T^.Duplicates := new(PTreeNode, init(s, T));
        InsertItem := nil; exit
        {
        возвращаем NIL, чтобы избежать "ротаций" дерева, т.к.
        мы просто изменили список дубликатов
        }
      end;
  end;

end;


function RBTree.Remove(s: string): boolean;
var T, prev_node, node: PTreeNode;
begin
  Remove := False;
  Node := SearchFirstMatch(s); { Найдем подходящий узел в дереве }
  if node = nil then exit;     { Строка не была найдена - выход }

  if node^.Duplicates <> nil then begin

    {
      если есть дубликаты - то один из дубликатов может занять
      место удаляемой записи
    }
    T := node;
    while T^.Duplicates <> nil do begin
      prev_node := T;
      T := T^.Duplicates;
    end;
    node^.data_string := T^.data_string;
    { Копируем содержимое последнего дубликата в ту запись, которую будем удалять }
    dispose(T);
    prev_node^.Duplicates := nil;
    { "отсекаем" последний элемент списка дубликатов }

    Remove := true; { удаление было успешным }
  end
  else
    Node^.Deleted := true; { Помечаем узел как "удаленный" для "ленивого" удаления }
  Remove := True
end;


function RBTree.Search(s: string): integer;
var
  node: PTreeNode;
  comparison: integer;
begin
  Search := -1;

  node := root;
  while Node <> nil do begin

    comparison := compare(s, node^.data_string);
    if comparison < 0 then Node := Node^.Left { просматриваем левое поддерево }
    else
      if comparison < 0 then Node := Node^.Right { просматриваем правое поддерево }
      else
        if Node^.Deleted then exit
          { если узел помечен на удаление - то не принимать его во внимание, выход }
        else begin
          { Строка найдена }
          search := 1; exit
        end;
  end;
  { Запись не найдена }
end;

function RBTree.SearchFirstMatch(s: string): PTreeNode;
{ Возвращает указатель на первый узел, хранящий заданную строку }
var
  node: PTreeNode;
  comparison: integer;
begin
  SearchFirstMatch := nil;

  node := root;
  while Node <> nil do begin

    comparison := compare(s, node^.data_string);
    if comparison < 0 then Node := Node^.Left { просматриваем левое поддерево }
    else
      if comparison > 0 then Node := Node^.Right { просматриваем правое поддерево }
      else
        if Node^.Deleted then exit
          { если узел помечен на удаление - то не принимать его во внимание, выход }
        else begin
          { Строка найдена }
          SearchFirstMatch := node; exit
        end;

  end;
end;

procedure RBTree.SaveToFile(var f: text);
{
  сохраняет узлы в Прямом (нисходящем) порядке
}
begin
  { Вызываем рекурсию }
  SaveNode(0, root, f);
end;

procedure RBTree.SaveNode(level: integer;
          const node: PTreeNode; var f: text);
const
  _color: array[0 .. 1] of char = ('B', 'R');
begin
  if node <> nil then begin

    if not node^.Deleted then begin
      writeln(f, '':3*level,
              node^.data_string + ' ('+_color[node^.Color]+')');
    end;
    SaveNode(level + 1, node^.Left, f);  { Сохраним узлы левого поддерева }
    SaveNode(level + 1, node^.Right, f); { Сохраним узлы правого поддерева }

  end;
end;

procedure RBTree.LoadFromFile(fn: string);
begin
  (* Не реализовано *)
end;

function RBTree.LeftDepth: integer;
begin
  LeftDepth := TreeDepth(Root^.Left); { Измеряем левое поддерево }
end;

function RBTree.RightDepth: integer;
begin
  RightDepth := TreeDepth(Root^.Right); { Измеряем правое поддерево  }
end;

function RBTree.TreeDepth(p: PTreeNode): integer;
var _left, _right: integer;
begin
  _left := 0; _right := 0;
  if p^.Left <> nil then
    _left := TreeDepth(p^.Left);   { Взять глубину левого поддерева }
  if p^.Right <> nil then
    _right := TreeDepth(p^.Right); { Взять глубину правого поддерева }

  if _left > _right then     { проверяем, какое поддерево "глубже" }
    TreeDepth := _left + 1   { вернем глубину левого поддерева + 1 }
  else
    TreeDepth := _right + 1; { вернем глубину правого поддерева + 1 }
end;


function RBTree.NumberOfLeaves(p: PTreeNode): integer;
var total: integer;
begin
  NumberOfLeaves := 1;

  total := 0;
  if (p^.Left = nil) and (p^.Right = nil) then exit; { узел является "листом" }

  { считаем число листьев в левом поддереве }
  if p^.Left <> nil then inc(total, NumberOfLeaves(p^.Left));
  { считаем число листьев в правом поддереве }
  if p^.Right <> nil then inc(total, NumberOfLeaves(p^.Right));

  NumberOfLeaves := total;
  { и возвращаем общее количество листьев в дереве }
end;

procedure RBTree.LeftRotation(node: PTreeNode);
var Right: PTreeNode;
begin
  Right := node^.Right; { hold node's right child }

  { make the node's right child its right child's left child }
  node^.Right := Right^.Left;
  if Right^.Left <> nil then
    Right^.Left^.Parent := Node; { point the child to its new parent }

  if Right <> nil then
    Right^.Parent := Node^.Parent; { point the child to its new parent }

  if Node^.Parent <> nil then begin { if node is not the root }
    if Node = Node^.Parent^.Left then { if node is a left child }
      Node^.Parent^.Left := Right   { make node's right child its parent's left child }
    else
      Node^.Parent^.Right := Right; { make node's right child its parent's right child }
  end
  else
    Root := Right; { node's right child is now the root }

  Right^.Left := Node; { node becomes its right child's left child }
  if Node <> nil then
    Node^.Parent := Right; { point node to its new parent }
end;

procedure RBTree.RightRotation(node: PTreeNode);
var Left: PTreeNode;
begin
  Left := node^.Left; { hold node's left child }

  { make the node's left child its left child's right child }
  Node^.Left := Left^.Right;
  if Left^.Right <> nil then
    Left^.Right^.Parent := Node; { point the child to its new parent }

  if Left <> nil then
    Left^.Parent := Node^.Parent; { point the child to its new parent }

  if Node^.Parent <> nil then begin { if node is not the root }
    if Node = Node^.Parent^.Right then { if node is a right child }
      Node^.Parent^.Right := Left { make node's left child its parent's right child }
    else
      Node^.Parent^.Left := Left; { make node's left child its parent's left child }
  end
  else
    Root := Left; { node's left child is now the root }

  Left^.Right := Node; { node becomes its left child's right child }
  if Node <> nil then
    Node^.Parent := Left; { point node to its new parent }
end;


{ Собственно, программа, иллюстрирующая использование КЧД }
var
  console: text;
  s: string_20;
  tree: RBTree;

begin
  assigncrt(console);
  rewrite(console);
  tree.init;

  {
    Вводим следующую последовательность строк:
    one
    two
    three
    four
    five
  }
  repeat
    write('enter new string (20 chars max): '); readln(s);
    if s <> '' then begin
      tree.insert(s);
      Writeln('**');
        tree.SaveToFile(console); { Выводим дерево на консоль }
      writeln('**');
    end;
  until s = '';
  tree.SaveToFile(console);

  { Проверяем работу Search }
  if tree.search('four') = 1 then writeln('found')
  else writeln('not found');

  { Проверяем работу Remove }
  tree.Remove('four');
  tree.SaveToFile(console);

  tree.done;
  close(console);
end.