主题：[原创]贪食蛇+扫雷 2 in 1 游戏，中文界面！！
阿Ben
[专家分：2200] 发布于 2005-08-27 23:52:00
这是lzl1403使用Turbo Pascal 7.0编的，我只不过是帮他贴上来的。
编译此程序必需的文件：
GRAPH.TPU TP7自带
EGAVGA.BGI TP7自带
GOTH.CHR TP7自带
TSCR.CHR TP7自带
HZK16 UCDOS 的16*16汉字点阵。具体请参阅[url]http://www.programfan.com/club/showbbs.asp?id=14025[/url]
另外，没有Crt补丁的请在此下载：
[url]http://www.mydrs.org/program/list.asp?id=136[/url]
首先运行这个安装来安装：
prooram setup;
begin
assign(output,'hero.dat');
rewrite(output);
writeln(0);
close(output);
end.
运行了安装程序并齐备必需文件后就可以玩游戏了：
PROGRAM biogame;
uses Graph,Crt,Dos;
label 99;
var
grDriver: Integer;
grMode: Integer;
ErrCode: Integer;
game:integer;
ch:char;
{==========OutChinese==============}
procedure putone(x,y:integer;s:string;color:integer);
type
chinesep=array[1..32] of byte;
var
a:chinesep;
f:file of chinesep;
i,j,x0,y0:integer;
k:byte;
q,w:longint;
begin
q:=ord(s[1])-160;
w:=ord(s[2])-160;
q:=(q-1)*94+(w-1);
assign(f,'HZK16') ;
reset(f);
if (q<0) or (q>=filesize(f)) then
begin
close(f);
exit;
end;
seek(f,q);
read(f,a);
close(f);
y0:=y;
for i:=1 to 32 do
begin
k:=a[i];
if i mod 2=1 then
begin
x0:=7+x;
y0:=y0+1;
end
else
x0:=15+x;
for j:=1 to 8 do
begin
if k and 1 =1 then putpixel(x0,y0,color);
x0:=x0-1;
k:=k shr 1;
end;
end;
end;
procedure outchinese(x,y:integer;s:string;blank:integer; color:integer);
var
temps:string;
k:integer;
begin
k:=1;
while k<length(s) do
begin
temps:=s[k]; k:=k+1;
temps:=temps+s[k]; k:=k+1;
putone(x+(k div 2-1)*(16+blank),y,temps,color);
end;
end;
PROCEDURE MineSweeper;
CONST
maxsize=15;
rnd:array[1..8,1..2]of shortint=((0,1),(1,0),(0,-1),(-1,0),(1,1),(-1,-1),(1,-1),(-1,1));
bug='I will die!';
VAR
grDriver: Integer;
grMode: Integer;
ErrCode: Integer;
sign:array[0..maxsize,0..maxsize]of 1..3;{1:No put 2:Put 3:Sign}
mine:array[0..maxsize,0..maxsize]of shortint;{-1:Mine 0:Safety 1..8:Danger}
safe,sweep:array[0..maxsize,0..maxsize]of boolean;
man:record
x,y:word;
end;
size,hard,total:integer;
ff,fk:boolean;
hh,mm,ss,ms:integer;
hh1,mm1,ss1,ms1,hh2,mm2,ss2,ms2:word;
s:string;
回复列表 （共40个回复）
沙发
阿Ben [专家分：2200] 发布于 2005-08-24 00:45:00
{=============Welcome==============}
PROCEDURE welcome;
VAR
ch:char;
BEGIN
hard:=1;
size:=10;
OutChinese(160,150,'游戏模式',0,10);
OutChinese(250,250,'初学者',0,9);
OutChinese(250,300,'老玩家',0,3);
OutChinese(250,350,'专家',0,3);
SetColor(2);
SetTextStyle(0,0,3);
OutTextXY(190,250,chr(26));
repeat
ch:=readkey;
case ch of
#72:begin{====Up====}
SetColor(0);
OutTextXY(190,200+50*hard,chr(26));
hard:=hard-1;
if hard<1
then hard:=3;
SetColor(2);
OutTextXY(190,200+50*hard,chr(26));
end;
#80:begin{===Down===}
SetColor(0);
OutTextXY(190,200+50*hard,chr(26));
hard:=hard+1;
if hard>3
then hard:=1;
SetColor(2);
OutTextXY(190,200+50*hard,chr(26));
end;
end;
OutChinese(250,250,'初学者',0,3);
OutChinese(250,300,'老玩家',0,3);
OutChinese(250,350,'专家',0,3);
case hard of
1:OutChinese(250,250,'初学者',0,9);
2:OutChinese(250,300,'老玩家',0,9);
3:OutChinese(250,350,'专家',0,9);
end;
until ch=#13;
if hard=1 then size:=10;
if hard=2 then size:=12;
if hard=3 then size:=15;
ClearDevice;
END;
{===========Initialize=============}
PROCEDURE init;
VAR
i,j,k,x,y:integer;
BEGIN
Randomize;
{========Draw a playboard=======}
SetColor(15);
for i:=0 to size do
begin
line(320-12*size,i*24+240-12*size,320+12*size,i*24+240-12*size);
line(i*24+320-12*size,240-12*size,i*24+320-12*size,240+12*size);
end;
SetColor(10);
for i:=1 to size do
for j:=1 to size do
Rectangle((j-1)*24+320-12*size+1,(i-1)*24+240-12*size+1,(j-1)*24+344-12*size-1,(i-1)*24+264-12*size-1);
SetColor(0);
Rectangle(320-12*size,240-12*size,344-12*size,264-12*size);
SetColor(10);
Rectangle(320-12*size+1,240-12*size+1,344-12*size-1,264-12*size-1);
板凳
阿Ben [专家分：2200] 发布于 2005-08-24 00:45:00
{=============Help==============}
SetTextStyle(0,0,2);
OutChinese(0,0,'控制',0,12);
OutChinese(0,15,'回车键 挖地雷',0,13);
OutChinese(0,30,'空格键 标记地雷',0,13);
OutChinese(0,45,'方向键 移动工兵',0,13);
{========Init playboard=========}
fillchar(sign,sizeof(sign),1);
fillchar(mine,sizeof(mine),0);
for i:=1 to size*hard do
repeat
x:=random(size)+1;
y:=random(size)+1;
if mine[x,y]<>-1
then begin
mine[x,y]:=-1;
break;
end;
until False;
for i:=1 to size do
for j:=1 to size do
if mine[i,j]<>-1
then for k:=1 to 8 do
if mine[i+rnd[k,1],j+rnd[k,2]]=-1
then inc(mine[i,j]);
man.x:=1;man.y:=1;
ff:=false;
END;
{================Redraw the playboard=============}
PROCEDURE redraw;
VAR
i,j:integer;
s:string;
BEGIN
SetFillStyle(0,0);
Bar((man.y-1)*24+320-12*size,(man.x-1)*24+240-12*size,(man.y-1)*24+344-12*size,(man.x-1)*24+264-12*size);
SetColor(10);
Rectangle((man.y-1)*24+320-12*size+1,(man.x-1)*24+240-12*size+1,(man.y-1)*24+344-12*size-1,(man.x-1)*24+264-12*size-1);
SetColor(3);
case sign[man.x,man.y] of
2:if mine[man.x,man.y]=0
then
for i:=1 to 3 do
for j:=1 to 3 do
circle((man.y-1)*24+320-12*size+i*6,(man.x-1)*24+240-12*size+j*6,0)
else begin
if mine[man.x,man.y]>0
then Str(mine[man.x,man.y],s);
SetTextStyle(4,0,3);
OutTextXY((man.y-1)*24+328-12*size,(man.x-1)*24+236-12*size,s);
end;
3:begin
SetFillStyle(1,4);
Bar((man.y-1)*24+320-12*size+2,(man.x-1)*24+240-12*size+2,(man.y-1)*24+344-12*size-2,(man.x-1)*24+264-12*size-2);
end;
end;
END;
3 楼
阿Ben [专家分：2200] 发布于 2005-08-24 00:46:00
{=============Play the game=========}
PROCEDURE play;
VAR
ch:char;
s:string;
BEGIN
ch:=readkey;
SetColor(0);
case ch of
#75:begin dec(man.y);if man.y<1 then man.y:=size;fk:=true;end;{Left}
#77:begin inc(man.y);if man.y>size then man.y:=1;fk:=true;end;{Right}
#72:begin dec(man.x);if man.x<1 then man.x:=size;fk:=true;end;{Up}
#80:begin inc(man.x);if man.x>size then man.x:=1;fk:=true;end;{Down}
#13:begin sign[man.x,man.y]:=2;end;
' ':if sign[man.x,man.y]=1
then sign[man.x,man.y]:=3
else if sign[man.x,man.y]=3
then sign[man.x,man.y]:=1;
'w':begin readln(s);if s=bug then ff:=true;cleardevice;end;
end;
END;
{===============Draw the safeties==============}
PROCEDURE dig(x,y:integer);
VAR
i,j:integer;
s:string;
BEGIN
if (x<1)or(x>size)or(y<1)or(y>size)
then exit;
if mine[x,y]=0
then begin
for i:=1 to 3 do
for j:=1 to 3 do
circle((y-1)*24+320-12*size+i*6,(x-1)*24+240-12*size+j*6,0);
safe[x,y]:=true;
sweep[x,y]:=true;
for i:=1 to 8 do
if safe[x+rnd[i,1],y+rnd[i,2]]=false
then dig(x+rnd[i,1],y+rnd[i,2]);
end
else begin
if mine[x,y]>0
then Str(mine[x,y],s);
SetTextStyle(4,0,3);
OutTextXY((y-1)*24+328-12*size,(x-1)*24+236-12*size,s);
sweep[x,y]:=true;
end;
sign[x,y]:=2;
END;
{=============Output the playboard=============}
PROCEDURE out;
VAR
i,j:integer;
BEGIN
{==============Draw the playboard============}
SetColor(15);
for i:=0 to size do
begin
line(320-12*size,i*24+240-12*size,320+12*size,i*24+240-12*size);
line(i*24+320-12*size,240-12*size,i*24+320-12*size,240+12*size);
end;
Setcolor(10);
for i:=1 to size do
for j:=1 to size do
Rectangle((j-1)*24+320-12*size+1,(i-1)*24+240-12*size+1,(j-1)*24+344-12*size-1,(i-1)*24+264-12*size-1);
4 楼
阿Ben [专家分：2200] 发布于 2005-08-24 00:47:00
{=============Help==============}
SetTextStyle(0,0,2);
OutChinese(0,0,'控制',0,12);
OutChinese(0,15,'回车键 挖地雷',0,13);
OutChinese(0,30,'空格键 标记地雷',0,13);
OutChinese(0,45,'方向键 移动工兵',0,13);
{===============Draw the man==============}
SetColor(3);
if fk=false
then
for i:=1 to size do
for j:=1 to size do
case sign[i,j] of
{===========Draw places' sign=============}
2:dig(i,j);
3:begin
SetFillStyle(1,4);
Bar((j-1)*24+320-12*size+2,(i-1)*24+240-12*size+2,(j-1)*24+344-12*size-2,(i-1)*24+264-12*size-2);
sign[i,j]:=3;
end;
end;
END;
{==============Check if win or lose============}
FUNCTION ended:boolean;
VAR
x,y,i,j,color:integer;
s1,s2:string;
BEGIN
Randomize;
ended:=false;
total:=0;
for i:=1 to size do
for j:=1 to size do
if sweep[i,j]=true
then inc(total);
if (total>=size*(size-hard))or ff
then begin
5 楼
阿Ben [专家分：2200] 发布于 2005-08-24 00:48:00
{==================WIN====================}
ClearDevice;
SetTextStyle(0,0,5);
repeat
x:=random(640);y:=random(480);
color:=random(15)+1;
for i:=1 to 10 do
begin
SetColor(color);
Circle(x,y,i*5);
Circle(x,y,i*5+15);
Circle(x,y,i*5+30);
SetColor(i+1);
OutChinese(280,200,'任务完成',0,i+1);
Delay(100);
ClearDevice;
end;
until KeyPressed;
Readln;
GetTime(hh2,mm2,ss2,ms2);
hh:=hh2-hh1;
mm:=mm2-mm1;
ss:=ss2-ss1;
ms:=ms2-ms1;
if ms<0
then begin ms:=ms+100;ss:=ss-1;end;
if ss<0
then begin ss:=ss+60;mm:=mm-1;end;
if mm<0
then begin mm:=mm+60;hh:=hh-1;end;
str(hh,s1);
s1:=s1+':';
str(mm,s2);
s1:=s1+s2+':';
str(ss,s2);
s1:=s1+s2+'''';
str(ms,s2);
s1:=s1+s2+'''''';
ClearDevice;
SetTextStyle(0,0,3);
OutChinese(100,100,'总时间',0,11);
OutTextXY(200,200,s1);
readln;
ended:=true;
exit;
end;
if (mine[man.x,man.y]=-1)and(sign[man.x,man.y]=2)
then begin
6 楼
阿Ben [专家分：2200] 发布于 2005-08-24 00:49:00
{==============LOSE==============}
ClearDevice;
SetBKColor(8);
Delay(100);
SetBKColor(7);
Delay(100);
SetBKColor(15);
Delay(200);
SetBKColor(7);
Delay(100);
SetBKColor(8);
Delay(100);
SetBKColor(0);
Delay(100);
SetColor(15);
for i:=0 to size do
begin
line(320-12*size,i*24+240-12*size,320+12*size,i*24+240-12*size);
line(i*24+320-12*size,240-12*size,i*24+320-12*size,240+12*size);
end;
Setcolor(10);
for i:=1 to size do
for j:=1 to size do
Rectangle((j-1)*24+320-12*size+1,(i-1)*24+240-12*size+1,(j-1)*24+344-12*size-1,(i-1)*24+264-12*size-1);
7 楼
阿Ben [专家分：2200] 发布于 2005-08-24 00:49:00
{=============Help==============}
SetTextStyle(0,0,2);
OutChinese(0,0,'控制',0,12);
OutChinese(0,15,'回车键 挖地雷',0,13);
OutChinese(0,30,'空格键 标记地雷',0,13);
OutChinese(0,45,'方向键 移动工兵',0,13);
for i:=1 to size do
for j:=1 to size do
begin
if mine[i,j]>=0
then begin
SetColor(7);
SetTextStyle(4,0,3);
Str(mine[i,j],s);
OutTextXY((j-1)*24+328-12*size,(i-1)*24+236-12*size,s);
end
else if (i<>man.x)or(j<>man.y)
then begin
SetTextStyle(0,0,2);
SetColor(4);
OutTextXY((j-1)*24+326-12*size,(i-1)*24+245-12*size,chr(5));
end
else begin
SetTextStyle(0,0,2);
SetColor(3);
OutTextXY((j-1)*24+326-12*size,(i-1)*24+245-12*size,chr(5));
end
end;
readln;
cleardevice;
SetTextStyle(0,0,10);
SetBKColor(8);
OutChinese(280,200,'任务失败',0,7);
readln;
ended:=true;
exit;
end;
END;
8 楼
阿Ben [专家分：2200] 发布于 2005-08-24 00:49:00
真长啊！再帖！！
9 楼
阿Ben [专家分：2200] 发布于 2005-08-24 00:50:00
var
s1:string;
t1,t2:longint;
f:text;
begin
cleardevice;
settextstyle(7,0,8);
setcolor(7);
assign(f,'hero.dat');
reset(f);
read(f,t2);
close(f);
t1:=(long-slong)*hard;
if t1>t2
then begin
t2:=t1;
outchinese(300,200,'新纪录!',0,2);
end
else outchinese(250,200,'很遗憾你输了……',0,7);
readln;
cleardevice;
str(t1,s1);
s1:=s1;
setcolor(5);
outchinese(200,100,'收获',0,5);
outtextxy(300,50,s1);
readln;
str(t1,s1);
s1:=s1;
setcolor(10);
outchinese(200,200,'成绩',0,10);
outtextxy(300,150,s1);
readln;
str(t2,s1);
s1:=s1;
setcolor(14);
outchinese(200,300,'最高分',0,14);
outtextxy(300,250,s1);
assign(f,'hero.dat');
rewrite(f);
write(f,t2);
close(f);
readln;
end;
10 楼
阿Ben [专家分：2200] 发布于 2005-08-24 00:50:00
{===============Main=================}
BEGIN
grDriver := Detect;
InitGraph(grDriver, grMode,' ');
ErrCode := GraphResult;
if ErrCode = grOk then
begin { Do graphics }
welcome;
init;
GetTime(hh1,mm1,ss1,ms1);
repeat
fk:=false;
play;
if (mine[man.x,man.y]=-1)and(sign[man.x,man.y]=2)
then
else
begin
fillchar(safe,sizeof(safe),false);
if not ff
then out;
redraw;
end;
until ended;
CloseGraph;
end
else
Writeln('Graphics error:', GraphErrorMsg(ErrCode));
END;
PROCEDURE snake;
const
step=20;
slong=5;
head=#1;
nut=#15;
var
grDriver: Integer;
grMode: Integer;
ErrCode: Integer;
x1,y1,nutx,nuty:integer;
ch,chh:char;
dirc,long,hard:integer;
i,p,t1:integer;
f1:boolean;
snake:array[1..200]of record
x,y:integer;
end;
procedure lost;
我来回复
您所在位置：