Процедуры и функции: функция для нахождения среднего арифметического стека

uses
  crt;
  
type
  ZKnote = ^Knote; {Указатель стека}
  Knote = record    {Узел стека}
    Next: ZKnote;   {указатель на следующий узел}
    info: integer; {полезная информация}
  end;
  
  Stapel = record
    Spitze: ZKnote;
  end;
 
var
  S: Stapel; 
  r: integer; {Служит счётчиком для подсчёта записей в стеке}
  f: text; {Файл для хранения базы данных}
  sname: string;  {Название файла}
  sename: string; {Переменная поиска}
  x: integer;
  
  
{-----------------------------------СТЕК----------------------------------------}
{добавление элемента в стек}
procedure Add(var S: Stapel; x: integer);
var
  z: ZKnote;
begin
  new(z); {создаем новый узел}
  z^.info := x;
  z^.next := S.Spitze; {он будет находиться перед вершиной}
  S.Spitze := z;    {Делаем z вершиной стека}
end;
 
{Возвращает true, если стек пуст}
function IsFree(var S: Stapel): boolean;
begin
  IsFree := S.Spitze = nil;
end;
 
{Возвращает число из вершины стека и затем уничтожает вершину}
function Gib(var S: Stapel): integer;
var
  z: ZKnote;
begin
  if IsFree(S) then begin
    exit;   end;    {если стек пуст, возвращаем -1}
  z := S.Spitze^.Next;   {запоминаем следующий узел}
  Gib := S.Spitze^.Info; {вытаскиваем инф-цию из вершины}
  dispose(S.Spitze);   {уничтожаем вершину}
  S.Spitze := z;         {делаем z вершиной}
end;
 
{Уничтожает стек}
procedure Tod(var S: Stapel);
begin
  while not isFree(S) do Gib(S);
end;
 
{Копирует один стек в другой}
procedure CopyStack(var t: Stapel; S: Stapel);
var
  z: ZKnote;
begin
  z := S.Spitze;
  while (z <> nil) do 
  begin
    Add(t, z^.Info);
    z := z^.Next;
  end;  
end;
 
{Печать элементов стека (начиная с головы стека)}
procedure Print(var S: Stapel);
var
  i: integer;
  t: Stapel;
begin
  if IsFree(S) = true then begin
    write('Пусто':50);    
  end
    else
  begin
    i := 1;
    CopyStack(t, S);  
    while not isFree(t) do 
    begin
      x := Gib(t);
      writeln('  ', i:2, '.   ', x);
      inc(i);
    end;
    writeln('Всего элементов в стеке: ', i-1);
    Tod(t);
  end;
end;
 
procedure Zadanie(var S: Stapel);
var
otv: real;
i: integer;
t: Stapel;
begin
if IsFree(S) = true then begin
write('Пусто':50); 
end
else
begin
i := 1;
CopyStack(t, S); 
x:=0;
while not isFree(t) do 
begin
x :=x + Gib(t);
    inc(i);
  end;
    writeln('Всего элементов в стеке: ', i-1);
    writeln;
    writeln('Сумма элементов в стеке: ', x);
    writeln;
    otv:=x/(i-1);
    writeln('Среднее Арифметичское: ',x,'/',i-1,'=',otv);
    Tod(t);
  end;
end;
 
procedure DelElem(var S: Stapel);
var
  t: Stapel;
  i: integer;
  pos: integer;
begin
  if IsFree(S) = true then begin
    textcolor(green);
    writeln(#10'  [ENTER] - выйти в главное меню');
    textcolor(white);
    readln;    
  end
    else
  begin
    write(#10'Введите номер удаляемого элемента [0-Отмена] - '); readln(pos);
    if pos = 0 then
    else
    begin
      CopyStack(t, S);
      Tod(S);
      begin
        for i := 1 to pos - 1 do 
        begin
          add(S, Gib(t));
        end;
        Gib(t);
        while not isFree(t) do add(S, Gib(t));
        write(' - Удалено');
        readln;
      end;
    end;
  end;
end; 
 
 
procedure Search(var S: Stapel; sename: integer);
var
  t: Stapel;
  key: boolean;
begin
  key := false;
  CopyStack(t, S);
  while not isFree(t) do 
  begin
    x := Gib(t);
    if (x = sename) then begin
      writeln('Совпадение: ', x);
      key := true;
    end;
  end;
  if key = false then write('Совпадений не найдено':40);
  Tod(t);
end;
 
 
procedure Search2(var S: Stapel; sename: integer);
var
  t: Stapel;
  key: boolean;
  i: integer;
begin
  i:=1;
  key := false;
  CopyStack(t, S);
  while not isFree(t) do 
  begin
    x := Gib(t);
    if (i = sename) then begin
      writeln('Совпадение: ', x);
      key := true;
    end;
    inc(i);
  end;
  if key = false then write('Совпадений не найдено':40);
  Tod(t);
end;
 
 
 
procedure CreatBase;
begin
  Tod(S);
  write('Введите название новой базы данных: '); readln(sname);
  assign(f,  sname + '.txt');
  rewrite(f);
end;
 
{--------------------------------Сохр. базы-------------------------------------------}
procedure SaveFile;
var t: Stapel;
begin
  if FileExists(sname + '.txt') = false then begin write('База не была загружена!!!') end
  else begin
    assign(f, sname + '.txt');
    rewrite(f);
    CopyStack(t, S);
    while not isFree(t) do 
    begin
      write(f, Gib(t));
    end;
    write('Сохранено');
    close(f);
  end;
end;
 
{--------------------------------загрузка базы-------------------------------------------}
procedure LoadBase;
begin
  Tod(S);
  write('Введите название базы данных: '); readln(sname);
  if FileExists(sname + '.txt') = false then begin write('База не найдена') end
  else begin
    write('База загружена'); 
    assign(f, sname + '.txt');
    reset(f);
    while not Eof(f) do
    begin
      read(f, x);
      Add(S, x);
    end;
    close(f);
  end;
end;
 
 
{-----------------------Ввод базы--------------------------------}
procedure Vvod;
var n, i, j: integer;
usl: char; {Переменная служит для проверки условия, в зависимости от знач. usl зависит будет ли выполнено условие}
begin
  clrscr;
  if FileExists(sname + '.txt') = false then begin{проверка был ли открыт файл, если нет, то выход в гл. меню}
    write('База не была загружена!!!'); readln; 
  end        {проверка, был ли открыт файл}
  else begin
      clrscr;
      write('Введите кол-во добавляемых элементов: '); readln(j);
      for i:=1 to j do
      begin
      write('Введите данные '); readln(x);
      Add(S, x);  {добавление в стек}
      end;
    end;
end;
{---------------------------------МЕНЮ------------------------------------------}
procedure menu_print(item_select: integer);
var
  item: array[1..10] of string;
  i: integer;
begin
  clrscr;
  writeln('==========Главное меню===========');
  item[1] := '·Создать новую базу              ';
  item[2] := '·Загрузить из файла              ';
  item[3] := '·Сохранить в файл                ';
  item[4] := '·Добавить                        ';
  item[5] := '·Удалить                         ';
  item[6] := '·Поиск по значению               ';
  item[7] := '·Поиск по индексу                ';
  item[8] := '·Просмотреть стек                ';
  item[9] := '·Задание                         ';
  item[10] := '·Выход                           ';
  
  for i := 1 to 10 do 
  begin
    if (item_select = i) then begin
      textcolor(black);
      textbackground(white);
      writeln(item[i]);
      textcolor(white);
      textbackground(black);
    end
    else begin
      writeln(item[i]);
    end;  
  end;
  HideCursor;
end;
{-----------------------Графическое Оформление Меню--------------------------
------------------------------Работа Меню-----------------------------------}
procedure menu;
var
  c: char;
  n: integer;
begin
  n := 1;
  menu_print(n);
  c := readkey;
  while c <> #13 do
  begin
    if (c = #0) then
      case ord(readkey) of
        40: 
          if (n = 10) then n := 1
          else inc(n);
        38: 
          if (n = 1) then n := 10
          else dec(n);
      end;
    menu_print(n);
    c := readkey;
  end;
  
  case n of
    1: { Создать базу }
      begin
        clrscr;
        CreatBase;
        Vvod;
        menu;
      end;
    2: { Загругить из файла }
      begin
        clrscr;
        LoadBase;
        readln;
        menu;
      end;
    3: { сохранить в файл }
      begin
        clrscr;
        SaveFile;
        readln;
        menu;
      end; 
    4: { Добавить}
      begin
        Vvod;
        menu;
      end;
    5: { Удалить }
      begin
        clrscr;
        if FileExists(sname + '.txt') = false then begin{проверка был ли открыт файл, если нет, то выход в гл. меню}
          write('База не была загружена!!!'); 
          readln; 
          menu;
        end
        else begin
          clrscr;
          print(S);            
          DelElem(S);          
          menu;
        end;
      end;
    6: { Поиск }
      begin
      var b: integer;
      clrscr;
      writeln('Введите искомый элемент: ');
      readln(b);
        clrscr;
        Search2(S, b);
        readln;
        menu;
      end;
    7: { поиск 2 }
      begin
      var b: integer;
      clrscr;
      writeln('Введите искомый элемент: ');
      readln(b);
        clrscr;
        Search(S, b);
        readln;
        menu;
        end;
    8: { Просмотреть }
      begin
        clrscr;
        print(S);        
        readln;
        menu;
   
      end;
    
    9: begin 
    clrscr;
    writeln('Задание: Найти среднее арифметическое элементов стека.');
    writeln;
    zadanie(S);        
    readln;
    menu;
      end;
    
    10: begin 
    writeln('Вы уверены?':47);
    writeln('Не сохранённые данные будут потеряны':60, #10);
    writeln('[ENTER]-ВЫЙТИ  [ESC]-ВЕРНУТЬСЯ':57);
    c:=readkey;
    if (c = #27) then menu
    else
    begin
    exit;
    end;
    end;
  end;
end;
{------------------------------Работа Меню-----------------------------------
---------------------------------МЕНЮ------------------------------------------}
 
begin
  SetWindowSize(90, 25);
  Menu;
end.

read(f,nn);
    r:=r+nn;k:=k+1;
    if nn<m then begin m:=nn;i:=filepos(f)-1;r:=0;k:=0;end
  end;