Текст программы Kurs.pas

program Delphins;

uses crt,tips;

var names,namer:string[10];

  key,kr:char;

  tek,i,j,izm:integer;

  exist,vfile,issor:boolean;

  nast:pered;

  temr,tt1,tt2,tt3,tt4:cc;

  outf:file of tabl2;

procedure menus(m:pered;max:byte);  {Вывод меню}

begin

clrscr;

  For i:=1 to max do begin

    if i=1 then begin

     textcolor(1); gotoxy(9,2); write(m.st[i]);

    end

    else begin

      if i=2 then textcolor(9)

      else textcolor(3);

      gotoxy(8,i+3);write(m.st[i]);

    end;

  end;

end;

procedure krutis;  {Звездочка рядом с активным элементом}

begin

  textcolor(14);

  if kr='/' then kr:='-'

    else if kr='-' then kr:='\'

      else if kr='\' then kr:='|'

        else kr:='/';

  gotoxy(6,tek+3);write(kr);

  textcolor(3);

end;

procedure ramka(ch:char); {перемещение указателя}

begin

  gotoxy(6,tek+3);Writeln(' ');

  textcolor(3);gotoxy(8,tek+3);write(nast.st[tek]);

  if ch='+' then tek:=tek+1

  else tek:=tek-1;

  if tek=1 then tek:=nast.m

  else if tek=nast.m+1 then tek:=2;

  key:=#0;

  textcolor(9);gotoxy(8,tek+3);write(nast.st[tek]);

  krutis;

end;

procedure tabl11(t:integer;rab:cc); {Вывод таблицы в файл}

var ooutf:text;

tem:cc;

begin

clrscr;

   writeln('Введите имя файла');

   readln(names);

   assign(ooutf,names);

   rewrite(ooutf);

   writeln(ooutf,menu2.st[t]);

   writeln(ooutf,'+--------------------------------------------------------------------------+');

   writeln(ooutf,'¦',mm[t-1,1]:14,'¦',mm[t-1,2]:14,'¦',mm[t-1,3]:14,'¦',mm[t-1,4]:14,'¦',mm[t-1,5]:14,'¦');

   writeln(ooutf,'+--------------+--------------+--------------+--------------+--------------¦');

   tem:=rab;

   while tem<>nil do

   begin

     writeln(ooutf,'¦',tem^.tabl.t1:14,'¦',tem^.tabl.t2:14,'¦',tem^.tabl.t3:14,'¦',tem^.tabl.t4:14,

     '¦',tem^.tabl.t5:14,'¦');

     tem:=tem^.sled;

   end;

   writeln(ooutf,'+--------------------------------------------------------------------------+');

   close(ooutf);

   nast:=menu1;

   menus(nast,nast.m);

   tek:=2;

end;

procedure tabl1(t:integer;rab:cc;yd:boolean); {Вывод таблицы на экран}

var tem:cc;

begin

clrscr;

   writeln(menu2.st[t]);

   writeln('+--------------------------------------------------------------------------+');

   writeln('¦',mm[t-1,1]:14,'¦',mm[t-1,2]:14,'¦',mm[t-1,3]:14,'¦',mm[t-1,4]:14,'¦',mm[t-1,5]:14,'¦');

   writeln('+--------------+--------------+--------------+--------------+--------------¦');

   tem:=rab;

   while tem<>nil do

   begin

     writeln('¦',tem^.tabl.t1:14,'¦',tem^.tabl.t2:14,'¦',tem^.tabl.t3:14,'¦',tem^.tabl.t4:14,

     '¦',tem^.tabl.t5:14,'¦');

     tem:=tem^.sled;

   end;

   writeln('+--------------------------------------------------------------------------+');

   if not yd then begin

     readln;

     nast:=menu1;

     menus(nast,nast.m);

     tek:=2;

   end;

   yd:=false;

end;

procedure sort(iz,t:integer; var rab:cc); {Сортировка по полю}

var po:integer;

  te1,te2,tem:cc;

  str1,str2:string;

  ttrtt:tabl2;

begin

  tabl1(tek,rab,true);

  writeln('Введите номер столбца по которому надо отсортировать данные');

  readln(po);

  te1:=rab;

  while te1<>nil do begin

    te2:=te1^.sled;

    while te2<>nil do begin

      case po of

        1:begin str1:=te1^.tabl.t1; str2:=te2^.tabl.t1; end;

        2:begin str1:=te1^.tabl.t2; str2:=te2^.tabl.t2; end;

        3:begin str1:=te1^.tabl.t3; str2:=te2^.tabl.t3; end;

        4:begin str1:=te1^.tabl.t4; str2:=te2^.tabl.t4; end;

        5:begin str1:=te1^.tabl.t5; str2:=te2^.tabl.t5; end;

      end;

      if str1>str2 then begin

        ttrtt:=te1^.tabl;

        te1^.tabl:=te2^.tabl;

        te2^.tabl:=ttrtt;

      end;

    te2:=te2^.sled;

   end;

  te1:=te1^.sled;

  end;

  tabl1(tek,rab,false);

end;

procedure obrabotka(iz,t:integer; var rab:cc); {Обработка записей}

var dlud:string;

  bis:boolean;

  tems,temr,tem:cc;

begin

  clrscr;

  if iz=1 then begin          {добавление записи}

     if rab<>nil then begin

       tem:=rab;

       while tem^.sled<>nil do tem:=tem^.sled;

       new(tem^.sled);

       tem:=tem^.sled;

     end

     else begin

       new(rab);

       tem:=rab;

     end;

      writeln(mm[t,1]);readln(tem^.tabl.t1);

      writeln(mm[t,2]);readln(tem^.tabl.t2);

      writeln(mm[t,3]);readln(tem^.tabl.t3);

      writeln(mm[t,4]);readln(tem^.tabl.t4);

      writeln(mm[t,5]);readln(tem^.tabl.t5);

      tem^.sled:=nil;

      tem:=rab;

      izm:=0;

      nast:=menu1;

      menus(nast,nast.m);

      tek:=2; iz:=0;

    end

  else if iz=2 then begin       {Удаление записи}

  tems:=rab;

  tabl1(tek,rab,true);

  writeln('Введите уникальный номер'); readln(dlud);

  bis:=true;

  if rab^.tabl.t1 = dlud then begin

    rab:=rab^.sled;

    bis:=false;

  end

    else begin

      while tems<>nil do begin

        if tems^.sled^.tabl.t1=dlud then begin

          tem:=tems^.sled;

          tems^.sled:=tems^.sled^.sled;

          dispose(tem);

          bis:=false;

          break;

        end;

        tems:=tems^.sled;

      end;

      end;

    if bis then writeln('Данной записи не обнаруженно');

     nast:=menu1;

     menus(nast,nast.m);

     tabl1(tek,rab,false);

     izm:=0;

     tek:=2;

  end

  else if iz=3 then begin   {изменение данных}

    tems:=rab;

    tabl1(tek,rab,true);

    writeln('Введите уникальный номер'); readln(dlud);

    bis:=true;

      while tems<>nil do begin

        if tems^.tabl.t1=dlud then begin

          writeln(mm[t,1]);readln(tems^.tabl.t1);

          writeln(mm[t,2]);readln(tems^.tabl.t2);

          writeln(mm[t,3]);readln(tems^.tabl.t3);

          writeln(mm[t,4]);readln(tems^.tabl.t4);

          writeln(mm[t,5]);readln(tems^.tabl.t5);

          break;

        end;

        tems:=tems^.sled;

      end;

    if bis then writeln('Данной записи не обнаруженно');

     nast:=menu1;

     menus(nast,nast.m);

     tabl1(tek,rab,false);

     izm:=0; tek:=2;

  end;

end;

procedure zapros(num:integer);    {Запросы}

var str1,str2,str3:string;

tem1,tem2:cc;

nay:boolean;

zz:tabl2;

begin

  clrscr;

  nay:=false;

  case num of

  2:begin          {Найти оценку}

    tem1:=tt1;

    writeln('Введите фамилию'); readln(str1);

    writeln('Введите название предмета');readln(str2);

    while tem1<>nil do begin

      if tem1^.tabl.t2=str1 then begin str1:=tem1^.tabl.t1; break; end;

      tem1:=tem1^.sled;

    end;

    tem1:=tt2;

    while tem1<>nil do begin

      if tem1^.tabl.t2=str2 then begin  str2:=tem1^.tabl.t1; break; end;

      tem1:=tem1^.sled;

    end;

    tem1:=tt4;

    while tem1<>nil do begin

      if ((tem1^.tabl.t5=str2) and (tem1^.tabl.t4=str1)) then begin

        textcolor(red);

        writeln('Оценка этого студента-',tem1^.tabl.t2);

        nay:=true; break;

      end;

      tem1:=tem1^.sled;

    end;

  end;

  3:begin                    {Преподаватель}

    writeln('Выедите название предмета');

    readln(str1);

    tem1:=tt2;

    while tem1<>nil do begin

      if tem1^.tabl.t2=str1 then begin  str1:=tem1^.tabl.t3; break; end;

      tem1:=tem1^.sled;

    end;

    tem1:=tt3;

    while tem1<>nil do begin

      if tem1^.tabl.t1=str1 then begin

        textcolor(red);

        writeln('Преподаватель-');

        with tem1^.tabl do write('     ',t2,', ',t3,', ',t4);

        nay:=true; break;

      end;

      tem1:=tem1^.sled;

    end;

  end;

  4:begin                    {Найти размер стипендии}

    writeln('Введите фамилию студента');

    readln(str1);

    tem1:=tt1;

    while tem1<>nil do begin

      if tem1^.tabl.t2=str1 then begin

        textcolor(red);

        writeln('Стипендия-',tem1^.tabl.t5);

        nay:=true; break;

      end;

      tem1:=tem1^.sled;

    end;

    end;

  5:begin                {Вывод всех студентов с избранной оценкой}

    writeln('Введите оценку');

    readln(str1);

    tem1:=tt4; tem2:=tt1;

    textcolor(red);

    while tem1<>nil do begin

      if tem1^.tabl.t2=str1 then begin

        str2:=tem1^.tabl.t4;

        while tem2<>nil do begin

          if tem2^.tabl.t1=str2 then begin

            with tem2^.tabl do

               writeln('Студент-',t3,' ',t4,' ',t2);

            nay:=true;

          end;

          tem2:=tem2^.sled;

        end;

      end;

      tem2:=tt1;   tem1:=tem1^.sled;

    end;

  end;

  6:begin            {Найти дату сдачи предмета}

  writeln('Введите название предмета');

  readln(str1);

    tem1:=tt2;

    while tem1<>nil do begin

      if tem1^.tabl.t2=str1 then begin  str1:=tem1^.tabl.t1; break; end;

      tem1:=tem1^.sled;

    end;

    tem1:=tt4;

    while tem1<>nil do begin

      if tem1^.tabl.t5=str1 then begin

        textcolor(red);

        writeln('Дата сдачи-',tem1^.tabl.t3);

        nay:=true;

      end;

      tem1:=tem1^.sled;

    end;

  end;

  end;

textcolor(red);

if not nay then writeln('Запрос невыполним');

  textcolor(3); readln;

  nast:=menu1;  menus(nast,nast.m);

  tek:=2;

end;

procedure writetip(temr:cc);

begin

clrscr;

 write('Введите имя файла');

 writeln('в котором хотите сохранить данные');

 readln(names);

 for i:=1 to 4 do begin

   if temr<>nil then begin temr:=nil; end;

   case i of

     1:begin temr:=tt1; namer:='1'+names; end;

     2:begin temr:=tt2; namer:='2'+names; end;

     3:begin temr:=tt3; namer:='3'+names; end;

     4:begin temr:=tt4; namer:='4'+names; end;

   end;

   assign(outf,namer);  rewrite(outf);

   while temr<>nil do begin

    write(outf, temr^.tabl);

    temr:=temr^.sled;

   end;

 CLOSE(outf);

 end;

 nast:=menu1;  menus(nast,nast.m);  tek:=2;

end;

procedure readtip(temr:cc);

var tems:cc;

begin

clrscr;

 write('Введите имя файла');

 writeln('из которого надо взять данные'); readln(names);

   for i:=1 to 4 do begin

   if temr<>nil then begin  temr:=nil; end;

   if tems<>nil then begin  tems:=nil; end;

   case i of

     1:begin new(tt1); temr:=tt1; namer:='1'+names; end;

     2:begin new(tt2); temr:=tt2; namer:='2'+names; end;

     3:begin new(tt3); temr:=tt3; namer:='3'+names; end;

     4:begin new(tt4); temr:=tt4; namer:='4'+names; end;

   end;

   assign(outf,namer);  reset(outf);

   if eof(outf) then begin

     case i of

     1:begin dispose(tt1);tt1:=nil;end;

     2:begin dispose(tt2);tt2:=nil;end;

     3:begin dispose(tt3);tt3:=nil;end;

     4:begin dispose(tt4);tt4:=nil;end;

     end;

   end

   else begin

   tems:=temr;

   while temr<>nil do begin

    if eof(outf) then break;

    read(outf,temr^.tabl);

    if eof(outf) then break;

    new(temr^.sled);

    temr:=temr^.sled;

   end;

   temr^.sled:=nil;

 case i of

     1:tt1:=tems;

     2:tt2:=tems;

     3:tt3:=tems;

     4:tt4:=tems;

 end;

   end;

  CLOSE(outf);

 end;

 nast:=menu1;  menus(nast,nast.m);  tek:=2;

end;

procedure main;

begin

key:=#0;

  if nast.st[1]=menu1.st[1] then begin {Если меню - основное}

    case tek of

    2:readtip(temr);

    3:writetip(temr);

    4,5,7:begin

      nast:=menu2;  menus(nast,nast.m);

      if tek=7 then issor:=true;

      if tek=4 then vfile:=true

      else if tek=5 then vfile:=false;

      tek:=2;

    end;

    6:begin

      nast:=menu3;  menus(nast,nast.m);  tek:=2;

    end;

    8:begin

      nast:=menu4;  menus(nast,nast.m);  tek:=2;

    end;

    9: begin

      exist:=true;

    end;

    end;

  end

  else if nast.st[1]=menu3.st[1] then begin  {Если текущее меню-menu3}

    case tek of

    2,3,4:begin

      izm:=tek-1;

      nast:=menu2;  menus(nast,nast.m); tek:=2;

    end;

    5:begin

      nast:=menu1;

      menus(nast,nast.m); tek:=2;

    end;

    end;

  end

  else if nast.st[1]=menu4.st[1] then begin  {Если текущее меню-menu4}

   case tek of

   2,3,4,5,6:zapros(tek);

   7:begin

      nast:=menu1;

      menus(nast,nast.m);  tek:=2;

   end;

   end;

  end

    else if nast.st[1]=menu2.st[1] then begin {Если текущее меню-menu2}

      if izm>0 then begin

        case tek of

          2:obrabotka(izm, tek-1,tt1);

          3:obrabotka(izm, tek-1,tt2);

          4:obrabotka(izm, tek-1,tt3);

          5:obrabotka(izm, tek-1,tt4);

        6:begin

        nast:=menu1;  menus(nast,nast.m); izm:=0; tek:=2;

        end;

        end;

      end

      else if issor=true then begin

        issor:=false;

        case tek of

        2:sort(izm, tek-1,tt1);

        3:sort(izm, tek-1,tt2);

        4:sort(izm, tek-1,tt3);

        5:sort(izm, tek-1,tt4);

        6:begin

        nast:=menu1;  menus(nast,nast.m);  izm:=0;  tek:=2;

        end;

        end;

      end

      else begin

        case tek of

        2:if vfile then tabl11(tek,tt1)

          else tabl1(tek,tt1,false);

        3:if vfile then tabl11(tek,tt2)

          else tabl1(tek,tt2,false);

        4:if vfile then tabl11(tek,tt3)

          else tabl1(tek,tt3,false);

        5:if vfile then tabl11(tek,tt4)

          else tabl1(tek,tt4,false);

        6:begin

        nast:=menu1;  menus(nast,nast.m);  izm:=0;  tek:=2;

        end;

        end;

      end;

  end;

end;

begin

clrscr;

textBackground(black);

tek:=2;       kr:='-';

   exist:=false;

nast:=menu1;  menus(nast,nast.m);

  while 1>0 do begin

    if keypressed then key:=readkey;

    case key of

     #80:ramka('+');

     #72:ramka('-');

     #27:exist:=true;

     #13:main;

    end;

  if exist then exit;

  krutis;

  end;

end.