Деревья1 / Unit2

unit Unit2;

interface
const
NilBT=nil;
type
BinT=^Node; { ЇаҐ¤бв ў«Ґ­ЁҐ ЎЁ­ а­®Ј® ¤ҐаҐў  }
Elem=char; { вЁЇ Elem ®ЇЁб ­ ў ¬®¤г«Ґ GlobalBT }
Node=record { 㧥«: }
Info:Elem; { = ᮤҐа¦Ё¬®Ґ }
LSub:BinT; { = «Ґў®Ґ Ї®¤¤ҐаҐў® }
RSub:BinT; { = Їа ў®Ґ Ї®¤¤ҐаҐў® }
end;{ Node }

function CreateBt :BinT;
function NullBT ( t:BinT ) :Boolean;
function RootBT ( t:BinT ) :Elem;
function LeftBT ( t:BinT ) :BinT;
function RightBT ( t:BinT ) :BinT;
function ConsBT ( e:Elem; LS,RS :BinT ) :BinT;
procedure DestroyBT ( var b: BinT);
procedure Otkaz ( n : Byte );
function Null(b:binT):boolean;
{-------------------------------------------------------------------------}
function MakeRoot ( e :Elem ) :BinT;
procedure SetLeft ( e :Elem; b:BinT );
procedure SetRight ( e :Elem; b:BinT );
{-------------------------------------------------------------------------}
{function EnterBt:BinT; {KLP}
procedure OutKLP(b:BinT);
procedure DisplayBT(b:BinT);
procedure OutLKP(b:BinT);
{-------------------------------------------------------------------------}
{procedure EnterBt(var b:BinT;qu:queue);}
function compare(b1,b2:BinT):boolean;
procedure ustupSpisok(b:BinT);
function proverka(var f:textfile):boolean;

implementation
uses unit1;
function Null(b:BinT):boolean;
begin
if b=nil then Null:=true
else Null:=false;
end;{Null}

procedure Otkaz ( n : Byte );
begin
Writeln;
Case n of
1 : Writeln( 'Oshibka : RootBT( Null_Bin_Tree ) !');
2 : Writeln( 'Oshibka : LeftBT( Null_Bin_Tree ) !');
3 : Writeln( 'Oshibka : RightBT( Null_Bin_Tree ) !');
4 : Writeln( 'Oshibka : ЁбзҐаЇ ­  Ї ¬пвм !');
5 : Writeln( 'Oshibka : SetLeft( Null_Bin_Tree )');
6 : Writeln( 'Oshibka : SetLeft( Not ( Null_Bin_Tree ( LeftBT ) ) )');
7 : Writeln( 'Oshibka : OshibkaЋ’ЉЂ‡ : SetRight( Null_Bin_Tree )');
8 : Writeln( 'Oshibka : SetRight( Not ( Null_Bin_Tree ( RightBT ) ) )');
else Writeln( 'Oshibka : ?');
end;
{HaLSub;} { гЎа ­ ¤«п вҐбвЁа®ў ­Ёп !!!!!!}
end{ Otkaz };

function CreateBT :BinT;
begin
CreateBT:=nil;
end{ CreateBT };

function NullBT ( t:BinT ) :Boolean;
begin
NullBT:=( t=nil);
end{ NullBT };

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

function LeftBT ( t:BinT ) :BinT;
begin
if t <> nil then LeftBT:=t^.LSub else Otkaz(2);
end{ LeftBT };

function RightBT ( t:BinT ) :BinT;
begin
if t <> nil then RightBT:=t^.RSub else Otkaz(3);
end{ RightBT };

function ConsBT ( e:Elem; LS,RS :BinT ) :BinT;
var b : BinT;
begin
{if MaxAvail >= SizeOf(Node) then
begin}
New( b );
b:=MakeRoot(e);
if LS<>nil then b^.Lsub:=LS;
if RS<>nil then b^.Rsub:=RS;
ConsBT:=b;
{end}
{else Otkaz(4);}
end{ ConsBT };

procedure DestroyBT ( var b: BinT );
begin
if b <> nil then
begin
DestroyBT( b^.LSub ); DestroyBT( b^.RSub );
Dispose( b );
b:=nil
end;
end{ DestroyBT };

{----------------„®Ї®«­ЁвҐ«м­лҐ дг­ЄжЁЁ-----------------------------------}
function MakeRoot ( e :Elem ) :BinT;
var b :BinT;
begin
{if MaxAvail >= SizeOf(Node) then
begin }
New( b );
b^.Info:=e; b^.LSub:=nil; b^.RSub:=nil;
MakeRoot:=b;
{ end
else Otkaz(4);}
end{ MakeRoot };

procedure SetLeft ( e :Elem; b:BinT );
begin
if NullBT( b ) then Otkaz( 5 )
else if NullBT( LeftBT( b ) ) then b^.LSub:=MakeRoot(e)
else Otkaz(6);
end{ SetLeft };

procedure SetRight ( e :Elem; b:BinT );
begin
if NullBT( b ) then Otkaz( 7 )
else if NullBT( RightBT( b ) ) then b^.RSub:=MakeRoot(e)
else Otkaz(8);
end{ SetRight };

{function EnterBt:BinT;
{Vvod uzlov v KLP poradke}
{var c:Char;
begin
Read(Fin,c);
if c='/' then EnterBT:=NilBT
Else EnterBT:=ConsBT(c,EnterBT,EnterBT);
end;{EnterBT}

procedure OutKLP(b:BinT);
{Bivid uzliv v KLP poradke}
begin
if not Null(b) then
begin
write(rootBT(b));
OutKLP(LeftBT(b));
OutKLP(rightBT(b));
end
{else write('/');}
end;{OutBT}

procedure OutLKP(b:BinT);
begin
if not Null(b) then
begin
OutLKP(leftBT(b));
write(rootBT(b));
OutLKP(RightBT(b));
end;
end;

procedure DisplayBT(b:BinT);
{Vivod postrochnogo povernutogo iz dereva}
begin
if Null(b) then writeln('/')
else begin
write(RootBT(b));
if not NullBT(RightBT(b)) then
begin
write(' ');
DisplayBT(RightBT(b));
write(#8);write(#8);
end;
if not Null(LeftBT(b)) then
begin
write(#10);
write(' ');
displayBT(LeftBT(b));
write(#8);write(#8);
end;
end{else};
end;{display}

function compare(b1,b2:BinT):boolean;
begin
compare:=true;
if b1^.info=b2^.info then begin
if ((b1.LSub=nil)and(b1.Rsub=nil)and(b2.LSub=nil)and (b2.Rsub=nil)) then
{====== если лист =====}
compare:=true else
begin {1}
if ((b1.LSub<>nil)and(b1.Rsub<>nil)and(b2.LSub<>nil)and (b2.Rsub<>nil))then
{====== если внутренняя вершина =====}
begin {2}
if ((b1^.Lsub.info=b2^.Lsub.info) or
(b1.Lsub.info=b2.Rsub.info)) and
((b1.Rsub.info=b2.Rsub.info) or
(b1.Rsub.info=b2.Lsub.info)) then begin {3}

if (b1^.Lsub^.info=b2^.Lsub^.info) then
compare:=compare(b1^.Lsub,b2^.Lsub);
if (b1^.Lsub^.info=b2^.Rsub^.info) then
compare:=compare(b1^.Lsub,b2^.Rsub);
if (b1^.Rsub^.info=b2^.Rsub^.info) then
compare:=compare(b1^.Rsub,b2^.Rsub);
if (b1^.Rsub^.info=b2^.Lsub^.info) then
compare:=compare(b1^.Rsub,b2^.Lsub);
end {3}
else compare:=false
end {2}
else
begin {4}
{===== если повернуты =====}

if ((b1.LSub<>nil)and(b1.Rsub=nil)and(b2.LSub=nil)and (b2.Rsub<>nil))then
begin
if (b1^.Lsub^.info=b2^.Rsub^.info) then compare:=compare(b1^.Lsub,b2^.Rsub) else compare:=false;
end
else
if ((b1.LSub=nil)and(b1.Rsub<>nil)and(b2.LSub<>nil)and (b2.Rsub=nil))then
begin
if (b1^.Rsub^.info=b2^.Lsub^.info) then compare:=compare(b1^.Rsub,b2^.Lsub) else compare:=false;
end
else

{===== если одна ветвь(левая или правая) =====}
if ((b1.LSub<>nil)and(b1.Rsub=nil)and(b2.LSub<>nil)and (b2.Rsub=nil))then
begin
if (b1^.Lsub^.info=b2^.Lsub^.info) then compare:=compare(b1^.Lsub,b2^.Lsub) else compare:=false;
end
else
if ((b1.LSub=nil)and(b1.Rsub<>nil)and(b2.LSub=nil)and (b2.Rsub<>nil))then
begin
if (b1^.Rsub^.info=b2^.Rsub^.info) then compare:=compare(b1^.Rsub,b2^.Rsub) else compare:=false;
end
else

begin
compare:=false;
equal:=false;
end;
end {4}

end {1}
end else
begin
compare:=false;
equal:=false;
end;
end;{compare}

procedure ustupSpisok(b:BinT);
begin
if Null(b) then writeln(f,'/')
else begin
write(f,RootBT(b)); write(f,#10);
if not NullBT(RightBT(b)) then
begin
write(f,' ');
ustupSpisok(RightBT(b));
write(f,#8);write(f,#8);
end;
if not Null(LeftBT(b)) then
begin
write(f,#10);
write(f,' ');
ustupSpisok(LeftBT(b));
write(f,#8);write(f,#8);
end;
end{else}{;}
end;{UstupSpisok}

function proverka(var f:textfile):boolean;
var a:char;
i:byte;
begin
reset(f);
proverka:=true;
i:=0;
while not eof(f) do begin
read(f,a);
case a of
'a'..'z','A'..'Z','/':begin end;
'1'..'9','0':begin end;
'А'..'Я','а'..'я':begin end;
else i:=i+1 end;
end;
if i>0 then proverka:=false;
closefile(f);
end;


end.