Задача на стек и дек. Опции

[Krjuger]

В общем задача заключается в том что надо из текстового файла заполнить дек и взять последние "Б" элементов и записать их в стек.Суть вопроса заключается в том какую реализацию выбрать.первый скособ это создать процедуру котора берет элемент из дека и пишет в стек,а вторая уже выполняет первую до выполнения условия(достижение Б),либо сделать лиш одну процедуру,которая делает все сразу.

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;
 

Вот описание стека и дека.Вопрос в том можно ли создать лиш одну буферную переменную или делать через две.каждого типа.

[volvo]

Я уже задавал тебе этот вопрос, ты решил, что лучше создать новую тему, что-ли? Авось не заметят? Как ты дек заполняешь? Можно заполнять его с начала, а потом читать с конца (или наоборот, но чтение и запись - с разных сторон), тогда достаточно просто взять первые B элементов из файла и записать в стек, дек напрочь не нужен. Если дек и пишется и потом читается с одно и той же стороны - то никуда не денешься, придется заполнять дек, а потом брать последние B элементов и переносить их в стек. Дублировать ничего не надо, в худшем случае потребуется один TStack, один TDeque, и одна переменная типа TElem...

Кстати, во избежание проблем, которые у тебя обязательно возникнут с твоим стилем программирования, я бы посоветовал тебе сделать так:

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-ов...

[Krjuger]

Не, стек и дек обязательно должны быть,это принципи и есть суть задания.а запись у меня с конца.

 
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;

Ту тему я подотру,чтобы если кому пригодится,не засорять.потому что темы немножко разные,потом может еще появится третья тема в моем исполнении про деревья.

Добавлено через 19 часов:
Как вам такая реализация?

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; {Љ®«-ў® н«Ґ¬Ґ­в®ў § ЇЁблў Ґ¬лҐ ў б⥪}
   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;

Просьба сильно ботинками не бить)

Добавлено через 6 часов:
Ну так кто нибуть может прокоментировать,прально ли я все делаю??

Добавлено через 30 минут:
процедура создания стека пересмотрена,но все равно не работает.

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;

[volvo]

Нет, конечно... В смысле, неправильно. Сам же сказал, ботинками не бить, вот все и молчат.

НА кой черт ты при создании Стека, когда Дек уже готов, опять создаешь

CurrDeq:= new(PTDeqItem);

? Смысл сего действия от меня ускользает. Тебе надо прочесть крайнее значение из Дека, запомнить его, и удалить Item, его хранивший. А ты вместо этого создаешь новый Item. Зачем?

Что за условие

while CurrDeq<V do

? Я что-то нигде не заметил, что Дек хранит какие-то порядковые целые числа, тебе надо считать, сколько элементов ты уже перенес в Стек, и это число сравнивать с V. Я уж не говорю о том, что сравнивать теплое с мягким (в твоем исполнении Integer c PTDeqItem - да еще и НЕинициализированным) вообще нельзя, у тебя программа даже компилироваться не должна. Так с какой стати она может быть правильной?

[Krjuger]

Могу удивить он компилируется в легкую.Так насчет ошибок щас посмотрим,ты далеко не уходи.

Добавлено через 12 мин.
Ну получилось что то в этом духе

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;

.

Сообщение отредактировано: Krjuger - 18.05.2009 22:42

[volvo]

Могу удивить он компилируется в легкую.

Ты сказки-то будешь внукам рассказывать... Это компилироваться не может по определению: пост №4 - строка №26, что такое TDeq? Нет такого типа, у тебя есть только TDeque... Дальше продолжать? Влегкую у него компилируется... Ты ПОЛНОСТЬЮ программу выложи, а я тебе скажу, компилируется она или нет.

[Krjuger]

Вот полная прога.Теперь, вроде, стек заполняется ,но не печатается.

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; {Љ®«-ў® н«Ґ¬Ґ­в®ў § ЇЁблў Ґ¬лҐ ў б⥪}
   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('<Џгбв®©>'); 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('<Џгбв®©>'); 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.

Ну я надеюсь,хоть кто нибудь ответит,или только волво со мной мучаться будет..

Добавлено через 7 часов:
Ауууу желающие помоч отзовитесь,у меня есть еще задачка на деревья,но пока я с этой недомараюсь,ту спрашивать не стану,ибо слишком жирно будет для меня)

Добавлено через 2 часа:
Так же выношу на суд божий еще одно мое творение, которое нефига не рабоатет.В этот раз выдает ошибку 16 разрядной подсистемы дос,типа процессор обнарушил неизвестную инстукцию

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.

Добавлено через 16 часов:
В общем по поводу первой задачи я ее сделал своими силами и она работает,только почему то она работает не так,как задумывал.Если кому надо:

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; {Љ®«-ў® н«Ґ¬Ґ­в®ў § ЇЁблў Ґ¬лҐ ў б⥪}
   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('<Џгбв®©>'); 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('<Џгбв®©>'); 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.

Да по поводу задачи с деревьями,она еще в силе.Стоит ли создавать отделью тему или мне кто нибудь в этой поможет?
Еще хотелось бы услышать коменрарии к момему способу реализации задачи на стек и дек.

[volvo]

Если кому надо:

Если б работало так, как задумывал, может и пригодилось бы кому. А так кодов на просторах сети - океан, только вот работает правильно очень малая часть...

Еще хотелось бы услышать коменрарии к момему способу реализации задачи на стек и дек.

Трудно ожидать от программы, вываливающейся по RTE 216 корректной работы... То, что твой компилятор не отлавливает эту ошибку времени выполнения, не значит, что ее нет:

Как ты думаешь, куда указывает CurrDeq, и что произойдет, когда ты попробуешь туда обратиться? А все происходит по той же причине: ты только даешь всем советы, как делать правильно, а сам - непонятно что творишь... Где инициализация переменной CurrDeq? Что в ней хранится при входе в процедуру, с учетом того, что она описана локально?

Так же выношу на суд божий еще одно мое творение, которое нефига не рабоатет

Как оно ДОЛЖНО работать - это нам предстоит догадаться? Без задания, без тестового файла данных - это типа квест такой, да?

[Krjuger]

Трудно ожидать от программы, вываливающейся по RTE 216 корректной работы...

Извини,с этим разделом я не знаком.Программа работает,просто когда я делал ,то я ожидал,что при записи в стек моя последовательность чисел опять перевернеться,а получилось что она выводит в том же порядке,что и записана в дек,но о этой причине я уже разобрался.

ты только даешь всем советы, как делать правильно, а сам - непонятно что творишь...

Скажм так советы я даю в той области,которую понимаю.Разве мои советы не несут никакого смысла?и не могут помоч в решении.А эту область, по которой я задаю вопросы,я не очень понимаю,поэтому у меня и глупые ошибки.Поэтому и прошу выносить критику.

Как оно ДОЛЖНО работать - это нам предстоит догадаться?

дерево должно заполниться из файла.

P.S.можно как нить помягче,а то такое ощущение,что ты на меня кричиш))))Что я полный дебил,и вообще нихрена не знаю.


А еще у меня вопрос.Почему,если из процедуры CreateStack я удалю reset(fin); То в этой строке мне выдает Division by zero.

Добавлено через 30 минут:

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; {Љ®«-ў® н«Ґ¬Ґ­в®ў § ЇЁблў Ґ¬лҐ ў б⥪}
   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('<Џгбв®©>'); 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('<Џгбв®©>'); 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); перестала выдаваться ошибка.Просьба обьяснить взаимосвязь.

И еще по поводу дерева..В приведенном ниже коде я пытаюсь создать деверо из информации,берущейся из текстового файла(Stat-пол мужчина-женщина,name-мня человека,Data-дата рождения данного человека)Сначала считываются пол,затем имя и в конце дата.печать чисто формальна,чтобы просто проверить заполнение дерева.

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.

Выдает ошибку 16 разрядной подсистемы дос, процессор NTVDM обнарушил недопустимую инстукцию

Добавлено через 18 часов:
volvo,а мне тоже надо создавать отдельюную тему для дерева,или ты в этой поможеш.А то я вон смотрю,ты на многих ругаешся,когда по несколько задач в одной теме.И почему хоть и изредка,но я получаю ответ только от тебя,остальным впадлу чтоли читать код:)Или у вас есть какое то разделение по "сферам влияния".В общем жду ответов,вроде все твои коментарии я учел,если правильно их понял.Если что поправлясь.

Добавлено через 3 часа:
В общем я немного пересмотрел программу с деревьями и получилось так.Ошибка про подсистему изчезла,но дерево все еще упорно не заполняется.

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.

[volvo]

В общем я немного пересмотрел программу с деревьями и получилось так.Ошибка про подсистему изчезла,но дерево все еще упорно не заполняется.

Ты файл test.txt наконец покажешь или нет? Я ж не могу ползать по твоей программе взад и вперед и подбирать файл так, чтобы дерево успешно из файла было создано, правильно? Присоединил бы файл, который должен быть прочитан - все было бы гораздо проще... А так... Сомневаюсь, что найдется время на подбор тестовых данных, да еще потом и ты скажешь: а у меня не такой файл был, программа все равно не работает. Это мы уже проходили, больше я на это не иду.

[Krjuger]

Хорошо вот текстовый файл и оновленный вариант программы.

Код

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;
ch: char;

Procedure Trash(var ch:char);
begin
  if (ch =#13) or  (ch =#10) or (ch =' ') or (ch =#0) then
  begin
   read(fin,ch);
   Trash(ch);
end;
end;

Procedure ReadStat(var fin: text; ch : char; var str: string);
    begin
        str:='';
    read(fin, ch);
    Trash(ch);
    str:=str+ch;
        repeat
            read(fin, ch);
            if not (ch = ' ') and not (ch=';') then
                str:=str+ch;
        until (ch=' ') or eoln(fin) or (ch=';');
  end;

Procedure ReadFile(var fin: text; ch : char; var str: string);
    begin
        str:='';
        repeat
            read(fin, ch);
            if not (ch = ' ') and not (ch=';') then
                str:=str+ch;
        until (ch=' ') or eoln(fin) or (ch=';');
  end;

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;

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,root^.left)
    else CreateNode(temp,root^.right);

  end;

End;

Procedure CreateTree(var root: PTree;var fin : text);
var
temp : PTree;
begin
new(temp);
while not eof(fin) do
  begin
     readstat(fin,ch,temp^.head.stat);
     readfile(fin,ch,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.

[volvo]

В результате ты хочешь получить вот такой результат:

boris kor bob bob rita ksenia maria
Нажмите любую клавишу для выхода в главное меню

? Тогда расскажу, что надо делать. Если другой - значит, я еще не разобрался, что именно тебе надо...

[Krjuger]

Вообще мне необходимо получить генеагогическое дерево,а уж как выводить его на экран,но тут без разници,потому что это не цель моего задания.А вообще задание звучит,заполнить генеалогическое дерево до 3 поколения данными из файла и вывести на экран,участвовал ли кто нибудь во второй мировой войше,и если такие есть то вывести их на экран. тобиш по суди дожно выводится boris kor bob ksenia rita bob maria

Сообщение отредактировано: Krjuger - 21.05.2009 20:03

[volvo]

тобиш по суди дожно выводится boris kor bob ksenia rita bob maria

Значит, так. Дерево создается неправильно, пересматривай алгоритм создания. Это минус. Плюс - в том, что оно-таки создается, и все итемы, прочитанные из файла в него попадают и благополучно выводятся на печать. Что я поменял (относительно программы из поста №18):

{ 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;

Хотя я бы процедуру CreateTree и AddItem переписал. Зачем создавать и удалять временный буфер, если можно прочесть данные в строки и число, и передавать их в AddItem... Хотя с другой стороны, тогда придется тянуть все параметры по многим подпрограммам, можешь оставить как есть...

Теперь о твоем многострадальном Деке + Стеке. Оно работает, выдает корректный результат. Все было бы хорошо, если бы не утечки памяти. Ты не чистишь память за собой, это плохо, и преподаватели (хорошие преподаватели) знают, как это проверяется. А для себя - это еще хуже. Привыкаешь работать, "не убирая мусор" за собой - потом при программировании под Win получаешь на пустом, казалось бы, месте ошибки типа "не хватает памяти для ресурсов", или что-нибудь в таком роде. А памяти-то гигабайты. И все равно, все очень быстро забрасывается мусором. Привыкай прямо сейчас: память выделил - значит надо вернуть.

[Krjuger]

В общем я почитал пяток другой факов и немного пересмотрел концепцию.пришел я к такому варианту.

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.

Но дерево все равно заполняется в виде пирамиды какой то.(текстовый файл все тот же)

Сообщение отредактировано: Krjuger - 22.05.2009 15:47

[volvo]

Если

текстовый файл все тот же

, то дерево в принципе не будет заполняться, ибо уже при чтении первой записи у тебя будет вылет: { не является целым числом. Точка, все дальнейшее - неправда.

Если чуть-чуть изменить входной файл (продублировать целое число, находящееся в каждой строке), то дерево будет построено, и даже выведено на экран:

Введённые данные:
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;

Что это? То есть, ты сообщаешь, что элемент не найден, и тут же разыменовываешь nil? Интересная концепция...

В общем, пока я не вижу ничего измененного. Ты по-прежнему как партизан молчишь, ЧТО ты за дерево такое особенное хочешь получить (говоришь, что главное - создать дерево, но как только оно у тебя НЕ ТАКОЕ, как ты хочешь - ты тут же говоришь, что оно неправильное). Как правильно - ведомо только тебе, вот и делай сам. Здесь телепатов нет. Что ты хотел, чтоб Паскаль по твоему хотению проник тебе в мысли, узнал вот из этого бреда:

male boris 1995 {корень}
fomale maria 1965 {мать}
male kor 1955 {отец}
fomale ksenia 1915 {бабушка по отцу}
male bob 1912 {дед по отцу}
fomale rita 1915 {бабушка по матери}
male bob 1912 {дед по матери}

, что Ксения - мать Кора, а Боб - отец Марии, и добавил эти итемы в нужные тебе места? Не бывать этому. Ты должен сообщить программе, кто есть кто, и кого куда добавлять. Иначе она всегда будет создавать просто какое-то дерево, которое нельзя назвать генеалогическим.

Извини, я не вижу прогресса у тебя в теме, посему.... Мне надоело переливать из пустого в порожнее. Ты не хочешь видеть того, что тебе говорят. А я не хочу говорить то, чего потом не видят.

[Krjuger]

Если Цитата
текстовый файл все тот же, то дерево в принципе не будет заполняться, ибо уже при чтении первой записи у тебя будет вылет: { не является целым числом. Точка, все дальнейшее - неправда.

Если чуть-чуть изменить входной файл (продублировать целое число, находящееся в каждой строке), то дерево будет построено, и даже выведено на экран:

Введённые данные:male boris 1995 1995male kor 1955 1955male bob 1912 1912male bob 1912 1912fomale maria 1965 1965fomale ksenia 1915 1915fomale rita 1915 1915Отображение в виде дерева:fomale ritafomale kseniafomale mariamale borismale kormale bobmale bob

Да это мой косяк,добавить добавил а упомянуть об этом забыл.

Walk:=Find(Root);
If Walk=Nil Then WriteLn('Элемент не найден.');
WriteLn('Найден элемент:');
Show(Walk^.Inf); WriteLn;

Что это? То есть, ты сообщаешь, что элемент не найден, и тут же разыменовываешь nil? Интересная концепция...

если я правильно понял,то должно быть так

Код

Walk:=Find(Root);
If Walk=Nil Then WriteLn('Элемент не найден.')
else
  begin
    WriteLn('Найден элемент:');
    Show(Walk^.Inf); WriteLn;
  end;

Сообщение отредактировано: Krjuger - 22.05.2009 17:23

[Krjuger]

Вроде я понял о чем ты так усердно пытался мне сказать и в общем добавил указатель на ветку,но тут такая проблема Root^.inf.stat не обновляется и продолжает висеть на значении первого(root) и поэтому все элементы улетают в правую ветвь.

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.

Тьфу извиняюсь эту оплошность я исправил,то вот по тому,как дерево выводится я все эще не мгу понять правильно ли оно собирается,а выглядеть оно должно так.

Код

                                    boris
          kor                   maria
      bob            ksenia       bob              rita  

А выходит с использованием твоей печати

Код

boris
  kor
      bob
      bob
  maria
      ksenia
      rita

Сообщение отредактировано: Krjuger - 22.05.2009 19:10

[Krjuger]

При этом,если сделать в процедуре

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;

и стало выводиться

Код

boris
  kor
      bob
      rita
  maria
      ksenia
      bob

Что уже больше похоже на правду.поэтому либо я не совсем понимаю вывод дерева.либо я хз как эту ошибку исправить.

Код

boris
  kor
      bob
      rita
  maria
      bob
      ksenia

Вот на мой взгляд правильный вывод,каким должен быть,либо Volvo поясти,может я чтото не понимаю.