Файловый архив студентов. Файловый архив студентов.
1328 вузов, 5500 предметов.
/ Регистрация
FAQ Обратная связь Вопросы и предложения
Добавил:
Опубликованный материал нарушает ваши авторские права? Сообщите нам.
Вуз:
Пермский национальный исследовательский политехнический университет
Предмет:
Информатика
Файл:

TP / Project / PROJECT

.PAS
Скачиваний:
30
Добавлен:
10.12.2013
Размер:
8 Кб
Скачать
☆ 
UNIT Unit36;
{------------------------------------------------------------}
                          INTERFACE
{------------------------------------------------------------}
uses Crt;

const
  Base = 'Base.dat';
  Temp = 'Temp.dat';
  Len = 30;
  HC = Yellow;
  THC = Brown;

type
  Worker = record
    FIO,Address,Tel,Email: string[Len];
  end;

var
  Index: Integer;
  w: Worker;
  f,ft: file of Worker;

procedure Header(s: String);
procedure Menu;
procedure FMenu;
procedure MaxIndex;
procedure Viewing;
procedure Additing;
procedure Editing;
procedure Deleting;
procedure Searching;
function Direct(C: Boolean; D: Char): Boolean;
procedure Sorting;
{------------------------------------------------------------}
                          IMPLEMENTATION
{------------------------------------------------------------}
procedure Header;
begin
  ClrScr;
  TextColor(HC);
  GotoXY(35,1); Write(s);
  GotoXY(1,3);
  TextColor(LightGray);
end;

procedure Menu;
begin
  Header('‹ Ў®а в®а­ п 10');
  WriteLn('1 - Џа®б¬®ва');
  WriteLn('2 - „®Ў ўЁвм');
  WriteLn('3 - €§¬Ґ­Ёвм');
  WriteLn('4 - “¤ «Ёвм');
  WriteLn('5 - Џ®ЁбЄ');
  WriteLn('6 - ‘®авЁа®ўЄ ');
  WriteLn('Esc - ‚л室');
end;

procedure FMenu;
begin
  WriteLn('1 - ”€Ћ');
  WriteLn('2 - Ђ¤аҐб');
  WriteLn('3 - ’Ґ«Ґд®­');
  WriteLn('4 - E-mail');
  WriteLn;
end;

procedure MaxIndex;
var
  w: Worker;
begin
  reset(f);
  Index:= 0;
  while not EOF(f) do begin
    Inc(Index);
    Read(f,w);
  end;
  close(f);
end;

procedure Viewing;
var
  i: Integer;
begin
  MaxIndex;
  reset(f);
  Header('Џа®б¬®ва');
  TextColor(THC);
  WriteLn('N       ” ¬Ё«Ёп €¬п ЋвзҐбвў®              Ђ¤аҐб         ’Ґ«Ґд®­       E-mail');
  TextColor(LightGray);
  WriteLn;
  for i:= 1 to Index do begin
    Read(f,w);
    with w do
      WriteLn(N:2,FIO:Len,Address:Len,Tel:10,Email:10);
  end;
  ReadKey;
  close(f);
end;

procedure Additing;
begin
  repeat
    MaxIndex;
    reset(f);
    Seek(f,Index);
    Header('„®Ў ў«Ґ­ЁҐ');
    with w do begin
      WriteLn(Index+1); N:= Index+1;
      Write('”€Ћ: '); ReadLn(FIO);
      Write('Ђ¤аҐб: '); ReadLn(Address);
      Write('’Ґ«Ґд®­: '); ReadLn(Tel);
      Write('E-mail: '); ReadLn(Email);
    end;
    Write(f,w);
    WriteLn;
    WriteLn('Enter - ¬Ґ­о');
    WriteLn('‹оЎ п ¤агЈ п - Їа®¤®«¦Ёвм');
    close(f);
  until ReadKey = #13;
end;

procedure Editing;
var
  i: Integer;
  wt: Worker;
begin
  repeat
    MaxIndex;
    reset(f);
    Header('€§¬Ґ­Ґ­ЁҐ');
    Write('‚ўҐ¤ЁвҐ ­®¬Ґа § ЇЁбЁ: '); ReadLn(i);
    if not (i in [1..Index]) then begin
      TextColor(Brown);
      WriteLn('ЌҐЇа ўЁ«м­® ўўҐ¤Ґ­ ­®¬Ґа Є ав®зЄЁ!');
      WriteLn('Ћ­ ¤®«¦Ґ­ Ўлвм: 1..',Index);
      TextColor(LightGray);
      ReadKey;
      exit;
    end
    else with w do begin
      Seek(f,i-1); Read(f,wt);
      N:= i;
      Write('”€Ћ: '); ReadLn(FIO);
      if FIO = '0' then FIO:= wt.FIO;
      Write('Ђ¤аҐб: '); ReadLn(Address);
      if Address = 0 then Address:= wt.Address;
      Write('’Ґ«Ґд®­: '); ReadLn(Tel);
      if Tel = 0 then Tel:= wt.Tel;
      Write('E-mail: '); ReadLn(Email);
      if Email = 0 then Email:= wt.Email;
    end;
    Seek(f,i-1); Write(f,w);
    close(f);
    WriteLn;
    WriteLn('Enter - ¬Ґ­о');
    WriteLn('‹оЎ п ¤агЈ п - Їа®¤®«¦Ёвм');
  until ReadKey = #13;
end;

procedure Deleting;
var
  i,n: Integer;
  w: Worker;
begin
  repeat
    WriteLn;
    WriteLn('1 - “¤ «Ёвм ®¤­г § ЇЁбм');
    WriteLn('0 - “¤ «Ёвм ўбҐ § ЇЁбЁ');
    WriteLn;
    case ReadKey of
    '1': begin
      MaxIndex;
      Write('‡ ЇЁбм N: '); ReadLn(n);
      if not (n in [1..Index]) then begin
        TextColor(Brown);
        WriteLn('ЌҐЇа ўЁ«м­® ўўҐ¤Ґ­ ­®¬Ґа Є ав®зЄЁ!');
        WriteLn('Ћ­ ¤®«¦Ґ­ Ўлвм: 1..',Index);
        TextColor(LightGray);
        ReadKey;
        exit;
      end
      else begin
        reset(f); rewrite(ft);
        for i:= 1 to Index do
          if i<n then begin
            Read(f,w);
            Write(ft,w);
          end
          else if i>n then begin
            Read(f,w);
            w.N:= i-1;
            Write(ft,w);
          end
          else Read(f,w);
        close(f); close(ft);
        erase(f);
        rename(ft,Base);
        TextColor(Red);
        WriteLn('„ ­­лҐ г¤ «Ґ­л');
        TextColor(LightGray);
      end;
    end;
    '0': begin
      erase(f);
      rewrite(f);
      TextColor(Red);
      WriteLn('‚ᥠ¤ ­­лҐ г¤ «Ґ­л');
      TextColor(LightGray);
    end;
    end;
    WriteLn;
    WriteLn('Enter - ¬Ґ­о');
    WriteLn('‹оЎ п ¤агЈ п - Їа®¤®«¦Ёвм');
  until ReadKey = #13;
end;

procedure Searching;
var
  i: Integer;
  wf: Worker;
begin
  repeat
    Header('Џ®ЁбЄ');
    FMenu;
    Case ReadKey of
    '1': begin
      Write('”€Ћ: '); ReadLn(wf.FIO);
      reset(f);
      while not EOF(f) do begin
        Read(f,w);
        if Pos(wf.FIO,w.FIO) > 0 then With w Do
          WriteLn(N:2,FIO:Len,Address:Len,Tel:10,Email:10);
        end;
      close(f);
    end;
    '2': begin
      Write('Ђ¤аҐб '); ReadLn(wf.Address);
      reset(f);
      while not EOF(f) do begin
        Read(f,w);
        if Pos(wf.Address,w.Address) > 0 then With w Do
          WriteLn(N:2,FIO:Len,Address:Len,Tel:10,Email:10);
        end;
      close(f);
    end;
    '3': begin
      Write('’Ґ«Ґд®­ '); ReadLn(wf.Tel);
      reset(f);
      while not EOF(f) do begin
        Read(f,w);
        if Pos(wf.Tel,w.Tel) > 0 then With w Do
          WriteLn(N:2,FIO:Len,Address:Len,Tel:10,Email:10);
        end;
      close(f);
    end;
    '4': begin
      Write('E-mail '); ReadLn(wf.Email);
      reset(f);
      while not EOF(f) do begin
        Read(f,w);
        if Pos(wf.Tel,w.Tel) > 0 then With w Do
          WriteLn(N:2,FIO:Len,Address:Len,Tel:10,Email:10);
        end;
      close(f);
    end;
    end;
    WriteLn;
    WriteLn('Enter - ¬Ґ­о');
    WriteLn('‹оЎ п ¤агЈ п - Їа®¤®«¦Ёвм');
  until ReadKey = #13;
end;

function Direct;
begin
  if D = '+' then Direct:= C else Direct:= not C;
end;

procedure Sorting;
var
  Ch,D: Char;
  Direction: Boolean;
  i,j,Nt: Integer;
  w1,w2,wt: Worker;
begin
  repeat
    Header('‘®авЁа®ўЄ ');
    FMenu;
    Ch:= ReadKey;
    Case Ch of
      '1': WriteLn('”€Ћ');
      '2': WriteLn('Љ дҐ¤а ');
      '3': WriteLn('„®«¦­®бвм');
      '4': WriteLn('ђ §ап¤');
      '5': WriteLn('‘в ўЄ ');
      '6': WriteLn('ЋЄ« ¤');
      '7': WriteLn('‡ аЇ« в ');
    end;
    Write('Ќ Їа ў«Ґ­ЁҐ (+,-): '); ReadLn(D);
    MaxIndex;
    reset(f);
    for i:=0 to Index-2 do begin
      Seek(f,i); Read(f,w1);
      wt:= w1; Nt:= w1.N;
      for j:=i to Index-1 do begin
        Seek(f,j); Read(f,w2);
        Case Ch of
          '1': Direction:= Direct(w2.FIO < w1.FIO, D);
          '2': Direction:= Direct(w2.Kafedra < w1.Kafedra, D);
          '3': Direction:= Direct(w2.Dolgnost < w1.Dolgnost, D);
          '4': Direction:= Direct(w2.Razrad < w1.Razrad, D);
          '5': Direction:= Direct(w2.Stavka < w1.Stavka, D);
          '6': Direction:= Direct(w2.Oklad < w1.Oklad, D);
          '7': Direction:= Direct(w2.Zarplata < w1.Zarplata, D);
        end;
        if Direction then begin
          wt:= w2;
          Nt:= j;
        end;
      end;
      Case Ch of
        '1': Direction:= Direct(wt.FIO < w1.FIO, D);
        '2': Direction:= Direct(wt.Kafedra < w1.Kafedra, D);
        '3': Direction:= Direct(wt.Dolgnost < w1.Dolgnost, D);
        '4': Direction:= Direct(wt.Razrad < w1.Razrad, D);
        '5': Direction:= Direct(wt.Stavka < w1.Stavka, D);
        '6': Direction:= Direct(wt.Oklad < w1.Oklad, D);
        '7': Direction:= Direct(wt.Zarplata < w1.Zarplata, D);
      end;
      if Direction then begin
        j:= wt.N;
        wt.N:= w1.N;
        w1.N:= j;
        Seek(f,i); Write(f,wt);
        Seek(f,Nt); Write(f,w1);
      end;
    end;
    close(f);
    Viewing;
    WriteLn;
    WriteLn('Enter - ¬Ґ­о');
    WriteLn('‹оЎ п ¤агЈ п - Їа®¤®«¦Ёвм');
  until ReadKey = #13;
end;

{------------------------------------------------------------}

begin
  assign(f,Base); assign(ft,Temp);
  {$I-}
  reset(f);
  {$I+}
  if IOResult<>0 then rewrite(f);
  close(f);
end.
Соседние файлы в папке Project
Помощь Обратная связь Вопросы и предложения Пользовательское соглашение Политика конфиденциальности