Программа учёта работы склада

Приложение  2

(текст  программы)

 

program maindatg;

uses crt,graph;

type

ptr=^newtype;

newtype=record

nam:string[20];

nom,dat:string[20];

cen:real;

ocen:real;

p:ptr; 

end;

const line2='╚═════════════╩═══════╩═══════════════╩═══════════════╩════════════════╝';

line1='║             ║       ║               ║               ║                ║';{объявляем переменные} 

var

key:char;

tek,beg,tek1,newp,next:ptr;{массив данных для обработки}

i,n:integer;{счетчики  для элементов массива}

go:boolean; 

procedure menu;

begin

textattr:=16*2+10;

    gotoxy(1,1);

    writeln ('╔════════════════╦════════════════╦══════════════╦═══════════════╦══════════╗');

    writeln ('║F1.Ввод данных  ║ F2. Дополнение ║ F3. Удаление ║ F4. Поиск     ║ F5.Вывод ║');

    writeln ('╠════════════════╬════════════════╬══════════════╬═══════════════╬══════════╣');

    writeln ('║F6.Запись  в файл║ F7.Чтение файла║ F8. Диаграмма║ F9. Сортировка║F10.Выход ║');

    writeln ('╚════════════════╩════════════════╩══════════════╩═══════════════╩══════════╝');

  textattr:=16*0+15;

    gotoxy(1,8);

  writeln('Выберите  пункт меню по клавише');

end; 
 
 

procedure tab;

begin

    gotoxy(1,6);    writeln ('╔══════════════════════════════════════════════════════════════════════╗');

    gotoxy(1,7);    writeln ('║ Склад                                                                ║');

    gotoxy(1,8);    writeln ('╠═════════════╦═══════╦═══════════════╦═══════════════╦════════════════╣');

    gotoxy(1,9);    writeln ('║Наименование ║ Номер ║Дата поставки  ║   Цена        ║Отпускная  цена ║');

    gotoxy(1,10);   writeln ('╠═════════════╬═══════╬═══════════════╬═══════════════╬════════════════╣');end; 
 
 

procedure freemem;

begin

   tek:=beg;

      while tek<>nil do

         begin

            tek:=tek^.p;

               dispose(beg);

                  beg:=tek;

                     end;

                     end; 

procedure testi(txt:string; var wt:integer);{объявляем процедуру контроля значений}

var ws:string;{строка  для чтения проверяемого значения}

wr:integer; {переменная  для перевода строки в число}

wl:integer;{флаг перевода}

begin

repeat {начало цикла  ввода}

write(txt);{выводим  запрос на ввод переменной}

readln(ws);{читаем строку  вместо нее}

val(ws,wr,wl);{переводим  строку в число}

if wl=0 then wt:=wr{возвращаем  значение переменной}

else begin  {выводим  сообщение об ошибке}

textattr:=16*0+4;

writeln('Ошибка: введен  символ вместо числа');

textattr:=16*0+15;

end;

until wl=0; {повторяем  до тех пор пока ввод будет  без ошибки}

end;

procedure Oshibka(SOOBSHENIYE:string);

begin

writeln(SOOBSHENIYE);

writeln('Нажмите Esc и повторите ввод');

repeat

until readkey=#27;

end; 
 

procedure testr(txt:string; var wt:real);{объявляем процедуру контроля значений}

var ws:string;{строка  для чтения проверяемого значения}

flag:boolean;

wr:real; {переменная  для перевода строки в число}

wl:integer;{флаг перевода}

begin

flag:=false;

repeat {начало цикла  ввода}

write(txt);{выводим запрос на ввод переменной}

readln(ws);{читаем строку  вместо нее}

val(ws,wr,wl);{переводим  строку в число}

if wl<>0 then Oshibka('Недопустимый  символ')

else if wr<0 then Oshibka('Недопустимое значение')

else flag:=true;

wt:=wr;{возвращаем  значение переменной}

until flag; {повторяем  до тех пор пока ввод будет  без ошибки}

end; 

procedure vvod;{объявляем  процедуру ввода}

var first:boolean;

    s:string; 

begin

clrscr;

writeln('Ввод данных');writeln;{выводим надпись на экран}

first:=true;

while true do begin{цикл}

write('Введите ФИО  наименование товара или * для  выхода:');readln(s);{считываем строку}

if s='*' then break;

if first then begin{первый элемент или нет}

       new(beg);

         tek:=beg;

         tek^.nam:=s;

write('Введите инвентарный  номер : ');readln(tek^.nom);{считываем и проверяем число}

write('Введите дату  поставки : ');readln(tek^.dat);

testr('Введите цену: ',tek^.cen);

tek^.ocen:=tek^.cen*1.1;

writeln('Цена с  надбавкой 10%:',tek^.ocen:5:2);

        Tek^.p:=nil;

       first:=false;

       end{if first}

       else begin

       If MaxAvail<SizeOf(newtype) then

        begin

       writeln('Не хватает памяти!');

        exit

       end;

       new(newp);

       newp^.nam:=s;

write('Введите инвентарный  номер : ');readln(newp^.nom);{считываем и  проверяем число}

write('Дату поставки: ');readln(newp^.dat);

testr('Введите цену: ',newp^.cen);

newp^.ocen:=newp^.cen*1.1;

writeln('Цена с  надбавкой в 10%:',newp^.ocen:5:2); 

        newp^.p:=nil;

         tek^.p:=newp;

         tek:=newp;

         end;{else fisrt}

end;{конец цикла}

writeln('Ввод даных  завершен. Нажмите любую клавишу');{вывод сообщения}

readkey;{ожидание  нажатия клавиши}

end; 

procedure addarray;{объявляем  процедуру дополнения}

begin

clrscr;

writeln('Дополнение  данных');writeln;{выводим надпись на  экран}

tek:=beg;

if tek=nil then begin writeln('Массив данных пуст! Нажмите любую клавишу...');readkey;exit;end;

{выводим надпись  на экран в случае ошибки  и завершаем работу}

testi('После какой  по номеру записи дополнить  ? :',n);{считываем номер, после которого  дополнять}

if n=0 then exit;

i:=1;

while tek<>nil do

      begin

      if n=i then break;

      tek:=tek^.p;

      inc(i);

      end;

if tek=nil then begin writeln('Запись не найдена, нажмите любую клавишу');readkey;exit;end;

{вставляем новый  элемент в массив}

new(newp);

write('Введите наименование  товара : ');readln(newp^.nam);

write('Введите инвентарный  номер : ');readln(newp^.nom);{считываем и  проверяем число}

write('Введите дату  поставки: ');readln(newp^.dat); 

testr('Введите цену : ',newp^.cen);

newp^.ocen:=newp^.cen*1.1;

n:=n+1;

writeln('Цена с надбавкой 10%:',newp^.ocen:5:2); 

       newp^.p:=tek^.p;

         tek^.p:=newp;

         tek:=newp;

writeln('Данные внесены.  Нажмите любую клавишу');readkey;

end; 

procedure find;{объявляем  процедуру поиска}

var nam:string;{переменная  для хранения наименования, которые  надо найти }

y,r:integer;

begin

clrscr;

writeln('Поиск данных');writeln;{выводим  надпись на экран}

tek:=beg;

if tek=nil then begin writeln('Данные не введены! Нажмите любую клавишу...');readkey;exit;end;

write('Введите наименование  товара, данные о котором следует  найти: ');readln(nam);

r:=0;

tek:=beg;

if tek=nil then begin writeln('Массив данных пуст! Нажмите любую клавишу...');readkey;exit;end;

{выводим надпись  на экран в случае ошибки  и завершаем работу}

while tek<>nil do

      begin

      if tek^.nam=nam then

         begin

writeln('Найдены данные:');{выводим надпись на экран}

inc(y);

r:=r+1;

gotoxy(1,9+r);writeln(line1);

with Tek^ do begin

gotoxy(1,4);tab;

gotoxy(2,9+r);writeln(nam);

gotoxy(15,9+r);writeln(nom);

gotoxy(25,9+r);writeln(dat);

gotoxy(37,9+r);writeln(cen:5:2);

gotoxy(49,9+r);writeln(ocen:5:2);

end;

writeln(line2);

end;

tek:=tek^.p;

end;

if y<1 then writeln('Данные не найдены! Нажмите любую клавишу');

writeln('Нажмите любую клавишу');readkey;

end; 

procedure del;     {процедура удаления}

var n,i:integer;

begin

clrscr;

writeln('Удаление данных');writeln;

tek:=beg;

if tek=nil then begin writeln('Массив данных пуст! Нажмите любую клавишу...');readkey;exit;end;

{выводим надпись  на экран в случае ошибки  и завершаем работу}

testi('Введите номер  записи для удаления:',n);{считываем номер}

if n=0 then exit;

i:=1;

while tek<>nil do

      begin

      if n=i then break;

      tek1:=tek;

      tek:=tek^.p;

      inc(i);

      end;

      n:=n-1;

if tek=nil then begin writeln('Запись не найдена, нажмите любую клавишу');readkey;exit;end;

if tek=beg then beg:=beg^.p else tek1^.p:=tek^.p;

dispose(tek);

writeln('Данные удалены  успешно. Нажмите любую клавишу');readkey;

end; 
 

procedure out;{процедура  вывода данных}

var i:integer;

begin

clrscr;

writeln('Вывод данных');writeln;

tek:=beg;

if tek=nil then

   begin  {если  массив пуст то выход}

   writeln('Ошибка: данные для вывода отсутствуют!  Нажмите любую клавишу');

   readkey;exit;

   end;

tab;

i:=2;