При необхідності зміните константу шляху до Паскалю

}

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 program...');

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.

{Лістинг нескладної навчальної гри в стилі Invareds