Nickolay.info. . . 4

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.

@Mail.ru
; E-mail