написанные программы / задание №6 — 1 / LLL66

program lab6;
uses crt;

type pcomp=^comp;
comp=record
vozrast: byte;
pol: string[2];
obrazov: string[1];
otvet: string[3];
p: pcomp;
end;
const pBeg:pComp=nil;
menus:array[1..3] of string[28]=
(' ђЂ‘Џ…—Ђ’ЉЂ ЂЌЉ…’ € Ћ’‚…’Ћ‚ ',
' ЏђЋ‘ЊЋ’ђ ',' ‚›•Ћ„ ');
var
sw:byte;
s:char;

procedure okno(x,y,z,w,ekran,symbol:byte);
var j:Byte;
begin
textbackground(ekran);
clrscr;
textcolor(symbol);
gotoxy(x,y);
write('Й');
for j:=x to z-1 do
write('Н');
write('»');
for j:=y+1 to w do
begin
gotoxy(x,j);
write('є');
gotoxy(z+1,j);
write('є');
end;
gotoxy(x,w+1);
write('И');
for j:=x+1 to z do
write('Н');
write('ј');
end;

procedure vivod;
begin
gotoxy(3,4); textcolor(2); TextBackground(0);
write(' ДД ‚Ћ‡ђЂ‘’ ДДДД ЏЋ‹ ДДДД ЋЃђЂ‡Ћ‚ЂЌ€… ДДДД Ћ’‚…’ ДД ');
end;

procedure CreateList;
var f:Text; pt,pp:pComp;
begin
assign(f,'D:\Borland\course1\olga6.txt');
{$I-}
reset(f);
{$I+}
if IOResult<>0 then begin clrscr;
Write(' file allocation error '); Halt; end;
while not eof(f) do begin
New(pt);
Readln(f,pt^.vozrast,pt^.pol,pt^.obrazov,pt^.otvet);
if pBeg=nil then
begin
pbeg:=pt;
pbeg^.p:=nil;
end else
begin
pt^.p:=nil;
pp^.p:=pt;
end;
pp:=pt;
end;
end;

procedure Encounter;
var a,b,c:Byte; pt,pp:pComp;
begin
a:=0;b:=0;c:=0;
pt:=pBeg;
while pt<>nil do begin
with pt^ do begin
if (pol=' ¬') and (vozrast>40) and
(obrazov='ў') and (otvet=' ¤ ') then Inc(a)
else
if (pol=' ¦') and (vozrast<30) and
(obrazov='б') and (otvet='­Ґв') then Inc(b)
else
if (pol=' ¬') and (vozrast<25) and
(obrazov='­') and (otvet=' ¤ ') then Inc(c);
end;
pt:=pt^.p;
end;
gotoxy(10,5);
write(' ');
gotoxy(10,6);
write(' ¬г¦зЁ­ ,бв аиҐ 40,®Ўа §.ўлби.,®вўҐв:¤  :',a,' ');
gotoxy(10,7);
write(' ¦Ґ­йЁ­ ,¬®«®¦Ґ 30,®Ўа §.б।.,®вўҐв:­Ґв :',b,' ');
gotoxy(10,8);
write(' ¬г¦зЁ­ ,¬®«®¦Ґ 25,®Ўа §.­ з.,®вўҐв:¤  :',c,' ');
gotoxy(10,9);
write(' ');
Readkey;
end;

procedure OutAll;
var pt:pComp; i:Byte;
begin
pt:=pBeg; i:=5;
while pt<>nil do
begin
gotoXY(3,i); Inc(i);
writeln(' ',pt^.vozrast,' ',pt^.pol,
' ',pt^.obrazov,' ',pt^.otvet,' ');
pt:=pt^.p;
end;
Readkey;
end;

procedure Button(s:string;func,cc:Byte;x,y:Word);
const c1:Byte=8; c2:Byte=7; c3:Byte=0; c4:Byte=2;
var i:Byte; t:Word;
begin
gotoXY(x+1,y); t:=y;
case func of
0,1:begin
TextColor(c1); TextBackground(7);
for i:=1 to Length(s) do Write('Я');
gotoXY(x+Length(s),y-1); Write('Ь');
gotoXY(x,y-1);
end;
2:begin
gotoXY(x,y); TextColor(cc);
while t>=y-1 do begin
gotoXY(x,t); for i:=1 to Length(s)+2 do Write('Ы'); Dec(t);
end;
gotoXY(x+1,y-1);
end;
end;
case func of
0:TextColor(c2);
1,2:TextColor(c4);
end;
TextBackground(c3);
Write(s); if func=2 then Delay(100);
end;

procedure KeyMenu(func,w:Byte);
begin
if func=0 then begin
Button(menus[1],func,7,5,3);
Button(menus[2],func,7,37,3);
Button(menus[3],func,7,51,3);
end else
case w of
1:Button(menus[1],func,7,5,3);
2:Button(menus[2],func,7,37,3);
3:Button(menus[3],func,7,51,3);
end;
end;


begin
CreateList;
okno(1,1,78,24,7,0);
sw:=1; KeyMenu(0,sw); KeyMenu(1,sw);
while True do
if keypressed then begin
s:=readkey;
case Ord(s) of
77:begin Inc(sw); if sw=4 then sw:=1; KeyMenu(0,sw); KeyMenu(1,sw); end;
75:begin Dec(sw); if sw=0 then sw:=3; KeyMenu(0,sw); KeyMenu(1,sw); end;
13:begin KeyMenu(2,sw);
case sw of
1:begin vivod; OutAll; end;
2:Encounter;
3:begin TextBackground(0); TextColor(7); clrscr; halt; end;
end;
okno(1,1,78,24,7,0);
KeyMenu(0,sw); KeyMenu(1,sw);
end;
end;
end;
end.