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

program pro6;
uses Crt;
type
PCard = ^Card;
Card = record
Num,Year,Amount:Word;
Author: string[13];
Title: string[30];
left,right: PCard;
end;
var y,n,m,j,k,i:Word; c,p,q:PCard; a:string[12]; t:string[30];
Ch:Char; f,f1,f2:Text; text:string;
wrnum,z:Byte; Found:array[1..4] of Word;

procedure ReadCard;
begin
Readln(f,n); Readln(f,a); Readln(f,t);
Readln(f,y); Readln(f,m); Readln(f);
end;

procedure GiveData(d:PCard);
begin
with d^ do begin
Num:=n; Author:=a; Title:=t; Year:=y; Amount:=m;
end;
end;

procedure AddCard;
begin
q:=p;
while p<>nil do begin
if y<p^.Year then p:=p^.left
else p:=p^.right;
end;
New(p);
with p^ do begin
GiveData(p);
left:=nil; right:=nil;
end;
if y<q^.Year then q^.left:=p
else q^.right:=p;
end;

procedure DataStructure;
begin
Reset(f); ReadCard;
if c=nil then New(c);
GiveData(c);
c^.left:=nil; c^.right:=nil;
p:=c;
while not Eof(f) do begin
ReadCard;
AddCard;
if n=0 then Exit;
end;
end;


procedure ClearWindow;
begin
TextBackground(0);
for i:=1 to 2 do begin
gotoXY(3,21+i); for j:=1 to 69 do Write(' ');
end;
for i:=5 to 19 do begin
gotoXY(5,i); for j:=1 to 74 do Write(' '); end;
TextColor(7);
gotoXY(3,22); Write('Type marked letter to open section');
end;

procedure RenewFile(r:PCard);
begin
with r^ do begin
if (Num>0) and (Num<150) then begin
Writeln(f1,Num); Writeln(f1,Author); Writeln(f1,Title);
Writeln(f1,Year); Writeln(f1,Amount); Writeln(f1);
end;
end;
end;

procedure OutSearch(c:PCard);
begin
with c^ do begin
begin
if (Num=0) or (Year=0) then Exit;
gotoXY(j,k); Writeln('Number: ',Num);
gotoXY(j,k+1); Writeln('Author: ',Author);
gotoXY(j,k+2); Writeln('Title: ',Title);
gotoXY(j,k+3); Writeln('Year: ',Year);
gotoXY(j,k+4); Writeln('Amount: ',Amount);
if k>=11 then begin j:=40; k:=5; end else k:=k+6;
if (j=40) and (k>=11) then Exit; Inc(i);
Found[i]:=Num; z:=i; gotoXY(35,7);
end;
end;
end;

procedure LookThrough(c:PCard;l:Byte);
begin
if c<>nil then begin
LookThrough(c^.left,l);
with c^ do begin
if l=1 then begin
if (Num=n) or (Author=a) or (Year=y)
then OutSearch(c); end;
if l=2 then RenewFile(c);
if (l=3) and (Num=n) then wrnum:=1;
end;
LookThrough(c^.right,l);
end;
end;

procedure InputCard;
var i:Word;
begin
gotoXY(3,22); Write('Type marked letter to choose,');
Write('when finished with data, press "Enter"');
TextBackground(7); TextColor(0);
gotoXY(5,5); Write('ЙНННННННННННННННННННННННННННННННННННННННННН»');
gotoXY(5,6); Write('є Input New Card є');
gotoXY(5,7); Write('МНННННННННННННННННННННННННННННННННННННННННН№');
gotoXY(5,8); Write('є List number: є');
gotoXY(5,9); Write('є Author: є');
gotoXY(5,10); Write('є Title: є');
gotoXY(5,11); Write('є Year of publication: є');
gotoXY(5,12); Write('є Amount: є');
gotoXY(5,13); Write('є є');
gotoXY(5,14); Write('є Cancel є');
gotoXY(5,15); Write('ИННННННННННННННННННННННННННННННННННННННННННј');
TextColor(4); gotoXY(13,8); Write('n'); gotoXY(8,11); Write('Y');
gotoXY(9,12); Write('m'); gotoXY(8,9); Write('A'); gotoXY(8,10);
Write('T'); gotoXY(23,14); Write('C');
repeat
repeat
Ch:=readkey; TextColor(0); TextBackground(7); wrnum:=0;
case UpCase(Ch) of
'N': begin gotoXY(21,8); Readln(n); end;
'A': begin gotoXY(18,9); Readln(a); end;
'T': begin gotoXY(17,10); Readln(t); end;
'Y': begin gotoXY(29,11); Readln(y); end;
'M': begin gotoXY(16,12); Readln(m); end;
'C': begin ClearWindow; Exit; end;
end;
if Ord(Ch)=27 then begin ClearWindow; Exit; end;
until Ch = #13;
LookThrough(c,3);
if (n=0) or (a='') or (t='') or (y=0) or (m=0) or (wrnum=1) then
begin
TextColor(7); TextBackground(0);
gotoXY(3,23); Write('Data incorrect!'); Readkey;
gotoXY(3,23); for i:=1 to 20 do Write(' ');
end;
if Ord(Ch)=27 then begin ClearWindow; Exit; end;
until (n<>0) and (a<>'') and (t<>'') and (y<>0) and (m<>0) and (wrnum<>1);
AddCard; TextColor(7); TextBackground(0);
gotoXY(8,23); Write('Save to file'); TextColor(4);
gotoXY(8,23); Write('S'); Ch:=readkey;
if UpCase(Ch)='S' then begin Rewrite(f1); LookThrough(c,2);
Close(f1); end;
ClearWindow;
end;

procedure Clear(cl:PCard);
begin
if cl^.right<>nil then Clear(cl^.left) else
begin
p^.Num:=cl^.Num; p^.Author:=cl^.Author; p^.Title:=cl^.Title;
p^.Year:=cl^.Year; p^.Amount:=cl^.Amount;
p:=cl;
cl:=cl^.left;
end;
end;

procedure DelCard(c:PCard; d:Word);
begin
if c<>nil then begin
DelCard(c^.left,d);
if d=c^.Num then
begin
p:=c;
if p^.right=nil then c:=p^.left;
if p^.left=nil then c:=p^.right;
Clear(p^.left); Exit;
end;
DelCard(c^.right,d);
end;
end;

procedure CursorOrigin;
begin
j:=3; k:=5; i:=1; TextColor(2); gotoXY(j,k); Write('*');
end;

procedure MoveCursor;
label 1;
begin
CursorOrigin;
while True do begin
1: Ch:=readkey;
case Ord(Ch) of
80: begin gotoXY(j,k); TextColor(0); Write('*');
if i=z then begin CursorOrigin; goto 1; end;
if (k>=11) and (j=38) then CursorOrigin;
if k>=11 then begin j:=38; k:=5; end else
begin k:=k+6; i:=i+1; end;
gotoXY(j,k); TextColor(2); Write('*'); n:=Found[i];
end;
27: Exit;
end;
case UpCase(Ch) of
'M': begin DelCard(c,n); end;
'F': begin Rewrite(f1); DelCard(c,n);
LookThrough(c,2); Close(f1); end;
end;
end;
end;

procedure Search;
begin
gotoXY(3,22); Write('Type marked letter to choose,');
Write('to start search press "Enter"');
TextBackground(7); TextColor(0);
gotoXY(5,5); Write('ЙНННННННННННННННННННННННННННННН»');
gotoXY(5,6); Write('є Searching Card є');
gotoXY(5,7); Write('МНННННННННННННННННННННННННННННН№');
gotoXY(5,8); Write('є List number: є');
gotoXY(5,9); Write('є Year of publication: є');
gotoXY(5,10); Write('є Author: є');
gotoXY(5,11); Write('є є');
gotoXY(5,12); Write('є Cancel є');
gotoXY(5,13); Write('ИННННННННННННННННННННННННННННННј'); TextColor(4);
gotoXY(13,8); Write('n'); gotoXY(8,9); Write('Y');
gotoXY(8,10); Write('A'); gotoXY(8,12); Write('C'); TextColor(0);
n:=0; y:=0; a:='';
repeat
repeat
Ch:=readkey;
case UpCase(Ch) of
'N': begin gotoXY(21,8); Readln(n); end;
'Y': begin gotoXY(29,9); Readln(y); end;
'A': begin gotoXY(16,10); Readln(a); end;
'C': begin ClearWindow; Exit; end;
end;
until Ch = #13;
until (n<>0) or (a<>'') or (y<>0);
ClearWindow;
TextBackground(0); TextColor(7);
gotoXY(5,23); Write('Clear in memory/file'); TextColor(4);
gotoXY(14,23); Write('m'); gotoXY(21,23); Write('f'); TextColor(7);
j:=5; k:=5; i:=0;
LookThrough(c,1);
if (z<>0) then MoveCursor;
if z=0 then begin TextBackground(1); TextColor(128); gotoXY(5,15);
Write(' No cards found '); TextColor(7); TextBackground(0); end;
Readkey; ClearWindow;
end;

procedure Environment;
var i,j:Word;
begin
TextColor(7); TextBackground(0);
gotoXY(1,1);
Write('Й'); for i:=1 to 77 do Write('Н'); Writeln('»');
Write('є Search Input Card Exit');
for i:=1 to 51 do Write(' '); Writeln('є');
Write('М'); for i:=1 to 77 do Write('Н'); Writeln('№');
for i:=1 to 17 do begin
Write('є'); for j:=1 to 77 do Write(' '); Writeln('є');
end;
Write('М'); for i:=1 to 77 do Write('Н'); Writeln('№');
for i:=1 to 2 do begin
Write('є'); for j:=1 to 77 do Write(' '); Writeln('є');
end;
Write('И'); for i:=1 to 77 do Write('Н'); Writeln('ј');
TextColor(4); gotoXY(4,2); Write('S'); gotoXY(12,2); Write('I');
gotoXY(24,2); Write('E'); TextColor(7);
gotoXY(3,22); Write('Type marked letter to open section');
end;

procedure PreView;
var pv,c:Byte;
begin
Reset(f2); pv:=2; TextBackground(0);
while pv<9 do begin
if pv=4 then c:=6 else if pv=6 then c:=1 else
if pv=8 then c:=4 else c:=2; TextColor(c);
for i:=1 to 5 do begin
gotoXY(15,10+i);
if pv/2=int(pv/2) then begin Readln(f2,text); Writeln(text); end
else ClrEol;
end;
Inc(pv); gotoXY(1,24);
if Keypressed then Exit;
Delay(1000);
end;
end;

begin
clrscr;
Assign(f,'C:\pro6_dat.txt');
Assign(f1,'C:\pro6_da1.txt');
Assign(f2,'D:\BORLAND\BIN\pro6_int.txt');
PreView;
Environment;
c:=nil; p:=nil; q:=nil;
DataStructure;
while True do begin
Ch:=readkey;
case Upcase(Ch) of
'I': InputCard;
'E': begin clrscr; TextColor(7); TextBackground(0); Halt; end;
'S': Search;
end;
clrscr; Environment;
end;
end.