Скачиваний:
126
Добавлен:
08.05.2014
Размер:
6.23 Кб
Скачать
program exp8;
uses Crt;
type
PInfCard=^InfCard;
InfCard=record
apt_num,floor,square:Byte;
address:string[35];
point:PInfCard;
end;
const A1:array[1..3] of string[15]=(' ‡ пўЄ  ',' ‚Ґбм бЇЁб®Є ',' ‚л室 ');
A2:array[1..5] of string[15]=(' Є®«-ў® Є®¬­ в ',' нв ¦ ',' Ї«®й ¤м ','  ¤аҐб ',' ўў®¤ ');
var f:Text; Ch:Char; pb:PInfCard; k,showed:Byte;
call:InfCard;

procedure Environment(k,j:Byte);
const c1:Byte=7; c2:Byte=2; c3:Byte=0;
x:array[1..3] of Word=(15,25,40);var i:Byte;
begin
case k of
0:begin
clrscr;
gotoXY(1,1); TextColor(7); TextBackground(0);
Write('Й'); for i:=1 to 77 do Write('Н'); Writeln('»');
for i:=2 to 23 do begin
gotoXY(1,i); Write('є'); gotoXY(79,i); Writeln('є');
end;
Write('И'); for i:=1 to 77 do Write('Н'); Writeln('ј');
gotoXY(2,3); for i:=1 to 77 do Write('Н');
end;
1:begin
TextColor(c1); TextBackground(0);
for i:=1 to 3 do begin
gotoXY(x[i],2); Write(A1[i]);
end;
TextBackground(c2); TextColor(c3);
gotoXY(x[j],2); Write(A1[j]);
end;
end;
TextColor(c1); TextBackground(0);
end;

procedure CreateList;
var pt,pp:PInfCard;
procedure Attach(var p:PInfCard);
begin
if p<>nil then New(p);
Readln(f,p^.apt_num);
Readln(f,p^.floor);
Readln(f,p^.square);
Readln(f,p^.address);
p^.point:=nil;
end;
begin
{$I-}
Assign(f,'exp8_dat.txt');
Reset(f);
{$I+}
if IOResult<>0 then begin Writeln('file not located'); Halt; end;
New(pb);
Attach(pb); pp:=pb;
while not Eof(f) do begin
New(pt);
Attach(pt);
pp^.point:=pt;
pp:=pt;
end;
end;

procedure Outer(x,y:Byte;p:PInfCard);
begin
TextColor(7);
gotoXY(x,y); Writeln(A2[1],' ',p^.apt_num);
gotoXY(x,y+1); Writeln(A2[2],' ',p^.floor);
gotoXY(x,y+2); Writeln(A2[3],' ',p^.square);
gotoXY(x,y+3); Writeln(A2[4],' ',p^.address);
end;

procedure DeleteCard(var p:PInfCard);
var pt,pp:PInfCard;
begin
if p=pb then pb:=pb^.point else begin
pt:=pb;
while pt<>nil do begin
pp:=pt; pt:=pt^.point;
if pt=p then
if pt^.point<>nil then begin
pp^.point:=pt^.point;
end
else pp^.point:=nil;
end;
end;
Dispose(p);
end;

procedure OUtCaRd(p:PInfCard);
var x,y:Byte;
begin
if (showed=1) or (showed=3) then y:=5 else y:=15;
if showed<3 then x:=5 else x:=34;
Outer(x,y,p);
end;

procedure LookThrough;
var pp,pt:PInfCard; found:Boolean;

procedure Compare(p:PInfCard);
begin
if (call.apt_num=p^.apt_num) and
(call.floor=p^.floor) and (abs(call.square-p^.square)/call.square*100<=10)
then begin found:=true; Inc(showed); OutCard(p); DeleteCard(p); end;
end;

begin
pt:=pb; found:=false; showed:=0;
while pt<>nil do begin
Compare(pt); pp:=pt;
pt:=pt^.point;
end;
if not found then begin New(pt); pt^:=call; pt^.point:=nil;
pp^.point:=pt;
end;
Readkey;
end;

procedure CallInput;
var i:Byte; Ch:Char;

procedure Choice(func,i:Byte);
begin
case func of
0:begin TextColor(2);
for i:=1 to 5 do begin gotoXY(23,8+i); Write(a2[i]); end;
end;
1:begin Textcolor(13);
gotoXY(23,8+i); Write(a2[i]);
end;
end;
end;

procedure Clear;
var i:Byte;
begin
TextBackground(0);
for i:=5 to 16 do begin gotoXY(22,i);
Write(' '); end;
end;

begin
gotoXY(22,5);
Write('Й'); for i:=1 to 35 do Write('Н'); Writeln('»');
for i:=6 to 15 do begin
gotoXY(22,i); Write('є'); gotoXY(58,i); Writeln('є');
end;
gotoXY(22,16); Write('И');
for i:=1 to 35 do Write('Н'); Writeln('ј');
TextColor(4); gotoXY(36,6); Write(' ‡ пўЄ  ');
Choice(0,0); Choice(1,1); i:=1;
while True do begin
if keypressed then Ch:=readkey;
case Ord(Ch) of
27:begin Clear; exit; end;
72:begin Dec(i); if i=0 then i:=5; Choice(0,0); Choice(1,i); gotoXY(40,8+i); end;
80:begin Inc(i); if i=6 then i:=1; Choice(0,0); Choice(1,i); gotoXY(40,8+i); end;
13:begin {$I-}
case i of
1:begin Readln(call.apt_num); end;
2:begin Readln(call.floor); end;
3:begin Readln(call.square); end;
4:begin Readln(call.address); end;
5:Break;
end;
{$I+} if IOResult<>0 then begin TextColor(128);
gotoXY(15,20); Write(' ЋиЁЎЄ  ўў®¤  '); Readkey;
TextColor(0); gotoXY(15,20); Write(' ');
gotoXY(23+Length(A2[i]),8+i); Write(' '); TextColor(2);
end;
end;
end;
Ch:=' ';
end; Clear; LookThrough;
end;

procedure OutAll;
var j,i,x,y:Byte; pt:PInfCard; Ch:Char;
begin j:=0; pt:=pb;
while True do begin
Inc(j);
if (j<=4) and (pt<>nil) then begin
if j>2 then x:=34 else x:=5;
if (j=1) or (j=3) then y:=5 else y:=15;
Outer(x,y,pt);
pt:=pt^.point;
end
else
begin Ch:=' ';
TextBackground(0); Ch:=Readkey;
for i:=4 to 23 do begin gotoXY(2,i);
Write(' ');
end; if pt=nil then Exit;
j:=0;
end;
end;
end;

begin
CreateList;
TextColor(7); TextBackground(0);
clrscr;
k:=1;
Environment(0,0);
Environment(1,k);
while True do begin
if keypressed then begin
Ch:=Readkey;
case Ord(Ch) of
75: begin Dec(k); if k=0 then k:=3; Environment(1,k); end;
77: begin Inc(k); if k=4 then k:=1; Environment(1,k); end;
13: begin
case k of
1: CallInput;
2: OutAll;
3: begin TextColor(7); TextBackground(0); clrscr; Halt; end;
end;
Environment(0,0); Environment(1,k);
end;
end;
end;
end;
end.

















Соседние файлы в папке задание №6 — 1