unit spiski;
interface
uses crt, vedomost;
type
point = ^recr;
recr = record
key: string;
skcode:integer;
wkcode:integer;
amount:integer;
price1:real;
next:point;
end;
var
head:point;
firstel:point;
last:point;
kk:recr;
p:point;
procedure EnterElem(kk:recr; p:point); {Ввод элемента записи}
procedure CreateEmpty(var firstel,head:point); {Создание пустого однонаправленного циклического списка с головным элементом}
procedure Addelemfirst(firstel:point); {Добавление элемента в начало циклического списка}
procedure Addelemlast(firstel, last:point); {Добавление элемента в конец циклического списка}
procedure DeleteElem(var firstel:point); {Удаление элемента из списка через уникальный идентификатор}
procedure DeleteSpisok(firstel:point); {Удаление циклического списка}
procedure OutputSpisok(firstel:point); {Вывод списка на экран}
procedure SpisokToFile(firstel:point); {Запись циклического списка в файл}
procedure FileToSpisok(firstel:point); {Вывод списка из типизированного файла}

Implementation

procedure EnterElem(kk:recr; p:point); {Ввод элемента записи}
begin
Write('Введите уникальный ключ-идентификатор записи: '); Readln(kk.key);
Write('Введите код склада: '); Readln(kk.skcode);
Write('Введите код цеха'); Readln(kk.wkcode);
Write('Введите кол-во произведенных деталей: '); Readln(kk.amount);
Write('Введите цену одной детали'); Readln(kk.price1);
kk.key:=p^.key;
kk.skcode:=p^.skcode;
kk.wkcode:=p^.wkcode;
kk.amount:=p^.amount;
kk.price1:=p^.price1;
end;

procedure CreateEmpty(var firstel,head:point); {Создание пустого однонаправленного циклического списка с головным элементом}
begin
if firstel=nil then begin
head^.next:=firstel;
firstel^.next:=head;
end;
end;

procedure Addelemfirst(firstel:point); {Добавление элемента в начало циклического списка}
var g, last:point;
begin
enterelem(kk,g);
  if firstel^.next=head then begin
    g:=firstel;
    firstel^.next:=head;
    head^.next:=firstel;
   end
else begin
    g^.next:=firstel;
    firstel^.next:=g;
    firstel:=last;
    g:=firstel;
    head^.next:=firstel;
end;
Writeln('Элемент успешно добавлен.');
 end;

procedure Addelemlast(firstel, last:point); {Добавление элемента в конец циклического списка}
var g,q: point;
begin
EnterElem(kk,g);
 if firstel^.next=head then begin
        g:=firstel;
        firstel^.next:=head;
        head^.next:=firstel;
        end
  else begin
   q:=firstel;
   while q^.next<>head do q:=q^.next;
   q^.next:=g;
   g:=last;
   last^.next:=head;
   end;
  Writeln('Элемент успешно добавлен.');
end;

procedure DeleteElem(var firstel:point); {Удаление элемента из списка через уникальный идентификатор}
var current, previous: point; var delkey:string;
begin
Write('Введите ключ-идентификатор элемента, который вы хотели бы удалить: '); Readln(delkey);
if firstel^.next=head then begin
Writeln('Ошибка удаления. Список пуст.');
exit;
end;
begin
previous:=last;
current:=firstel;
  while (current^.next<>head) and (current^.key<>delkey) do begin
  previous:= current;
  current:=current^.next;
  end;
 if current^.next=head then begin
 Writeln('Ошибка удаления. Элемента с заданным идентификатором в списке нет.');
 exit;
 end;
 if previous^.next=current then begin
 firstel:=firstel^.next;
 end
 else begin
 previous^.next:=current^.next;
 dispose(current);
 Writeln('Элемент с заданным идентификатором успешно удален.');
 end;
 end;
end;

procedure DeleteSpisok(firstel:point); {Удаление циклического списка}
var deleting:point;
begin
if firstel^.next=head then begin
writeln('Ошибка удаления. Список пуст.');
end;
  while firstel^.next<>head do begin
       deleting:=firstel;
       firstel:=firstel^.next;
       dispose(deleting);
    end;
    Writeln('Список успешно удален.');
end;

procedure OutputSpisok(firstel:point); {Вывод списка на экран}
var cur: point;
begin
if firstel^.next=head then begin
writeln('Список пуст. Чтобы вывести его на экран, для начала заполните его элементами.');
exit;
end;
cur:=firstel;
writeln('Код склада          Код цеха          Кол-во деталей          Цена за единицу');
writeln('-----------------------------------------------------------------------------');
   while cur^.next<>cur do begin
        Writeln(cur^.skcode, '          ', cur^.wkcode, '          ', cur^.amount, '          ', cur^.price1);
        writeln('-----------------------------------------------------------------------------');
        cur:=cur^.next;
       end;
end;

procedure SpisokToFile(firstel:point); {Запись циклического списка в файл}
var tf: text; var name:string; var qu:point;
begin
Write('Введите имя для файла: '); Readln(name);
if fileexists(name) then begin
      Writeln('Ошибка. Файл с таким именем уже существует.');
      exit;
end;
assign(tf, name);
rewrite(tf);
Writeln(tf, 'Код склада          Код цеха          Кол-во деталей          Цена за единицу');
Writeln(tf, '-----------------------------------------------------------------------------');
close(tf);
begin
qu:=firstel;
  while qu^.next<>head do begin
  append(tf);
  Writeln(tf, qu^.skcode, '          ', qu^.wkcode, '          ', qu^.amount, '          ', qu^.price1);
  Writeln(tf, '-----------------------------------------------------------------------------');
  close(tf);
  qu:=qu^.next;
  end;
  Writeln('Список успешно сохранен в файл ', name);
  end;
  end;

  procedure FileToSpisok(firstel:point); {Вывод списка из типизированного файла}
  var hk: fty; var lo: zapis; var namety:string; var un:point; var gc, a:integer;
  begin
  Writeln('Введите имя файла: '); Readln(namety);
  if fileexists(namety) then begin
  assign(hk, namety);
  reset(hk);
  gc:=filesize(hk);
  un:=firstel;
  writeln('Код склада          Код цеха          Кол-во деталей          Цена за единицу');
writeln('-----------------------------------------------------------------------------');
  for a := 0 to gc-1 do begin
  seek(hk, a);
  read(hk, lo);
   un^.skcode:=lo.sk_code;
   un^.wkcode:=lo.wr_code;
   un^.amount:=lo.amount;
   un^.price1:=lo.price1;
   Writeln(un^.skcode, '          ', un^.wkcode, '          ', un^.amount, '          ', un^.price1);
   writeln('-----------------------------------------------------------------------------');
   end;
   end
   else begin
   Writeln('Ошибка. Файла с таким именем не существует.');
   end;
   end;


   End.