tp7 / L11

uses Crt, Dos;
const
Base = 'Base.dat'
type
mass = array[1..7] of String[10];
b = record
FIO: string[30];
gruppa, data, zach: Byte;
rmatem, rfizik, summ: real;
end;
PtrPoint = ^P;
P = record
D: b;
Pred, Next: PtrPoint;
end;

const
M: mass = (
'Просмотр',
'Добавить',
'Изменить',
'Удалить',
'Поиск',
'Сортировка',
'Выход');
FM: mass = (
'ФИО',
' Группа ',
' Дата рождения ',
' Зачетная книжка ',
' Рейтинг по математике ',
' Рейтинг по физике ',
' Суммарный рейтинг ');

var
R: Registers;
ListBegin, ListEnd: PtrPoint;
i: Byte;
Index: Integer;
f: file of b;

procedure HeaderX(X: Byte; s: String);
begin
TextBackground(Black);
ClrScr;
TextColor(yellow);
GotoXY(X,1); Write(s);
GotoXY(1,3);
TextColor(LightGray);
end;

function MouseInButton(X1M,Y1M,X2M:Byte): Boolean;
var
X1,Y1,X2,Y2: Integer;
Begin
MouseInButton:= False;
R.AX:= $03; Intr($33,R);
for i:=1 to 7 do begin
X1:= X1M*8;
Y1:= Y1M*8 + (i-1)*8;
X2:= X2M*8;
Y2:= Y1 + 8;
if (R.CX > X1) and (R.CX < X2) and
(R.DX > Y1) and (R.DX < Y2) then begin
MouseInButton:= True;
exit;
end;
end;
end;
procedure Run(i: Byte);
begin
case i of
1: Viewing;
2: Additing;
3: Editing;
4: Deleting;
5: Searching;
6: Sorting;
7: halt;
end;
end;

procedure Menu(X1,Y1,X2,Y2,n: Byte; Me: mass);
var
ch: Char;
s: String;
begin
R.AX:= $00; Intr($33,R);
R.AX:= $01; Intr($33,R);
Window(X1,Y1,X2,Y2);
{ Рисуем рамку }
s:= '';
for i:=1 to 12 do
s:= s + #196;
TextColor(Brown);
Write(#218,s, #191);
GotoXY(1,9); Write(#192,s, #217);
for i:=1 to n do begin
GotoXY(1,1+i); Write(#179);
GotoXY(14,1+i); Write(#179);
end;
{ Выводим меню }
for i:=1 to n do begin
GotoXY(3,1+i); Write(Me[i]);
end;
{ Запускаем цикл выбора пункта меню }
repeat
if MouseInButton(X1,Y1,X2) then
repeat
R.AX:= $03; Intr($33,R);
if R.BX = 1 then
if Me[1] = 'Просмотр' then begin
Run(i);
exit;
end else exit;
until not MouseInButton(X1,Y1,X2);
until False;
end;

index := FileSize(f);

procedure MakeList;
var
i: Integer;
w: b;
p,r: PtrPoint;
begin
reset(f);
if Index>0 then Read(f,w);
New(p); ListBegin:= p;
p^.D:= w;
p^.Pred:= NIL; p^.Next:= NIL;
for i:= 1 to Index do begin
Read(f,w);
New(r);
r^.D:= w;
p^.Next:= r; r^.Pred:= p;
r^.Next:= NIL;
p:= r;
end;
ListEnd:= p;
close(f)
end;

function SeekofPoint(n: Integer): PtrPoint;
var
p: PtrPoint;
i: Integer;
begin
p:= ListBegin;
for i:=1 to n-1 do
p:= p^.Next;
SeekofPoint:= p;
end;

procedure Viewing;
var
i: Integer;
p: PtrPoint;
begin
Window(20,5,80,25);
p:= ListBegin;
HeaderX(25,'Просмотр');
TextColor(Brown);
WriteLn(' Фамилия Имя Отчество Группа Дата Зач рейтинг по матике Рейтинг по физике Суммарный рейтинг');
TextColor(LightGray);
WriteLn;
for i:= Index downto 1 do begin
with p^.D do
WriteLn(FIO: 30,gruppa:2,data:2,zach:3,rmatem:4:1,rfizik:7,summ:9);
p:= p^.Next;
end;
ReadKey;
TextMode(Co80);
end;

procedure Additing;
var
p,r: PtrPoint;
begin
repeat
Window(20,5, 80,25);
HeaderX(25,'Добавление');
p:= ListEnd;
New(r);
p^.Next:= r;
r^.Pred:= p;
r^.Next:= NIL;
with r^.D do begin
Inc(Index);
WriteLn(Index);
Write('ФИО: '); ReadLn(FIO);
Write('Группа: '); ReadLn(gruppa);
Write('Дата рождения: '); ReadLn(data);
Write('Зачетная книжка: '); ReadLn(zach);
Write('Рейтинг по математике: '); ReadLn(rmatem);
Write('Рейтинг по физике: '); ReadLn(rfizik);
summ:= Round(rmatem + rfizik);
end;
ListEnd:= r;
WriteLn;
WriteLn('Enter - меню');
WriteLn('Любая другая - продолжить');

until ReadKey = #13;
TextMode(Co80);
end;

procedure Editing;
var
i: Integer;
p: PtrPoint;
wt: b;
begin
repeat
Window(20,5, 80,25);
p:= ListBegin;
HeaderX(25,'Изменение');
Write('Введите номер записи: '); ReadLn(i);
if not (i in [1..Index]) then begin
TextColor(Brown);
WriteLn('Неправильно введен номер карточки!');
WriteLn('Он должен быть: 1..',Index);
TextColor(LightGray);
ReadKey;
exit;
end
else begin
p:= SeekofPoint(i);
wt:= p^.D;
with p^.D do begin
Write('ФИО: '); ReadLn(FIO);
if FIO = '0' then FIO:= wt.FIO;
Write(' Группа: '); ReadLn(gruppa);
if gruppa = 0 then gruppa:= wt. gruppa;
Write(' Дата рождения: '); ReadLn(data);
if data = 0 then data:= wt. data;
Write(' Зачетная книжка: '); ReadLn(zach);
if zach = 0 then zach:= wt. zach;
Write(' Рейтинг по математике: '); ReadLn(rmatem);
if rmatem = 0 then rmatem:= wt. rmatem;
Write(' Рейтинг по физике: '); ReadLn(rfizik);
if rfizik = 0 then rfizik:= wt. rfizik;
summ:= Round(rmatem * rfizik);
end;
end;
WriteLn;
WriteLn('Enter - меню');
WriteLn('Любая другая - продолжить');
until ReadKey = #13;
TextMode(Co80);
end;

procedure Deleting;
var
i,n: Integer;
p,r: PtrPoint;
w: b;
begin
Window(20,5, 80,25);
repeat
WriteLn;
WriteLn('1 - Удалить одну запись');
WriteLn('0 - Удалить все записи');
WriteLn;
case ReadKey of
'1': begin
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
dec(Index);
if n = 1 then begin
p:= ListBegin;
ListBegin:= ListBegin^.Next;
if ListBegin = NIL then begin
ListEnd:= NIL;
TextColor(Red);
WriteLn('Данные удалены');
WriteLn('Список пуст');
TextColor(LightGray);
ReadKey; exit;
end
else begin
ListBegin^.Pred:= NIL;
dispose(p);
TextColor(Red); WriteLn('Данные удалены'); TextColor(LightGray);
end;
end
else begin
p:= SeekofPoint(n-1);
r:= p^.Next;
p^.Next:= r^.Next;
dispose(r);
r:= p^.Next;
if not (r = NIL) then r^.Pred:= p
else r:= p;
ListEnd:= r;
TextColor(Red); WriteLn('Данные удалены'); TextColor(LightGray);
end;
end;
end;
'0': begin
for i:=1 to Index do begin
p:= ListBegin;
ListBegin:= ListBegin^.Next;
dispose(p);
end;
ListEnd:= NIL;
TextColor(Red); WriteLn('Все данные удалены'); TextColor(LightGray);
end;
end;
WriteLn;
WriteLn('Enter - меню');
WriteLn('Любая другая - продолжить');
until ReadKey = #13;
TextMode(Co80);
end;

procedure Searching;
var
i: Integer;
p: PtrPoint;
wf,w: b;
begin
Window(20,5, 80,25);
repeat
HeaderX(25,'Поиск');
Menu(4,4,8,12,7,FM);
Case i of
1: begin
Write('ФИО: '); ReadLn(wf.FIO);
p:= ListBegin;
while not (p=NIL) do with p^.D do begin
if Pos(wf.FIO,FIO) > 0 then
WriteLn(FIO: 30, gruppa:3, data:5,
zach:5, rmatem:4:1, rfizik:7, summ:7);
p:= p^.Next;
end;
end;
2: begin
Write(' Группа '); ReadLn(wf. gruppa);
p:= ListBegin;
while not (p=NIL) do with p^.D do begin
if wf. gruppa = gruppa then
WriteLn(FIO: 30, gruppa:3, data:5,
zach:5, rmatem:4:1, rfizik:7, summ:7);
p:= p^.Next;
end;
end;
3: begin
Write(' Дата рождения '); ReadLn(wf. data);
p:= ListBegin;
while not (p=NIL) do with p^.D do begin
if wf. data = data then
WriteLn(FIO: 30, gruppa:3, data:5,
zach:5, rmatem:4:1, rfizik:7, summ:7);
p:= p^.Next;
end;
end;
4: begin
Write(' Зачетная книжка '); ReadLn(wf. zach);
p:= ListBegin;
while not (p=NIL) do with p^.D do begin
if wf. zach = zach then
WriteLn(FIO: 30, gruppa:3, data:5,
zach:5, rmatem:4:1, rfizik:7, summ:7);
p:= p^.Next;
end;
end;
5: begin
Write(' Рейтинг по математике '); ReadLn(wf. rmatem);
p:= ListBegin;
while not (p=NIL) do with p^.D do begin
if wf. rmatem = rmatem then
WriteLn(FIO: 30, gruppa:3, data:5,
zach:5, rmatem:4:1, rfizik:7, summ:7);
p:= p^.Next;
end;
end;
6: begin
Write(' Рейтинг по физике '); ReadLn(wf. rfizik);
p:= ListBegin;
while not (p=NIL) do with p^.D do begin
if wf. rfizik = rfizik then
WriteLn(FIO: 30, gruppa:3, data:5,
zach:5, rmatem:4:1, rfizik:7, summ:7);
p:= p^.Next;
end;
end;
7: begin
Write(' Суммарный рейтинг '); ReadLn(wf. summ);
p:= ListBegin;
while not (p=NIL) do with p^.D do begin
if wf. summ = summ then
WriteLn(FIO: 30, gruppa:3, data:5,
zach:5, rmatem:4:1, rfizik:7, summ:7);
p:= p^.Next;
end;
end;
end;
WriteLn;
WriteLn('Enter - меню');
WriteLn('Любая другая - продолжить');
until ReadKey = #13;
TextMode(Co80);
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;
p,r,s: PtrPoint;
w1,w2,wt: b;
begin
Window(20,5, 80,25);
repeat
HeaderX(25,'Сортировка');
Menu(4,4,8,12,7,FM);
Case i of
1: WriteLn('ФИО');
2: WriteLn(' Группа ');
3: WriteLn(' Дата рождения ');
4: WriteLn(' Зачетная книжка ');
5: WriteLn(' Рейтинг по математике ');
6: WriteLn(' Рейтинг по физике ');
7: WriteLn(' Суммарный рейтинг ');
end;
Write('Направление (+,-): '); ReadLn(D);
p:= ListBegin;
for i:=0 to Index-2 do begin
p:= SeekofPoint(i+1);
w1:= p^.D;
wt:= w1;
for j:=i to Index-1 do begin
p:= SeekofPoint(i+1);
w2:= p^.D;
Case i of
1: Direction:= Direct(w2.FIO < w1.FIO, D);
2: Direction:= Direct(w2. gruppa < w1. gruppa, D);
3: Direction:= Direct(w2. data < w1. data, D);
4: Direction:= Direct(w2. zach < w1. zach, D);
5: Direction:= Direct(w2. rmatem < w1. rmatem, D);
6: Direction:= Direct(w2. rfizik < w1. rfizik, D);
7: Direction:= Direct(w2. summ < w1. summ, D);
end;
if Direction then begin
wt:= w2;
Nt:= j;
end;
end;
Case i of
1: Direction:= Direct(wt.FIO < w1.FIO, D);
2: Direction:= Direct(wt. gruppa < w1. gruppa, D);
3: Direction:= Direct(wt. data < w1. data, D);
4: Direction:= Direct(wt. zach < w1. zach, D);
5: Direction:= Direct(wt. rmatem < w1. rmatem, D);
6: Direction:= Direct(wt. rfizik < w1. rfizik, D);
7: Direction:= Direct(wt. summ < w1. summ, D);
end;
if Direction then begin
p:= SeekofPoint(i+1); p^.D:= wt;
r:= SeekofPoint(Nt); r^.D:= w1;
s:= r^.Pred; r^.Pred:= p^.Pred; p^.Pred:= s;
s:= r^.Next; r^.Next:= p^.Next; p^.Next:= s;
end;
end;

Viewing;
WriteLn;
WriteLn('Enter - меню');
WriteLn('Любая другая - продолжить');
until ReadKey = #13;
TextMode(Co80);
end;

procedure WriteF;
var
i: Integer;
p: PtrPoint;
begin
rewrite(f);
p:= ListBegin;
for i:=1 to Index do begin
Write(f,p^.D);
p:= p^.Next;
end;
close(f);
end;



begin
assign(f,Base);
{$I-}
reset(f);
{$I+}
if IOResult<>0 then rewrite(f);
close(f);
repeat
MakeList;
index := FileSize(f);
HeaderX(33,'Лабораторная 11');
Menu(3,3,17,12,7,M);
WriteF;
until False;
end.