Разработать программу, создающую файл записей, содержащий список друзей

{Разработать программу, создающую файл записей, содержащий
 информацию о проживающих в гостиничном комплексе (фамилия,
 занимаемый номер, дата приезда, дата отъезда). Реализовать
 процедуры добавления новых записей, поиска по фамилии, 
 вывода информации, начиная с конкреной даты, удаление записей,
 сортировку файла по возрастанию номеров апартаментов.}
 
Program TipFile;
Uses Crt;
Const
  FLOOR=5;              {число этажей в гостинице}
  APPART=20;            {число номеров на этаже}
  TEX_3='   |     Фамилия     |Занимаемый номер|Дата приезда|Дата отъезда';
Type
  TData=Record
         gg,mm,dd:Byte;
       End;
  TZap=Record
         fam:string[10]; {фамилия проживающего}
         nomer:Word;     {занимаемый номер}
         data_pr_gg,
         data_pr_mm,
         data_pr_dd,     {дата приезда}
         data_ot_gg,
         data_ot_mm,
         data_ot_dd:Byte;{дата отъезда}
       End;
  TFZ= File of TZap;
 
{Проверка существования файла с указанным именем}
Procedure Exist(Var nameFT:String);
Var
  ch:Char;
Begin
  If FileExists(nameFT)
  Then Begin
         WriteLn('Такой файл уже есть!');
         Write('Уничтожить его? Y/N -> ');
         ReadLn(ch);
         If ch In ['N', 'n']
         Then Repeat
                WriteLn('Введите новое имя файла:');
                ReadLn(nameFT);
                If FileExists(nameFT)
                Then Begin
                       WriteLn('Такой файл уже есть!');
                       Write('Уничтожить его? Y/N -> ');
                       ReadLn(ch);
                     End;
              Until(NOT FileExists(nameFT))Or(ch In ['Y', 'y', 'Н', 'н']);   
      End;
End;
 
{создание нового файла}
Procedure SozdFZ(Var fname:String);
Var
   z:TZap;
   i:1..FLOOR;
   j:1..APPART;
 otv:CHAR;
  fz:TFZ;
Begin
  Exist(fname);
  Assign(fz,fname);
  ReWrite(fz);
  Repeat
    ClrScr;
    WriteLn('Добавляем новую запись:');
    WriteLn;
    With z
      Do Begin
           Write(' фамилия проживающего.'); ReadLn(fam);
           Write(' занимаемый номер.....'); ReadLn(nomer);
           i:=z.nomer Div 100;
           j:=z.nomer-i*100;
           If(i<1)Or(i>FLOOR)Or(j<1)Or(j>APPART)
           Then Begin
                  WriteLn('Ошибка в указании номера');
                  WriteLn('Повторите ввод после нажатия ENTER');
                  ReadLn; Continue;
                End;
           Write('дата приезда:  год.(гг)..');ReadLn(data_pr_gg);
           Write('             месяц.(мм)..');ReadLn(data_pr_mm);
           Write('              день.(дд)..');ReadLn(data_pr_dd);
           Write('дата отъезда:  год.(гг)..');ReadLn(data_ot_gg);
           Write('             месяц.(мм)..');ReadLn(data_ot_mm);
           Write('              день.(дд)..');ReadLn(data_ot_dd);
           If (data_pr_gg>data_ot_gg)Or
             ((data_pr_gg=data_ot_gg)And(data_pr_mm>data_ot_mm))Or
             ((data_pr_gg=data_ot_gg)And(data_pr_mm=data_ot_mm)And
              (data_pr_dd>data_ot_dd))
           Then Begin
                  WriteLn('Ошибка в наборе дат.');
                  WriteLn('Повторите ввод после нажатия ENTER');
                  ReadLn; Continue;
                End;
         End;
      Write(fz,z);
      Write('Продолжать ввод?..y/n..'); ReadLn(otv);
    Until Not (otv In ['Y','y', 'Н', 'н']);
    Close(fz);
End;
 
{Сортировка файла по вторичному ключу (по занятым номерам апартаментов)}
Procedure Sort_Fz(fname:String);
Var
  z1,z2:TZap;
     fp:Boolean;
  i,nom:Integer;
     fz:TFZ;
Begin
  If NOT FileExists(fname)
  Then Begin
         WriteLn('Файл ', fname, ' не существует, сортировка невозможна');
         Exit;
       End;
  Assign(fz,fname);
  Reset(fz);
  nom:=FileSize(fz)-1;
  Repeat
    fp:=FALSE;
    For i:=0
    To nom-1
    Do Begin
         Seek(fz,i);
         Read(fz,z1,z2);
         If z1.nomer>z2.nomer
         Then Begin
                Seek(fz,FilePos(fz)-2);
                Write(fz,z2,z1);
                fp:=true;
              End;
         End;
  Until Not fp;
  Close(fz);
End;
 
{Печать существующих записей, начиная с указанной даты}
Procedure ProsmFz(fname:String; den:TData);
Var
  z:TZap;
  fz:TFZ;
Begin
  If NOT FileExists(fname)
  Then Begin
         WriteLn('Файл ', fname, ' не существует, просмотр невозможен');
         Exit;
       End;
  ClrScr;
  Assign(fz,fname);
  Reset(fz);
  Write('С ');
  If den.dd<10 Then Write('0');
  Write(den.dd,'.');
  If den.mm<10 Then Write('0');
  Write(den.mm,'.');
  If den.gg<10 Then Write('0');
  WriteLn(den.gg,' в гостинице проживали:');
  WriteLn;
  WriteLn('   ',TEX_3);
 
  WHILE Not EOF(fz)
    Do Begin
         Read(fz,z);
         With z Do
           Begin
             If(den.gg<data_ot_gg)Or
               ((den.gg=data_ot_gg)And(den.mm<data_ot_mm))Or
               ((den.gg=data_ot_gg)And(den.mm=data_ot_mm)And(den.dd<=data_ot_dd))
             Then Begin
                    Write('      | ');
                    Write(z.fam:15,' ');
                    Write('|       ',z.nomer);
                    Write('      |  ');
                    If data_pr_dd<10 Then Write('0');
                    Write(data_pr_dd,'.');
                    If data_pr_mm<10 Then Write('0');
                    Write(data_pr_mm,'.');
                    If data_pr_gg<10 Then Write('0');
                    Write(data_pr_gg);
                    Write('  |  ');
                    If data_ot_dd<10 Then Write('0');
                    Write(data_ot_dd,'.');
                    If data_ot_mm<10 Then Write('0');
                    Write(data_ot_mm,'.');
                    If data_ot_gg<10 Then Write('0');
                    Write(data_ot_gg);
                  End;
           End;
         WriteLn;
       End;
  WriteLn;
  WriteLn('Для продолжения нажмите ENTER');
  ReadLn;
  ClrScr;
  Close(fz);
End;
 
{Процедура добавления новых записей в существующий файл}
Procedure Dobavl(fname:String);
Var
    z:TZap;
  otv:CHAR;
    i:1..FLOOR;
    j:1..APPART;
   fz:TFZ;
Begin
  Assign(fz,fname);
  If NOT FileExists(fname)
  Then ReWrite(fz)
  Else Begin
         Reset(fz);
         Seek(fz,FileSize(fz));
       End;  
  Repeat
    ClrScr;
    WriteLn('Добавление записей в файл ', fname, ':'); WriteLn;
    With z
      Do Begin
           Write('фамилия проживающего..'); ReadLn(fam);
           Write('занимаемый номер......'); ReadLn(nomer);
           i:=z.nomer Div 100;
           j:=z.nomer-i*100;
           If(i<1)Or(i>FLOOR)Or(j<1)Or(j>APPART)
           Then Begin
                  WriteLn('Ошибка в указании номера');
                  WriteLn('Повторите ввод после нажатия ENTER');
                  ReadLn; Continue;
                End;
           Write('дата приезда:  год.(гг)..');ReadLn(data_pr_gg);
           Write('             месяц.(мм)..');ReadLn(data_pr_mm);
           Write('              день.(дд)..');ReadLn(data_pr_dd);
           Write('дата отъезда:  год.(гг)..');ReadLn(data_ot_gg);
           Write('             месяц.(мм)..');ReadLn(data_ot_mm);
           Write('              день.(дд)..');ReadLn(data_ot_dd);
           If(data_pr_gg>data_ot_gg)Or
             ((data_pr_gg=data_ot_gg)And(data_pr_mm>data_ot_mm))Or
             ((data_pr_gg=data_ot_gg)And(data_pr_mm=data_ot_mm)And
              (data_pr_dd>data_ot_dd))
           Then Begin
                  WriteLn('Ошибка в наборе дат.');
                  WriteLn('Повторите ввод после нажатия ENTER');
                  ReadLn; Continue;
                End;
         End;
    Write(fz,z);
    Write('Продолжаем ввод?..y/n..'); ReadLn(otv);
  Until Not (otv In ['Y','y', 'Н', 'н']);
  Close(fz);
End;
 
{Поиск проживающего по фамилии}
Procedure Poisk_Fam(fname:String; famil:String[10]);
Var
    z:TZap;
   fz:TFZ;
Begin
  If NOT FileExists(fname)
  Then Begin
         WriteLn('Файл ', fname, ' не существует, поиск записей невозможен');
         Exit;
       End;
  ClrScr;
  WriteLn('С фамилией ',famil,' в гостинице проживали:');
  WriteLn;
  WriteLn('   ',TEX_3);
  Assign(fz,fname); Reset(fz);
  While Not EOF(fz)
  Do Begin
       Read(fz,z);
       If z.fam=famil
       Then Begin
              With z Do
              Begin
                Write('      | ');
                Write(fam:15,' ');
                Write('|       ',nomer);
                Write('      |  ');
                If data_pr_dd<10 Then Write('0');
                Write(data_pr_dd,'.');
                If data_pr_mm<10 Then Write('0');
                Write(data_pr_mm,'.');
                If data_pr_gg<10 Then Write('0');
                Write(data_pr_gg);
                Write('  |  ');
                If data_ot_dd<10 Then Write('0');
                Write(data_ot_dd,'.');
                If data_ot_mm<10 Then Write('0');
                Write(data_ot_mm,'.');
                If data_ot_gg<10 Then Write('0');
                Write(data_ot_gg);
              End;
              WriteLn;
            End;
     End;
  WriteLn;
  WriteLn('Для продолжения нажмите ENTER');
  ReadLn;
  ClrScr;
  Close(fz);
End;
 
{Удаление записей}
Procedure Udal_Zap(fname:String);
Var
      z:TZap;
    otv:CHAR;
  nomer:Word;
      i:1..FLOOR;
      j:1..APPART;
 fz,fpr:TFZ;
     pr:Boolean;
Begin
  If NOT FileExists(fname)
  Then Begin
         WriteLn('Файл ', fname, ' не существует, удаление записей невозможно');
         Exit;
       End;
  ClrScr;
  Repeat
    Assign(fz,fname); Reset(fz);
    WriteLn('Введите номер апартаментов для поиска:');
    ReadLn(nomer);
    i:=nomer Div 100;
    j:=nomer-i*100;
    If(i<1)Or(i>FLOOR)Or(j<1)Or(j>APPART)
    Then Begin
           WriteLn('Ошибка в указании номера');
           WriteLn('Повторите ввод после нажатия ENTER');
           ReadLn; {Continue;}
         End;
    Assign(fpr,'h:\\pr.dat'); Rewrite(fpr);
    pr:=TRUE;
    While NOT EOF(fz)
    DO Begin
         Read(fz,z);
         If z.nomer=nomer
         Then Begin
                pr:=FALSE;
                WriteLn('Производится удаление ');
                WriteLn('записи для апартаментов ',nomer);
                Write('Подтвердите удаление y/n ->');
                ReadLn(otv);
                If(otv In['Y','y', 'Н', 'н'])
                Then Continue;
              End;
         Write(fpr,z);
       End;  
    Close(fz);
    Erase(fz);
    Close(fpr);
    Rename(fpr,fname);
    WriteLn('Корректировка закончена.');
    If pr Then WriteLn('Запись не обнаружена.');
    Write('Продолжить корректировку?.y/n.'); ReadLn(otv);
  Until Not (otv In ['Y','y', 'Н', 'н']);
End;
 
{Основная программа}
Var
     fname:String;
       otv:Byte;
       den:TData;
        ch:Char;
  familiya:String[10];
 
Begin
  Repeat
    ClrScr;
    WriteLn('Выбор операции:1 - создание файла');
    WriteLn('               2 - поиск записей');
    WriteLn('               3 - добавление записи');
    WriteLn('               4 - удаление записи');
    WriteLn('               5 - просмотр записей');
    WriteLn('               6 - завершение работы');
    ReadLn(otv);
    Case otv Of
      1:Begin
          ClrScr;
          Write('Введите имя создаваемого файла: ');
          ReadLn(fname);
          SozdFZ(fname);
        End;
      2:Begin
          ClrScr;
          Write('Введите фамилию для поиска..');
          ReadLn(familiya);
          Write('Введите имя существующего файла..');
          ReadLn(fname);
          Poisk_fam(fname,familiya);
        End;
      3:Begin
          ClrScr;
          WriteLn('Добавление новой записи.');
          Write('Введите имя существующего файла..');
          ReadLn(fname);
          Dobavl(fname);
        End;
      4:Begin
          ClrScr;
          WriteLn('Удаление записи.');
          Write('Введите имя существующего файла..');
          ReadLn(fname);
          Udal_Zap(fname);
        End;
      5:Begin
          ClrScr;
          Write('Введите имя существующего файла..');
          ReadLn(fname);
          WriteLn('Введите дату начала просмотра');
          Write('  год.(гг)..');  ReadLn(den.gg);
          Write('месяц.(мм)..');  ReadLn(den.mm);
          Write(' день.(дд)..');  ReadLn(den.dd);
          WriteLn('Нужна предварительная сортировка');
          Write('записей по номерам апартаметов? y/n..');
          ReadLn(ch);
          If ch In['Y','y', 'Н', 'н']
          Then Sort_Fz(fname);
          ProsmFz(fname,den);
        End;
      6:Begin
          WriteLn('Работа заканчивается?');
          Write('y/n..');
          ReadLn(ch);
          If ch In['Y','y', 'Н', 'н']
          Then Exit;
        End;
    End;
  Until otv=6;
End.