Программа №4

 

program bin_tree;

const n = 8;

type pnode = ^node;

node = record

v: integer;

right, left: pnode;

lf, rf: boolean;

end;

var root: pnode;

st: boolean; {флажок для определения прошито ли дерево}

v: integer;

right, left: pnode;

j, h, i, answ, answ2: integer;

const m: array[1..n] of integer = (5,4,8,6,1,7,3,9);

 

{------------ create of tree -------------}

 

procedure Insert(var root: pnode; X: integer);

{Дополнительная процедура, создающая и инициирующая новый узел}

procedure CreateNode(var p: pnode; n: integer);

begin

new(p);

p^.v:= n; p^.left:= nil; p^.right:= nil; end;

begin

if root = nil then CreateNode(root, X) {создаем новый узел дерева}

else with root^ do begin if v < X then Insert(right, X) else if v > X then Insert(left, X)

else {Действия, производимые в случае повторного внесения элементов в дерево}

begin

writeln('Такой элемент уже есть'); exit; end; end; end;

 

{--------- View of tree --------------------}

procedure ViewTree(root: pnode);

var mas1, mas2: array[1..8] of integer;

q, m1, m2: integer; Sch, Chl, Chr: pnode;

{функция для определения количества отступов}

function sc(s: integer): integer; var c, c1, w: integer;

begin c:= 0; sc:= 0; s:= s-1; if s = 0 then exit;

for w:= 1 to s do begin c1:= 1+2*c; c:= c1; end;

sc:= c1; end;

{поиск узла или листа дерева по значению v}

procedure Search(root: pnode; s: integer);

begin

if root^.v = s then begin Sch:= root; exit; end;

if root = nil then exit else begin

Search(root^.right, s); Search(root^.left, s); end; end;

 

{занесение потомков узлов дерева одного уровня во 2-ой массив}

 

procedure ToMas2;

begin

if Sch^.left <> nil then begin Chl:= Sch^.left; m2:= m2+1; mas2[m2]:= Chl^.v; end

else begin m2:= m2+1; mas2[m2]:= 0; end; if Sch^.right <> nil then begin

Chr:= Sch^.right; m2:= m2+1; mas2[m2]:= Chr^.v; end else begin

m2:= m2+1; mas2[m2]:= 0; end; end;

{занесение потомков узлов дерева следующего уровня в первый массив}

procedure ToMas1;

begin

if Sch^.left <> nil then begin Chl:= Sch^.left; m1:= m1+1; mas1[m1]:= Chl^.v;

end else begin m1:= m1+1;mas1[m1]:= 0;end;

if Sch^.right <> nil then begin

Chr:= Sch^.right; m1:= m1+1; mas1[m1]:= Chr^.v; end else begin m1:= m1+1;

mas1[m1]:= 0; end; end;

{если уровень дерева не является последним - заносим 2 нуля в первый массив}

procedure NilToMas1;

begin

if i > 1 then begin m1:= m1+1; mas1[m1]:= 0; {первый ноль} m1:= m1+1;

mas1[m1]:= 0; {второй ноль} end; end;

{если уровень не последний - заносим нули во второй массив}

procedure NilToMas2;

begin

if i > 1 then begin m2:= m2+1; mas2[m2]:= 0; m2:= m2+1; mas2[m2]:= 0; end; end;

begin

mas1[1]:= root^.v; m1:= 1; m2:= 0; for i:= h downto 1 do begin writeln;

{отображаем первый элемент уровня}

if mas1[1] = 0 then begin NilToMas2; write('':(sc(i)+1)); end else begin write('':sc(i), mas1[1]);

Search(root, mas1[1]); ToMas2; end;

{отображаем остальные элементы, если уровень дерева не содержит корень}

if m1 > 1 then begin

for q:= 2 to m1 do if mas1[q] = 0 then begin NilToMas2; write('':(sc(i+1)+1)); end

else begin write('':sc(i+1), mas1[q]); Search(root, mas1[q]); ToMas2;end; end;m1:= 0;

{на следующий уровень}

if i = 1 then break else i:= i-1; writeln; if mas2[1] = 0 then begin NilToMas1; write('':(sc(i)+1));

end else begin write('':sc(i), mas2[1]); Search(root, mas2[1]); ToMas1; end;

for q:= 2 to m2 do begin if mas2[q] = 0 then begin

NilToMas1; write('':(sc(i+1)+1)); end else begin write('':sc(i+1), mas2[q]); Search(root, mas2[q]); ToMas1; end; end; m2:= 0;

{на следующий уровень}

end;

end;

{------------- Прямой порядок прохождения -------------}

procedure PrintDown(level: integer; root: pnode);

{в этом обходе заодно рассчитаем высоту дерева h для его представления}

begin if root = nil then exit; with root^ do begin

{для прошивки дерева устанавливаем флажки}

if right = nil then rf:= false; lf:= false;

{определяем высоту дерева}

if (left = nil) and (right = nil) then begin j:= j+1; if h < j then

{высотой дерева является его максимальный путь прохождения}

 

h:= j; j:= 0; end;

writeln('':2*level, v); j:= j+1; PrintDown(level+1, left); PrintDown(level+1, right)

end; end;

{--------------- Симметричный порядок прохождения -------}

procedure PrintLex(level: integer; root: pnode);

begin

if root = nil then exit; with root^ do begin PrintLex(level+1, left); writeln('':2*level, v);

PrintLex(level+1, right); end end;

 

{----------- Концевой порядок прохождения ----------}

 

procedure PrintUp(level: integer; root: pnode);

begin

if root = nil then exit; with root^ do begin PrintUp(level+1, left); PrintUp(level+1, right);

writeln('':2*level, v); end end;

 

{------------ прошивка ------------------------------}

procedure Threading(x: pnode);

var p: pnode; stop: boolean;

{устанавливаем указатель}

procedure rightPointer(y: pnode; i: integer);

begin

if stop = true then exit; j:= j+1; {подсчитываем число рекурсий} if y = nil then exit;

with y^ do begin rightPointer(left, i); if (j > i) and (rf = true) then begin j:= 0;

writeln('Прошиваем ', x^.v, ' элемент с ', v);

x^.right:= y;

{сворачиваем рекурсию}

stop:= true;

{помечаем, что узел или лист прошит}

x^.lf:= true; exit; end; if lf = true then exit;

rightPointer(right, i);

end end;

begin

i:= i+1; {подсчитываем число рекурсий}

if x = nil then exit; with x^ do begin

rf:= true; {помечаем, что узел или лист посещался}

Threading(left); if (rf = true) and (right = nil) then

{если узел не прошит}

begin stop:= false;

{прошиваем его}

rightPointer(root, i); end; if (left = nil) and (right = nil) then

{прошиваем лист}

begin stop:= false; rightPointer(root, i); end; writeln(' ',v);

if lf = true then {если узел или лист прошит} exit; {выходим}Threading(right);

end; end;

{------------- формирование дерева ---------------}

procedure Cycle;

begin

for i:= 1 to n do Insert(root, m[i]); end;

 

{----------------------------------------------------}

 

begin

Cycle;

{определим высоту дерева обходом сверху-вниз}

PrintDown(1, root); writeln('Выберите действие');

while true do begin writeln('1 - провести обход, 2 - отобразить дерево, 3 - выполнить прошивку, 4 - выход');

readln(answ);

case answ of

1: begin if st = true then writeln('Обход невозможен - дерево прошито')

else begin writeln('Выберите обход: 1 - сверху-вниз, 2 - слева-направо, 3 - снизу-вверх');

readln(answ2); case answ2 of

1:begin writeln('Обход сверху-вниз:'); PrintDown(1, root); end;

2:begin writeln('Обход слева-направо:'); PrintLex(1, root); end;

3:begin writeln('Обход снизу-вверх:'); PrintUp(1, root); end; end; end; end;

2: if st = true then writeln('Дерево прошито - его представление невозможно')

else

begin writeln('Представление дерева:'); {вызоваем процедуру представления дерева}

ViewTree(root); end;

3: begin if st = true then writeln('Дерево уже прошито')

else begin writeln('Прошивка:'); i:= 0; j:= 0; Threading(root); st:= true; end; end;

4: exit; end; writeln; end; end.