TP / Project / PUNIT

UNIT PUnit;
{------------------------------------------------------------}
INTERFACE
{------------------------------------------------------------}
uses Crt;

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

type
Worker = record
N: Integer;
FIO,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 - 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,Tel:20,Email:20);
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(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(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(FIO:Len,Tel:10,Email:10);
end;
close(f);
end;
'2': 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(FIO:Len,Tel:10,Email:10);
end;
close(f);
end;
'3': 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(FIO: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('E-mail');
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.Tel < w1.Tel, D);
'3': Direction:= Direct(w2.Email < w1.Email, 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.Tel < w1.Tel, D);
'3': Direction:= Direct(wt.Email < w1.Email, 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.