Версия для печати темы

 
Program dog;
uses crt;
type
dog=record
     Naz:string;
     FIO:string;
     Vozr:string;
     Tem:string;
     Ter:integer;
     mes:byte;
end;
const
  punkts:array[1..3,1..7] of string[70]=
  (('Работа с файлом',
    'Формирование ответов на запросы пользователя',
    'Выход','','','',''),
   ('Вывод и редактирование файла',
    'Создание нового файла',
    'Дополнение файла',
    'Назад',
    '','',''),
   ('1.список кличек собак и возраст',
    '2.адреса хозяев,возраст и пол собаки в порядке убывания возраста собаки',
    '3.средний возраст собак',
    '4.график зависимости численности собак в зависимости от возраста',
    '5.круговая диаграмма иллюстрирующая возрастной состав по полу собаки',
    '6.столбиковая диаграмма количества собак каждой породы',
    'Назад'));
  proverkas:array[0..5] of string[50]=
  ('Введите количество записей:',
   'Введите Породу:',
   'Введите Кличку:',
   'Введите Возраст:',
   'Введите Адрес хозяина:',
   'Вветите Пол собаки:');
  proverka_errors:array[0..5] of string[50]=
  ('Ошибка ввода',
   'Ошибка ввода',
   'Ошибка ввода',
   'Ошибка ввода',
   'Ошибка ввода',
   'Ошибка ввода');
  kol_punktov:array[1..3] of integer=(3,4,7);
  {--------------------------------------}

procedure menu(nomer_menu,punkt0:integer);
const
  x1=7;
  y1=15;
  x2=73;
  y2=35;
  x10=5;
  x20=75;
  y10=5;
  y20=40;
var
  w:dog;
  punkt:integer;
  k:char;
  f:file of dog;
{--------------1--------------------}


 procedure spis_grup;
 begin
 clrscr;
 writeln ('список кличек');
 readln;
 menu(2,punkt);
 end;
  {------------2----------------------}
 procedure stoim;
 begin
 clrscr;
 writeln ('в порядке убывания');
 readln;
 menu(2,punkt);
 end;
  {-------------3---------------------}
 procedure obem;
 begin
 clrscr;
 writeln ('средний возраст');
 readln;
 menu(2,punkt);
 end;
  {------------4----------------------}
 procedure grafik;
 begin
 clrscr;
 writeln ('график');
 readln;
 menu(2,punkt);
 end;
  {------------5----------------------}
 procedure krug;
 begin
 clrscr;
 writeln ('круговая диаграмма');
 readln;
 menu(2,punkt);
 end;
  {------------6----------------------}
 procedure stolbik;
 begin
 clrscr;
 writeln ('столбиковая диаграмма');
 readln;
 menu(2,punkt);
 end;
   {-------------------------------------}

  procedure write_punkt(color,punkt:integer);
  begin
    textcolor(color);
    gotoxy((x2-x1+2-length(punkts[nomer_menu,punkt]))div 2,(y2-y1-kol_punktov[nomer_menu])div 2+2*(punkt-1));
    write(punkts[nomer_menu,punkt]);
  end;{of write_punkt}
  {-------------------------------------}
  procedure write_menu(nomer_menu:integer);
  var
    i:integer;
  begin
    textbackground(brown);{color}
    window(1,1,80,50);
    clrscr;
    textbackground(black);
    window(x1,y1,x2,y2);
    clrscr;
    for i:=1 to kol_punktov[nomer_menu] do
      if i=punkt0 then write_punkt(red,i) else write_punkt(yellow,i);
  end;
  {of write_menu}
  {-------------------------------------}
  procedure write_text(text:string;y,color:integer);
  begin
    textcolor(color);
    gotoxy((x2-x1-length(text)) div 2,y);
    writeln(text);
  end;
  {of write text}
  {-------------------------------------}
  function proverka(nomer:integer):string;
  const
    simbols:set of char=['А'..'Я','а'..'я','.',' ','-'];
  var
    s:string;
    n,error,i:integer;
    flag:boolean;
  begin
    flag:=true;
    repeat
      clrscr;
      if not(flag) then write_text(proverka_errors[nomer],14,20);
      write_text(proverkas[nomer],7,yellow);
      gotoxy(10,10);
      readln(s);
      val(s,n,error);
      flag:=true;
      case nomer of
        0:if (error=0)and(n>0) then flag:=true else flag:=false;
        1:for i:=1 to length(s)do
            if not(s[i] in simbols) then flag:=false;
        2:for i:=1 to length(s) do
            if not(s[i] in simbols) then flag:=false;
        3:if (s='д')or(s='ю')or(s='в') then flag:=true else flag:=false;
        4:if (s='х')or(s='п')or(s='и') then flag:=true else flag:=false;
        5:if (error=0)and(n>0) then flag:=true else flag:=false;
        6:if (error=0)and(n>0)and(n<=12) then flag:=true else flag:=false;
      end;
    until flag;
    proverka:=s;
  end;
  {of proverka}
  procedure open_file;
  begin
    {$I-}
    assign(f,'rgz_2.dat');
    reset(f);
    if ioresult=2 then
    begin
      assign(f,'rgz_2.dat');
      rewrite(f);
    end;
    {$I+}
  end;
  {of open_file}
  procedure ramka(nomer:integer);
  var
    s:string;
  begin
    textbackground(brown);
    window(1,1,80,50);
    clrscr;
    if nomer=1 then
    begin
      textcolor(4);
      s:='Вверх/вниз-выбор записи';
      gotoxy(40-length(s) div 2,43);
      writeln(s);
      s:='Нажмите ENTER, чтобы изменить запись';
      gotoxy(40-length(s) div 2,45);
      writeln(s);
      s:='ESC-выход';
      gotoxy(40-length(s) div 2,47);
      writeln(s);
      textcolor(yellow);
    end;
    textbackground(black);
    window(x10,y10,x20,y20);
    clrscr;
    window(x10+1,y10+1,x20-1,y20-1);
    clrscr;
  end;
  procedure vivod(file_p:integer);
  var
    i:integer;
    w:dog;
  begin
    window(x10+1,y10+1,x20-1,y20-1);
    clrscr;
    seek(f,file_p);
    for i:=1 to y20-y10-2 do
    begin
      if eof(f) then break;
      read(f,w);
        gotoxy(1,i);
      writeln(w.naz);
        gotoxy(10,i);
      writeln(w.fio);
        gotoxy(20,i);
      writeln(w.vozr);
        gotoxy(30,i);
      writeln(w.tem);
        gotoxy(40,i);
      writeln(w.ter);
        gotoxy(50,i);
      writeln(w.mes);
    end;
  end;
  {of vivod}
  procedure dop_file(file_p:integer);
  var
    n,error:integer;
    w1:dog;
  begin
    w.fio:=proverka(1);
    w.naz:=proverka(2);
    w.vozr:=proverka(3);
    w.tem:=proverka(4);
    val(proverka(5),n,error);
    w.ter:=n;
    val(proverka(6),n,error);
    w.mes:=n;
    seek(f,file_p);
    write(f,w);
  end;
  {of dop_file}
  procedure out_file;
  var
    p,file_p,file_p_0:integer;
  begin
    open_file;
    ramka(1);
    if filesize(f)<=y20-y10 then
    begin
      file_p:=filesize(f);
      p:=file_p;
    end
    else
    begin
      file_p:=filesize(f)-(y20-y10-2);
      p:=y20-y10-1;
    end;
    vivod(file_p);
    file_p:=filesize(f);
    gotoxy(1,p);
    repeat
      k:=readkey;
      file_p_0:=file_p;
      case k of
        #32:menu(2,1);
        #13:begin
              dop_file(file_p);
              out_file;
            end;
        #72:begin
              if p>1 then p:=p-1;
              if file_p>0 then file_p:=file_p-1;
              if (p=1)and(file_p<>file_p_0) then vivod(file_p);
              gotoxy(1,p);
            end;
        #80:begin
              if (p<(y20-y10-1))and(p<filesize(f)) then p:=p+1;
              if file_p<filesize(f) then file_p:=file_p+1;
              if (p>=(y20-y10-1))and(file_p<>file_p_0) then vivod(file_p-(y20-y10-2));
              gotoxy(1,p);
            end;
        #27:halt;
      end;
    until k=#27;
  end;
  {of out_file}
  procedure new_file;
  begin
    assign(f,'rgz_2.dat');
    rewrite(f);
    close(f);
    menu(2,2);
  end;
  {of new_file}
begin
  write_menu(nomer_menu);
  punkt:=punkt0;
  repeat
    k:=readkey;
    write_punkt(yellow,punkt);
    case k of
      #72:if punkt=1 then punkt:=kol_punktov[nomer_menu]
          else punkt:=punkt-1;
      #80:if punkt=kol_punktov[nomer_menu] then punkt:=1
          else punkt:=punkt+1;
      #13:case nomer_menu of
            1:case punkt of
                1:menu(2,1);
                2:menu(3,1);
                3:halt;
              end;
            2:case punkt of
                1:out_file;
                2:new_file;
                3:begin
                    open_file;
                    dop_file(filesize(f));
                    close(f);
                    out_file;
                  end;
                4:menu(1,1);
              end;
            3:case punkt of
                1:spis_grup;
                2:stoim;
                3:obem;
                4:grafik;
                5:krug;
                6:stolbik;
                7:menu(1,2);
              end;
          end;
    end;
    write_punkt(red,punkt);
  until k=#13;
end;
{of menu}
begin
  textmode(C80 + Font8x8);
  menu(1,1);
end.