SERGE_BLIZNUK
Silver Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
Код:
Program LR_5;
Uses Crt;
Const
n_items=7;
l_name=30;
Type
tname=string[l_name];
pMan=^Man;
Man=record
name:tname;
birth:integer;
pay:real;
next:pMan;
prev:pMan;
end;
Var
DefaultMode,ActiveColor,InactiveColor:word;
key:char;
item:word;
prev:word;
beg:pMan;
fin:pMan;
p:pMan;
name:tname;
person:Man;
function Find(p:pMan; const name:tname):pMan; forward;
procedure Message(message:string); forward;
procedure ShowBase(beg:pMan); forward;
procedure Add(var beg,fin:pMan; const person:Man);
var p:pMan;
begin
new(p);
p^:=person;
p^.next:=nil;
p^.prev:=fin;
if beg=nil
then beg:=p
else fin^.next:=p;
fin:=p;
end;
procedure Clear;
begin
window(1,3,80,25);
TextAttr:=White;
clrscr;
end;
procedure Del(var beg,fin,p:pMan);
begin
if (p=beg) and (p=fin) then
begin
beg:=nil;
fin:=nil;
end
else
if p=beg then
begin
beg:=beg^.next;
beg^.prev:=nil;
end
else
if p=fin then
begin
fin:=fin^.prev;
fin^.next:=nil;
end
else
begin
p^.prev^.next:=p^.next;
p^.next^.prev:=p^.prev;
end;
dispose(p);
end;
procedure DlgWindow;
begin
window(10,6,70,12);
TextAttr:=Green+LightGray*16;
clrscr;
end;
procedure DrawItem(item,color:word);
const
d=12;
items:array [1..n_items] of string[d]=
('vyvod basy', 'dobavlenie', 'izmenenie', 'ydalenie',
'poisk', 'vybor', 'vyxod');
pos:array[1..n_items] of integer=(1,d+2,2*d+3,3*d+3,4*d+2,5*d-2,6*d-6);
begin
window(1,1,80,2);
TextBackGround(LightGray);
TextColor(color);
gotoXY(pos[item],1);
write(items[item]);
end;
procedure Edit(beg:pMan; const person:Man);
var
p:pMan;
begin
p:=Find(beg,person.name);
if p<>nil then
begin
p^.birth:=person.birth;
p^.pay:=person.pay;
end;
end;
procedure Error(message: string);
begin
window(1,1,80,25);
TextAttr:=Red+Blink;
clrscr;
gotoXY(35,12);
write(message);
repeat
until keypressed;
TextMode(DefaultMode);
halt;
end;
function Find(p:pMan; const name:tname):pMan;
begin
while p<>nil do
begin
if name= p^.name then
begin
Find:=p;
exit;
end;
p:=p^.next;
end;
Message('takogo imeni faila net!');
Find:=nil;
end;
procedure Info(const person:Man);
begin
DlgWindow;
with person do
begin
gotoXY(2,2);
writeln('imya faila: ',name);
gotoXY(2,4);
writeln('data sozdanya: ',birth);
gotoXY(2,6);
writeln('kolichestvo obrasheni: ',pay:5:2);
end;
readln;
end;
procedure InitMenu(ActiveColor,InactiveColor:word);
var item:word;
begin
window(1,1,80,2);
TextBackGround(LightGray);
clrscr;
DrawItem(1,ActiveColor);
for item:=2 to n_items do DrawItem(item,InactiveColor);
gotoXY(1,2);
TextColor(InactiveColor);
write('----------------------------------------------------');
gotoXY(1,1);
end;
procedure Message(message:string);
begin
DlgWindow;
gotoXY(2,4);
write(message);
readln;
end;
procedure Query(var person:Man);
var
s:string;
err:integer;
i,len:integer;
begin
DlgWindow;
with person do
begin
repeat
gotoXY(2,2);
write('imya faila: ');
clreol;
readln(name);
len:=length(name);
for i:=len+1 to l_name do name := name + ' ';
until len<>0;
repeat
gotoXY(2,4);
write('data sozdaniya: ');
clreol;
readln(s);
val(s,birth,err);
until (err = 0) and (birth>0);
repeat
gotoXY(2,6);
write('kolichestvo obrasheni: ');
clreol;
readln(s);
val(s,pay,err);
until (err = 0) and (pay>0);
end;
end;
procedure QueryName(var name:tname);
var
i,len:integer;
begin
DlgWindow;
gotoXY(2,2);
write('imya faila: ');
clreol;
readln(name);
len:=length(name);
for i:=len+1 to l_name do name:=name+' ';
end;
procedure ReadFile(var beg,fin:pMan);
var
f:text;
person:Man;
begin
{$I-}
assign(f,'dbase.txt');
reset(f);
if(IOResult<>0) then Error('fail dbase.txt ne naiden!');
{$I+}
while not eof(f) do
begin
with person do readln(f,name,birth,pay);
Add(beg,fin,person);
end;
close(f);
end;
procedure Select(beg:pMan);
procedure QueryPay(var pay:real);
var
s:string;
err:integer;
begin
DlgWindow;
repeat
gotoXY(2,6);
write('kolichestvo obrasheni: ');
clreol;
readln(s);
val(s,pay,err);
until (err=0) and (pay>0);
end;
var
begs,fins:pMan;
p:pMan;
pay:real;
begin
QueryPay(pay);
begs:=nil;
fins:=nil;
p:=beg;
while p<>nil do
begin
if p^.pay>pay
then Add(begs,fins,p^);
p:=p^.next;
end;
ShowBase(begs);
end;
procedure ShowBase(beg:pMan);
const step=18;
procedure ShowPage(var p:pMan);
var
i:integer;
begin
clrscr;
gotoXY(1,1);
writeln('imya faila data sozdania kolichestvo obrashenii');
i:=0;
while p<>nil do
begin
with p^ do writeln(' ',name,birth:5,pay:15:2);
p:=p^.next;
inc(i);
if i>step then exit;
end;
end;
var
i:integer;
key:char;
p,pn:pMan;
begin
if beg=nil then
begin
Message('spisok pyst!');
exit
end;
window(3,4,78,24);
TextBackGround(LightGray);
TextColor(white);
p:=beg;
while true do
begin
pn:=p;
ShowPage(p);
key:=readkey;if key=#0 then key:=readkey;
case ord(key) of
27: exit;
13,80,81: if p=nil then p:=pn;
72,73: begin
p:=pn;
for i:=1 to step do
begin
p:=p^.prev;
if p=nil then
begin
p:=beg;
break;
end;
end;
end;
end;
end;
end;
Begin
DefaultMode:=LastMode;
TextMode(C80);
beg:=nil;
fin:=nil;
ReadFile(beg,fin);
clrscr;
ActiveColor:=LightGreen;
InactiveColor:=Green;
InitMenu(ActiveColor,InactiveColor);
item:=1;
prev:=1;
while true do
begin
key:=readkey;
if key=#0 then key:=readkey;
case ord(key) of
13: case item of
1: ShowBase(beg);
2: begin
Query(person);
Add(beg,fin,person);
end;
3: begin
Query(person);
Edit(beg,person);
end;
4: begin
QueryName(name);
p:=Find(beg,name);
if p<>nil then Del(beg,fin,p);
end;
5: begin
QueryName(name);
p:=Find(beg,name);
if p<>nil then Info(p^);
end;
6: Select(beg);
7: exit;
end;
15,75: begin
prev:=item;
dec(item);
if item=0 then item:=n_items;
end;
9,77: begin
prev:=item;
inc(item);
if item=n_items+1 then item:=1;
end;
end;
Clear;
DrawItem(prev,InactiveColor);
DrawItem(item,ActiveColor);
end;
TextMode(DefaultMode);
end.
|
|
