Помощь студенту ⁄ Файлы ⁄ лабы на Паскале ⁄ работа с деревьями Паскаль
23 Июня 2017, Пятница 03:04 >>> Качественная веб-разработка <<<	03:04

Главная Файлы Статьи Форум Связь

Меню сайта

Советуем...

ИЗУЧЕНИЕ ЗАКОНОВ РАВНОУСКОРЕННОГО ДВИЖЕНИЯ (Машина Атвуда )

Работа с Турбо Паскалем #1/2

Примеры решений задач по теории вероятностей

Сборник шпор по физике

Опрос

Сотрудничество

Поставьте себе на сайт и сообщите мне

Связь с админом

Файлы

Главная » Файлы » Учебные материалы » лабы на Паскале

работа с деревьями Паскаль

Название: работа с деревьями Паскаль
Категория: лабы на Паскале
Формат файла: *.pas
Размер: 3.5Kb
Просмотров: 4620
Загрузок: 1144
Комментариев: 1
Дата добавления: 01 Июня 2009, 12:27
Теги:готовые лабы, ссылка, деревья, ФУНКЦИИ, Паскаль, процедуры, списки, программирование, информатика, индексы

Поделиться:

Скачать:

Скачать работа с деревьями Паскаль бесплатно и без регистрации

Внимание! Если ссылка не работает, файл не найден или просто возникают какие-либо вопросы, напишите об этом, пожалуйста, мне на почту: xdypx@yandex.ru. В письме достаточно указать ссылку на эту страницу и описание проблемы или свой вопрос.

Описание:
Задание:
Дан текстовый файл с изображением целых чисел, которые переписать в стек St1. Используя стек St2, выбрать только нечетные положительные числа и построить из них сбалансированное дерево.

Исходный код:
Program Lab12;
uses crt;
type Ptr=^Node;
     Node=record
       Dn:Integer;
       Ln,Rn:Ptr;
     end;

Type
TElement=^element;
Element=record
a:integer;
next:TElement;
End;

procedure proverka(filename:string);
var f:text;
Begin
{$I-}
Assign(f,filename);
reset(f);
{$I+}
if ioresult<>0 then Begin textcolor(204); writeln('ERROR FILE!!!'); readln; halt; End
else writeln('fail "',filename,'" otkrit');
End;

procedure printfile(filename:string);
var f:text;
    a:string; b:integer;
Begin
Assign(f,filename);
reset(f);
while not eof(f) do
Begin
   readln(f,a);
   writeln(a);
End;
close(f);
End;

procedure CreateStack(var First:TElement; x:integer);
var Q:TElement;
Begin
new(Q);
Q^.a:=x;
Q^.next:=First;
First:=q;
End;

function PrintStack(var First:TElement; var x:integer):boolean;
var q:TElement;
begin
    if First=nil then PrintStack:=false else
     Begin
      x:=First^.a;
      Q:=First;
      First:=First^.next;
      dispose(q);
      PrintStack:=true;
     End;
end;

function KolEl(var T:ptr):integer;
begin
   if T=nil then kolel:=0
   else kolEL:=kolel(T^.Ln)+1+kolel(T^.Rn);
end;

procedure AddTree(var t:Ptr; D:integer);
begin
   if t=nil then
              begin
               new(t);
               t^.Dn:=D;
               t^.Ln:=nil;
               t^.Rn:=nil;
              end
            else if kolEL(t^.Ln)<kolEL(t^.Rn) then AddTree(t^.Ln,D)
                                          else AddTree(t^.Rn,D);
end;

procedure PrintTree(t:Ptr; H:integer);
const M=6;
var i:integer;
begin
if T<>nil then
   begin
    PrintTree(t^.Ln,H+M);
   for i:=1 to H do write(' ');
    Writeln(t^.Dn);
   PrintTree(t^.Rn,H+M);
   end;
end;

procedure DoneTree(t:Ptr);
begin
   if t<>nil then
              if (t^.Ln=nil) and (t^.Rn=nil) then Dispose(t)
         else
          begin
           DoneTree(t^.Ln); t^.Ln:=nil;
           DoneTree(t^.Rn); t^.Rn:=nil;
           Dispose(t);
          end;
end;

procedure transfer(var First:TElement; filename:string);
var F:text; st,sl:string; l,code,x:integer;
Begin
Assign(f,filename);
reset(f);
st:='';
sl:='';
while not eof(f) do
Begin
   readln(f,st);
    for l:=1 to length(st) do
     Begin
      if st[l]<>' ' then sl:=sl+st[l] else
       Begin
        val(sl,x,code);
        CreateStack(First,x);
        sl:='';
       End;
     End;
End;
close(F);
End;

{===========================MAIN===============================}

var i,z,U:integer;
     t:Ptr;
     First, First2:TElement;

BEGIN
ClrScr;
first:=nil;
first2:=nil;
t:=nil;
i:=0;

writeln('1: BBOD 4uceJl Bpy4HyIO');
writeln('2: B39Tb 4ucJlA u3 qpauJla');
write('-->');
readln(u);
writeln;

if u=1 then
Begin
writeln('vvedite 4isla: ');
   readln(z);
   CreateStack(First,z);
   while z<>0 do
    Begin
     readln(z);
     CreateStack(First,z);
    End;
End;

if u=2 then
Begin
   proverka('g:\in.txt');
   printfile('g:\in.txt');
   transfer(First,'g:\in.txt');
End;
   writeln('sodergimoe pervogo steka: ');
   while PrintStack(First,z)<>false do
    Begin
     write(z,' ');
     if ((i mod 2<>0) and (z>0)) then CreateStack(First2,z);
     inc(i);
    End;
   writeln;
   writeln('sodergimoe vtorogo steka: ');
   while PrintStack(First2,z)<>false do Begin write(z,' '); AddTree(t,z); End;
   writeln;
   writeln('vivod dereva: ');
   writeln;
   PrintTree(t,4);
   DoneTree(t);

readln;
End.

Комментарии:

Всего комментариев: 1

Порядок вывода комментариев: