procedure outlist;
begin
curr := first;
if curr = nil then
writeln('Make your choise')
else
begin
writeln;
writeln('Output list: ');
repeat
write(curr^.element, ' ');
curr := curr^.next;
until curr = nil;
end;
writeln;
end;

{vklu4enie elementa v spisok}
procedure insert(var zero: boolean);
begin
if zero = false then
begin
write('Input element: ');
readln(reg);
new(newptr);
newptr^.element := reg;
if first = nil then
begin
if reg = 0 then
begin
zero := true;
first := newptr;
first^.next := nil;
outlist;
end
else
begin
first := newptr;
first^.next := nil;
end;
end
else
begin
if reg <> 0 then
begin
curr := first;
repeat {поиск необходимого элемента}
prev := curr; {переназначение указателей}
curr := curr^.next; {указатель на предыдущий элемент
становится текущим указателем, указатель на текущий
элемент указывает на следующий}
until curr = nil;
prev^.next := newptr;
newptr^.next := curr;
end
else
begin
curr := first;
repeat {поиск необходимого элемента}
prev := curr; {переназначение указателей}
curr := curr^.next; {указатель на предыдущий элемент
становится текущим указателем, указатель на текущий
элемент указывает на следующий}
until curr = nil;
prev^.next := newptr;
newptr^.next := curr;
zero := true;
outlist;
end;
end;
end
else outlist;
end;

{vyvod spiska na ekran}

{procedura MinMax}
procedure MinMax;
var
min, max, i: integer;
begin
if first = nil then
begin
writeln('list is empty! Press ENTER...');
readln;
end
else
begin
curr := first;
min := curr^.element;
max := curr^.element;
repeat {поиск необходимого элемента}
prev := curr; {переназначение указателей}
curr := curr^.next; {указатель на предыдущий элемент
становится текущим указателем, указатель на текущий
элемент указывает на следующий}

if (curr^.element > max) and (curr^.element <> 0) then max := curr^.element
else if (curr^.element < min) and (curr^.element <> 0) then min := curr^.element;
until curr^.next = nil;
writeln('min =',min,' max =', max);
end;
curr := first;
i := 0;
write('Iskomuu ryad : ');
repeat
prev := curr;
curr := curr^.next;
if (curr^.element = min) or (curr^.element = max) then i := i + 1;
if (i = 1) and (curr^.element <> min) and (curr^.element <> max) then
write(' ',curr^.element);
until curr^.next = nil;
writeln;
end;

begin
zero := false;
first := nil;
repeat
writeln('I - input M - MinMax Q - quit');
writeln;
write('input command: ');
readln(ch);
ch := upcase(ch);
case ch of
'I': insert(zero);
'M': MinMax;
end;
until ch = 'Q';
readln;
end.

Добавлено (07.03.2007, 19:49)
---------------------------------------------
только вводи одно число, а потом опять input

procedure outlist;
begin
curr := first;
if curr = nil then
writeln('Make your choise')
else
begin
writeln;
writeln('Output list: ');
repeat
write(curr^.element, ' ');
curr := curr^.next;
until curr = nil;
end;
writeln;
end;

{procedura MinMax}
procedure MinMax(var min, max: word);
var
i: integer;
begin
if first = nil then
begin
writeln('list is empty! Press ENTER...');
readln;
end
else
begin
curr := first;
min := curr^.element;
max := curr^.element;
repeat {поиск необходимого элемента}
prev := curr; {переназначение указателей}
curr := curr^.next; {указатель на предыдущий элемент
становится текущим указателем, указатель на текущий
элемент указывает на следующий}

if (curr^.element > max) and (curr^.element <> 0) then max := curr^.element
else if (curr^.element < min) and (curr^.element <> 0) then min := curr^.element;
until curr^.next = nil;
end;
end;

{подпрога ищет строку между ми и макс эл-тами}
procedure ryadok(var min, max: word);
var
i: word;
begin
writeln('min =',min,' max =', max);
curr := first;
i := 0;
if (curr^.element = min) or (curr^.element = max) then i := i + 1;
if (i = 1) and (curr^.element <> min) and (curr^.element <> max) then
write(' ',curr^.element);
write('Iskomuu ryad : ');
repeat
prev := curr;
curr := curr^.next;
if (curr^.element = min) or (curr^.element = max) then i := i + 1;
if (i = 1) and (curr^.element <> min) and (curr^.element <> max) then
write(' ',curr^.element);
until curr^.next = nil;
writeln;
end;

{vklu4enie elementa v spisok}
procedure insert(var zero: boolean);
begin
if zero = false then
begin
write('Input element: ');
readln(reg);
new(newptr);
newptr^.element := reg;
if first = nil then
begin
if reg = 0 then
begin
zero := true;
first := newptr;
first^.next := nil;
outlist;
MinMax(min, max);
ryadok(min, max);
end
else
begin
first := newptr;
first^.next := nil;
end;
end
else
begin
if reg <> 0 then
begin
curr := first;
repeat {поиск необходимого элемента}
prev := curr; {переназначение указателей}
curr := curr^.next; {указатель на предыдущий элемент
становится текущим указателем, указатель на текущий
элемент указывает на следующий}
until curr = nil;
prev^.next := newptr;
newptr^.next := curr;
end
else
begin
curr := first;
repeat {поиск необходимого элемента}
prev := curr; {переназначение указателей}
curr := curr^.next; {указатель на предыдущий элемент
становится текущим указателем, указатель на текущий
элемент указывает на следующий}
until curr = nil;
prev^.next := newptr;
newptr^.next := curr;
zero := true;
outlist;
MinMax(min, max);
ryadok(min, max);
end;
end;
end
else outlist;
end;

{vyvod spiska na ekran}

begin
zero := false;
first := nil;
repeat
writeln('I - input Q - quit');
writeln;
write('input command: ');
readln(ch);
ch := upcase(ch);
if ch = 'I' then insert(zero);
until ch = 'Q';
end.

Добавлено (07.03.2007, 21:42)
---------------------------------------------
вот это работает

Добавлено (07.03.2007, 21:42)
---------------------------------------------
только нужно ещо защиту наваять)

защита-не главное. и на том спасибо

{$APPTYPE CONSOLE}

uses
SysUtils;

type
ptr = ^zap;
zap = record
element: string;
next: ptr;
end;
var
first: ptr;
ch, ch2: char;
newptr, curr, prev: ptr;
reg: string;

{vklu4enie elementa v spisok}
procedure insert;
begin
write('Input element: ');
readln(reg);
new(newptr);
newptr^.element := reg;
if first = nil then
begin
first := newptr;
first^.next := nil;
end
else
begin
curr := first;
repeat {поиск необходимого элемента}
prev := curr; {переназначение указателей}
curr := curr^.next; {указатель на предыдущий элемент
становится текущим указателем, указатель на текущий
элемент указывает на следующий}
until curr = nil;
prev^.next := newptr;
newptr^.next := curr;
end;
end;

{vyvod spiska na ekran}
procedure outlist;
begin
curr := first;
if curr = nil then
writeln('Make your choise')
else
begin
writeln;
writeln('Output list: ');
repeat
write(curr^.element, ' ');
curr := curr^.next;
until curr = nil;
end;
writeln;
writeln;
end;

{procedura podscheta kolichestva uslov}
procedure Assign;
var
i: integer;
begin
if first = nil then {если список пустой}
begin
writeln('List is empty. Press ENTER...');
readln;
end
else
begin {если список не пустой}
i := 1;
curr := first;
repeat {поиск необходимого элемента}
inc(i);
prev := curr; {переназначение указателей}
curr := curr^.next; {указатель на предыдущий элемент
становится текущим указателем, указатель на текущий
элемент указывает на следующий}
until curr^.next = nil;
end;
writeln('THE number of knots is ',i,' Press ENTER...');
readln;
end;

{poisk nomera yzla}
procedure Search;
var
reg: string;
k: integer;
poisk: boolean;
begin
poisk := false;
if first = nil then {если список пустой}
begin
writeln('List is empty. Press ENTER...');
readln;
end
else begin {если список не пустой}
write('Input element:');
readln(reg); {ввод значения, которое будет извлекаться}
curr := first;
k := 1;
if curr^.element = reg then {если необходимый элемент найден}
begin
poisk := true;
writeln('THE KNOT''S NUMBER IS ',k);
end
else
repeat
inc(k); {поиск необходимого элемента}
prev := curr; {переназначение указателей}
curr := curr^.next; {указатель на предыдущий элемент
становится текущим указателем, указатель на текущий
элемент указывает на следующий}
if curr^.element = reg then {если элемент списка совпадает с заданным}
begin
poisk := true;
writeln('THE KNOT''S NUMBER IS ',k);
end;
until curr^.next = nil;

if poisk = false then
begin {если элемент не найден}
writeln(reg,' not found in list. Press ENTER...');
readln;
end;
end;
end; {конец процедуры delete}

Begin
first := nil;
repeat
outlist;
writeln('B -Build_list A -Assign_number_of_knots' +#10 + #13+
'S -Search_knot''s number Q -quit');
writeln;
write('input command: ');
readln(ch);
ch := upcase(ch);
case ch of
'B': begin
writeln('build list, please:');
repeat
insert;
writeln('continue ? (Y/N)');
readln(ch2);
ch2 := upcase(ch2);
until ch2 = 'N';
end;
'A': Assign;
'S': Search;
end;
until ch = 'Q';
End.

Добавлено (19.03.2007, 21:51)
---------------------------------------------
program Project2;

{$APPTYPE CONSOLE}

uses
SysUtils;

type
ptr = ^zap;
zap = record
element: string;
next: ptr;
end;
var
first: ptr;
ch, ch2: char;
newptr, curr, prev: ptr;
reg: string;

{vklu4enie elementa v spisok}
procedure insert;
begin
write('Input element: ');
readln(reg);
new(newptr);
newptr^.element := reg;
if first = nil then
begin
first := newptr;
first^.next := nil;
end
else
begin
curr := first;
repeat {поиск необходимого элемента}
prev := curr; {переназначение указателей}
curr := curr^.next; {указатель на предыдущий элемент
становится текущим указателем, указатель на текущий
элемент указывает на следующий}
until curr = nil;
prev^.next := newptr;
newptr^.next := curr;
end;
end;

{vyvod spiska na ekran}
procedure outlist;
begin
curr := first;
if curr = nil then
writeln('Make your choise')
else
begin
writeln;
writeln('Output list: ');
repeat
write(curr^.element, ' ');
curr := curr^.next;
until curr = nil;
end;
writeln;
writeln;
end;

{procedura podscheta kolichestva uslov}
procedure Assign;
var
i: integer;
begin
if first = nil then {если список пустой}
begin
writeln('List is empty. Press ENTER...');
readln;
end
else
begin {если список не пустой}
i := 1;
curr := first;
repeat {поиск необходимого элемента}
inc(i);
prev := curr; {переназначение указателей}
curr := curr^.next; {указатель на предыдущий элемент
становится текущим указателем, указатель на текущий
элемент указывает на следующий}
until curr^.next = nil;
end;
writeln('THE number of knots is ',i,' Press ENTER...');
readln;
end;

{poisk nomera yzla}
procedure Search;
var
reg: string;
k: integer;
poisk: boolean;
begin
poisk := false;
if first = nil then {если список пустой}
begin
writeln('List is empty. Press ENTER...');
readln;
end
else begin {если список не пустой}
write('Input element:');
readln(reg); {ввод значения, которое будет извлекаться}
curr := first;
k := 1;
if curr^.element = reg then {если необходимый элемент найден}
begin
poisk := true;
writeln('THE KNOT''S NUMBER IS ',k);
end
else
repeat
inc(k); {поиск необходимого элемента}
prev := curr; {переназначение указателей}
curr := curr^.next; {указатель на предыдущий элемент
становится текущим указателем, указатель на текущий
элемент указывает на следующий}
if curr^.element = reg then {если элемент списка совпадает с заданным}
begin
poisk := true;
writeln('THE KNOT''S NUMBER IS ',k);
end;
until curr^.next = nil;

if poisk = false then
begin {если элемент не найден}
writeln(reg,' not found in list. Press ENTER...');
readln;
end;
end;
end; {конец процедуры delete}

Begin
first := nil;
repeat
outlist;
writeln('B -Build_list A -Assign_number_of_knots' +#10 + #13+
'S -Search_knot''s number Q -quit');
writeln;
write('input command: ');
readln(ch);
ch := upcase(ch);
case ch of
'B': begin
writeln('build list, please:');
repeat
insert;
writeln('continue ? (Y/N)');
readln(ch2);
ch2 := upcase(ch2);
until ch2 = 'N';
end;
'A': Assign;
'S': Search;
end;
until ch = 'Q';
End.

Добавлено (19.03.2007, 21:54)
---------------------------------------------
эта прога вычисляет количество узлов, но в очереди, думаю, что к дереву ты ее сможешь приставить

Добавлено (01.04.2007, 09:59)
---------------------------------------------
эта процедура самоповторяющаяся, цикл не делай

{$APPTYPE CONSOLE}

uses
SysUtils;
type
ptr = ^Node;
Node = record
key: integer;
left, right: ptr;
end;
var
n, j: integer;
root, t: ptr;
reg: integer;
eldepth, depth, i: integer;
ch: char;

function getTree(max, curr: integer): ptr;
var
newNode: ptr;
begin
if curr = max then
newNode := nil
else
begin
new(newNode);
with newNode^ do
begin
i := i + 1;
key := i;
left := getTree(max, curr + 1);
right := getTree(max, curr + 1);
end;
end;
result := newNode;
end;

procedure printTree(t: ptr; h, reg: integer; var depth, res: integer);
var
i: integer;
curr: integer;
begin
if t <> nil then
with t^ do
begin
curr := depth + 1;
printTree(right, h + 2, reg, curr, res);
for i := 1 to h do
write(' ');
if key = reg then
begin
res := curr - 1;
write('[', key, ']');
end
else write(key);
writeln;
printTree(left, h+2, reg, curr, res);
end;
end;

procedure preorder(var j: integer; t: ptr);
begin
if t <> nil then
begin
inc(j);
preorder(j, t^.left);
preorder(j, t^.right);
writeln('uzloff ' , j);
end;
readln;
end;

procedure menu;
begin
writeln('1-Count');
ch := upcase(ch);
case ch of
'1': preorder(j, t);
end;
end;
Begin
write('depth ');
readln(n);
i := 1;
root := getTree(n, 0);
eldepth := 0;
depth := 0;
printTree(root, 0, reg, depth, eldepth);
writeln('p-count');
j := 0;
menu;
readln;
End.

program Project3;

{$APPTYPE CONSOLE}

uses
SysUtils;

type
Ptr = ^Node; {тип}
Node = record {запись}
key: integer; {ключ,а лучше записать как значение листка. Умнее смотрится)}
left, right: Ptr; {левое, правое поддерево}
end;

var
n: integer;
root: Ptr; {корень дерева}
elem_value: integer;
elem_depth,depth,i: integer; {параметры для вывода дерева}

{получение дерева}
function get_tree(max_depth: integer; cur_depth: integer): Ptr;
var
newNode: Ptr; {новый елемент}
begin
if cur_depth = max_depth then
newNode := nil
else
begin
new(newNode);
with newNode^ do begin
inc(i);
key := i;
left := get_tree(max_depth, cur_depth+1);
right := get_tree(max_depth, cur_depth+1);
end;
end;
result := newNode;
end;

{вывод дерева}
procedure PrintTree(t: Ptr; h, elem_value : integer; var depth, res : integer);
var i: integer;
cur_depth: integer;
begin
if t <> nil then
with t^ do
begin
cur_depth := depth+1;
PrintTree(right, h+5, elem_value, cur_depth, res);
for i := 1 to h do write(' ');
if key=elem_value then begin
res := cur_depth-1;
write('[',key,']');
end
else write(key);
writeln;
PrintTree(left, h+5, elem_value, cur_depth, res);
end;
end;

{основная программа}
Begin
Write('Enter a depth of the tree : ');
Readln(n);
i := 1;
root := get_tree(n, 0);
Write('Enter value of the element, which you want to find : ');
readln(elem_value);
elem_depth := 0; depth := 0;
PrintTree(root, 0, elem_value, depth, elem_depth);
Writeln('Your element is on the ',elem_depth,' level under the root.');
readln;
End.