old/PAS/BTree.pas

Uses CRT;
Type
  UT = char;                            {Пользовательский тип}
  PBTree = ^TBTree;                     {Указатель на дерево}
  TBTree = record                       {Просто дерево}
    info : UT;                          {Значение}
    count: word;                        {Количество}
    Left : PBTree;                      {Левая ветвь}
    Right: PBTree;                      {Правая ветвь}
  end;

Function NewChild(info:UT) : PBtree;    {Функция создания новой ветви}
var
 ne : PBTree;                           {Указатель на результат}
begin
 New(ne);
 Ne^.info  := Info;                     {Заполняем зн-е}
 Ne^.Left  := nil;
 Ne^.Right := nil;
 Ne^.count := 1;                        {Кол-во - 1}
 NewChild  := ne;
end; {NewChild}
{---------------------------------}
Procedure DelBranch(br:PBTree);         {Удаление ветви, вмести с детьми}
begin
  if br^.left <> nil then DelBranch(br^.left);  {Если есть левый ребенок -
                                                 удаляем его}
  if br^.right <> nil then DelBranch(br^.right);{А если есть и правый - и
                                                 его тоже!}
  Dispose(br);                                  {Собственно удаление}
end;{DelBranch}
{---------------------------------}
Procedure SetLRootRInfo(info:UT;Br:PBTree);     {Добавление нового зн-я на
                                                 на ветвь}
begin
  if info < Br^.info then                       {Посылаем на лево}
   begin
     if (Br^.Left=nil) then Br^.Left := NewChild(info)  {Если никого - вешаем}
     else SetLRootRInfo(info,BR^.Left);            {Иначе - спускаем на лево}
   end
  else                                 {А если такой-же - увеличиваем кол-во}
   if (info=Br^.info) then inc(Br^.count)
  else                                 {Значит оно - справа}
   begin
     if (Br^.Right=nil) then            {Если никого - вешаем направо}
       Br^.Right := NewChild(info)
     else SetLRootRInfo(info,BR^.Right);  {Иначе - спускаем на право}
   end;
end;{SetLRootRInfo}
{---------------------------------}
Function MakeLRootRTree(st:string;count:word):PBTree;
  {Создание двоичного дерева для поиска}
var
  ret : PBTree;
  pos : byte;
Begin
  ret := NewChild(st[1]);
  for pos := 2 to count do SetLRootRInfo(st[pos],ret);
  MakeLRootRTree := ret;
End; {MakeLRootRTree}
{---------------------------------}
var
  h : word;                         {Глобальная переменная - номер уровня}
Procedure FindInfo(info:UT;Br:PBTree); {Поиск зн-я в дереве, с подсчетом H}
begin
 if (Br<>nil) then begin
 if (info<Br^.Info) then begin inc(h); FindInfo(info,Br^.Left) end
 else if (info>Br^.Info) then begin inc(h); FindInfo(info,Br^.Right) end;
 end
 else h := 0;
end;

Var
  test  : string;
  BTree : PBTree;
  ch    : char;
BEGIN
  WriteLn('Введите массив для создания двоичного дерева поиска методом Left->Root->Right');
  ReadLn(test);
  BTree := MakeLRootRTree(test,Length(test));
  h := 1;
  WriteLn('Введите символ для поиска по дереву: ');
  ch := ReadKey;
  FindInfo(ch,BTree);
  DelBranch(BTree);
  if (h<>0) then
    WriteLn('Символ ''',ch,''' найден на ',h,'-ом уровне')
  else
    WriteLn('Символ ''',ch,''' не найден');
  ReadKey;
END.