program sysotffk;
uses
crt;
const
maxk=5;maxz=18;maxx=19;maxy=19;maxtx=5;maxty=5;maxcj=100;maxjb=12;
px:array[1..maxz,1..maxk] of byte=
((1,2,3,4,5),(1,2,3,4,4),(2,2,3,4,5),(1,2,3,3,4),(2,3,3,4,5),
(3,2,3,4,3),(2,3,4,2,3),(2,3,4,3,4),(2,2,3,4,3),(4,2,3,4,3),
(2,3,3,4,4),(2,3,3,3,4),(3,4,3,2,3),(2,4,2,3,4),(2,3,4,3,3),
(2,3,4,4,4),(1,2,3,3,4),(3,4,5,2,3));
py:array[1..maxz,1..maxk] of byte=
((3,3,3,3,3),(3,3,3,3,4),(4,3,3,3,3),(3,3,3,4,3),(3,4,3,3,3),
(2,3,3,3,4),(3,3,3,4,4),(3,3,3,4,4),(2,3,3,3,4),(2,3,3,3,4),
(2,2,3,3,4),(2,2,3,4,4),(2,2,3,4,4),(2,2,3,3,3),(2,2,2,3,4),
(2,2,2,3,4),(3,3,3,4,4),(3,3,3,4,4));
jbc:array[1..maxjb] of string=
('①[4×4]','②[4×5]','③[5×5]','④[5×6]','⑤[6×6]',
'⑥[6×7]','⑦[7×7]','⑧[7×8]','⑨[8×8]','⑩[8×9]','⑾[9×9]','⑿[9×10]');
jbx:array[1..maxjb] of byte=(4,4,5,5,6,6,7,7,8,8,9,9);
jby:array[1..maxjb] of byte=(4,5,5,6,6,7,7,8,8,9,9,10);
FileName='sysoftfk.dat';
type
arby=array[1..maxx,1..maxy] of byte;
var
lc,lh,l0:arby;F:file of arby;
tx:array[1..maxk] of byte;
ty:array[1..maxk] of byte;
i,r,rt,jb,inkey:byte;
x,y,ink,kx,ky:shortint;
hxm:boolean;
cj:word;
procedure ptt(s,d,n:word);
var
i:word;
begin
for i:=1 to n do
begin
sound(200+s*random(i));
delay(d);
end;
NoSound;
end;
procedure pxy(x,y,c:byte;sh:string);
var
x0,y0:byte;
begin
x0:=wherex;y0:=wherey;
gotoxy(x,y);textcolor(c);write(sh);
gotoxy(x0,y0);
end;
procedure ppm;
const
c=7;
procedure pplx;
var x:byte;
begin
for x:=1 to maxx+2 do
begin
pxy(x*2-1,1,c,'━');pxy(x*2-1,maxy+2,c,'━');
end
end;
procedure pply;
var y:byte;
begin
for y:=1 to maxy+2 do
begin
pxy(1,y,c,'┃');pxy(maxx*2+3,y,c,'┃');
end;
end;
procedure ppll;
begin
pxy(1, 1,c,'┏');
pxy(1, maxy+2,c,'┗');
pxy(maxx*2+3, 1,c,'┓');
pxy(maxx*2+3,maxy+2,c,'┛');
end;
begin
clrscr;
pplx;pply;ppll;
end;
procedure pp0;
var
x,y:byte;cjc:string;
begin
ppm;
for x:=1 to maxx do
for y:=1 to maxy do
lc[x,y]:=0;
l0:=lc;jb:=1;cj:=0;
str(cj:8,cjc);
pxy(maxx*2+10,maxy div 3, jb,'级别:'+jbc[jb]);
pxy(maxx*2+10,maxy div 3+2,jb,'成绩:'+cjc);
pxy(1,maxy+4,15,'Zswang (C)1999,10');
end;
function fke:shortint;
var c:char;
begin
c:=readkey;
if (c=#0)and(keypressed) then
begin
c:=readkey;
fke:=-ord(c);
end
else
fke:=ord(c)
end;
procedure psj(n:byte);
var i:byte;
begin
for i:=1 to maxk do
begin
tx[i]:=px[n,i];ty[i]:=py[n,i];
end;
end;
procedure pwz(x,y,n,b:byte);
var
sh:string[2];c:byte;
begin
case b of
0 : if lc[x,y]=0 then
sh:=' '
else
begin
n:=lc[x,y];
sh:='★';
end;
2 : begin
lc[x,y]:=n;
sh:='★';
end;
1 : if lc[x,y]=0 then sh:='□' else sh:='■';
3 : sh:='☆';
4 : sh:=' ';
5 : begin
lc[x,y]:=0;
sh:=' ';
end;
end;{case}
c:=n mod 7+1;
pxy(x*2+1,y+1,c,sh);
end;
procedure ptx(x,y:shortint;n,b:byte);
var i:byte;
begin
for i:=1 to maxk do
pwz(x+tx[i],y+ty[i],n,b);
end;
function fma(x,y:shortint):boolean;
begin
fma:=(x>=1)and(x<=maxx)and(y>=1)and(y<=maxy);
end;
function flc(x,y:shortint):byte;
var i,b:byte;
begin
b:=0;
i:=1;
repeat
if fma(x+tx[i],y+ty[i]) then
begin
if lc[x+tx[i],y+ty[i]]<>0 then b:=2
end
else
b:=3;
inc(i);
until (b=3)or(i>maxk);
flc:=b;
end;
procedure pzd;
var i,t:word;bool:boolean;
begin
bool:=true;
for i:=1 to maxk do
if not fma(x+ty[i],y+6-tx[i]) then
bool:=false;
if bool then
begin
ptx(x,y,r,0);
for i:=1 to maxk do
begin
t:=tx[i];tx[i]:=ty[i];ty[i]:=6-t
end
end
end;
procedure pxc(mx,my:byte);
var
lcy:boolean;
function fflc(tx,ty,mx,my:byte):boolean;
label loop;
var
ix,iy:byte;bool:boolean;
begin
bool:=true;
for ix:=1 to mx do
for iy:=1 to my do
if lc[tx+ix-1,ty+iy-1]=0 then
begin
bool:=false;
goto loop
end;
loop: fflc:=bool;
end;
procedure ppxx(tx,ty,mx,my:byte);
var
ix,iy:byte;
begin
for ix:=1 to mx do
for iy:=1 to my do
lh[tx+ix-1,ty+iy-1]:=5;
end;
procedure ppxc(mx,my:byte);
var
tx,ty:byte;
begin
for tx:=1 to maxx-mx+1 do
for ty:=1 to maxy-my+1 do
if fflc(tx,ty,mx,my) then
begin
lcy:=true;
ppxx(tx,ty,mx,my);
end;
end;
procedure ppcc;
var
x,y:byte;cjc:string;
begin
for x:=1 to maxx do
for y:=1 to maxy do
if lh[x,y]=5 then
begin
pwz(x,y,7,5);inc(cj);
str(cj:8,cjc);
pxy(maxx*2+15,maxy div 3+2,jb,cjc);
if (cj mod maxcj=0)and(jb+1<=MaxJB) then
begin
inc(jb);
pxy(maxx*2+15,maxy div 3,jb,jbc[jb]);
end;
end;
end;
begin
lcy:=false;
lh:=l0;
if mx=my then
ppxc(mx,my)
else
begin
ppxc(mx,my);
ppxc(my,mx);
end;
if lcy then ppcc;
end;
procedure pb1;
var
x,y:byte;
begin
for x:=1 to maxx do
for y:=1 to maxy do
pwz(x,y,0,0)
end;
procedure psa;
var
x,y:byte;
begin
assign(F,FileName);
Rewrite(F);
write(F,lc);
close(F);
end;
procedure plo;
var
x,y:byte;
begin
assign(F,FileName);
Reset(F);
Read(F,lc);
close(F);
pb1;
end;
begin
pp0;
randomize;
rt:=random(maxz)+1;
repeat
x:=round(maxx/2)-4;
y:=round(maxy/2)-4;
r:=rt;
rt:=random(maxz)+1;psj(rt);ptx(maxx+7,maxy div 3,rt,3);hxm:=false;
psj(r);
repeat
ptx(x,y,r,1);
ink:=fke;inkey:=abs(ink);
ky:=0;kx:=0;
case ink of
{1}49,{2}50,{3}51,{4}52,{6}54,{7}55,{8}56,{9}57,-75,-77,-72,-80
: begin
if (inkey in [49,52,55])or(ink=-75) then kx:=-1;
if (inkey in [51,54,57])or(ink=-77) then kx:=+1;
if (inkey in [55,56,57])or(ink=-72) then ky:=-1;
if (inkey in [49,50,51])or(ink=-80) then ky:=+1;
if flc(x+kx,y+ky)<>3 then
begin
ptx(x,y,r,0);x:=x+kx;y:=y+ky;ptt(40,10,50);
end;
end;
{5}53,13 :if flc(x,y)=0 then
begin
ptx(x,y,r,2);
hxm:=true;
pxc(jbx[jb],jby[jb]);
end
else
ptt(40,10,100);
32,{0}48 :pzd;
-60 :psa;
-61 :plo;
end;{case}
until (ink=27)or(hxm);
psj(rt);ptx(maxx+7,maxy div 3,rt,4);
until ink=27;
{ psj(maxz);ptx(maxx+7,maxy div 3,rt,3)}
{ writeln(fke);}
end.
//turbo pascal 7.0
//不你的要求,自己改改吧
program sysotffk;
uses
crt;
const
maxk=5;maxz=18;maxx=19;maxy=19;maxtx=5;maxty=5;maxcj=100;maxjb=12;
px:array[1..maxz,1..maxk] of byte=
((1,2,3,4,5),(1,2,3,4,4),(2,2,3,4,5),(1,2,3,3,4),(2,3,3,4,5),
(3,2,3,4,3),(2,3,4,2,3),(2,3,4,3,4),(2,2,3,4,3),(4,2,3,4,3),
(2,3,3,4,4),(2,3,3,3,4),(3,4,3,2,3),(2,4,2,3,4),(2,3,4,3,3),
(2,3,4,4,4),(1,2,3,3,4),(3,4,5,2,3));
py:array[1..maxz,1..maxk] of byte=
((3,3,3,3,3),(3,3,3,3,4),(4,3,3,3,3),(3,3,3,4,3),(3,4,3,3,3),
(2,3,3,3,4),(3,3,3,4,4),(3,3,3,4,4),(2,3,3,3,4),(2,3,3,3,4),
(2,2,3,3,4),(2,2,3,4,4),(2,2,3,4,4),(2,2,3,3,3),(2,2,2,3,4),
(2,2,2,3,4),(3,3,3,4,4),(3,3,3,4,4));
jbc:array[1..maxjb] of string=
('①[4×4]','②[4×5]','③[5×5]','④[5×6]','⑤[6×6]',
'⑥[6×7]','⑦[7×7]','⑧[7×8]','⑨[8×8]','⑩[8×9]','⑾[9×9]','⑿[9×10]');
jbx:array[1..maxjb] of byte=(4,4,5,5,6,6,7,7,8,8,9,9);
jby:array[1..maxjb] of byte=(4,5,5,6,6,7,7,8,8,9,9,10);
FileName='sysoftfk.dat';
type
arby=array[1..maxx,1..maxy] of byte;
var
lc,lh,l0:arby;F:file of arby;
tx:array[1..maxk] of byte;
ty:array[1..maxk] of byte;
i,r,rt,jb,inkey:byte;
x,y,ink,kx,ky:shortint;
hxm:boolean;
cj:word;
procedure ptt(s,d,n:word);
var
i:word;
begin
for i:=1 to n do
begin
sound(200+s*random(i));
delay(d);
end;
NoSound;
end;
procedure pxy(x,y,c:byte;sh:string);
var
x0,y0:byte;
begin
x0:=wherex;y0:=wherey;
gotoxy(x,y);textcolor(c);write(sh);
gotoxy(x0,y0);
end;
procedure ppm;
const
c=7;
procedure pplx;
var x:byte;
begin
for x:=1 to maxx+2 do
begin
pxy(x*2-1,1,c,'━');pxy(x*2-1,maxy+2,c,'━');
end
end;
procedure pply;
var y:byte;
begin
for y:=1 to maxy+2 do
begin
pxy(1,y,c,'┃');pxy(maxx*2+3,y,c,'┃');
end;
end;
procedure ppll;
begin
pxy(1, 1,c,'┏');
pxy(1, maxy+2,c,'┗');
pxy(maxx*2+3, 1,c,'┓');
pxy(maxx*2+3,maxy+2,c,'┛');
end;
begin
clrscr;
pplx;pply;ppll;
end;
procedure pp0;
var
x,y:byte;cjc:string;
begin
ppm;
for x:=1 to maxx do
for y:=1 to maxy do
lc[x,y]:=0;
l0:=lc;jb:=1;cj:=0;
str(cj:8,cjc);
pxy(maxx*2+10,maxy div 3, jb,'级别:'+jbc[jb]);
pxy(maxx*2+10,maxy div 3+2,jb,'成绩:'+cjc);
pxy(1,maxy+4,15,'本程序由 王集鹄 设计 Tel:(0851)6847004 Bp:126-124499');
end;
function fke:shortint;
var c:char;
begin
c:=readkey;
if (c=#0)and(keypressed) then
begin
c:=readkey;
fke:=-ord(c);
end
else
fke:=ord(c)
end;
procedure psj(n:byte);
var i:byte;
begin
for i:=1 to maxk do
begin
tx[i]:=px[n,i];ty[i]:=py[n,i];
end;
end;
procedure pwz(x,y,n,b:byte);
var
sh:string[2];c:byte;
begin
case b of
0 : if lc[x,y]=0 then
sh:=' '
else
begin
n:=lc[x,y];
sh:='★';
end;
2 : begin
lc[x,y]:=n;
sh:='★';
end;
1 : if lc[x,y]=0 then sh:='□' else sh:='■';
3 : sh:='☆';
4 : sh:=' ';
5 : begin
lc[x,y]:=0;
sh:=' ';
end;
end;{case}
c:=n mod 7+1;
pxy(x*2+1,y+1,c,sh);
end;
procedure ptx(x,y:shortint;n,b:byte);
var i:byte;
begin
for i:=1 to maxk do
pwz(x+tx[i],y+ty[i],n,b);
end;
function fma(x,y:shortint):boolean;
begin
fma:=(x>=1)and(x<=maxx)and(y>=1)and(y<=maxy);
end;
function flc(x,y:shortint):byte;
var i,b:byte;
begin
b:=0;
i:=1;
repeat
if fma(x+tx[i],y+ty[i]) then
begin
if lc[x+tx[i],y+ty[i]]<>0 then b:=2
end
else
b:=3;
inc(i);
until (b=3)or(i>maxk);
flc:=b;
end;
procedure pzd;
var i,t:word;bool:boolean;
begin
bool:=true;
for i:=1 to maxk do
if not fma(x+ty[i],y+6-tx[i]) then
bool:=false;
if bool then
begin
ptx(x,y,r,0);
for i:=1 to maxk do
begin
t:=tx[i];tx[i]:=ty[i];ty[i]:=6-t
end
end
end;
procedure pxc(mx,my:byte);
var
lcy:boolean;
function fflc(tx,ty,mx,my:byte):boolean;
label loop;
var
ix,iy:byte;bool:boolean;
begin
bool:=true;
for ix:=1 to mx do
for iy:=1 to my do
if lc[tx+ix-1,ty+iy-1]=0 then
begin
bool:=false;
goto loop
end;
loop: fflc:=bool;
end;
procedure ppxx(tx,ty,mx,my:byte);
var
ix,iy:byte;
begin
for ix:=1 to mx do
for iy:=1 to my do
lh[tx+ix-1,ty+iy-1]:=5;
end;
procedure ppxc(mx,my:byte);
var
tx,ty:byte;
begin
for tx:=1 to maxx-mx+1 do
for ty:=1 to maxy-my+1 do
if fflc(tx,ty,mx,my) then
begin
lcy:=true;
ppxx(tx,ty,mx,my);
end;
end;
procedure ppcc;
var
x,y:byte;cjc:string;
begin
for x:=1 to maxx do
for y:=1 to maxy do
if lh[x,y]=5 then
begin
pwz(x,y,7,5);inc(cj);
str(cj:8,cjc);
pxy(maxx*2+15,maxy div 3+2,jb,cjc);
if (cj mod maxcj=0)and(jb+1<=MaxJB) then
begin
inc(jb);
pxy(maxx*2+15,maxy div 3,jb,jbc[jb]);
end;
end;
end;
begin
lcy:=false;
lh:=l0;
if mx=my then
ppxc(mx,my)
else
begin
ppxc(mx,my);
ppxc(my,mx);
end;
if lcy then ppcc;
end;
procedure pb1;
var
x,y:byte;
begin
for x:=1 to maxx do
for y:=1 to maxy do
pwz(x,y,0,0)
end;
procedure psa;
var
x,y:byte;
begin
assign(F,FileName);
Rewrite(F);
write(F,lc);
close(F);
end;
procedure plo;
var
x,y:byte;
begin
assign(F,FileName);
Reset(F);
Read(F,lc);
close(F);
pb1;
end;
begin
pp0;
randomize;
rt:=random(maxz)+1;
repeat
x:=round(maxx/2)-4;
y:=round(maxy/2)-4;
r:=rt;
rt:=random(maxz)+1;psj(rt);ptx(maxx+7,maxy div 3,rt,3);hxm:=false;
psj(r);
repeat
ptx(x,y,r,1);
ink:=fke;inkey:=abs(ink);
ky:=0;kx:=0;
case ink of
{1}49,{2}50,{3}51,{4}52,{6}54,{7}55,{8}56,{9}57,-75,-77,-72,-80
: begin
if (inkey in [49,52,55])or(ink=-75) then kx:=-1;
if (inkey in [51,54,57])or(ink=-77) then kx:=+1;
if (inkey in [55,56,57])or(ink=-72) then ky:=-1;
if (inkey in [49,50,51])or(ink=-80) then ky:=+1;
if flc(x+kx,y+ky)<>3 then
begin
ptx(x,y,r,0);x:=x+kx;y:=y+ky;ptt(40,10,50);
end;
end;
{5}53,13 :if flc(x,y)=0 then
begin
ptx(x,y,r,2);
hxm:=true;
pxc(jbx[jb],jby[jb]);
end
else
ptt(40,10,100);
32,{0}48 :pzd;
-60 :psa;
-61 :plo;
end;{case}
until (ink=27)or(hxm);
psj(rt);ptx(maxx+7,maxy div 3,rt,4);
until ink=27;
{ psj(maxz);ptx(maxx+7,maxy div 3,rt,3)}
{ writeln(fke);}
end.