Бинарные деревья / DEREVO2

unit Derevo2;
INTERFACE



uses crt;
const
ForLen = 50;
NilT = nil;
type
Tree = ^tNode;
Forest = array [1..ForLen] of Tree; {«Ґб}
Elem = char; {ЇаҐ¤бв ў«Ґ­ЁҐ ЎЁ­ а­®Ј® ¤ҐаҐў }
{вЁЇ Elem ®ЇЁб ­ ў GlobalT}
tNode = record {㧥«:}
Info: Elem; { ᮤҐа¦Ё¬®Ґ}
Sub1: Tree;
Sub2: Tree;
Sub3: Tree;
Sub4: Tree;
Sub5: Tree;
end {Node};

var
st1: string;
i1,y1,lenght1:integer;
t,tt:text;

procedure Otkaz (n: Byte); {б®®ЎйҐ­Ёп ®Ў ®иЁЎЄ е}
function CreateT: Tree; {ᮧ¤ ­ЁҐ Ѓ„}
function NullT (t: Tree): Boolean; {Їа®ўҐаЄ  Їгбв® «Ё „Ѓ}
function RootT (t: Tree): Elem; {§­ з ­ЁҐ Є®а­п Ѓ„}
function T1 (t: Tree): Tree;
function T2 (t: Tree): Tree;
function T3 (t: Tree): Tree;
function T4 (t: Tree): Tree;
function T5 (t: Tree): Tree;
function Cons_T (e: Elem; L1,L2,L3,L4,L5: Tree): Tree; {Є®­бвагЄв®а ¤ҐаҐў }
procedure DestroyT (var b: Tree); {г¤ «Ґ­ЁҐ ¤ҐаҐў }
procedure WriteT (D : Tree); {ўлў®¤ ¤ҐаҐў  ў бЄ®Ў ЇаҐ¤бв ў«Ґ­ЁЁ ­  нЄа ­}
procedure WriteT1 (D : Tree;var tt:text); {ўлў®¤ ¤ҐаҐў  ў бЄ®Ў ЇаҐ¤бв ў«Ґ­ЁЁ ў д ©«}
function EnterT(s:string) : Tree; {ўў®¤ ¤ҐаҐў  Ё§ д ©« }
procedure DisplayT1 (b: Tree; n,l: integer); {ўлў®¤ ЇҐаҐў Ё§®Ўа ¤ҐаҐў  ­  нЄа ­}
procedure DisplayT2 (b: Tree; n,l: integer;var tt:text); {ўлў®¤ ЇҐаҐў Ё§®Ўа ¤ҐаҐў  ­  нЄа ­}

procedure CreateForest(var F : forest); {ᮧ¤ ­ЁҐ «Ґб }
procedure Listin(T : Tree; var F:forest); {ў®§ўа й Ґв «Ґб Ї®¤¤ҐаҐўмҐў ¤ҐаҐў }
procedure Tail(T : Tree; var F,F1 : forest ); {ў®§ўа § Ґв «Ґб ¤ҐаҐў  ЎҐ§ Ј®«®ўл}
function Head (F : forest):Tree; {ў®§ўа й Ґв Ј®«®ў­®Ґ ¤ҐаҐў® «Ґб }
function NullF(F:forest):boolean; {Їа®ўҐаЄ  Їгбв «Ё «Ґб}

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

IMPLEMENTATION
procedure Otkaz (n: Byte);
begin
Case n of
1: Write ('Ћ’ЉЂ‡: RootT (Null_Bin_Tree)!');
2: Write ('Ћ’ЉЂ‡: LeftT (Null_Bin_Tree)!');
3: Write ('Ћ’ЉЂ‡: RightT (Null_Bin_Tree)!');
4: Write ('Ћ’ЉЂ‡: ЁбзҐаЇ ­  Ї ¬пвм!')
else Write ('Ћ’ЉЂ‡: ?')
end;
Halt
end {Otkaz};


function CreateT: Tree;
begin
CreateT := nil
end {CreateT};

function NullT (t: Tree): Boolean;
begin
NullT := (t = nil)
end {NullT};

function RootT (t: Tree): Elem;
begin
if t <> nil then RootT := t^.Info else Otkaz(1)
end {RootT};

function T1 (t: Tree): Tree;
begin
if t <> nil then T1 := t^.Sub1 else Otkaz(2)
end {T1};

function T2 (t: Tree): Tree;
begin
if t <> nil then T2 := t^.Sub2 else Otkaz(2)
end {T2};

function T3 (t: Tree): Tree;
begin
if t <> nil then T3 := t^.Sub3 else Otkaz(2)
end {T3};

function T4 (t: Tree): Tree;
begin
if t <> nil then T4 := t^.Sub4 else Otkaz(2)
end {T4};

function T5 (t: Tree): Tree;
begin
if t <> nil then T5 := t^.Sub5 else Otkaz(2)
end {T5};



function Cons_T (e: Elem; L1, L2, L3, L4, L5: Tree): Tree;
var b: Tree;
begin
if MaxAvail >= SizeOf (tNode) then
begin
New (b);
b^.Info:= e;
b^.Sub1:= L1;
b^.Sub2:= L2;
b^.Sub3:= L3;
b^.Sub4:= L4;
b^.Sub5:= L5;
Cons_T:= b
end
else
Otkaz(4)
end {Cons_T};

procedure DestroyT(var b: Tree);
begin
if b <> nil then
begin
DestroyT (b^.Sub1);
DestroyT (b^.Sub2);
DestroyT (b^.Sub3);
DestroyT (b^.Sub4);
DestroyT (b^.Sub5);
Dispose (b)
end
end {DestroyT};


procedure WriteT (D : Tree);
begin
write('(');
write(rootT(D));
if (T1(D) <> nil) then WriteT(T1(D));
if (T2(D) <> nil) then WriteT(T2(D));
if (T3(D) <> nil) then WriteT(T3(D));
if (T4(D) <> nil) then WriteT(T4(D));
if (T5(D) <> nil) then WriteT(T5(D));
write(')');
end;

procedure WriteT1 (D : Tree;var tt:text);
begin
write(tt,'(');
write(tt,rootT(D));
if (T1(D) <> nil) then WriteT1(T1(D),tt);
if (T2(D) <> nil) then WriteT1(T2(D),tt);
if (T3(D) <> nil) then WriteT1(T3(D),tt);
if (T4(D) <> nil) then WriteT1(T4(D),tt);
if (T5(D) <> nil) then WriteT1(T5(D),tt);
write(tt,')');
end;


function EnterT(s:string) : Tree;
var ll:integer;
rrr:tree;



function EntT : Tree;
var
c,temp : char;
begin
c := s[ll]; inc(ll);
{ write(c); readkey; }
if (c = '(') then
begin
c := s[ll]; inc(ll);
end;
{write(c); readkey;}
if (c = ')') then
begin
EntT := nil;
ll := ll -1
end else
begin
EntT := Cons_T(c,EntT,EntT,EntT,EntT,EntT);
c := s[ll]; inc(ll);
end;
end;
begin
ll:=1;
rrr:=entt;
entert := rrr;
end;


procedure DisplayT1 (b: Tree; n,l: integer);
{ўлў®¤ Ї®бва®з­®Ј® Ё Ї®ўҐа­гв®Ј® Ё§®Ўа ¦Ґ­Ёп ЎЁ­ а­®Ј® ¤ҐаҐў  ЎҐ§ ў®§ўа в  Є аҐвЄЁ}
{n га®ўҐ­м 㧫 }
var i,j,k,r: integer;
begin
k:=1;
r:=1;
for j:=1 to n do k:=k+1;
k:=k+l;
if NullT (b) then {Writeln}
else
begin

for i:=1 to k do write(' ');
Write ({' ',} RootT (b)); writeln;

DisplayT1(T1(b),n+1,k);
DisplayT1(T2(b),n+1,k);
DisplayT1(T3(b),n+1,k);
DisplayT1(T4(b),n+1,k);
DisplayT1(T5(b),n+1,k);
{writeln;}
end;
end; {DisplayBT1}


procedure DisplayT2 (b: Tree; n,l: integer;var tt:text);
{ўлў®¤ Ї®бва®з­®Ј® Ё Ї®ўҐа­гв®Ј® Ё§®Ўа ¦Ґ­Ёп ЎЁ­ а­®Ј® ¤ҐаҐў  ЎҐ§ ў®§ўа в  Є аҐвЄЁ}
{n га®ўҐ­м 㧫 }
var i,j,k,r: integer;
begin
k:=1;
r:=1;
for j:=1 to n do k:=k+1;
k:=k+l;
if NullT (b) then {Writeln}
else
begin

for i:=1 to k do write(tt,' ');
Write (tt,RootT(b)); writeln(tt);
DisplayT2(T1(b),n+1,k,tt);
DisplayT2(T2(b),n+1,k,tt);
DisplayT2(T3(b),n+1,k,tt);
DisplayT2(T4(b),n+1,k,tt);
DisplayT2(T5(b),n+1,k,tt);
{writeln;}
end;
end; {DisplayBT1}



procedure CreateForest(var F : forest);
var t : integer;
begin
for t := 1 to ForLen do F[t] := nil;
end;

procedure Listin(T : Tree; var F:forest);
begin
CreateForest(F);
F[2] := T2(T);
F[1] := T1(T);
F[3] := T3(T);
F[4] := T4(T);
F[5] := T5(T);
end; {Listing}

procedure Tail(T : Tree; var F,F1 : forest );
var n : integer;
begin
CreateForest(F1);
for n := 1 to ForLen do
begin
if (F[n] <> T) then F1[n] := F[n];
end;
end;

function Head (F : forest):Tree;
var
n : integer;
begin
n:=1;
while ( (nullT(F[n])) and (n <= ForLen)) do inc(n);
if (n=ForLen + 1) then Head := nil else Head := F[n];
end; {Tail}

function NullF(F:forest):boolean;
var n : integer;
begin
n:=1;
while ( (nullT(F[n])) and (n <= ForLen)) do inc(n);
if (n=ForLen + 1) then NullF := true else NullF := false;
end;
end.