TElem = integer;
TStack = ^TElement;
TElement = record
info:TElem;
Next:TStack;
end;
TData = integer;
PTDeqItem = ^TDeqItem;
TDeqItem = record
Data: TData;
next, prev: PTDeqItem;
End;
TDeq = Record
pStart, pFinish: PTDeqItem;
End;
TElem = integer;
PTStackItem = ^TStackItem;
TStackItem = record
info:TElem;
Next: PTStackItem;
end;
TStack = PTStackItem;
PTDeqItem = ^TDeqItem;
TDeqItem = record
Data: TElem;
next, prev: PTDeqItem;
End;
TDeque = Record
Head, Tail: PTDeqItem;
End;
, так ошибиться будет гораздо сложнее, скажем, если понадобится сделать стек/дек не целых, а Char-ов или Real-ов...
Procedure Create(var Deq : TDeq; var fin:text);
var
curr: PTDeqItem;
ch : TData;
begin
reset(fin);
while not seekeof(fin) do
begin
curr:= new(PTDeqItem);
read(fin,ch);
curr^.next := Deq.pStart;
curr^.prev := nil;
curr^.data :=ch;
If Deq.pStart <> nil Then
Deq.pStart^.prev := curr
Else
Deq.pFinish := curr;
Deq.pStart := curr;
end;
close(fin);
end;
program laba10;
Uses CRT;
Type
TElem = integer;
PTStackItem = ^TStackItem;
TStackItem = record
Data: TElem;
Next: PTStackItem;
end;
TStack = PTStackItem;
PTDeqItem = ^TDeqItem;
TDeqItem = record
Data: TElem;
next, prev: PTDeqItem;
End;
TDeque = Record
head,tail: PTDeqItem;
End;
var
Deq : TDeq;
Stack : TStack;
v : integer; {Љ(r)«-ў(r) н«Ґ¬Ґв(r)ў § ЇЁблў Ґ¬лҐ ў б⥪}
fin : text;
Procedure CreateDeque(var Deq : TDeque; var fin:text);
var
curr: PTDeqItem;
ch : TData;
begin
reset(fin);
while not seekeof(fin) do
begin
curr:= new(PTDeqItem);
read(fin,ch);
curr^.next := Deq.руфв;
curr^.prev := nil;
curr^.data :=ch;
If Deq.руфв <> nil Then
Deq.head^.prev := curr
Else
Deq.tail := curr;
Deq.head := curr;
end;
close(fin);
end;
Procedure CreateStack(var Deq : TDeque; var fin:text;v:integer);
var
CurrDeq: PTDeqItem;
CurrStack:PTStackItem;
begin
reset(fin);
while CurrDeq<V do
begin
CurrDeq:= new(PTDeqItem);
CurrStack:= new(PTStackItem);
CurrDeq^.prev := Deq.tail;
CurrDeq^.next := nil;
CurrStack^.next := nil;
СurrStack^.data :=СurrDeq^.data;
If Deq.pStart <> V Then
Stack^.next := curr;
end;
end;
Procedure CreateStack(var Deq : TDeque; var fin:text;v:integer);
var
CurrDeq: PTDeqItem;
CurrStack:PTStackItem;
begin
reset(fin);
while CurrDeq^.data<V do
begin
CurrDeq:= new(PTDeqItem);
CurrStack:= new(PTStackItem);
CurrDeq^.prev := Deq.tail;
CurrDeq^.next := nil;
CurrStack^.next := nil;
CurrStack^.data :=CurrDeq^.data;
If CurrDeq^.data<>V Then
Stack^.data:= CurrStack^.data;
Deq.tail:=Deq.tail^.prev;
end;
CurrDeq:= new(PTDeqItem);
while CurrDeq<V do
Procedure CreateStack(var Deq : TDeque; var fin:text;v:integer);
var
CurrDeq: PTDeqItem;
CurrStack:PTStackItem;
S:integer;
begin
reset(fin);
S:=0;
while S<=V do
begin
CurrDeq^.prev := Deq.tail;
CurrDeq^.next := nil;
CurrStack^.next :=Stack;
CurrStack^.data :=CurrDeq^.data;
Stack:=CurrStack;
Deq.tail:=CurrDeq^.prev;
S:=S+1;
end;
end;
.
program laba10;
Uses CRT;
Type
TElem = integer;
PTStackItem = ^TStackItem;
TStackItem = record
Data: TElem;
Next: PTStackItem;
end;
TStack = PTStackItem;
PTDeqItem = ^TDeqItem;
TDeqItem = record
Data: TElem;
next, prev: PTDeqItem;
End;
TDeque = Record
head,tail: PTDeqItem;
End;
var
Deq : TDeque;
Stack : TStack;
v : integer; {Љ(r)«-ў(r) н«Ґ¬Ґв(r)ў § ЇЁблў Ґ¬лҐ ў б⥪}
fin : text;
Procedure InitDeq(Var Deq: TDeque);
Begin
Deq.head := nil;
Deq.tail := nil;
End;
Function IsEmpty(Var Deq: TDeque): Boolean;
Begin
isEmpty := (Deq.head = nil);
End;
Procedure CreateDeq(var Deq : TDeque; var fin:text);
var
curr: PTDeqItem;
ch : TElem;
begin
reset(fin);
while not seekeof(fin) do
begin
curr:= new(PTDeqItem);
read(fin,ch);
curr^.next := Deq.head;
curr^.prev := nil;
curr^.data :=ch;
If Deq.head <> nil Then
Deq.head^.prev := curr
Else
Deq.tail := curr;
Deq.head := curr;
end;
close(fin);
end;
Procedure PrintDeq(Var Deq: TDeque);
Var p: PTDeqItem;
Begin
WriteLn( 'Printing Deck...' );
If isEmpty(Deq) Then
Begin
WriteLn('<Џгбв(r)(c)>'); Exit
End;
p := Deq.head;
While p <> nil Do
Begin
Write( p^.Data, ' ' );
p := p^.next
End;
WriteLn
End;
Procedure InitStack(var Stack:TStack);
begin
Stack:=nil;
end;
Function StackEmpty(Stack:TStack):Boolean;
begin
StackEmpty:=(Stack=NIL);
end;
Procedure StackPush(var Stack:TStack; E:TElem);
var
z:TStack;
begin
new(z);
z^.next:=Stack;
z^.data:=E;
Stack:=z;
end;
Procedure CreateStack(var Deq : TDeque;var Stack : Tstack; var fin:text;v:integer);
var
CurrDeq: PTDeqItem;
CurrStack:PTStackItem;
S:integer;
begin
reset(fin);
S:=1;
while S<=V do
begin
CurrDeq^.prev := Deq.tail^.prev;
CurrDeq^.data :=Deq.tail^.data;
CurrStack^.next :=Stack;
CurrStack^.data :=CurrDeq^.data;
Stack:=CurrStack;
write(Stack^.data,' ');{Проверка заполнения(ненужная строчка)}
Deq.tail:=Deq.tail^.prev;
Stack^.next:=nil;
S:=S+1;
end;
end;
Procedure PrintStack(Var Stack: TStack);
Var p: PTStackItem;
Begin
WriteLn( 'Printing Stack...' );
If StackEmpty(Stack) Then
Begin
WriteLn('<Џгбв(r)(c)>'); Exit
End;
p := Stack^.next;
While p <> nil Do
Begin
Write( p^.data, ' ' );
p := p^.next;
End;
WriteLn
End;
begin
clrscr;
chdir('C:\Tpascal');
assign(fin,'test1.txt');
InitDeq(Deq);
InitStack(Stack);
CreateDeq(Deq,fin);
PrintDeq(Deq);
readln(v);
CreateStack(Deq,Stack,fin,v);
PrintStack(Stack);
readln;
end.
program laba11;
Uses CRT;
type
DTree = record
Data: integer;
Name: string;
stat: String;
end;
PTree = ^TTree;
TTree = record
head : DTree;
left,right: PTree;
end;
var
fin:text;
temp:PTree;
root:PTree;
Function ReadFile(var fin: text; var str: string): boolean;
var tmp: char;
begin
str:='';
repeat
read(fin, tmp);
if not (tmp = ' ') and not (tmp=';') then
str:=str+tmp;
until (tmp=' ') or eoln(fin) or (tmp=';');
case tmp of
' ': readFile:=true;
else readFile:=false;
end;
end;
Procedure CreateNode(n: PTree;var p:PTree);
Begin
p^.head.stat := n^.head.stat;
p^.head.name := n^.head.name;
p^.head.data := n^.head.data;
p^.left := nil;
p^.right := nil;
End;
Procedure AddItem(Var root: PTree; X: PTree);
{ Функция, создающая новый лист дерева с заданным значением Data }
var
parent, pwalk: PTree;
Begin
{
Если корень дерева - нулевой (только начали заполнять дерево),
то создаем новый элемент и запоминаем его, как корень
}
if root = nil then CreateNode(X,root)
else begin
{ Если дерево уже не пустое - тогда начинаем "прогулку" по нему... }
pWalk := root; { "гулять" начнем с корня }
while pWalk <> nil do begin { пока не добрались до пустого указателя - делаем следующее }
{ запоминаем текущий элемент, в качестве "родителя" его потомка }
parent := pWalk;
{
переходим в левую лил правую ветвь в зависимости от соотношения величин
нового элемента и "текущего", которым мы "гуляем" по дереву
}
if pWalk^.head.stat='male' then pWalk := pWalk^.left
else pWalk := pWalk^.right
end;
{
Если мы здесь - значит, добрались до пустого указателя...
Вот теперь делаем то, для чего запоминали родителя текущего элемента:
опять же в зависимости от того, больше или меньше добавляемое значение,
чем значение "родителя", создаем новый элемент и запоминаем его в левой,
или правой ветке...
}
if x^.head.stat='male' then CreateNode(parent^.left,X)
else CreateNode(parent^.right,X);
end;
End;
Procedure CreateTree(var root: PTree;var fin : text);
var
temp : PTree;
begin
readfile(fin,temp^.head.stat);
readfile(fin,temp^.head.name);
read(fin,temp^.head.data);
temp^.Left := nil; temp^.Right := nil;
root:=temp;
while not eof(fin) do
begin
readfile(fin,temp^.head.stat);
readfile(fin,temp^.head.name);
read(fin,temp^.head.data);
AddItem(root,temp);
end;
end;
procedure printKLP(root:PTree);
begin
if (root<>NIL) then
begin
write(root^.head.name,' '); (* Распечатать корень дерево *)
printKLP(root^.left); (* Распечатать левое поддерево *)
printKLP(root^.right);(* Распечатать правое поддерево *)
end;
end;
procedure printKLP_wrapper(root:PTree);
begin
clrscr;
if (root=NIL) then (* Если дерево пустое *)
writeln('Дерево пусто!')
else (* Иначе *)
PrintKLP(root); (* Распечатать дерево *)
writeln;
writeln('Нажмите любую клавишу для выхода в главное меню');
readkey;
end;
begin
clrscr;
chdir('C:\TPascal');
assign(fin,'test.txt');
reset(fin);
CreateTree(root,fin);
printKLP_wrapper(root);
close(fin);
end.
program laba10;
Uses CRT;
Type
TElem = integer;
PTStackItem = ^TStackItem;
TStackItem = record
Data: TElem;
Next: PTStackItem;
end;
TStack = PTStackItem;
PTDeqItem = ^TDeqItem;
TDeqItem = record
Data: TElem;
next, prev: PTDeqItem;
End;
TDeque = Record
head,tail: PTDeqItem;
End;
var
Deq : TDeque;
Stack : TStack;
v : integer; {Љ(r)«-ў(r) н«Ґ¬Ґв(r)ў § ЇЁблў Ґ¬лҐ ў б⥪}
fin : text;
Procedure InitDeq(Var Deq: TDeque);
Begin
Deq.head := nil;
Deq.tail := nil;
End;
Function IsEmpty(Var Deq: TDeque): Boolean;
Begin
isEmpty := (Deq.head = nil);
End;
Procedure CreateDeq(var Deq : TDeque; var fin:text);
var
curr: PTDeqItem;
ch : TElem;
begin
reset(fin);
while not seekeof(fin) do
begin
curr:= new(PTDeqItem);
read(fin,ch);
curr^.next := Deq.head;
curr^.prev := nil;
curr^.data :=ch;
If Deq.head <> nil Then
Deq.head^.prev := curr
Else
Deq.tail := curr;
Deq.head := curr;
end;
close(fin);
end;
Procedure PrintDeq(Var Deq: TDeque);
Var p: PTDeqItem;
Begin
WriteLn( 'Printing Deck...' );
If isEmpty(Deq) Then
Begin
WriteLn('<Џгбв(r)(c)>'); Exit
End;
p := Deq.head;
While p <> nil Do
Begin
Write( p^.Data, ' ' );
p := p^.next
End;
WriteLn
End;
Procedure InitStack(var Stack:TStack);
begin
Stack:=nil;
end;
Function StackEmpty(Stack:TStack):Boolean;
begin
StackEmpty:=(Stack=NIL);
end;
Procedure StackPush(var Stack:TStack; E:TElem);
var
tmp:TStack;
begin
new(tmp);
tmp^.next:=Stack;
tmp^.data:=E;
Stack:=tmp;
end;
Procedure CreateStack(var Deq : TDeque;var Stack : TStack; v : integer);
var
CurrDeq: PTDeqItem;
ch : TElem;
S : integer;
begin
S:=1;
reset(fin);
while S<=V do
begin
CurrDeq^.prev := Deq.tail^.prev;
CurrDeq^.data := Deq.tail^.data;
ch := CurrDeq^.data;
StackPush(Stack,ch);
Deq.tail:=Deq.tail^.prev;
S:=S+1;
end;
end;
Procedure PrintStack(Var Stack: TStack);
Var p: PTStackItem;
Begin
WriteLn( 'Printing Stack...' );
If StackEmpty(Stack) Then
Begin
WriteLn('<Џгбв(r)(c)>'); Exit
End;
p := Stack;
While p <> nil Do
Begin
Write( p^.data, ' ' );
p := p^.next;
End;
WriteLn
End;
begin
clrscr;
chdir('C:\Tpascal');
assign(fin,'test1.txt');
InitDeq(Deq);
InitStack(Stack);
CreateDeq(Deq,fin);
PrintDeq(Deq);
readln(v);
CreateStack(Deq,Stack,v);
PrintStack(Stack);
readln;
end.
program laba10;
Uses CRT;
Type
TElem = integer;
PTStackItem = ^TStackItem;
TStackItem = record
Data: TElem;
Next: PTStackItem;
end;
TStack = PTStackItem;
PTDeqItem = ^TDeqItem;
TDeqItem = record
Data: TElem;
next, prev: PTDeqItem;
End;
TDeque = Record
head,tail: PTDeqItem;
End;
var
Deq : TDeque;
Stack : TStack;
v : integer; {Љ(r)«-ў(r) н«Ґ¬Ґв(r)ў § ЇЁблў Ґ¬лҐ ў б⥪}
fin : text;
Procedure InitDeq(Var Deq: TDeque);
Begin
Deq.head := nil;
Deq.tail := nil;
End;
Function IsEmpty(Var Deq: TDeque): Boolean;
Begin
isEmpty := (Deq.head = nil);
End;
Procedure CreateDeq(var Deq : TDeque; var fin:text);
var
curr: PTDeqItem;
ch : TElem;
begin
reset(fin);
while not seekeof(fin) do
begin
new(curr);
read(fin,ch);
curr^.next := Deq.head;
curr^.prev := nil;
curr^.data :=ch;
If Deq.head <> nil Then
Deq.head^.prev := curr
Else
Deq.tail := curr;
Deq.head := curr;
end;
close(fin);
end;
Procedure PrintDeq(Var Deq: TDeque);
Var p: PTDeqItem;
Begin
WriteLn( 'Printing Deck...' );
If isEmpty(Deq) Then
Begin
WriteLn('<Џгбв(r)(c)>'); Exit
End;
p := Deq.head;
While p <> nil Do
Begin
Write( p^.Data, ' ' );
p := p^.next
End;
WriteLn
End;
Procedure InitStack(var Stack:TStack);
begin
Stack:=nil;
end;
Function StackEmpty(Stack:TStack):Boolean;
begin
StackEmpty:=(Stack=NIL);
end;
Procedure StackPush(var Stack:TStack; E:TElem);
var
tmp:TStack;
begin
new(tmp);
tmp^.next:=Stack;
tmp^.data:=E;
Stack:=tmp;
end;
Procedure CreateStack(var Deq : TDeque;var Stack : TStack; v : integer);
var
CurrDeq: PTDeqItem;
ch : TElem;
S : integer;
begin
S:=1;
new(CurrDeq);
while S<=V do
begin
CurrDeq^.prev := Deq.tail^.prev;
CurrDeq^.data := Deq.tail^.data;
ch := CurrDeq^.data;
StackPush(Stack,ch);
Deq.tail:=Deq.tail^.prev;
S:=S+1;
end;
dispose(CurrDeq);
end;
Procedure PrintStack(Var Stack: TStack);
Var p: PTStackItem;
Begin
WriteLn( 'Printing Stack...' );
If StackEmpty(Stack) Then
Begin
WriteLn('<Џгбв(r)(c)>'); Exit
End;
p := Stack;
While p <> nil Do
Begin
Write( p^.data, ' ' );
p := p^.next;
End;
WriteLn
End;
begin
clrscr;
chdir('C:\Tpascal');
assign(fin,'test1.txt');
InitDeq(Deq);
InitStack(Stack);
CreateDeq(Deq,fin);
PrintDeq(Deq);
readln(v);
CreateStack(Deq,Stack,v);
PrintStack(Stack);
readln;
end.
Изменил.После того, как добавил new(CurrDeq); при удалении reset(fin); перестала выдаваться ошибка.Просьба обьяснить взаимосвязь.
program laba11;
Uses CRT;
type
DTree = record
Data: integer;
Name: string;
stat: String;
end;
PTree = ^TTree;
TTree = record
head : DTree;
left,right: PTree;
end;
var
fin:text;
temp:PTree;
root:PTree;
Function ReadFile(var fin: text; var str: string): boolean;
var tmp: char;
begin
str:='';
repeat
read(fin, tmp);
if not (tmp = ' ') and not (tmp=';') then
str:=str+tmp;
until (tmp=' ') or eoln(fin) or (tmp=';');
case tmp of
' ': readFile:=true;
else readFile:=false;
end;
end;
Procedure CreateNode(n: PTree;var p:PTree);
Begin
p^.head.stat := n^.head.stat;
p^.head.name := n^.head.name;
p^.head.data := n^.head.data;
p^.left := nil;
p^.right := nil;
End;
Procedure AddItem(Var root: PTree; X: PTree);
{ Функция, создающая новый лист дерева с заданным значением Data }
var
parent, pwalk: PTree;
Begin
if root = nil then CreateNode(X,root)
else begin
{ Если дерево уже не пустое - тогда начинаем "прогулку" по нему... }
pWalk := root; { "гулять" начнем с корня }
while pWalk <> nil do begin { пока не добрались до пустого указателя - делаем следующее }
parent := pWalk;
if pWalk^.head.stat='male' then pWalk := pWalk^.left
else pWalk := pWalk^.right
end;
if x^.head.stat='male' then CreateNode(parent^.left,X)
else CreateNode(parent^.right,X);
end;
End;
Procedure CreateTree(var root: PTree;var fin : text);
var
temp : PTree;
begin
readfile(fin,temp^.head.stat);
readfile(fin,temp^.head.name);
read(fin,temp^.head.data);
temp^.Left := nil; temp^.Right := nil;
root:=temp;
while not eof(fin) do
begin
readfile(fin,temp^.head.stat);
readfile(fin,temp^.head.name);
read(fin,temp^.head.data);
AddItem(root,temp);
end;
end;
procedure printKLP(root:PTree);
begin
if (root<>NIL) then (* Если дерево не пустое *)
begin
write(root^.head.name,' '); (* Распечатать корень дерево *)
printKLP(root^.left); (* Распечатать левое поддерево *)
printKLP(root^.right);(* Распечатать правое поддерево *)
end;
end;
procedure printKLP_wrapper(root:PTree);
begin
clrscr;
if (root=NIL) then (* Если дерево пустое *)
writeln('Дерево пусто!') (* Сообщить об этом *)
else (* Иначе *)
PrintKLP(root); (* Распечатать дерево *)
writeln;
writeln('Нажмите любую клавишу для выхода в главное меню');
readkey;
end;
begin
clrscr;
chdir('C:\TPascal');
assign(fin,'test.txt');
reset(fin);
CreateTree(root,fin);
printKLP_wrapper(root);
close(fin);
end.
program laba11;
Uses CRT;
type
DTree = record
Data: integer;
Name: string;
stat: String;
end;
PTree = ^TTree;
TTree = record
head : DTree;
left,right: PTree;
end;
var
fin:text;
temp:PTree;
root:PTree;
Procedure ReadFile(var fin: text; var str: string);
var
tmp: char;
begin
str:='';
repeat
read(fin, tmp);
if not (tmp = ' ') and not (tmp=';') then
str:=str+tmp;
until (tmp=' ') or eoln(fin) or (tmp=';');
end;
Procedure CreateNode(temp : PTree;var root:PTree);
Begin
root^.head.stat := temp^.head.stat;
root^.head.name := temp^.head.name;
root^.head.data := temp^.head.data;
root^.left := nil;
root^.right := nil;
End;
Procedure AddItem(Var root: PTree; temp: PTree);
{ Функция, создающая новый лист дерева с заданным значением Data }
var
parent, pwalk: PTree;
Begin
if root = nil then CreateNode(temp,root)
else
begin
pWalk := root; { "гулять" начнем с корня }
while pWalk <> nil do begin { пока не добрались до пустого указателя - делаем следующее }
parent := pWalk;
if pWalk^.head.stat='male' then pWalk := pWalk^.left
else pWalk := pWalk^.right
end;
if temp^.head.stat='male' then CreateNode(temp,parent^.left)
else CreateNode(temp,parent^.right);
end;
End;
Procedure CreateTree(var root: PTree;var fin : text);
var
temp : PTree;
begin
new(temp);
new(root);
while not eof(fin) do
begin
readfile(fin,temp^.head.stat);
readfile(fin,temp^.head.name);
read(fin,temp^.head.data);
AddItem(root,temp);
end;
end;
procedure printKLP(root:PTree);
begin
if (root<>NIL) then (* Если дерево не пустое *)
begin
write(root^.head.name,' '); (* Распечатать корень дерево *)
printKLP(root^.left); (* Распечатать левое поддерево *)
printKLP(root^.right);(* Распечатать правое поддерево *)
end;
end;
procedure printKLP_wrapper(root:PTree);
begin
clrscr;
if (root=NIL) then (* Если дерево пустое *)
writeln('Дерево пусто!') (* Сообщить об этом *)
else (* Иначе *)
PrintKLP(root); (* Распечатать дерево *)
writeln;
writeln('Нажмите любую клавишу для выхода в главное меню');
end;
begin
clrscr;
chdir('C:\TPascal');
assign(fin,'test.txt');
reset(fin);
CreateTree(root,fin);
printKLP_wrapper(root);
close(fin);
readkey;
end.
boris kor bob bob rita ksenia maria
Нажмите любую клавишу для выхода в главное меню
{ 1 - реализацию CreateNode }
Procedure CreateNode(temp : PTree; var root:PTree);
Begin
new(root); { !!! вот только в этом месте выделяем память под элемент !!! }
root^.head.stat := temp^.head.stat;
root^.head.name := temp^.head.name;
root^.head.data := temp^.head.data;
root^.left := nil;
root^.right := nil;
End;
{ 2 - процедура печати дерева теперь такая: }
procedure printKLP(root:PTree);
procedure print(level: integer; root:PTree);
begin
if root<>NIL then begin
writeln('':2*level, root^.head.name);
print(level+1, root^.left);
print(level+1, root^.right);
end;
end;
begin
clrscr;
if (root=NIL) then writeln('Дерево пусто!')
else Print(0, root);
writeln;
writeln('Нажмите любую клавишу для выхода в главное меню');
end;
{ 3 - ну, и само создание дерева: }
Procedure CreateTree(var root: PTree; var fin : text);
var
temp : PTree;
begin
while not eof(fin) do begin
new(temp); { <--- Временное хранилище: создали ... }
readfile(fin,temp^.head.stat); { читаем stat }
readfile(fin,temp^.head.name); { читаем имя }
read(fin,temp^.head.data); { читаем дату рождения }
readln(fin); { все остальное - пропускаем !!! }
AddItem(root,temp); { и добавляем прочитанное в дерево }
dispose(temp); { <--- Временное хранилище: удалили}
end;
end;
program laba11;
Uses Crt;
Type TInf=Record
pol: String;
name: String;
BirthB,BirthD: Integer;
end;
TTree=^Tree;
Tree=Record
Inf:TInf;
Left,Right: TTree;
end;
var
fin : text;
root : TTree;
list : Tinf;
walk : TTree;
{-------------------------------------------------------------------------}
Procedure ReadFile(var fin: text; var str: string);
var tmp: char;
begin
str:='';
repeat
read(fin, tmp);
if not (tmp = ' ') and not (tmp=';') then
str:=str+tmp;
until (tmp=' ') or eoln(fin) or (tmp=';');
end;
Procedure Show(List: TInf);{Отображение данных записи}
Begin
Write(List.pol,' ',List.name,' ',list.BirthB,' ',list.BirthD);
WriteLn; {Перевод строки}
End;
Procedure Input(Var list: TInf);{Заполнение записи путём ввода данных из файла}
Begin
Readfile(fin,list.pol);
Readfile(fin,list.name);
Read(fin,list.BirthB);
Read(fin,list.BirthD);
readln(fin);
End;
{-------------------------------------------------------------------------}
Function SignKey(B: TInf): Boolean;
Begin SignKey:=False;
If B.pol='male' then SignKey:=True;
End;
Function FindKey(A: TInf): Boolean;
Begin FindKey:=False;
If (A.BirthB<1942) and (A.BirthD>1942) then FindKey:=True;
End;
Function NewSheet(X:TInf): TTree; {размещение в куче нового элемента}
Var Temp: TTree;
Begin
New (Temp);
Temp^.Inf:=X;
Temp^.Right:=Nil;
Temp^.Left:=Nil;
NewSheet:=Temp;
End;
Procedure AddSheet(Var Root: TTree; tmp: TInf);{размещение нового элемента (листа) в структуре}
Begin
If Root<>Nil then begin
If SignKey(tmp) then begin
If Root^.Left=Nil then Root^.Left:=NewSheet(tmp) else AddSheet(Root^.Left,tmp);
end else begin
If Root^.Right=Nil then Root^.Right:=NewSheet(tmp) else AddSheet(Root^.Right,tmp);
end;
end else begin {дерево не создано, создаем его}
Root:=NewSheet(tmp);
end;
End;
Procedure AddTree(Var Root: TTree; New: TTree);{размещение нового в структуре}
Begin
If Root<>Nil then begin
If New<>Nil then begin
If SignKey(New^.Inf) then begin
If Root^.Left=Nil then Root^.Left:=New else AddTree(Root^.Left,New);
end else begin
If Root^.Right=Nil then Root^.Right:=New else AddTree(Root^.Right,New);
end;
end;
end else begin {дерево не создано, пытаемся создать его}
Root:=New;
end;
End;
Function Find(Root: TTree): TTree;{Поиск элемента}
Var temp: Ttree;
Begin temp:=Nil;
If Root<>Nil then begin {Если дерево не пустое}
If FindKey(Root^.Inf) then begin {Проверяем значение ключевого поля}
temp:=Root; {Если нашли нужный элемент, запоминаем его значение}
end else begin {если не нашли}
temp:=Find(Root^.Left); {пытаемся найти в других ветвях дерева (сначала слева)}
If temp=Nil then temp:=Find(Root^.Right); {Потом справа, если слева ничего не нашли}
end;
end;
Find:=temp; {Результат функции - значение временной переменной temp}
End;
Procedure ShowTree(R: TTree); {Вывод дерева на экран}
Begin
If R<>Nil then begin {Если ветвь не пуста}
Show(R^.Inf); {выводим информацию}
If R^.Left <> nil then ShowTree(R^.Left); {если слева имеется сук, выводим и его}
If R^.Right <> nil then ShowTree(R^.Right);{тоже самое справа...}
end;
End;
Procedure Print(T: TTree; g: integer); {Печать дерева. G-глубина (по лекции)}
Begin
If T=nil then Writeln ('Дерево пустое') else begin
g:=g+1;
If T^.Right <> nil then
Print (T^.Right, g);
Writeln (T^.Inf.pol,' ', T^.Inf.name);
If T^.Left <> nil then
Print (T^.Left,g);
g:=g-1;
End;
End;
{-------------------------------------------------------------------------}
begin
ClrScr; {Основная программа}
assign(fin,'C:\Tpascal\test.txt');
reset(fin);
Root:=Nil; {Начальные условия - пустое дерево}
while not eof(fin) do begin {В цикле вводим записи }
Input(list);
AddSheet(Root,list);{Добовляем данные}
end;
WriteLn;
WriteLn('Введённые данные: ');
ShowTree(Root); WriteLn;
ReadLn;
WriteLn('Отображение в виде дерева:');
Print(Root,0);
ReadLn;
Walk:=Find(Root);
If Walk=Nil Then WriteLn('Элемент не найден.');
WriteLn('Найден элемент:');
Show(Walk^.Inf); WriteLn;
close(fin);
END.
Но дерево все равно заполняется в виде пирамиды какой то.(текстовый файл все тот же)
Введённые данные:
male boris 1995 1995
male kor 1955 1955
male bob 1912 1912
male bob 1912 1912
fomale maria 1965 1965
fomale ksenia 1915 1915
fomale rita 1915 1915
Отображение в виде дерева:
fomale rita
fomale ksenia
fomale maria
male boris
male kor
male bob
male bob
Walk:=Find(Root);
If Walk=Nil Then WriteLn('Элемент не найден.');
WriteLn('Найден элемент:');
Show(Walk^.Inf); WriteLn;
male boris 1995 {корень}
fomale maria 1965 {мать}
male kor 1955 {отец}
fomale ksenia 1915 {бабушка по отцу}
male bob 1912 {дед по отцу}
fomale rita 1915 {бабушка по матери}
male bob 1912 {дед по матери}
program laba11;
Uses Crt;
Type TInf=Record
stat : string;
pol: String;
name: String;
BirthB,BirthD: Integer;
end;
TTree=^Tree;
Tree=Record
Inf:TInf;
Left,Right: TTree;
end;
var
fin : text;
root : TTree;
walk : TTree;
tmp : Tinf;
{-------------------------------------------------------------------------}
Procedure ReadFile(var fin: text; var str: string);
var tmp: char;
begin
str:='';
repeat
read(fin, tmp);
if not (tmp = ' ') and not (tmp=';') then
str:=str+tmp;
until (tmp=' ') or eoln(fin) or (tmp=';');
end;
Procedure Show(List: TInf);{Отображение данных записи}
Begin
Write(List.pol,' ',List.name,' ',list.BirthB,' ',list.BirthD);
WriteLn; {Перевод строки}
End;
Procedure Input(Var list: TInf);{Заполнение записи путём ввода данных из файла}
Begin
Readfile(fin,list.stat);
Readfile(fin,list.pol);
Readfile(fin,list.name);
Read(fin,list.BirthB);
Read(fin,list.BirthD);
readln(fin);
End;
{-------------------------------------------------------------------------}
Function SignKey(B: TInf): Boolean;
Begin SignKey:=False;
If B.pol='male' then SignKey:=True;
End;
Function FindKey(A: TInf): Boolean;
Begin FindKey:=False;
If (A.BirthB<1942) and (A.BirthD>1942) and (A.pol='male') then FindKey:=True;
End;
Function NewSheet(X:TInf): TTree; {размещение в куче нового элемента}
Var Temp: TTree;
Begin
New (Temp);
Temp^.Inf:=X;
temp^.inf.stat:=X.stat;
Temp^.Right:=Nil;
Temp^.Left:=Nil;
NewSheet:=Temp;
End;
Procedure AddSheet(Var Root: TTree; tmp: TInf);{размещение нового элемента (листа) в структуре}
Begin
If Root<>Nil then
begin
if tmp.stat='father' then
begin
If Root^.Left=Nil then
Root^.Left:=NewSheet(tmp)
else
begin
If SignKey(tmp) then
AddSheet(Root^.Left,tmp)
else
AddSheet(Root^.right,tmp);
end;
end
else
begin
If Root^.Right=Nil then
Root^.Right:=NewSheet(tmp)
else
begin
If SignKey(tmp) then
AddSheet(Root^.Left,tmp)
else
AddSheet(Root^.Right,tmp);
end;
end;
end
else
begin {дерево не создано, создаем его}
Root:=NewSheet(tmp);
end;
End;
Function Find(Root: TTree): TTree;{Поиск элемента}
Var temp: Ttree;
Begin temp:=Nil;
If Root<>Nil then begin {Если дерево не пустое}
If FindKey(Root^.Inf) then begin {Проверяем значение ключевого поля}
temp:=Root; {Если нашли нужный элемент, запоминаем его значение}
end else begin {если не нашли}
temp:=Find(Root^.Left); {пытаемся найти в других ветвях дерева (сначала слева)}
If temp=Nil then temp:=Find(Root^.Right); {Потом справа, если слева ничего не нашли}
end;
end;
Find:=temp; {Результат функции - значение временной переменной temp}
End;
procedure printKLP(root:TTree);
procedure print(level: integer; root:TTree);
begin
if root<>NIL then begin
writeln('':2*level, root^.inf.name);
print(level+1, root^.left);
print(level+1, root^.right);
end;
end;
begin
if (root=NIL) then writeln('Дерево пусто!')
else Print(0, root);
writeln;
writeln('Нажмите любую клавишу для выхода в главное меню');
end;
{-------------------------------------------------------------------------}
begin
ClrScr; {Основная программа}
assign(fin,'C:\Tpascal\test.txt');
reset(fin);
Root:=Nil; {Начальные условия - пустое дерево}
while not eof(fin) do begin {В цикле вводим записи }
Input(tmp);
AddSheet(Root,tmp);{Добовляем данные}
end;
WriteLn;
WriteLn('Введённые данные: ');
ShowTree(Root); WriteLn;
ReadLn;
WriteLn('Отображение в виде дерева:');
printKLP(root);
readln;
Walk:=Find(Root);
If Walk=Nil Then WriteLn('Элемент не найден.')
else
begin
WriteLn('Найден элемент:');
Show(Walk^.Inf); WriteLn;
end;
readln;
close(fin);
END.
Procedure AddSheet(Var Root: TTree; tmp: TInf);{размещение нового элемента (листа) в структуре}
Begin
If Root<>Nil then
begin
if Root^.inf.stat='father' then
begin
If Root^.Left=Nil then
Root^.Left:=NewSheet(tmp)
else
begin
If SignKey(tmp) then
AddSheet(Root^.right,tmp){я поменял право и лево тут}
else
AddSheet(Root^.left,tmp);{и тут}
end;
end
else
begin
If Root^.Right=Nil then
Root^.Right:=NewSheet(tmp)
else
begin
If SignKey(tmp) then
AddSheet(Root^.Left,tmp)
else
AddSheet(Root^.Right,tmp);
end;
end;
end
else
begin {дерево не создано, создаем его}
Root:=NewSheet(tmp);
end;
End;