old/PAS/mytree.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;{FindInfo}
{---------------------------------}
Function GetHeight(BTree:PBTree):word;
var
 max,h : word;

Procedure Calc(Br:PBtree);
begin
 if Br <> nil then
  begin
    inc(h);
    Calc(Br^.Left);
    Calc(Br^.Right);
    dec(h);
  end
 else
  begin
    if h > max then max := h;
  end;
end;

begin
  max := 0;
  h := 0;
  Calc(BTree);
  GetHeight := max;
end;{GetHeight}
{---------------------------------}
Procedure ShowTree(Tree:PBTree);
var x,y : byte;
{-=-=-=-=-=-=-}
procedure WriteBranch(Br:PBTree;x,y:byte);
begin
  GotoXY(x,y);
  TextColor(BLue);
  Write(BR^.Info);
  TextColor(LightGray);
  GotoXY(x,y+1);
  if (Br^.Left<>nil) and (Br^.Right<>nil) then
   begin
     Write('╧');
     GotoXY(x-6,y+1);
     Write('╒═════');
     WriteBranch(Br^.Left,x-6,y+2);
     GotoXY(x+1,y+1);
     Write('═════╕');
     WriteBranch(Br^.Right,x+6,y+2);
   end
  else
    if (Br^.Left=nil) and (Br^.Right<>nil) then
     begin
       Write('╘═════╕');
       WriteBranch(Br^.Right,x+6,y+2);
     end
  else if (Br^.Left<>nil) and (Br^.Right=nil) then
   begin
     GotoXY(x-6,y+1);
     Write('╒═════╛');
     WriteBranch(Br^.Left,x-6,y+2);
   end;
end;
{-=-=-=-=-=-=-}
begin
  if GetHeight(Tree) > 10 Then begin WriteLn('Tree to high!');exit;end;
  x := 40;
  y := 1 ;
  ClrScr;
  WriteBranch(Tree,x,y);
end;{ShowTree}
{---------------------------------}
Var
  test  : string;
  BTree : PBTree;
  ch    : char;
BEGIN
  ClrScr;
  WriteLn('Введите массив для создания двоичного дерева поиска методом Left->Root->Right');
  ReadLn(test);
  BTree := MakeLRootRTree(test,Length(test));
{  WriteLn('Высота дерева: ',GetHeight(BTree));
  WriteLn('Введите символ для поиска по дереву: ');
  ch := ReadKey;
  h := 1;
  FindInfo(ch,BTree);
  if (h<>0) then
    WriteLn('Символ ''',ch,''' найден на ',h,'-ом уровне')
  else
    WriteLn('Символ ''',ch,''' не найден');
  WriteLn('Press any key to view tree');
  ReadKey;}
  ShowTree(Btree);
  DelBranch(BTree);
  ReadKey;
END.