Задачи на Pascal/Object Pascal/Free Pascal (Delphi/Lazarus) - [1072] :: Прикладное программирование

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]=
('Auaia aacu', 'Aiaaaeaiea', 'Eciaiaiea', 'Oaaeaiea',
'Iiene', 'Auai?', 'Auoia');
pos:array[1..n_items] of integer={iiceoee ia?aea ioieoia iai?}
(1,d+2,2*d+3,3*d+3,4*d+2,5*d-2,6*d-6);
{iiceoee ii?aaaeaiu iaoiaii ?o?iiai iiaai?a}
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('Oaeiai nio?oaieea iao!');
Find:=nil;
end;

procedure Info(const person:Man);
begin
DlgWindow;
with person do
begin
gotoXY(2,2);
writeln('Oaieeey: ',name);
gotoXY(2,4);
writeln('Aia ?i?aaiey: ',birth);
gotoXY(2,6);
writeln('Ieeaa: ',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('Oaieeey: ');
clreol;
readln(name);
len:=length(name);
for i:=len+1 to l_name do name := name + ' ';
until len<>0;
repeat
gotoXY(2,4);
write('Aia ?i?aaiey: ');
clreol;
readln(s);
val(s,birth,err);
until (err = 0) and (birth>0);
repeat
gotoXY(2,6);
write('Ieeaa: ');
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('Oaieeey: ');
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-}
24
assign(f,'dbase.txt');
reset(f);
if(IOResult<>0) then Error('Oaee dbase.txt ia iaeaai!');
{$I+}
while not eof(f) do
begin
with person do readln(f,name,birth,pay);
Add(beg,fin,person); {aiaaaeaiea yeaiaioa a nienie}
end;
close(f);
end;

procedure Select(beg:pMan);

procedure QueryPay(var pay:real);
var
s:string;
err:integer;
begin
DlgWindow;
repeat
gotoXY(2,4);
write('Ieeaa: ');
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('Oaieeey Aia ?i?aaiey Ieeaa');
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('Nienie iono!');
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. [/code][#][/#]

Модерирует : ShIvADeSt
Версия для печати • Подписаться • Добавить в закладки
На первую страницу • к этому сообщению • к последнему сообщению