Nickolay.info. Îáó÷åíèå. Ó÷åáíèê ïî Ïàñêàëþ. Ïðèëîæåíèå 4 |
1. Ðåøåíèå ñèñòåìû ëèíåéíûõ àëãåáðàè÷åñêèõ óðàâíåíèé Ax=b ìåòîäîì Ãàóññà.
program Slau;
uses crt;
const size=30; {ìàêñèìàëüíî äîïóñòèìàÿ ðàçìåðíîñòü}
type matrix=array [1..size,1..size+1]
of real;
type vector=array [1..size] of real;
function GetNumber (s:string;
a,b:real):real;
{Ââîä ÷èñëà èç èíòåðâàëà a,b.
Åñëè a=b, òî ÷èñëî ëþáîå}
var n:real;
begin
repeat
write (s);
{$I-}readln (n);{$I+}
if (IoResult<>0) then
writeln ('Ââåäåíî íå ÷èñëî!')
else if (a<b) and ((n<a) or (n>b)) then
writeln ('×èñëî íå â èíòåðâàëå îò ',
a,' äî ',b)
else break;
until false;
GetNumber:=n;
end;
procedure GetMatrix (n,m:integer;
var a:matrix); {ââîä ìàòðèöû}
var i,j:integer; si,sj: string [3];
begin
for i:=1 to n do begin
str (i,si);
for j:=1 to m do begin
str (j,sj);
a[i,j]:=GetNumber ('a['+ si+ ','+ sj+
']=', 0,0);
end;
end;
end;
procedure GetVector (n:integer;
var a:vector); {ââîä âåêòîðà}
var i:integer; si:string [3];
begin
for i:=1 to n do begin
str (i,si);
a[i]:=GetNumber ('b['+si+']=',0,0);
end;
end;
procedure PutVector (n:integer;
var a:vector); {âûâîä âåêòîðà}
var i:integer;
begin
writeln;
for i:=1 to n do writeln (a[i]:10:3);
end;
procedure MV_Mult (n,m:integer;
var a:matrix;var x,b:vector);
{óìíîæåíèå ìàòðèöû íà âåêòîð}
var i,j:integer;
begin
for i:=1 to n do begin
b[i]:=0;
for j:=1 to m do b[i]:=b[i]+a[i,j]*x[j];
end;
end;
function Gauss (n:integer; var a:matrix;
var x:vector):boolean;
{ìåòîä Ãàóññà ðåøåíèÿ ÑËÀÓ}
{a - ðàñøèðåííàÿ ìàòðèöà ñèñòåìû}
const eps=1e-6; {òî÷íîñòü ðàñ÷åòîâ}
var i,j,k:integer;
r,s:real;
begin
for k:=1 to n do begin {ïåðåñòàíîâêà
äëÿ äèàãîíàëüíîãî ïðåîáëàäàíèÿ}
s:=a[k,k];
j:=k;
for i:=k+1 to n do begin
r:=a[i,k];
if abs(r)>abs(s) then begin
s:=r;
j:=i;
end;
end;
if abs(s)<eps then begin
{íóëåâîé îïðåäåëèòåëü, íåò ðåøåíèÿ}
Gauss:=false;
exit;
end;
if j<>k then
for i:=k to n+1 do begin
r:=a[k,i];
a[k,i]:=a[j,i];
a[j,i]:=r;
end; {ïðÿìîé õîä ìåòîäà}
for j:=k+1 to n+1 do a[k,j]:=a[k,j]/s;
for i:=k+1 to n do begin
r:=a[i,k];
for j:=k+1 to n+1 do
a[i,j]:=a[i,j]-a[k,j]*r;
end;
end;
if abs(s)>eps then begin {îáðàòíûé õîä}
for i:=n downto 1 do begin
s:=a[i,n+1];
for j:=i+1 to n do s:=s-a[i,j]*x[j];
x[i]:=s;
end;
Gauss:=true;
end
else Gauss:=false;
end;
var a,a1:matrix;
x,b,b1:vector;
n,i,j:integer;
begin
n:=trunc(GetNumber
('Ââåäèòå ðàçìåðíîñòü ìàòðèöû: ',2,size));
GetMatrix (n,n,a);
writeln ('Ââîä ïðàâîé ÷àñòè:');
GetVector (n,b);
for i:=1 to n do begin
{äåëàåì ðàñøèðåííóþ ìàòðèöó}
for j:=1 to n do a1[i,j]:=a[i,j];
a1[i,n+1]:=b[i];
end;
if Gauss (n,a1,x)=true then begin
write ('Ðåøåíèå:');
PutVector (n,x);
write ('Ïðîâåðêà:');
MV_Mult (n,n,a,x,b1);
PutVector (n,b1);
end
else write ('Ðåøåíèÿ íåò');
reset (input); readln;
end.
2. Ïðîöåäóðíî-îðèåíòèðîâàííàÿ ðåàëèçàöèÿ çàäà÷è ñîðòèðîâêè îäíîìåðíîãî ìàññèâà ïî âîçðàñòàíèþ.
program sort;
const size=100;
type vector=array [1..size] of real;
procedure GetArray (var n:integer;
var a:vector);
var i:integer;
begin
repeat
writeln ('Ââåäèòå ðàçìåðíîñòü ìàññèâà:');
{$I-}readln (n); {$I+}
if (IoResult<>0) or (n<2) or (n>size)
then writeln
('Ðàçìåðíîñòü äîëæíà áûòü îò 2 äî ',size);
until (n>1) and (n<size);
for i:=1 to n do begin
write (i,' ýëåìåíò=');
readln (a[i]);
end;
end;
procedure PutArray (n:integer;
var a:vector);
var i:integer;
begin
writeln;
for i:=1 to n do writeln (a[i]:10:3);
end;
procedure sortArray (n:integer;
var a:vector);
var i,j:integer; buf:real;
begin
for i:=1 to n do
for j:=i+1 to n do if a[i]>a[j] then begin
buf:=a[i]; a[i]:=a[j]; a[j]:=buf;
end;
end;
var a:vector;
n:integer;
begin
GetArray (n,a);
sortArray (n,a);
write ('Îòñîðòèðîâàííûé ìàññèâ:');
PutArray (n,a);
end.
3. Âû÷èñëåíèå âñåõ ìèíîðîâ âòîðîãî ïîðÿäêà â êâàäðàòíîé ìàòðèöå.
program minor2_count;
const size=10;
type Matrix= array [1..size,1..size]
of real;
function minor2 (n:integer;
i,j,l,k:integer; a:matrix):real;
begin
minor2:=a[i,j]*a[l,k]-a[l,j]*a[i,k];
end;
procedure Input2 (var n:integer;
maxn:integer; var a:matrix);
var i,j:integer;
begin
repeat
writeln;
write ('Ââåäèòå ðàçìåðíîñòü ìàòðèöû ',
'(îò 2 äî ',size,' âêëþ÷èòåëüíî):');
readln (n);
until (n>1) and (n<size);
for i:=1 to n do begin
writeln;
write ('Ââåäèòå ',i,' ñòðîêó ìàòðèöû:');
for j:=1 to n do read (a[i,j]);
end;
end;
var i,j,k,l,n:integer;
s:real;
a:matrix;
begin
Input2 (n,size,a);
for i:=1 to n do
for j:=1 to n do
for l:=i+1 to n do
for k:=j+1 to n do begin
s:=minor2 (n,i,j,l,k,a);
writeln;
writeln ('Ìèíîð [',i,',',j,']');
writeln (' [',l,',',k,']=',s:8:3);
end;
end.
4. Ó÷åáíàÿ áàçà äàííûõ "Ñòóäåíòû".
type student = record
{Îïðåäåëåíèå çàïèñè "Ñòóäåíò"}
name:string[20];
balls:array [1..4] of integer;
end;
const filename='students.dat';
{Èìÿ áàçû äàííûõ}
var s:student; {Òåêóùàÿ çàïèñü}
f:file of student; {Ôàéë áàçû äàííûõ}
kol,current:longint;
{Êîëè÷åñòâî çàïèñåé è òåêóùàÿ çàïèñü}
size:integer; {Ðàçìåð çàïèñè â áàéòàõ}
st1,st2:string;
{Áóôåðíûå ñòðîêè äëÿ äàííûõ}
procedure Warning (msg:string);
{Ñîîáùåíèå-ïðåäóïðåæäåíèå}
begin
writeln; writeln (msg);
write ('Íàæìèòå Enter äëÿ ïðîäîëæåíèÿ');
reset (input); readln;
end;
procedure out; {Çàêðûòèå áàçû è âûõîä}
begin
close (f); halt;
end;
procedure Error (msg:string);
{Ñîîáùåíèå îá îøèáêå + âûõîä èç ïðîãðàììû}
begin
writeln; writeln (msg);
write ('Íàæìèòå Enter äëÿ âûõîäà');
reset (input); readln; out;
end;
procedure open; {îòêðûòü, ïðè íåîáõîäèìîñòè
ñîçäàòü ôàéë çàïèñåé}
begin
assign (f,filename);
repeat
{$I-} reset (f); {$I+}
if IoResult <> 0 then begin
Warning
('Íå ìîãó îòêðûòü ôàéë '+filename+
'... Áóäåò ñîçäàí íîâûé ôàéë');
{$I-}rewrite (f);{$I+}
if IoResult <> 0 then
Error ('Íå ìîãó ñîçäàòü ôàéë! '+
'Ïðîâåðüòå ïðàâà è ñîñòîÿíèå äèñêà');
end
else break;
until false;
end;
procedure getsize (var kol:longint;
var size:integer);
{Âåðíåò òåêóùåå ÷èñëî çàïèñåé kol è
ðàçìåð çàïèñè â áàéòàõ size}
begin
reset (f);
size:=sizeof(student);
if filesize(f)=0 then kol:=0
else begin
seek(F, Filesize(F));
kol:=filepos (f);
end;
end;
function getname (s:string):string;
{Ïåðåâîäèò ñòðîêó â âåðõíèé ðåãèñòð
c ó÷åòîì êèðèëëèöû DOS}
var i,l,c:integer;
begin
l:=length(s);
for i:=1 to l do begin
c:=ord(s[i]);
if (c>=ord('à')) and (c<=ord('ï'))
then c:=c-32
else if (c>=ord('ð')) and (c<=ord('ÿ'))
then c:=c-80;
s[i]:=Upcase(chr(c));
end;
getname:=s;
end;
procedure prints;
{Âñïîìîãàòåëüíàÿ ïðîöåäóðà ïå÷àòè -
ïå÷àòàåò òåêóùóþ s}
var i:integer;
begin
write (getname(s.name),': ');
for i:=1 to 4 do begin
write (s.balls[i]);
if i<4 then write (',');
end;
writeln;
end;
procedure print (n:integer); {Âûâåñòè
çàïèñü íîìåð n (ñ ïåðåõîäîì ê íåé)}
begin
seek (f,n-1); read (f,s); prints;
end;
procedure go (d:integer); {Ïåðåéòè íà d
çàïèñåé ïî áàçå}
begin
writeln;
write ('Òåêóùàÿ çàïèñü: ');
if current=0 then writeln ('íåò')
else begin
writeln (current);
print (current);
end;
current:=current+d;
if current<1 then begin
Warning ('Íå ìîãó ïåðåéòè íà çàïèñü '+
'ñ íîìåðîì ìåíüøå 1');
if kol>0 then current:=1
else current:=0;
end
else if current>kol then begin
str (kol,st1);
Warning ('Íå ìîãó ïåðåéòè íà çàïèñü '+
'ñ íîìåðîì áîëüøå '+st1);
current:=kol;
end
else begin
writeln ('Íîâàÿ çàïèñü: ',current);
print (current);
end;
end;
procedure search;
{Ïîèñê çàïèñè â áàçå ïî ôàìèëèè}
var i,found,p:integer;
begin
if kol<1 then
Warning ('Áàçà ïóñòà! Èñêàòü íå÷åãî')
else begin
writeln;
write ('Ââåäèòå ôàìèëèþ (÷àñòü ôàìèëèè)',
' äëÿ ïîèñêà, ðåãèñòð ñèìâîëîâ ëþáîé:');
reset (input);
readln (st1);
st1:=getname(st1);
seek (f,0);
found:=0;
for i:=0 to kol-1 do begin
read (f,s);
p:=pos(st1,getname(s.name));
if p>0 then begin
writeln ('Çàïèñü íîìåð ',i+1);
prints;
found:=found+1;
if found mod 10 = 0 then
Warning ('Ïàóçà...');
{Ïàóçà ïîñëå âûâîäà 10 íàéäåííûõ}
end;
end;
if found=0 then
Warning ('Íè÷åãî íå íàéäåíî...');
end;
end;
procedure add;
{Äîáàâèòü çàïèñü â êîíåö áàçû}
var i,b:integer;
begin
repeat
writeln;
write ('Ââåäèòå ôàìèëèþ ñòóäåíòà ',
'äëÿ äîáàâëåíèÿ:');
reset (input);
readln (st1);
if length(st1)<1 then begin
Warning ('Ñëèøêîì êîðîòêàÿ ñòðîêà!'+
' Ïîâòîðèòå ââîä');
continue;
end
else if length(st1)>20 then begin
Warning ('Ñëèøêîì äëèííàÿ ñòðîêà! '+
'Áóäåò îáðåçàíà äî 20 ñèìâîëîâ');
st1:=copy (st1,1,20);
end;
s.name:=st1;
break;
until false;
for i:=1 to 4 do begin
repeat
writeln; {ñëåäîâàëî áû ïðåäóñìîòðåòü
âîçìîæíîñòü ââîäà íå âñåõ îöåíîê}
write ('Ââåäèòå îöåíêó ',i,' èç 4:');
{$I-}readln (b);{$I+}
if (IoResult<>0) or (b<2) or (b>5)
then begin
Warning ('Íåâåðíûé ââîä! Îöåíêà - '+
'ýòî ÷èñëî îò 2 äî 5! Ïîâòîðèòå.');
continue;
end
else begin
s.balls[i]:=b; break;
end;
until false;
end;
seek (f,filesize(f));
write (f,s); kol:=kol+1; current:=kol;
end;
procedure delete; {Óäàëåíèå òåêóùåé çàïèñè}
var f2:file of student; i:integer;
begin
if kol<1 then
Warning ('Áàçà ïóñòà! Óäàëÿòü íå÷åãî')
else begin
assign (f2,'students.tmp');
{$I-}rewrite(f2);{$I+}
if IoResult<>0 then begin
Warning ('Íå ìîãó îòêðûòü íîâûé ôàéë '+
'äëÿ çàïèñè!'+#13+#10+
' Îïåðàöèÿ íåâîçìîæíà. Ïðîâåðüòå '+
'ïðàâà äîñòóïà è òåêóùèé äèñê.');
Exit;
end;
seek (f,0);
for i:=0 to kol-1 do begin
if i+1<>current then begin
{ïåðåïèñûâàåì âñå çàïèñè, êðîìå òåêóùåé}
read (f,s); write (f2,s);
end;
end;
close (f); {çàêðûâàåì èñõîäíóþ ÁÄ}
erase (f); {Óäàëÿåì èñõîäíóþ ÁÄ,
ïðîâåðêà IoResult îïóùåíà!}
rename (f2,filename); {Ïåðåèìåíîâûâàåì f2
â èìÿ ÁÄ}
close (f2); {Çàêðûâàåì
ïåðåèìåíîâàííûé f2}
open; {Ñâÿçûâàåì ÁÄ ñ ïðåæíåé
ôàéëîâîé ïåðåìåííîé f}
kol:=kol-1;
if current>kol then current:=kol;
end;
end;
procedure sort;
{ñîðòèðîâêà áàçû ïî ôàìèëèè ñòóäåíòà}
var i,j:integer;
s2:student;
begin
if kol<2 then
Warning ('Â áàçå íåò 2-õ çàïèñåé!'+
' Ñîðòèðîâàòü íå÷åãî')
else begin
for i:=0 to kol-2 do begin
{Îáû÷íàÿ ñîðòèðîâêà}
seek (f,i); {òîëüêî â ó÷åáíûõ öåëÿõ -
ðàáîòàåò íåîïòèìàëüíî}
read (f,s);{è ìíîãî îáðàùàåòñÿ ê äèñêó!}
for j:=i+1 to kol-1 do begin
seek (f,j);
read (f,s2);
if getname(s.name)>getname(s2.name)
then begin
seek (f,i); write (f,s2);
seek (f,j); write (f,s);
s:=s2; {Ïîñëå ïåðåñòàíîâêè â s óæå
íîâàÿ çàïèñü!}
end;
end;
end;
end;
end;
procedure edit; {ðåäàêòèðîâàíèå çàïèñè
íîìåð current}
var i,b:integer;
begin
if (kol<1) or (current<1) or (current>kol)
then Warning ('Íåâåðíûé íîìåð '+
'òåêóùåé çàïèñè! Íå ìîãó ðåäàêòèðîâàòü')
else begin
seek (f,current-1);
read (f,s);
repeat
writeln ('Çàïèñü íîìåð ',current);
writeln ('Âûáåðèòå äåéñòâèå:');
writeln ('1. Ôàìèëèÿ (',s.name,')');
for i:=1 to 4 do
writeln (i+1,'. Îöåíêà ',i,
' (',s.balls[i],')');
writeln ('0. Çàâåðøèòü ðåäàêòèðîâàíèå');
reset (input);
{$I-}readln (b);{$I+}
if (IoResult<>0) or (b<0) or (b>5) then
Warning ('Íåâåðíûé ââîä! Ïîâòîðèòå')
else begin
if b=1 then begin
write ('Ââåäèòå íîâóþ ôàìèëèþ:');
{äëÿ ïðîñòîòû çäåñü íåò}
{ïðîâåðîê êîððåêòíîñòè}
reset (input); readln (s.name);
end
else if b=0 then break
else begin
write ('Ââåäèòå íîâóþ îöåíêó:');
reset (input); readln (s.balls[b-1]);
end;
end;
until false;
seek (f,current-1);
{Ïèøåì, äàæå åñëè çàïèñü íå ìåíÿëàñü -}
write (f,s); {â ðåàëüíûõ ïðîåêòàõ
òàê íå äåëàþò}
end;
end;
procedure menu; {Óïðàâëåíèå ãëàâíûì ìåíþ è
âûçîâ ïðîöåäóð}
var n:integer;
begin
repeat
writeln;
writeln ('Âûáåðèòå îïåðàöèþ:');
writeln ('1 - âïåðåä');
writeln ('2 - íàçàä');
writeln ('3 - ïîèñê ïî ôàìèëèè');
writeln ('4 - äîáàâèòü â êîíåö');
writeln ('5 - óäàëèòü òåêóùóþ');
writeln ('6 - ñîðòèðîâàòü ïî ôàìèëèè');
writeln ('7 - íà÷àëî áàçû');
writeln ('8 - êîíåö áàçû');
writeln ('9 - èçìåíèòü òåêóùóþ');
writeln ('0 - âûõîä');
reset (input);
{$I-}read (n);{$I+}
if (IoResult<>0) or (n<0) or (n>9)
then begin
Warning ('Íåâåðíûé ââîä!');
continue;
end
else break;
until false;
case n of
1: go (1);
2: go (-1);
3: search;
4: add;
5: delete;
6: sort;
7: go (-(current-1));
8: go (kol-current);
9: edit;
0: out;
end;
end;
begin {Ãëàâíàÿ ïðîãðàììà}
open;
getsize (kol,size);
str(kol,st1);
str(size,st2);
writeln;
writeln('==============================');
writeln('Ó÷åáíàÿ áàçà äàííûõ "Ñòóäåíòû"');
writeln('==============================');
Warning ('Ôàéë '+FileName+
' îòêðûò'+#13+#10+
'×èñëî çàïèñåé='+st1+#13+#10+
'Ðàçìåð çàïèñè='+st2+#13+#10);
{+#13+#10 - äîáàâèòü ê ñòðîêå ñèìâîëû
âîçâðàòà êàðåòêè è ïåðâîäà ñòðîêè}
if kol=0 then current:=0
else current:=1;
repeat
menu;
until false;
end.
5. Ïðîãðàììà ñîäåðæèò êîäû ÷àñòî èñïîëüçóåìûõ êëàâèø è ïå÷àòàåò èõ íàçâàíèÿ.
uses crt;
const ESC=#27; ENTER=#13; F1=#59;
F10=#68; TAB=#9; SPACE=#32;
UP=#72; DOWN=#80; LEFT=#75; RIGHT=#77;
HOME=#71; END_=#79;
PAGE_UP=#73; PAGE_DN=#81;
var ch:char;
begin
clrscr;
repeat
ch:=Upcase(readkey);
case ch of
'A'..'z': write ('Letter');
SPACE: write ('SPACE');
ENTER: write ('ENTER');
TAB: write ('TAB');
#0: begin
ch:=readkey;
case ch of
F1: write ('F1');
F10: write ('F10');
LEFT: write ('LEFT');
RIGHT: write ('RIGHT');
UP: write ('UP');
DOWN: write ('DOWN');
HOME: write ('HOME');
END_: write ('END');
PAGE_UP: write ('PgUp');
PAGE_DN: write ('PgDn');
end;
end;
else begin
end;
end;
until ch=Esc;
end.
6.1. Ïðîãðàììà ïîçâîëÿåò äâèãàòü ïî òåêñòîâîìó ýêðàíó "ïðèöåë" ñ ïîìîùüþ êëàâèø ñî ñòðåëêàìè.
uses crt;
{$V-} {îòêëþ÷èëè ñòðîãèé êîíòðîëü òèïîâ}
const ESC=#27; UP=#72; DOWN=#80;
LEFT=#75; RIGHT=#77;
var ch:char;
procedure Draw (x,y:integer;mode:boolean);
{mode îïðåäåëÿåò, íàðèñîâàòü èëè ñòåðåòü}
var sprite:array [1..3] of string [3];
{"ïðèöåë", çàäàííûé ìàññèâîì sprite}
i:integer;
begin
sprite[1]:='/|\';
sprite[2]:='-=-';
sprite[3]:='\|/';
if mode=true then textcolor (White)
else textcolor (Black);
for i:=y to y+2 do begin
gotoxy (x,i); write (sprite[i-y+1]);
end;
gotoxy (x+1,y+1);
end;
procedure status (n:integer; s:string);
{ðèñóåò ñòðîêó ñòàòóñà
âíèçó èëè ââåðõó ýêðàíà}
begin
textcolor (Black); textbackground (White);
gotoxy (1,n); write (' ':79);
gotoxy (2,n); write (s);
textcolor (White); textbackground (Black);
end;
var x,y:integer;
begin
textMode (cO80);
status (1,'Ïðèìåð óïðàâëåíèÿ äâèæåíèåì!');
status(25,'Ñòðåëêè-óïðàâëåíèå;ESC-âûõîä');
x:=10; y:=10;
repeat
Draw (x,y,true);
ch:=Upcase(readkey);
case ch of
#0: begin
ch:=readkey;
Draw (x,y,false);
case ch of
LEFT: if x>1 then x:=x-1;
RIGHT: if x<77 then x:=x+1;
UP: if y>2 then y:=y-1;
DOWN: if y<22 then y:=y+1;
end;
end;
end;
until ch=ESC;
clrscr;
end.
6.2. Ýòà âåðñèÿ ïðîãðàììû 6.1 ïîçâîëÿåò "ïðèöåëó" ïðîäîëæàòü äâèæåíèå äî òåõ ïîð, ïîêà îí íå íàòîëêíåòñÿ íà êðàé ýêðàíà.
uses crt;
{$V-}
const ESC=#27; UP=#72; DOWN=#80;
LEFT=#75; RIGHT=#77;
const goleft=1; GoRight=2; goup=3;
godown=4; gostop=0;
{âîçìîæíûå íàïðàâëåíèÿ äâèæåíèÿ}
const myDelay=1000; {çàäåðæêà äëÿ Delay}
var ch:char; LastDir:integer;
{ïîñëåäíåå íàïðàâëåíèå äâèæåíèÿ}
procedure Draw (x,y:integer;mode:boolean);
var sprite:array [1..3] of string [3];
i:integer;
begin
sprite[1]:='/|\';
sprite[2]:='-=-';
sprite[3]:='\|/';
if mode then textcolor (White)
else textcolor (Black);
for i:=y to y+2 do begin
gotoxy (x,i);
write (sprite[i-y+1]);
end;
gotoxy (x+1,y+1);
end;
procedure status (n:integer; s:string);
begin
textcolor (Black); textbackground (White);
gotoxy (1,n); write (' ':79);
gotoxy (2,n); write (s);
textcolor (White); textbackground (Black);
end;
var x,y:integer;
begin
clrscr;
status(1,'Óïðàâëåíèå äâèæåíèåì-2');
status(25,'Ñòðåëêè-óïðàâëåíèå;ESC-âûõîä');
x:=10; y:=10; LastDir:=goleft;
repeat {áåñêîíå÷íûé öèêë ðàáîòû ïðîãðàììû}
repeat {öèêë äî íàæàòèÿ êëàâèøè}
Draw (x,y,true); Delay (myDelay);
Draw (x,y,false);
case LastDir of
goLeft:
if x>1 then Dec(x)
else begin
x:=1; LastDir:=gostop;
end;
GoRight:
if x<77 then inc(x)
else begin
x:=77; LastDir:=gostop;
end;
goUp:
if y>2 then Dec(y)
else begin
y:=2; LastDir:=gostop;
end;
goDown:
if y<22 then inc(y)
else begin
y:=22; LastDir:=gostop;
end;
end;
until keyPressed;
{îáðàáîòêà íàæàòèÿ êëàâèøè}
ch:=Upcase(readkey);
case ch of
#0: begin
ch:=readkey;
case ch of
LEFT: LastDir:=goLeft;
RIGHT: LastDir:=GoRight;
UP: LastDir:=goUp;
DOWN: LastDir:=goDown;
end;
end;
ESC: halt;
end;
until false;
end.
7. Äåìî-ïðîãðàììà äëÿ ñîçäàíèÿ íåñëîæíîãî äâóõóðîâíåâîãî ìåíþ ïîëüçîâàòåëÿ. Ïåðåîïðåäåëèâ ïîëüçîâàòåëüñêóþ ÷àñòü ïðîãðàììû, íà åå îñíîâå ìîæíî ñîçäàòü ñîáñòâåííûé êîíñîëüíûé èíòåðôåéñ.
uses crt; { Ãëîáàëüíûå äàííûå: }
const maxmenu=2; {êîëè÷åñòâî ìåíþ}
maxpoints=3; {ìàêñ. êîëè÷åñòâî ïóíêòîâ}
var x1,x2,y: array [1..maxmenu] of integer;
{x1,x2- íà÷àëî è êîíåö êàæäîãî ìåíþ,
y- ñòðîêà íà÷àëà êàæäîãî ìåíþ}
kolpoints, points: array [1..maxmenu] of
integer;{Êîë-âî ïóíêòîâ è òåêóùèå ïóíêòû }
text: array [1..maxmenu,1..maxpoints]
of string[12]; { Íàçâàíèÿ ïóíêòîâ }
txtcolor, textback, cursorback:integer;
{ Öâåòà òåêñòà, ôîíà, êóðñîðà}
mainhelp:string[80]; { Ñòðîêà ïîìîùè }
procedure DrawMain (s:string); {Î÷èùàåò
ýêðàí, ðèñóåò ñòðîêó ãëàâíîãî ìåíþ s }
begin Window (1,1,80,25);
textcolor (txtcolor);
textbackground (textback);
clrscr; gotoxy (1,1); write (s);
end;
procedure DrawHelp (s:string);
{ Âûâîäèò ïîäñêàçêó s }
var i:integer; begin
textcolor (txtcolor);
textbackground (textback); gotoxy (1,25);
for i:=1 to 79 do write (' ');
gotoxy (1,25); write (s);
end;
procedure doubleFrame (x1,y1,x2,y2:integer;
Header: string);
{ Ïðîöåäóðà ðèñóåò äâîéíîé ðàìêîé îêíî }
var i,j: integer;
begin gotoxy (x1,y1);
write ('╔');
for i:=x1+1 to x2-1 do write('═');
write ('╗');
for i:=y1+1 to y2-1 do begin
gotoxy (x1,i); write('║');
for j:=x1+1 to x2-1 do write (' ');
write('║');
end;
gotoxy (x1,y2); write('╚');
for i:=x1+1 to x2-1 do write('═');
write('╝');
gotoxy (x1+(x2-x1+1-Length(Header))
div 2,y1);
write (Header); {Âûâîäèì çàãîëîâîê}
gotoxy (x1+1,y1+1);
end;
procedure clearFrame (x1,y1,x2,y2:integer);
var i,j:integer;
begin textbackground (textback);
for i:=y1 to y2 do begin
gotoxy (x1,i);
for j:=x1 to x2 do write (' ');
end;
end;
procedure cursor (Menu,Point: integer;
Action: boolean);{ Ïîäñâå÷èâàåò (åñëè
Action=true) èëè ãàñèò ï. Point ìåíþ Menu}
begin textcolor (Txtcolor);
if Action=true then
textbackground (cursorBack)
else textbackground (textBack);
gotoxy (x1[Menu]+1,y[Menu]+Point);
write (text[Menu][Point]);
end;
procedure DrawMenu (Menu:integer;
Action: boolean);{Ðèñóåò ìåíþ ñ íîìåðîì
Menu, åñëè Action=true, èíà÷å ñòèðàåò }
var i:integer;
begin
if Action=true then textcolor (Txtcolor)
else textcolor (textBack);
textbackground (textBack);
doubleFrame (x1[Menu], y[Menu], x2[Menu],
y[Menu]+1+KolPoints[Menu],'');
for i:=1 to KolPoints[Menu] do begin
gotoxy (x1[Menu]+1, y[Menu]+i);
writeln (text[Menu][i]);
end;
end;
{×àñòü, îïðåäåëÿåìàÿ ïîëüçîâàòåëåì}
procedure Init; { Óñòàíîâêà ãëîáàëüíûõ
äàííûõ è íà÷àëüíàÿ îòðèñîâêà }
begin
txtcolor:=yELLOW; textback:=BLUE;
cursorback:=LIGHTcyAN;
kolpoints[1]:=2; kolpoints[2]:=1;
{ïóíêòîâ â êàæäîì ìåíþ}
points[1]:=1; points[2]:=1;
{âûáðàí ïî óìîë÷àíèþ â êàæäîì ìåíþ}
x1[1]:=1; x2[1]:=9; y[1]:=2;
text[1,1]:='Çàïóñê'; text[1,2]:='Âûõîä ';
x1[2]:=9; x2[2]:=22; y[2]:=2;
text[2,1]:='Î ïðîãðàììå';
DrawMain ('Ôàéë Ñïðàâêà');
MainHelp:='ESC - Âûõîä èç ïðîãðàììû '+
'ENTER - âûáîð ïóíêòà ìåíþ '+
'Ñòðåëêè - ïåðåìåùåíèå';
DrawHelp(MainHelp);
end;
procedure Work; { Ðàáî÷àÿ ïðîöåäóðà }
var i,kol:integer; ch:char;
begin
DrawHelp('Èäåò ðàñ÷åò...');
{ Ñòðîêà ñòàòóñà }
textcolor (LIGHTGRAY);
textbackground (BLACK);
{ Âûáèðàåì öâåòà äëÿ ðàáîòû â îêíå }
doubleFrame (2,2,78,24,' Ðàñ÷åò ');
Window (3,3,77,23);
{Ñåêöèÿ äåéñòâèé, âûïîëíÿåìûõ ïðîãðàììîé}
writeln;
write ('Ââåäèòå ÷èñëî øàãîâ: ');
{$I-}read (kol);{$I+}
if IoResult<>0 then writeln
('Îøèáêà! Âû ââåëè íå ÷èñëî')
else if kol>0 then begin
for i:=1 to kol do
writeln ('Âûïîëíÿåòñÿ øàã ',i);
writeln ('Âñå ñäåëàíî!');
end
else writeln ('Îøèáêà! ×èñëî áîëüøå 0');
{Âîññòàíîâëåíèå îêíà è âûõîä}
Window (1,1,80,25);
DrawHelp('Íàæìèòå ëþáóþ êëàâèøó...');
ch:=readkey;
clearFrame (2,2,78,24); { Ñòèðàåì îêíî }
end;
procedure Out; { Î÷èñòêà ýêðàíà è âûõîä}
begin
textcolor (LIGHTGRAY);
textbackground (BLACK); clrscr; halt(0);
end;
procedure Help; {Îêíî ñ èíôîðìàöèåé}
var ch:char;
begin
textcolor (Txtcolor);
textbackground (textback);
doubleFrame (24,10,56,13,' Î ïðîãðàììå ');
DrawHelp ('Íàæìèòå êëàâèøó...');
gotoxy (25,11);
writeln(' Äåìîíñòðàöèÿ ïðîñòåéøåãî ìåíþ');
gotoxy (25,12);
write ( ' Íîâîñèáèðñê, ÍÃÀÑÓ');
ch:=readkey;
clearFrame (24,10,58,13);
end;
procedure command (Menu,Point:integer);
{Âûçûâàåò ïðîöåäóðû ïîñëå âûáîðà â ìåíþ }
begin
if Menu=1 then begin
if Point=1 then Work
else if Point=2 then Out;
end
else begin
if Point=1 then Help;
end;
end;
{Êîíåö ÷àñòè ïîëüçîâàòåëÿ }
procedure MainMenu (Point,
HorMenu:integer); { Ïîääåðæèâàåò ñèñòåìó
îäíîóðîâíåâûõ ìåíþ }
var ch: char; funckey:boolean;
begin
Points[HorMenu]:=Point;
DrawMenu (HorMenu,true);
repeat
cursor (HorMenu,Points[HorMenu],true);
ch:=readkey;
cursor (HorMenu,Points[HorMenu],false);
if ch=#0 then begin
funckey:=true; ch:=readkey;
end
else funckey:=false;
if funckey=true then begin
ch:=Upcase (ch);
if ch=#75 then begin { Ñòðåëêà âëåâî }
DrawMenu (HorMenu,false);
HorMenu:=HorMenu-1;
if (HorMenu<1) then HorMenu:=maxMenu;
DrawMenu (HorMenu,true);
end
else if ch=#77 then begin
{ Ñòðåëêà âïðàâî }
DrawMenu (HorMenu,false);
HorMenu:=HorMenu+1;
if (HorMenu>maxMenu) then HorMenu:=1;
DrawMenu (HorMenu,true);
end
else if ch=#72 then begin
{ Ñòðåëêà ââåðõ }
Points[HorMenu]:=Points[HorMenu]-1;
if Points[HorMenu]<1 then
Points[HorMenu]:=Kolpoints[HorMenu];
end
else if ch=#80 then begin
{ Ñòðåëêà âíèç }
Points[HorMenu]:=Points[HorMenu]+1;
if (Points[HorMenu]>KolPoints[HorMenu])
then Points[HorMenu]:=1;
end;
end
else if ch=#13 then begin
{ Êëàâèøà ENTER }
DrawMenu (HorMenu,false);
command (HorMenu,Points[HorMenu]);
DrawMenu (HorMenu,true);
DrawHelp (MainHelp);
end;
until (ch=#27) and (funckey=false);
{ Ïîêà íå íàæàòà êëàâèøà ESC }
end;
{ Îñíîâíàÿ ïðîãðàììà }
begin
Init;
MainMenu (1,1);
Out;
end.
8. Ïðîñòåéøèé "ãåíåðàòîð" ïðîãðàììû íà Ïàñêàëå. Èç âõîäíîãî ôàéëà, ñîäåðæàùåãî òåêñò, ãåíåðèðóåòñÿ ïðîãðàììà äëÿ ëèñòàíèÿ ýòîãî òåêñòà.
program str2Pas;
uses crt; label 10,20;
var ch:char;str:string;
I,J,Len,count:word; InFile,OutFile:text;
procedure Error (ErNum:char);
begin
case ErNum of
#1: writeln
('Çàïóñêàéòå ñ 2 ïàðàìåòðàìè -',#13,#10,
'èìåíàìè âõîäíîãî è âûõîäíîãî ôàéëà.',
#13,#10,
'Âî âõîäíîì ôàéëå ñîäåðæèòñÿ òåêñò',
#13,#10,
'â îáû÷íîì ASCII-ôîðìàòå,',#13,#10,
'â âûõîäíîì áóäåò ïðîãðàììà íà Ïàñêàëå');
#2:
writeln
(' Íå ìîãó îòêðûòü âõîäíîé ôàéë!');
#3:
writeln
(' Íå ìîãó îòêðûòü âûõîäíîé ôàéë!');
else writeln (' Íåèçâåñòíàÿ îøèáêà!');
end;
halt;
end;
begin
if Paramcount<>2 then Error (#1);
assign (InFile,Paramstr(1));
reset (InFile);
if (IoResult<>0) then Error (#2);
assign (OutFile,Paramstr(2));
rewrite (OutFile);
if (IoResult<>0) then Error (#3);
{ Âïèñàòü çàãîëîâîê ïðîãðàììû }
writeln (OutFile,'uses crt;');
write (OutFile,'const colstr=');
{ Óçíàòü ÷èñëî ñòðîê òåêñòà }
count:=0;
while not Eof (InFile) do begin
readLn (InFile,str);
count:=count+1;
end;
reset (InFile);
writeln (OutFile,count,';');
{ Ñëåäóþùèé ñåãìåíò ïðîãðàììû: }
writeln (OutFile,'var ch:char;');
writeln (OutFile,' List:boolean;');
writeln (OutFile,
' I,start,endstr:word;');
writeln (OutFile,
' ptext:array [1..colstr] of string;');
writeln (OutFile,'begin');
{ Ñòðîêè ëèñòàåìîãî òåêñòà: }
for I:=1 to count do begin
Len:=0;
repeat
if (Eof (InFile)=true) then goto 10;
read (InFile,ch);
if ch=#39 then begin
Len:=Len+1; str[Len]:=#39;
Len:=Len+1; str[Len]:=#39;
end
else if ch=#13 then begin
read (InFile,ch);
if (ch=#10) then goto 10
else goto 20;
end
else begin
20:
Len:=Len+1; str[Len]:=ch;
end;
until false;
10:
write (OutFile,' ptext[',I,']:=''');
for J:=1 to Len do
write (OutFile,str[J]);
writeln (OutFile,''';');
end;
{ Ñåãìåíò ïðîãðàììû }
writeln (OutFile,' textcolor (YELLOW);');
writeln (OutFile,
' textbackground (Blue);');
writeln (OutFile,
' List:=true; start:=1;');
{ Ïîñëåäíÿÿ ñòðîêà íà ýêðàíå: }
if (count>25) then
writeln (OutFile,' endstr:=25;')
else writeln (OutFile,' endstr:=colstr;');
writeln (OutFile,' repeat');
writeln (OutFile,
' if (List=true) then begin');
writeln (OutFile,' clrscr;');
writeln (OutFile,
' for I:=start to endstr-1 do ',
'write (ptext[I],#13,#10);');
writeln (OutFile,
' write (ptext[endstr]);');
writeln (OutFile,' List:=false;');
writeln (OutFile,' end;');
writeln (OutFile,' ch:=readkey;');
writeln (OutFile,
' if ch= #0 then begin');
writeln (OutFile,' ch:=readkey;');
writeln (OutFile,' case ch of');
writeln (OutFile,' #72: begin');
writeln (OutFile,
' if start>1 then begin');
writeln (OutFile,' start:=start-1;');
writeln (OutFile,
' endstr:=endstr-1;');
writeln (OutFile,' List:=true;');
writeln (OutFile,' end;');
writeln (OutFile,' end;');
writeln (OutFile,' #80: begin');
writeln (OutFile,
' if endstr<colstr then begin');
writeln (OutFile,' start:=start+1;');
writeln (OutFile,
' endstr:=endstr+1;');
writeln (OutFile,' List:=true;');
writeln (OutFile,' end;');
writeln (OutFile,' end;');
{ Ëèñòàíèå PgUp è PgDn }
if (count>25) then begin
writeln (OutFile,' #73: begin');
writeln (OutFile,
' if start>1 then begin');
writeln (OutFile,
' start:=1; endstr:=25;');
writeln (OutFile,' List:=true;');
writeln (OutFile,' end;');
writeln (OutFile,' end;');
writeln (OutFile,' #81: begin');
writeln (OutFile,
' if endstr<colstr then begin');
writeln (OutFile,
' start:=colstr-24; endstr:=colstr;');
writeln (OutFile,' List:=true;');
writeln (OutFile,' end;');
writeln (OutFile,' end;');
end;
{ Çàêëþ÷èòåëüíûé ñåãìåíò }
writeln (OutFile,' else begin end;');
writeln (OutFile,' end;');
writeln (OutFile,' end');
writeln (OutFile,' else begin');
writeln (OutFile,' case ch of');
writeln (OutFile,' #27: begin');
writeln (OutFile,
' textcolor (LightGray);');
writeln (OutFile,
' textbackground (Black);');
writeln (OutFile,' clrscr;');
writeln (OutFile,' halt;');
writeln (OutFile,' end;');
writeln (OutFile,' else begin');
writeln (OutFile,' end;');
writeln (OutFile,' end;');
writeln (OutFile,' end;');
writeln (OutFile,' until false;');
writeln (OutFile,'end.');
close (InFile); close (OutFile);
writeln ('OK.');
end.
9. Øàáëîí ïðîãðàììû äëÿ ðàáîòû ñ ìàòðèöàìè è òåêñòîâûìè ôàéëàìè.
program Files;{ Ïðîãðàììà äåìîíñòðèðóåò
ðàáîòó ñ òåêñòîâûìè ôàéëàìè è ìàòðèöàìè }
const rows=10; cols=10;
type matrix=array [1..rows,1..cols]
of real;
var f1,f2:text; a,b:matrix;
Name1,Name2:string; n,m:integer;
procedure Error (msg:string);
begin
writeln; writeln (msg);
writeln ('Íàæìèòå Enter äëÿ âûõîäà');
reset (Input); readln; halt;
end;
procedure readDim (var f:text;
var n,m:integer);{ ×èòàåò èç ôàéëà f
ðàçìåðíîñòè ìàòðèöû: n - ÷èñëî ñòðîê,
m - ÷èñëî ñòîëáöîâ. Åñëè n<0 èëè n>rows
(÷èñëî ñòðîê) èëè m<0 èëè m>cols (÷èñëî
ñòîëáöîâ), ïðåðâåò ðàáîòó. }
var s:string;
begin
{$I-}read (f,n);{$I+}
if (IoResult<>0) or (n<0) or (n>rows)
then begin
str (rows,s);
Error ('Íåâåðíîå ÷èñëî ñòðîê '+
'â ôàéëå äàííûõ!'+#13+#10+
'äîëæíî áûòü îò 1 äî '+s);
end;
{$I-}read (f,m);{$I+}
if (IoResult<>0) or (m<0) or (m>cols)
then begin
str (cols,s);
Error ('Íåâåðíîå ÷èñëî ñòîëáöîâ '+
'â ôàéëå äàííûõ!'+#13+#10+
'äîëæíî áûòü îò 1 äî '+s);
end;
end;
procedure readMatrix (var f:text;
n,m:integer; var a:matrix);
{ ×èòàåò èç ôàéëà f ìàòðèöó a
ðàçìåðíîñòüþ n*m }
var i,j:integer; er:boolean;
begin
er:=false;
for i:=1 to n do
for j:=1 to m do begin
{$I-}read (f,a[i,j]);{$I+}
if IoResult<>0 then begin
er:=true; a[i,j]:=0;
end;
end;
if er=true then begin
writeln;
writeln
(' ïðî÷èòàííûõ äàííûõ åñòü îøèáêè!');
writeln ('Íåâåðíûå ýëåìåíòû ìàòðèöû',
' çàìåíåíû íóëÿìè');
end;
end;
procedure writeMatrix (var f:text;
n,m:integer; var a:matrix);
{ Ïèøåò â ôàéë f ìàòðèöó a[n,m] }
var i,j:integer;
begin
for i:=1 to n do begin
for j:=1 to m do write (f,a[i,j]:11:4);
writeln (f);
end;
end;
procedure Proc1 (n,m:integer;
var a,b:matrix);
{ Ìàòðèöó a[n,m] ïèøåò â ìàòðèöó b[n,m],
ìåíÿÿ çíàêè ýëåìåíòîâ }
var i,j:integer;
begin
for i:=1 to n do
for j:=1 to m do b[i,j]:=-a[i,j]
end;
begin
if Paramcount<1 then begin
writeln ('Èìÿ ôàéëà äëÿ ÷òåíèÿ:');
readLn (Name1);
end
else Name1:=Paramstr(1);
if Paramcount<2 then begin
writeln ('Èìÿ ôàéëà äëÿ çàïèñè:');
readLn (Name2);
end
else Name2:=Paramstr(2);
assign (f1,Name1);
{$I-}reset (f1);{$I+}
if IoResult<>0 then
Error ('Íå ìîãó îòêðûòü '+Name1+
' äëÿ ÷òåíèÿ');
assign (f2,Name2);
{$I-}rewrite (f2);{$I+}
if IoResult<>0 then
Error ('Íå ìîãó îòêðûòü '+Name2+
' äëÿ çàïèñè');
readDim (f1,n,m);
readMatrix (f1,n,m,a);
Proc1 (n,m,a,b);
writeMatrix (f2,n,m,b);
close (f1); close (f2);
end.
10. Ïîäñ÷åò êîëè÷åñòâà äíåé îò ââåäåííîé äàòû äî ñåãîäíÿøíåãî äíÿ.
program Days;
uses Dos;
const mondays: array [1..12] of integer =
(31,28,31, 30,31,30, 31,31,30, 31,30,31);
var d,d1,d2,m1,m2,y1,y2:word;
function Leapyear (year:word):boolean;
begin
if (year mod 4 =0) and (year mod 100 <>0)
or (year mod 400 =0) then Leapyear:=true
else Leapyear:=false;
end;
function correctDate
(day,mon,year:integer):boolean;
var maxday:integer;
begin
if (year<0) or (mon<1) or (mon>12) or
(day<1) then correctDate:=false
else begin
maxday:=mondays[mon];
if (Leapyear (year)=true) and (mon=2)
then maxday:=29;
if (day>maxday) then correctDate:=false
else correctDate:=true;
end;
end;
function KolDays (d1,m1,d2,m2,y:word):word;
var i,f,s:word;
begin
s:=0;
if m1=m2 then KolDays:=d2-d1
else for i:=m1 to m2 do begin
f:=mondays[i];
if (Leapyear (y)=true) and (i=2)
then f:=f+1;
if i=m1 then s:=s+(f-d1+1)
else if i=m2 then s:=s+d2
else s:=s+f;
KolDays:=s;
end;
end;
function countDays (day1, mon1, year1,
day2, mon2, year2:word):word;
var f,i:word;
begin
f:=0;
if year1=year2 then countDays:=
KolDays (day1, mon1, day2, mon2, year1)
else for i:=year1 to year2 do begin
if i=year1 then f:=
KolDays (day1, mon1, 31, 12, year1)
else if i=year2 then f:=f+
KolDays (1,1,day2,mon2,year2)-1
else f:=f+KolDays (1,1,31,12,i);
countDays:=f;
end;
end;
begin
getdate (y2,m2,d2,d);
writeln ('Ãîä Âàøåãî ðîæäåíèÿ?');
readln (y1);
writeln ('Ìåñÿö Âàøåãî ðîæäåíèÿ?');
readln (m1);
writeln ('Äåíü Âàøåãî ðîæäåíèÿ?');
readln (d1);
if correctDate (d1,m1,y1)=false then begin
writeln ('Íåäîïóñòèìàÿ äàòà!'); halt;
end;
if (y2<y1) or ( (y2=y1) and
( (m2<m1) or ( (m2=m1) and (d2<d1))))
then begin writeln ('Ââåäåííàÿ äàòà',
' ïîçäíåå ñåãîäíÿøíåé!'); halt;
end;
d:=countDays (d1,m1,y1,d2,m2,y2);
writeln ('Êîëè÷åñòâî äíåé= ',d);
end.
11.1. Èñõîäíûé òåêñò ìîäóëÿ äëÿ ïîääåðæêè ìûøè.
unit Mouse;
{Ïðèìåðû èñïîëüçîâàíèÿ -
ñì. mousetst.pas â ãðàôèêå,
mousetxt.pas â òåêñòîâîì ðåæèìå 80*25}
interface
var MousePresent:boolean;
function MouseInit(var nb:integer):boolean;
{ Èíèöèàëèçàöèÿ ìûøè - âûçûâàòü ïåðâîé.
Âåðíåò true, åñëè ìûøü îáíàðóæåíà }
procedure Mouseshow; {Ïîêàçàòü êóðñîð ìûøè}
procedure MouseHide; {Ñêðûòü êóðñîð ìûøè}
procedure Mouseread(var x,y,bMask:integer);
{Ïðî÷èòàòü ïîçèöèþ ìûøè.
Âåðíåò ÷åðåç x,y êîîðäèíàòû êóðñîðà
(äëÿ òåêñòîâîãî ðåæèìà ñì. ïðèìåð),
÷åðåç bmask - ñîñòîÿíèå êíîïîê
(0-îòïóùåíû,1-íàæàòà ëåâàÿ,2-íàæàòà ïðàâàÿ,
3-íàæàòû îáå) }
procedure MousesetPos(x,y:word);
{Ïîñòàâèòü êóðñîð â óêàçàííóþ ïîçèöèþ}
procedure Mouseminxmaxx(minx,maxx:integer);
{Óñòàíîâèòü ãðàíèöû ïåðåìåùåíèÿ ïî x}
procedure Mouseminymaxy(miny,maxy:integer);
{Óñòàíîâèòü ãðàíèöû ïåðåìåùåíèÿ ïî y}
procedure setVideoPage(Page:integer);
{Óñòàíîâèòü íóæíóþ âèäåîñòðàíèöó}
procedure GetVideoPage(var Page:integer);
{Ïîëó÷èòü íîìåð âèäåîñòðàíèöû}
function MouseGetb(bMask:word; var count,
Lastx, Lasty:word):word;
procedure MousekeyPreset
(var key,sost,x,y:integer);
implementation
uses Dos;
var r: registers;
Mi:pointer;
function MouseInit(var nb:integer):boolean;
begin
if MousePresent then begin
r.Ax:=0; Intr($33,r);
if r.Ax=0 then begin
nb:=0; MouseInit:=false
end
else begin
nb:=r.Ax; MouseInit:=true
end
end
else begin
nb:=0; MouseInit:=false
end
end;
procedure Mouseshow;
begin
r.Ax:=1; Intr($33,r)
end;
procedure MouseHide;
begin
r.Ax:=2; Intr($33,r)
end;
procedure Mouseread(var x,y,bMask:integer);
begin
r.Ax:=3; Intr($33,r);
x:=r.cx; y:=r.dx; bMask:=r.Bx
end;
procedure MousesetPos(x,y:word);
begin
r.Ax:=4; r.cx:=x; r.dx:=y;
Intr($33,r)
end;
function MouseGetb(bMask:word;
var count,Lastx,Lasty:word):word;
begin
r.Ax:=5; r.Bx:=bMask;Intr($33,r);
count:=r.Bx; Lastx:=r.cx;
Lasty:=r.dx; MouseGetb:=r.Ax
end;
procedure Mouseminxmaxx(minx,maxx:integer);
begin
r.Ax:=7; r.cx:=minx;
r.dx:=maxx; Intr($33,r)
end;
procedure Mouseminymaxy(miny,maxy:integer);
begin
r.Ax:=8; r.cx:=miny;
r.dx:=maxy; Intr($33,r)
end;
procedure setVideoPage(Page:integer);
begin
r.Ax:=$1D; r.Bx:=Page; Intr($33,r)
end;
procedure GetVideoPage(var Page:integer);
begin
r.Ax:=$1E; Intr($33,r); Page:=r.Bx;
end;
procedure MousekeyPreset
(var key,sost,x,y:integer);
begin
r.Ax:=$6; r.Bx:=key; Intr($33,r);
key:=r.Ax; sost:=r.Bx;
x:=r.cx; y:=r.dx;
end;
begin
GetIntVec($33,Mi);
if Mi=nil then
MousePresent:=false
else if byte(Mi^)=$cE then
MousePresent:=false
else MousePresent:=true
end.
11.2. Òåñò ìîäóëÿ mouse.pas â ãðàôè÷åñêîì ðåæèìå (mousetst.pas).
program MouseTst;
uses graph,Mouse,crt;
var grDriver : integer; grMode : integer;
Errcode : integer;
procedure init;
begin
grDriver:=VGA;grMode:=VGAHi;
initgraph(grDriver, grMode, '');
Errcode:=graphresult;
if Errcode <> grOk then begin
writeln('Îøèáêà èíèöèàëèçàöèè ãðàôèêè:',
grapherrormsg(Errcode)); halt;
end;
end;
var n,x,y,x0,y0,b:integer; s1,s2:string;
begin
init;
mouseinit(n);
mouseshow;
setfillstyle (solidfill,BLACK);
setcolor (WHITE);
settextJustify(centertext, centertext);
x0:=-1; y0:=-1;
repeat
mouseread (x,y,b);
if (x<>x0) or (y<>y0) then begin
str (x,s1); str (y,s2);
bar (getmaxx div 2-50,
getmaxy-15,getmaxx div 2+50,getmaxy-5);
outtextxy (getmaxx div 2,
getmaxy-10,s1+' '+s2);
x0:=x; y0:=y;
end;
until keypressed;
mousehide;
closegraph;
end.
11.3. Òåñò ìîäóëÿ mouse.pas â òåêñòîâîì ðåæèìå (mousetxt.pas).
program MouseTxt;
uses crt,mouse;
var n,x,y,b:integer;
n1,k,lastx,lasty:word;
begin
textmode(3);
mouseinit (n);
mouseshow;
repeat
mouseread (x,y,b);
gotoxy (1,25);
write ('x=',(x div 8 + 1):2,
' y=',(y div 8 + 1):2,' b=',b:2);
until keypressed;
mousehide;
end.
12.1. Ó÷åáíàÿ èãðà, èñïîëüçóþùàÿ ñîáñòâåííûé ôàéë ðåñóðñîâ. Ïåðâûé ëèñòèíã ñîäåðæèò óòèëèòó äëÿ ñîçäàíèÿ ôàéëà ðåñóðñîâ resfile èç ôàéëîâ *.bmp òåêóùåé äèðåêòîðèè, ñïèñîê êîòîðûõ íàõîäèòñÿ â ôàéëå filelist.txt. Ôàéëû *.bmp äîëæíû áûòü ñîõðàíåíû â ðåæèìå 16 öâåòîâ. Ïðè íåîáõîäèìîñòè ñëåäóåò èçìåíèòü â ïðîãðàììå êîíñòàíòó ïóòè ê Ïàñêàëþ.
uses graph,crt;
const VGAPath='c:\TP7\egavga.bgi';
FileList='filelist.txt';
resfile='attack.res';
const width=32; height=20;
const color: array [0..15] of byte=
(0,4,2,6,1,5,3,7,8,12,10,14,9,13,11,15);
const maxx=639; maxy=479;
cx=MAxx div 2; cy=maxy div 2;
type bmpinfo=record
h1,h2:char;
size,reserved,offset,b,width,
height: longint;
plans,bpp:word;
end;
var Driver, Mode: integer;
DriverF: file; List,res:text;
DriverP: pointer; s:string;
procedure Wait;
var ch:char;
begin
reset (Input); repeat until keyPressed;
ch:=readkey; if ch=#0 then readkey;
end;
procedure closeMe;
begin
if DriverP <> nil then begin
FreeMem(DriverP, Filesize(DriverF));
close (DriverF);
end;
closegraph;
end;
procedure graphError;
begin
closeMe;
writeln('graphics error:',
grapherrormsg(graphresult));
writeln('Press any key to halt ');
Wait;
halt (graphresult);
end;
procedure InitMe;
begin
assign(DriverF, VGAPath);
reset(DriverF, 1);
getmem(DriverP, Filesize(DriverF));
Blockread(DriverF, DriverP^,
Filesize(DriverF));
if registerBGIdriver(DriverP)<0 then
graphError;
Driver:=VGA; Mode:=VGAHi;
initgraph(Driver, Mode,'');
if graphresult < 0 then graphError;
end;
procedure clearscreen;
begin
setfillstyle (solidfill, White);
bar (0,0,maxx,maxy);
end;
procedure Window
(x1,y1,x2,y2,color,Fillcolor:integer);
begin
setcolor (color);
setfillstyle (1,Fillcolor);
bar (x1,y1,x2,y2);
rectangle (x1+2,y1+2,x2-2,y2-2);
rectangle (x1+4,y1+4,x2-4,y2-4);
setfillstyle (1,DArKGrAy);
bar (x1+8,y2+1,x2+8,y2+8);
bar (x2+1,y1+8,x2+8,y2);
end;
procedure Error (code:integer; str:string);
begin
Window (cx-140,cy-100,cx+140,
cy-70,Black,YELLOW);
case code of
1: s:='Ôàéë '+str+' íå íàéäåí!';
2: s:='Ôàéë '+str+' íå ôîðìàòà BMP-16';
3: s:='Ôàéë '+str+' èñïîð÷åí!';
end;
settextjustify (Lefttext, toptext);
settextstyle(DefaultFont, HorizDir, 1);
outtextxy (cx-136,cy-92,s);
Wait;
halt(code);
end;
function Draw (x0,y0:integer; fname:string;
transparent:boolean):integer;
var f:file of bmpinfo;
bmpf:file of byte;
res:integer; info:bmpinfo;
x,y:integer; b,bh,bl:byte;
nb,np:integer; tpcolor:byte;
i,j:integer;
begin
assign(f,fname);
{$I-} reset (f); {$I+}
res:=IoResult;
if res <> 0 then Error (1,fname);
read (f,info);
close (f);
if info.bpp<>4 then Error(2,fname);
x:=x0;
y:=y0+info.height;
nb:=(info.width div 8)*4;
if (info.width mod 8) <> 0 then nb:=nb+4;
assign (bmpf,fname);
reset (bmpf);
seek (bmpf,info.offset);
if transparent then begin
read (bmpf,b);
tpcolor:=b shr 4;
seek (bmpf,info.offset);
end
else tpcolor:=17;
for i:=1 to info.height do begin
np:=0;
for j:=1 to nb do begin
read (bmpf,b);
if np<info.width then begin
bh:=b shr 4;
if bh <> tpcolor then
putpixel (x,y,color[bh]);
inc (x);
inc(np);
end;
if np<info.width then begin
bl:=b and 15;
if bl <> tpcolor then
putpixel (x,y,color[bl]);
inc(x);
inc(np);
end;
end;
x:=x0;
dec(y);
end;
close (bmpf);
Draw:=info.height;
end;
var i,j:word;
b:char;
r:integer;
begin
InitMe;
clearscreen;
assign (List,FileList);
{$I-}
reset (List);
{$I+}
if IoResult <> 0 then Error (1,FileList);
assign (res,resfile);
{$I-}
rewrite (res);
{$I+}
if IoResult <> 0 then Error (1,resfile);
settextjustify (centertext,toptext);
while not eof(List) do begin
readLn (List,s);
clearscreen;
Draw (0,0,s,true);
for j:=1 to height do
for i:=1 to width do begin
b:=chr(getpixel (i,j));
write (res,b);
end;
setcolor (BLACK);
outtextxy (cx,maxy-20,'Ôàéë '+s+' ÎÊ');
Wait;
end;
closeMe;
close (res);
close (List);
end.
12.2. Ëèñòèíã ñîäåðæèò èñõîäíûé òåêñò èãðû â ñòèëå Invaders. Êîìïèëèðîâàòü â Ïàñêàëü 7. Ïðè íåîáõîäèìîñòè èçìåíèòü êîíñòàíòó ïóòè ê Ïàñêàëþ. Òðåáóåò ôàéëà ðåñóðñîâ, ñîçäàííîãî óòèëèòîé èç ëèñòèíãà 12.1. Òðåáóåò óñòàíîâëåííîãî ãðàôè÷åñêîãî øðèôòà trip.chr.
uses graph,crt,Dos;
const width=32; height=20;
type Picture=array [0..width-1,0..height-1]
of char;
type sprite=record
state,x,y,Pnum,PREDir: word;
end;
const VGAPath='c:\TP7\egavga.bgi';
FontPath='c:\TP7\Trip.chr';
sprName='attack.res';
const ESC=#27; F1=#59; SPACE=#32;
UP=#72; DOWN=#80; LEFT=#75; RIGHT=#77;
const maxx=639; maxy=479;
cx=maxx div 2; cy=maxy div 2;
maxsprites=11; maxPictures=11;
maxshoots=100;
const LeftDir=0; RightDir=1;
UpDir=2; DownDir=3;
Delta=2; shootradius=5;
var ch:char; s:string;
Hour,min,sec,sec1,secN,secN1,
sec100,secI,secI1:word;
var Driver, Mode, Font1,
currentsprites, currentBottom,
currentshoots, shootx, Lives,
Enemyshooter, Enemies,
shootsProbability: integer;
score,Level:longint;
DriverF,FontF: file;
DriverP,FontP: pointer;
spr: array [1..maxsprites] of sprite;
Pict: array [1..maxPictures] of Picture;
shoots: array [1..maxshoots] of sprite;
shooter,DieMe,InGame,Initshoot:boolean;
procedure Wait;
var ch:char;
begin
reset (Input); repeat until keyPressed;
ch:=readkey; if ch=#0 then readkey;
end;
procedure closeAll;
begin
if FontP <> nil then begin
FreeMem(FontP, Filesize(FontF));
close (FontF);
end;
if DriverP <> nil then begin
FreeMem(DriverP, Filesize(DriverF));
close (DriverF);
end;
closegraph;
end;
procedure graphError;
begin
closeAll;
writeln('graphics error:',
grapherrormsg(graphresult));
writeln('Press any key to halt');
Wait; halt (graphresult);
end;
procedure InitAll;
begin
assign(DriverF, VGAPath);
reset(DriverF, 1);
getmem(DriverP, Filesize(DriverF));
Blockread(DriverF, DriverP^,
Filesize(DriverF));
if registerBGIdriver(DriverP)<0 then
graphError;
Driver:=VGA; Mode:=VGAHi;
initgraph(Driver, Mode,'');
if graphresult < 0 then graphError;
assign(FontF, FontPath);
reset(FontF, 1);
getmem(FontP, Filesize(FontF));
Blockread(FontF, FontP^, Filesize(FontF));
Font1:=registerBGifont(FontP);
if Font1 < 0 then graphError;
end;
procedure clearscreen;
begin
setfillstyle (solidfill, White);
bar (0,0,maxx,maxy);
end;
procedure Window
(x1,y1,x2,y2,color,Fillcolor:integer);
begin
setcolor (color);
setfillstyle (1,Fillcolor);
bar (x1,y1,x2,y2);
rectangle (x1+2,y1+2,x2-2,y2-2);
rectangle (x1+4,y1+4,x2-4,y2-4);
setfillstyle (1,DArKGrAy);
bar (x1+8,y2+1,x2+8,y2+8);
bar (x2+1,y1+8,x2+8,y2);
end;
procedure outtextcxy (y:integer; s:string);
begin
settextjustify (centertext,centertext);
outtextxy (cx ,y,s);
end;
procedure start;
begin
clearscreen;
Window (10,10,maxx-10,maxy-10,Blue,White);
settextstyle(Font1, HorizDir, 4);
outtextcxy (25,'Àòàêà èç êîñìîñà');
settextstyle(Font1, HorizDir, 1);
outtextcxy (maxy-25,
'Íàæìèòå êëàâèøó äëÿ íà÷àëà');
Wait;
end;
procedure restorescreen
(sNum,Dir,Delta:word);
var x,y:word;
begin
x:=spr[sNum].x; y:=spr[sNum].y;
setfillstyle (solidfill,White);
case Dir of
LeftDir: begin
bar(x+width-Delta,y,x+width-1,
y+height-1);
end;
RightDir: begin
bar (x,y,x+Delta,y+height-1);
end;
UpDir: begin
bar (x,y+height-Delta,
x+width-1,y+height-1);
end;
DownDir: begin
bar (x,y,x+width-1,y+Delta);
end;
end;
end;
procedure Drawsprite (sNum:word);
var i,j,x,y,n,b:integer;
begin
N:=spr[sNum].PNum;
x:=spr[sNum].x; y:=spr[sNum].y;
for j:=y to y+height-1 do
for i:=x to x+width-1 do begin
b:=ord(Pict[n,i-x,j-y]);
putpixel(i,j,b);
end;
end;
procedure GoLeft;
var x,d2:word;
begin
x:=spr[1].x; d2:=delta*4;
if x>d2 then begin
restorescreen (1,LeftDir,d2);
Dec(spr[1].x,d2); Drawsprite (1);
end;
end;
procedure GoRight;
var x,d2:word;
begin
x:=spr[1].x;
d2:=delta*4;
if x+width < maxx then begin
restorescreen (1,RightDir,d2);
Inc(spr[1].x,d2);
Drawsprite (1);
end;
end;
procedure showLives;
begin
str(Lives,s);
setfillstyle (solidfill,White);
setcolor (RED); bar (80,0,110,10);
outtextxy (82,2,s);
end;
procedure showscore;
begin
str(score,s);
setfillstyle (solidfill,White);
setcolor (Blue); bar (150,0,250,10);
outtextxy (152,2,s);
end;
procedure showshoots;
begin
str(currentshoots,s);
setfillstyle (solidfill,White);
setcolor (Black); bar (20,0,50,10);
outtextxy (20,2,s);
end;
procedure showLevel;
begin
str(Level,s);
setfillstyle (solidfill,White);
setcolor (Blue); bar (251,0,350,10);
outtextxy (253,2,'Level '+s);
end;
procedure shoot;
var i:integer;
begin
if currentshoots>0 then begin
for i:=1 to maxshoots do
if (sec<>sec1) and (shoots[i].state=0)
then begin
Dec(currentshoots);
showshoots;
spr[1].PNum:=6; Drawsprite (1);
GetTime(Hour,min,sec,sec100);
shootx:=spr[1].x; shooter:=true;
shoots[i].x:=spr[1].x+ (width div 2);
shoots[i].y:=spr[1].y - 5;
shoots[i].PNum:=UpDir;
shoots[i].state:=1;
break;
end;
end;
end;
procedure Help(s:string);
begin
setfillstyle (solidfill,White);
setcolor (Blue);
bar (10,maxy-10,maxx-10,maxy);
outtextxy (10,maxy-9,s);
end;
procedure Error (code:integer; str:string);
begin
Window (cx-120,cy-100,cx+120,cy-70,
Black,YELLOW);
case code of
1: s:='Ôàéë '+str+' íå íàéäåí!';
end;
settextjustify (Lefttext, toptext);
settextstyle(DefaultFont, HorizDir, 1);
outtextxy (cx-116,cy-92,s);
Wait; closeAll; halt(code);
end;
procedure DrawField;
var i,x,y:integer;
begin
clearscreen;
with spr[1] do begin
state:=1; Pnum:=1;
x:=maxx div 2;
y:=maxy - 10 - height;
Drawsprite (1);
end;
x:=100;
y:=10;
for i:=2 to currentsprites do begin
spr[i].state:=1;
spr[i].PNum:=7;
spr[i].x:=x; spr[i].y:=y;
Drawsprite (i);
inc(x,50);
if x>maxx-width then begin
x:=100;
if y<currentBottom-height then
Inc(y,height)
else y:=10;
end;
end;
for i:=1 to maxshoots do
shoots[i].state:=0;
shooter:=false;
Enemyshooter:=-1;
sec:=0; secN:=0;
secI1:=100; sec1:=100; secN1:=100;
setfillstyle (solidfill,RED);
FillEllipse (10,5,5,4);
showshoots;
setfillstyle (solidfill,Green);
bar (60,1,72,10);
setfillstyle (solidfill,LightGreen);
bar (62,3,70,8);
showLives;
setfillstyle (solidfill,YELLOW);
setcolor (Black);
for i:=1 to 3 do begin
circle (126+i*2,5,4);
FillEllipse (126+i*2,5,4,4);
end;
showscore;
showLevel;
InGame:=true;
end;
procedure Loadsprites;
var F:text;
n,i,j,r:integer;
b:char;
begin
assign (f,sprName);
{$I-}
reset (f);
{$I+}
if IoResult<>0 then Error (1,sprName);
for n:=1 to maxPictures do
for j:=0 to height-1 do
for i:=0 to width-1 do begin
read (f,b);
Pict [n,i,j]:=b;
end;
close (f);
end;
procedure Deltas (sNum,Dir:integer;
var dx,dy:integer);
var x,y:integer;
begin
x:=spr[sNum].x; y:=spr[sNum].y;
case Dir of
LeftDir: begin
Dec(x,Delta);
if x<0 then x:=0;
end;
RightDir: begin
Inc(x,Delta);
if x>maxx-width then x:=maxx-width;
end;
UpDir: begin
Dec (y,Delta);
if y<10 then y:=10;
end;
DownDir: begin
Inc(y,Delta);
if y>currentBottom then
y:=currentBottom;
end;
end;
dx:=x; dy:=y;
end;
function Between (a,x,b:integer):boolean;
begin
if (x>a) and (x<b) then Between:=true
else Between:=false;
end;
procedure shootMovies;
var i,d,n:integer;
x,y:word;
found:boolean;
begin
for i:=1 to maxshoots do
if shoots[i].state=1 then begin
x:=shoots[i].x; y:=shoots[i].y;
d:=shoots[i].PNum;
setfillstyle (solidfill,White);
setcolor (White);
fillellipse(x,y,shootradius,shootradius);
if d=updir then begin
setfillstyle (solidfill,RED);
if y<15 then begin
shoots[i].state:=0; continue;
end;
found:=false;
for n:=2 to currentsprites do begin
if spr[n].state=1 then begin
if (Between(spr[n].x,x,
spr[n].x+width)) and
(Between(spr[n].y,y,
spr[n].y+height)) then begin
shoots[i].state:=0;
found:=true;
spr[n].state:=2;
Inc(spr[n].PNum);
Inc(score,10+5*n);
showscore;
break;
end;
end;
end;
if not found then Dec(y,Delta);
end
else begin
setfillstyle (solidfill,Blue);
if y>maxy-10-(height div 2) then begin
shoots[i].state:=0;
continue;
end;
found:=false;
if Between(spr[1].x,x,spr[1].x+width)
and
Between(spr[1].y,y,spr[1].y+height)
then begin
shoots[i].state:=0; found:=true;
Inc(spr[1].Pnum); DieMe:=true;
Help ('you are missed one life :-(');
Drawsprite (1);
end;
if not found then Inc(y,Delta);
end;
if not found then begin
fillellipse(x,y,shootradius,shootradius);
shoots[i].x:=x; shoots[i].y:=y;
end;
end;
end;
procedure Enemiesstep;
var i,k,Dir,dx,dy,n:integer;
begin
Enemies:=0;
for i:=2 to currentsprites do begin
if spr[i].state=1 then begin
Inc(Enemies);
for k:=1 to 3 do begin
dir:=random(4);
if dir=spr[i].pREDir then break;
end;
spr[i].pREDir:=dir;
Deltas (i, dir, dx, dy);
restorescreen (i,Dir,Delta);
spr[i].x:=dx; spr[i].y:=dy;
Drawsprite (i);
Initshoot:=false;
GetTime(Hour,min,secN1,sec100);
if (secN1<>secN) and
(1+random(100)<shootsProbability) then
Initshoot:=true;
if Initshoot then begin
secN:=secN1;
for n:=1 to maxshoots do
if (shoots[n].state=0) and
(Enemyshooter<>i) then begin
Enemyshooter:=i;
shoots[n].x:=dx+ (width div 2);
shoots[n].y:=dy +height +5;
shoots[n].PNum:=DownDir;
shoots[n].state:=1;
break;
end;
end;
end
else if spr[i].state=2 then begin
GetTime (Hour,min,secI,sec100);
Drawsprite (i);
if secI<>secI1 then begin
secI1:=secI;
if (spr[i].PNum<11) then
Inc(spr[i].PNum)
else begin
spr[i].state:=0;
setfillstyle (solidfill, White);
bar (spr[i].x,spr[i].y,
spr[i].x+width-1,spr[i].y+height-1);
end;
end;
end;
end;
end;
procedure Timefunctions;
var i:integer;
begin
if not InGame then Exit;
GetTime(Hour,min,sec1,sec100);
if (shooter) and (sec<>sec1) then begin
spr[1].PNum:=1;
if shootx=spr[1].x then Drawsprite (1);
shooter:=false;
end;
if (DieMe) and (sec<>sec1) then begin
if spr[1].Pnum<5 then begin
sec:=sec1; Inc(spr[1].PNum);
Drawsprite (1); DieMe:=true;
end
else begin
DieMe:=false;
if Lives>0 then begin
Dec(Lives); showLives;
spr[1].PNum:=1;
Drawsprite (1);
end
else InGame:=false;
end;
end;
end;
function getlongintTime:longint;
{Âåðíåò ñèñòåìíîå âðåìÿ êàê longint}
var Hour,minute,second,sec100: word;
var k,r:longint;
begin
GetTime (Hour, minute, second, sec100);
k:=Hour; r:=k*360000;
k:=minute; Inc (r,k*6000);
k:=second; Inc(r,k*100);
Inc(r,sec100); getlongintTime:=r;
end;
procedure Delay (ms:word);
var endTime,curTime : longint;
cor:boolean;
begin
cor:=false;
endTime:=getlongintTime + ms div 10;
if endTime>8639994 then cor:=true;
repeat
curTime:=getlongintTime;
if cor=true then begin
if curTime<360000 then
Inc (curTime,8639994);
end;
until curTime>endTime;
end;
label 10,20;
begin
randomize; InitAll; InGame:=false;
start;
settextstyle (DefaultFont,HorizDir,1);
settextjustify (Lefttext,toptext);
Loadsprites;
currentBottom:=200; currentshoots:=50;
Lives:=3; score:=0; Level:=1;
shootsProbability:=5;
currentsprites:=5;
10:
DrawField;
if Level>1 then begin
str(Level-1,s);
Help ('cool, you''re complete level '+s);
end
else Help
('Let''s go! Kill them, invaders!');
repeat
if InGame then repeat
Enemiesstep;
if Enemies=0 then begin
Inc(score,100+Level*10);
if shootsProbability<100 then
Inc (shootsProbability);
if currentsprites<maxsprites then
Inc(currentsprites);
if currentBottom<maxy-10-4*height then
Inc(currentBottom,10);
currentshoots:=50;
Delay(1000);{Ïàóçà ïåðåä ñëåä. óðîâíåì}
Inc(Level);
goto 10;
end;
shootMovies;
if not InGame then begin
Help ('sorry, you''re dead');
end;
Timefunctions;
until keypressed;
ch:=readkey;
case ch of
SPACE:
if not DieMe and InGame then shoot;
#0: begin
ch:=readkey;
case ch of
F1: Help
('Sorry, there''s no help here :-)');
LEFT: if not DieMe and InGame
then GoLeft;
RIGHT: if not DieMe and InGame
then GoRight;
UP: if not DieMe and InGame
then shoot;
end;
end;
end;
until ch=ESC;
closeAll;
end.
ãîñòåâàÿ; E-mail |