给我一个用free pascal编译的游戏程序
当然可以了。编程序写到手腕酸到时候敲一个游戏进去是最好不过到啦。
用pascal有一点点麻烦，但是也是可以轻松实现的。不过用delphi更方便。
用pascal可以用面向单元的程序，但是不怎么好看。给你一点样本代码吧。
俄罗斯方块：
USES Crt;
CONST
Change:Array [0..6,0..3,0..7] Of Byte =(((0,1,1,1,2,1,3,1),(1,0,1,1,1,2,1,3),(0,1,1,1,2,1,3,1),(1,0,1,1,1,2,1,3)),
((1,0,0,1,1,1,2,1),(1,0,1,1,1,2,2,1),(0,1,1,1,2,1,1,2),(1,0,0,1,1,1,1,2)),
((1,0,2,0,1,1,2,1),(1,0,2,0,1,1,2,1),(1,0,2,0,1,1,2,1),(1,0,2,0,1,1,2,1)),
((1,0,2,0,0,1,1,1),(0,0,0,1,1,1,1,2),(1,0,2,0,0,1,1,1),(0,0,0,1,1,1,1,2)),
((0,0,1,0,1,1,2,1),(1,0,0,1,1,1,0,2),(0,0,1,0,1,1,2,1),(1,0,0,1,1,1,0,2)),
((1,0,2,0,1,1,1,2),(0,0,0,1,1,1,2,1),(1,0,0,2,1,1,1,2),(2,2,0,1,1,1,2,1)),
((0,0,1,0,1,1,1,2),(2,0,0,1,1,1,2,1),(2,2,1,0,1,1,1,2),(0,2,0,1,1,1,2,1)));
VAR
Board:Array [0..3,0..11,1..25] Of Byte;
Players,N,Nowx,Nowy,Kind,Trans,Speed:Byte;
Time,Score:Word;
Now:Array [0..7] Of Byte;
PROCEDURE Furbish;
VAR B,C:Byte;
Begin
For C:=24 Downto 2 Do Begin
Gotoxy(1,C);
For B:=1 To 10 Do
If Board[0,B,C]=0 Then Write(' ')
Else Write('圹');
End;
End;
PROCEDURE Clear;
Var A,B,C:Byte;D:Boolean;
Begin
For A:=24 Downto 1 Do
Begin
D:=True;
For B:=1 To 10 Do
If Board[0,B,A]=0 Then D:=False;
If D=True Then
Begin
Score:=Score+10;Gotoxy(1,1);Write(Score:5,'0');
For C:=A Downto 2 Do
For B:=1 To 10 Do
Board[0,B,C]:=Board[0,B,C-1];
A:=A+1;
End;
End;
Furbish;
End;
FUNCTION Canmove(X,Y:Byte):Boolean;
BEGIN
Canmove:=True;
If Board[0,X+Now[0],Y+Now[1]]>0 Then Canmove:=False;
If Board[0,X+Now[2],Y+Now[3]]>0 Then Canmove:=False;
If Board[0,X+Now[4],Y+Now[5]]>0 Then Canmove:=False;
If Board[0,X+Now[6],Y+Now[7]]>0 Then Canmove:=False;
End;
PROCEDURE Clean;
Begin
Gotoxy((Nowx+Now[0])*2-1,Nowy+Now[1]);Write(' ');
Gotoxy((Nowx+Now[2])*2-1,Nowy+Now[3]);Write(' ');
Gotoxy((Nowx+Now[4])*2-1,Nowy+Now[5]);Write(' ');
Gotoxy((Nowx+Now[6])*2-1,Nowy+Now[7]);Write(' ');
End;
PROCEDURE Show;
Begin
Gotoxy((Nowx+Now[0])*2-1,Nowy+Now[1]);Write('圹');
Gotoxy((Nowx+Now[2])*2-1,Nowy+Now[3]);Write('圹');
Gotoxy((Nowx+Now[4])*2-1,Nowy+Now[5]);Write('圹');
Gotoxy((Nowx+Now[6])*2-1,Nowy+Now[7]);Write('圹');
End;
BEGIN
Fillchar(Board,Sizeof(Board),0);
Randomize;Score:=0;
For N:=1 To 24 Do
Board[0,0,N]:=1;
For N:=1 To 24 Do
Board[0,11,N]:=1;
For N:=1 To 10 Do
Board[0,N,25]:=1;
Window(31,2,50,25);Textcolor(White);Textbackground(Blue);
Clrscr;Window(31,2,51,25);
Speed:=1;
Kind:=Random(7);Trans:=Random(4);Nowx:=4;Nowy:=1;
For N:=0 To 7 Do
Now[N]:=Change[Kind,Trans,N];
While Canmove(Nowx,Nowy) Do
Begin
Repeat
Clean;Nowy:=Nowy+1;Show;
Repeat
If Keypressed Then
Case Upcase(Readkey) Of
#0:Case Readkey Of
#75:If Canmove(Nowx-1,Nowy) Then Begin Clean;Nowx:=Nowx-1;Show;End;
#77:If Canmove(Nowx+1,Nowy) Then Begin Clean;Nowx:=Nowx+1;Show;End;
#80:Begin Clean;Repeat
If Canmove(Nowx,Nowy+1) Then Nowy:=Nowy+1;
Until Not(Canmove(Nowx,Nowy+1));Show;End;
#61:Begin Gotoxy(9,12);Write('Pause');Repeat Delay(1000);Until Keypressed;Furbish;End;
End;
#27:Exit;
' ',#13:Begin
Clean;Trans:=Trans+1;
If Trans=4 Then Trans:=0;
For N:=0 To 7 Do
Now[N]:=Change[Kind,Trans,N];
If Not(Canmove(Nowx,Nowy)) Then Begin Trans:=Trans-1;For N:=0 To 7 Do
Now[N]:=Change[Kind,Trans,N];Show;End
Else Show;
End;
End;
Until Not(Keypressed);
Delay((10-Speed)*50);
Until Not(Canmove(Nowx,Nowy+1));
Score:=Score+1;Gotoxy(1,1);Write(Score:5,'0');Speed:=(Score Div 300)+1;
Board[0,Nowx+Now[0],Nowy+Now[1]]:=1;
Board[0,Nowx+Now[2],Nowy+Now[3]]:=1;
Board[0,Nowx+Now[4],Nowy+Now[5]]:=1;
Board[0,Nowx+Now[6],Nowy+Now[7]]:=1;
Clear;
Kind:=Random(7);Trans:=Random(4);Nowx:=4;Nowy:=1;
For N:=0 To 7 Do
Now[N]:=Change[Kind,Trans,N];
End;
Gotoxy(7,12);Write('GAME OVER');Readln;
END.
Program Clock;
{$THREADING ON}
{$APPTYPE GUI}
Uses Graph, Dos, WinCrt;
Var
H,M,S,S100 : Word;
HH,MM,SS,SS100 : Word;
Y,Mt,D,W : Word;
Gd, Gm : SmallInt;
Function CatchKey(P : Pointer) : Longint;
Begin
While True Do
If ReadKey=#27 Then
Halt(0);
End;
Procedure Date;
Var
St,C : String;
Begin
SetTextStyle(DefaultFont,0,6);
SetColor(White);
GetDate(Y,Mt,D,W);
Str(Y,C);
St:=C+'-';
Str(Mt,C);
If Length(C)=1 Then
St:=St+'0'+C
Else
St:=St+C;
Str(D,C);
If Length(C)=1 Then
St:=St+'-0'+C
Else
St:=St+'-'+C;
OutTextXY(90,30,St);
Case W Of
0 : St:='Sun.';
1 : St:='Mon.';
2 : St:='Tue.';
3 : St:='Wed.';
4 : St:='Thu.';
5 : St:='Fri.';
6 : St:='Sat.';
End;
OutTextXY(230,410,St);
SetColor(Green);
End;
Procedure Cls;
Begin
SetFillStyle(SolidFill, Black);
Bar(100,100,540,380);
SetFillStyle(SolidFill, White);
Bar(120,120,520,360);
SetColor(Black);
Line(290,120,290,360);
Line(350,120,350,360);
SetColor(Green);
OutTextXY(290,200,':');
End;
Procedure ClsH;
Begin
SetFillStyle(SolidFill, White);
Bar(120,120,289,360);
End;
Procedure ClsM;
Begin
SetFillStyle(SolidFill, White);
Bar(351,120,520,360);
End;
Procedure Init;
Var
St,C : String;
Begin
BeginThread(@CatchKey);
SetFillStyle(SolidFill, Green);
FloodFill(0,0,640);
SetTextStyle(DefaultFont,0,10);
Cls;
Date;
SetTextStyle(DefaultFont,0,10);
GetTime(HH,MM,SS,SS100);
Str(HH,C);
If Length(C)=1 Then
St:='0'+C
Else
St:=C;
OutTextXY(130,200,St);
Str(MM,C);
If Length(C)=1 Then
St:='0'+C
Else
St:=C;
OutTextXY(360,200,St);
SetColor(Black);
Line(120,160,290,160);
Line(120,320,290,320);
Line(350,160,520,160);
Line(350,320,520,320);
SetColor(Green);
End;
Procedure Clock;
Var
St,C : String;
Begin
GetTime(H,M,S,S100);
If MMM Then
Begin
ClsM;
Str(MM,C);
If Length(C)=1 Then
St:='0'+C
Else
St:=C;
OutTextXY(360,130,St);
Str(M,C);
If Length(C)=1 Then
St:='0'+C
Else
St:=C;
OutTextXY(360,280,St);
SetColor(Black);
Line(350,240,520,240);
SetColor(Green);
Delay(1000);
ClsM;
Str(M,C);
If Length(C)=1 Then
St:='0'+C
Else
St:=C;
OutTextXY(360,200,St);
SetColor(Black);
Line(350,160,520,160);
Line(350,320,520,320);
SetColor(Green);
End;
If HHH Then
Begin
ClsH;
Str(HH,C);
If Length(C)=1 Then
St:='0'+C
Else
St:=C;
OutTextXY(130,130,St);
Str(H,C);
If Length(C)=1 Then
St:='0'+C
Else
St:=C;
OutTextXY(130,280,St);
SetColor(Black);
Line(120,240,290,240);
SetColor(Green);
Delay(1000);
ClsH;
Str(H,C);
If Length(C)=1 Then
St:='0'+C
Else
St:=C;
OutTextXY(130,200,St);
SetColor(Black);
Line(120,160,290,160);
Line(120,320,290,320);
SetColor(Green);
End;
HH:=H;
MM:=M;
SS:=S;
SS100:=S100;
End;
Begin
Gd := d8bit;
Gm := m640x480;
InitGraph(Gd, Gm, '');
Init;
While True Do
Clock;
CloseGraph;
End.
var
plife,plifemax,patt,pre:integer;
gr,ex,exmax:integer;
alife,alife1,aatt,are:integer;
name,fname:string;
na:text;
code,co:string;
dz:integer;
money:longint;
mp,mpmax:integer;
red,blue,knife,clothes:integer;
i:integer;
god:array[1..100] of 1..7;
godthing:integer;
procedure bag;
var
obj:integer;
begin
writeln;
writeln;
writeln('百宝箱:');
writeln('1:红色药丸: ',red,' 2:兰色药丸: ',blue,' 3:神剑:',knife,' 4:防身衣:',clothes,' 5;离开');
writeln;
writeln;
writeln('请选择:');
repeat
readln( obj);
case obj of
1:begin
if red>0 then begin
red:=red-1;
plife:=plife+40;
if plife>plifemax then plife:=plifemax;
end;
end;
2:begin
if blue>0 then begin
blue:=blue-1;
mp:=mp+40;
if mp>mpmax then mp:=mpmax;
end;
end;
3:begin
if knife>0 then begin
knife:=knife-1;
patt:=patt+15;
end;
end;
4:begin
if clothes>0 then begin
clothes:=clothes-1;
pre:=pre+15;
end;
end;
end;
writeln;
writeln;
writeln;
until obj=5;
exit;
end;
procedure bagplus(sh:integer);
begin
case sh of
1:red:=red+1;
2:blue:=blue+1;
3:knife:=knife+1;
4:clothes:=clothes+1;
end;
end;
procedure shop;
var
ob:integer;
begin
writeln;
writeln;
writeln('欢迎来到商店!');
writeln(' 1:红色药丸 2:兰色药丸 3:神剑 4:防身衣 5:离开');
writeln(' $15 $15 $30 $30');
writeln;
writeln('你想买什么？');
writeln;
repeat
readln(ob);
case ob of
1:begin
if money>=15 then
begin
money:=money-15;
bagplus(1);
writeln('OK!');
writeln(' 1:红色药丸 2:兰色药丸 3:神剑 4:防身衣 5:离开');
writeln(' $15 $15 $30 $30');
writeln;
writeln('你想买什么？');
writeln;
end
else writeln('钱不够啊，老大！');
end;
2:begin
if money>=15 then
begin
money:=money-15;
bagplus(2);
writeln('OK!');
writeln(' 1:红色药丸 2:兰色药丸 3:神剑 4:防身衣 5:离开');
writeln(' $15 $15 $30 $30');
writeln;
writeln('你想买什么？');
writeln;
end
else writeln('钱不够啊，老大！');
end;
3:begin
if money>=30 then
begin
money:=money-30;
bagplus(3);
writeln('OK!');
writeln(' 1:红色药丸 2:兰色药丸 3:神剑 4:防身衣 5:离开');
writeln(' $15 $15 $30 $30');
writeln;
writeln('你想买什么？');
writeln;
end
else writeln('钱不够啊，老大！');
end;
4:begin
if money>=30 then
begin
money:=money-30;
bagplus(4);
writeln('OK!');
writeln(' 1:红色药丸 2:兰色药丸 3:神剑 4:防身衣 5:离开');
writeln(' $15 $15 $30 $30');
writeln;
writeln('你想买什么？');
writeln;
end
else writeln('钱不够啊，老大！');
end;
end;
until ob=5;
exit;
end;
procedure storm;
var
ka,kp:integer;
begin
if mp>=30 then begin
writeln;
writeln;
writeln('破天一剑！！！！！！！！！！');
writeln(' 怪物生命:',alife1);
writeln('你的生命:',plife,'/',plifemax);
kp:=(random(patt)-random(are))*33; ;
if kp>0 then begin
writeln('攻击！！怪物得到',kp,' 伤害！?！');
alife1:=alife1-kp;
end
else begin
writeln('你无法攻击');
end;
ka:=aatt-pre+random(aatt div 4)-aatt div 2;
if ka>0 then begin
writeln('怪物攻击！！你得到',ka,' 伤害！?！');
plife:=plife-ka;
end
else begin
writeln( ' 怪物无法攻击');
end;
mp:=mp-30;
end
else writeln('魔力不够！！');
end;
procedure wall;
var
ka,kp:integer;
begin
if mp>=15 then begin
writeln;
writeln;
writeln('你用雷光！！！！');
writeln('怪物生命：',alife1);
writeln('你的生命:',plife,'/',plifemax);
kp:=(random(patt)-random(are))*26;
if kp>0 then begin
writeln('攻击！！怪物得到',kp,' 伤害！?！');
alife1:=alife1-kp;
end
else begin
writeln('你输了');
end;
ka:=aatt-pre+random(aatt div 4)-aatt div 2;
if ka>0 then begin
writeln('怪物攻击！！你得到',ka,' 伤害！?！');
plife:=plife-ka;
end
else begin
writeln( ' 你赢了！！！！！');
end;
mp:=mp-10;
end
else writeln('生命不够！！');
end;
procedure ball;
var
ka,kp:integer;
begin
if mp>=5 then begin
writeln;
writeln;
writeln('你用粉碎神拳！！！');
writeln('怪物生命：',alife1);
writeln('你的生命:',plife,'/',plifemax);
kp:=(random(patt)-random(are))*20;
if kp>0 then begin
writeln('攻击！！怪物得到',kp,' 伤害！?！');
alife1:=alife1-kp;
end
else begin
writeln('你输了');
end;
ka:=aatt-pre+random(aatt div 4)-aatt div 2;
if ka>0 then begin
writeln('怪物攻击！！你得到',ka,' 伤害！?！');
plife:=plife-ka;
end
else begin
writeln( ' 你赢了！！！！！');
end;
mp:=mp-10;
end
else writeln('生命不够！！');
end;
procedure magic;
var
ma:integer;
begin
writeln;
writeln;
writeln('1. 粉碎神拳 [5] 2. 雷光 [15] 3.破天一剑 [30]');
writeln('魔法值: ',mp,'/',mpmax);
read(ma);
case ma of
1:ball;
2:wall;
3:storm;
end;
end;
procedure plusmoney;
var
money1:longint;
begin
money1:=random(alife);
writeln;
writeln;
writeln('你得到 $',money1);
money:=money1+money;
end;
procedure load;
begin
close(na);
writeln;
writeln;
writeln('你的名字: ');
readln;
readln(name);
fname:=concat(name,'.txt');
assign(na,fname);
reset(na);
readln(na,code);
writeln('输入密码：');
readln(co);
if co<>code then
begin
writeln('密码错误');
readln;
halt;
end;
readln(na,plife);
readln(na,plifemax);
readln(na,patt);
readln(na,pre);
readln(na,ex);
readln(na,exmax);
readln(na,gr);
readln(na,money);
readln(na,mp);
readln(na,mpmax);
readln(na,red);
readln(na,blue);
readln(na,knife);
readln(na,clothes);
end;
procedure save;
var i:integer;
begin
close(na);
assign(na,fname);
rewrite(na);
writeln(na,code);
writeln(na,plife);
writeln(na,plifemax);
writeln(na,patt);
writeln(na,pre);
writeln(na,ex);
writeln(na,exmax);
writeln(na,gr);
writeln(na,money);
writeln(na,mp);
writeln(na,mpmax);
writeln(na,red);
writeln(na,blue);
writeln(na,knife);
writeln(na,clothes);
writeln(na,godthing);
for i:=1 to godthing do writeln(god[i]);
writeln;
writeln;
writeln('save successfully');
writeln;
writeln;
end;
procedure see;var i:integer;
begin
writeln('你的名字: ',name);
writeln('你的生命: ',plife,'/',plifemax);
writeln('攻击力: ',patt);
writeln('防御力: ',pre);
writeln('经验: ',ex);
writeln('升级经验',exmax);
writeln('级数: ',gr);
writeln('钞票:',money);
writeln('魔力: ',mp,'/',mpmax);
write('光之七神器:');for i:=1 to godthing do write(god[i],' ');
writeln;
writeln('百宝箱:');
writeln('红色药丸:',red);
writeln('兰色药丸:',blue);
writeln('神剑:' ,knife);
writeln('防身衣:',clothes);
writeln;
writeln;
end;
procedure people;
begin
plife:=100;
plifemax:=100;
patt:=20;
pre:=15;
money:=100;
gr:=1;
ex:=0;
exmax:=20;
mp:=50;
mpmax:=50;
red:=5;
blue:=5;
knife:=0;
clothes:=0;
end;
procedure old;
var i:integer;
begin
writeln('输入你的名字 :');
readln;
readln(name);
fname:=concat(name,'.txt');
assign(na,fname);
reset(na);
readln(na,code);
writeln('输入密码：');
readln(co);
if co<>code then
begin
writeln('密码错误！');
readln;
halt;
end;
readln(na,plife);
readln(na,plifemax);
readln(na,patt);
readln(na,pre);
readln(na,ex);
readln(na,exmax);
readln(na,gr);
readln(na,money);
readln(na,mp);
readln(na,mpmax);
readln(na,red);
readln(na,blue);
readln(na,knife);
readln(na,clothes);
readln(na,godthing);
for i:=1 to godthing do readln(god[i]);
end;
procedure new;
var i:integer;
begin
writeln( ' 输入你的名字: ');
readln;
readln(name);
if name<>'0' then begin
fname:=concat(name,'.txt');
assign(na,fname);
rewrite(na);
writeln('输入密码');
readln(code);
writeln(na,code);
people;
writeln(na,plife);
writeln(na,plifemax);
writeln(na,patt);
writeln(na,pre);
writeln(na,ex);
writeln(na,exmax);
writeln(na,gr);
writeln(na,money);
writeln(na,mp);
writeln(na,mpmax);
writeln(na,red);
writeln(na,blue);
writeln(na,knife);
writeln(na,clothes);
writeln(godthing);
for i:=1 to godthing do writeln(god[i]);
end
else halt;
end;
procedure denlu;
var
dl:byte;
begin
writeln('-------------------自制的游戏不要笑----------------------');
writeln('-----------------------仅供娱乐----------------------');
writeln('1: 新游戏 2:老游戏 3:退出');
read(dl);
case dl of
1:new;
2:old;
3:halt;
end;
end;
procedure godthing2;
var
qi:integer;
begin
randomize;
qi:=random(50);
case qi of
0,8:begin
writeln('得到光之七神具----1:辟天宝剑');
writeln('攻击增加60点!!!');
patt:=patt+60;
godthing:=godthing+1;
god[godthing]:=1;
end;
3,16:begin
writeln('得到光之七神具----2:开地玄远剑');
writeln('攻击力*2');
patt:=patt*2;
godthing:=godthing+1;
god[godthing]:=2;
end;
end;
end;
procedure grow;
begin
if ex>=exmax then begin
plife:=plifemax+50;
plifemax:=plife;
patt:=patt+15;
pre:=pre+15;
mpmax:=mpmax+30;
mp:=mpmax;
ex:=0;
gr:=gr+1;
exmax:=exmax+100;
writeln('升级!!');
godthing2;
writeln;
writeln;
end;
end;
procedure experience;
begin
randomize;
ex:=ex+random(alife)+30;
grow;
end;
procedure attack;
var
win,lost,run:boolean;
ch,ff,kp,ka:integer;
procedure winner;
begin
win:=false;
if alife1<1 then win :=true;
end;
procedure loster;
begin
lost:=false;
if plife<1 then lost:=true;
end;
begin
win:=false;
lost:=false;
run:=false;
writeln('1:攻击; 2:逃跑');
writeln('你的生命:',plife,'/',plifemax);
writeln('你的魔法值: ',mp,'/',mpmax);
readln(ch);
if ch=1 then begin
alife1:=alife;
repeat
writeln;
writeln;
writeln('1:物理￥攻击; 2:魔法￥攻击; 3:用百宝箱; 4.逃跑 ');
read(ff);
case ff of
1:begin
writeln;
writeln;
writeln;
writeln;
{}
kp:=random(patt)-random(are);
if kp>0 then begin
writeln('你攻击！！怪物受到',kp,' 伤害');
alife1:=alife1-kp;
end
else begin
writeln('你输了');
end;
ka:=random(aatt)-random(pre);
if ka>0 then begin
writeln('怪物攻击，你得到',ka,' 伤害');
plife:=plife-ka;
end
else begin
writeln( '怪物输了');
end;
writeln(' 怪物生命:',alife1);
writeln('你生命:',plife,'/',plifemax);
writeln('你的魔法值: ',mp,'/',mpmax);
end;
2:begin
magic;
end;
3:begin
bag;
end;
4:begin
run:=true;
writeln('逃跑失败');
end;
end;
winner;
loster;
until win or lost or run;
if win then begin experience; plusmoney; writeln('你赢了!!!'); writeln; end;
if lost then
begin
writeln('输了');
readln;
halt;
end;
end
else exit;
end;
procedure animal;
begin
alife:=plifemax+random(50);
if plifemax=100 then begin
aatt:=15;
are:=10;
end
else begin
aatt:=aatt+10;
are:=are+7;
end;
attack;
end;
procedure meet;
var
cc:integer;
begin
randomize;
cc:=random(100);
if cc<40 then begin
writeln;
writeln('你遇见一个怪物');
animal;
end
else writeln('没碰到.......');
end;
procedure choose;
begin
writeln('1:找怪物; 2:去商店; 3:读取; 4:保存; 5:退出 6:查看 7:用百宝箱');
read(dz);
case dz of
1:meet;
2:shop;
3:load;
4:save;
6:see;
7:bag;
end;
end;
begin
denlu;
while dz<>5 do
choose;
close(na);
end.
魔兽
中国象棋
type
qp=array[0..9,1..9]of shortint;
const
es:array['a'..'i']of byte=(1,2,3,4,5,6,7,8,9);
se:array[ 1 .. 9 ]of char=('a','b','c','d','e','f','g','h','i');
ci:array['0'..'9']of byte=(0,1,2,3,4,5,6,7,8,9);
qz:array[ 1 ..14 ]of string[2]=('车','马','炮','仕','相','兵','帅','车','马','包','士','象','卒','将');
yqp:qp=(( 8, 9,12,11,14,11,12, 9, 8),
( 0, 0, 0, 0, 0, 0, 0, 0, 0),
( 0,10, 0, 0, 0, 0, 0,10, 0),
(13, 0,13, 0,13, 0,13, 0,13),
( 0, 0, 0, 0, 0, 0, 0, 0, 0),
( 0, 0, 0, 0, 0, 0, 0, 0, 0),
( 6, 0, 6, 0, 6, 0, 6, 0, 6),
( 0, 3, 0, 0, 0, 0, 0, 3, 0),
( 0, 0, 0, 0, 0, 0, 0, 0, 0),
( 1, 2, 5, 4, 7, 4, 5, 2, 1));
var
t,sx,sy,ex,ey,bushu:integer;
qipan:qp;
procedure initqp(var a:qp);
var i,j:integer;
begin
fillchar(a,sizeof(a),0);
for i:=1 to 9 do
for j:=0 to 9 do
a[j,i]:=yqp[j,i];
end;
procedure print(q:qp);
var i,j:integer;
b:array[1..10,1..9]of string[2];
begin
writeln;
writeln('中国象棋[By angwuy]');
writeln('红:帅仕相车马炮兵');
writeln('黑:将士象车马包卒');
writeln;
for i:=1 to 10 do
for j:=1 to 8 do
b[i,j]:='+-';
for i:=1 to 10 do
b[i,9]:='-+';
for i:=1 to 10 do
for j:=1 to 9 do
if q[i-1,j]>0 then b[i,j]:=qz[q[i-1,j]];
writeln(' a b c d e f g h i');
writeln('0 ',b[1,1],'--',b[1,2],'--',b[1,3],'--',b[1,4],'--',b[1,5],'--',b[1,6],'--',b[1,7],'--',b[1,8],'-',b[1,9]);
writeln(' | | | | \ | / | | | |');
writeln('1 ',b[2,1],'--',b[2,2],'--',b[2,3],'--',b[2,4],'--',b[2,5],'--',b[2,6],'--',b[2,7],'--',b[2,8],'-',b[2,9]);
writeln(' | | | | / | \ | | | |');
writeln('2 ',b[3,1],'--',b[3,2],'--',b[3,3],'--',b[3,4],'--',b[3,5],'--',b[3,6],'--',b[3,7],'--',b[3,8],'-',b[3,9]);
writeln(' | | | | | | | | |');
writeln('3 ',b[4,1],'--',b[4,2],'--',b[4,3],'--',b[4,4],'--',b[4,5],'--',b[4,6],'--',b[4,7],'--',b[4,8],'-',b[4,9]);
writeln(' | | | | | | | | |');
writeln('4 ',b[5,1],'--',b[5,2],'--',b[5,3],'--',b[5,4],'--',b[5,5],'--',b[5,6],'--',b[5,7],'--',b[5,8],'-',b[5,9]);
writeln(' | 楚河 汉界 |');
writeln('5 ',b[6,1],'--',b[6,2],'--',b[6,3],'--',b[6,4],'--',b[6,5],'--',b[6,6],'--',b[6,7],'--',b[6,8],'-',b[6,9]);
writeln(' | | | | | | | | |');
writeln('6 ',b[7,1],'--',b[7,2],'--',b[7,3],'--',b[7,4],'--',b[7,5],'--',b[7,6],'--',b[7,7],'--',b[7,8],'-',b[7,9]);
writeln(' | | | | | | | | |');
writeln('7 ',b[8,1],'--',b[8,2],'--',b[8,3],'--',b[8,4],'--',b[8,5],'--',b[8,6],'--',b[8,7],'--',b[8,8],'-',b[8,9]);
writeln(' | | | | \ | / | | | |');
writeln('8 ',b[9,1],'--',b[9,2],'--',b[9,3],'--',b[9,4],'--',b[9,5],'--',b[9,6],'--',b[9,7],'--',b[9,8],'-',b[9,9]);
writeln(' | | | | / | \ | | | |');
writeln('9 ',b[10,1],'--',b[10,2],'--',b[10,3],'--',b[10,4],'--',b[10,5],'--',b[10,6],'--',b[10,7],'--',b[10,8],'-',b[10,9]);
end;
function checkred(a:qp;sx,sy,ex,ey:integer):boolean;
var i,j,t:integer;
begin
checkred:=true;
if not(a[sy,sx] in [1..7]) then begin checkred:=false;exit;end;
if a[ey,ex] in [1..7] then begin checkred:=false;exit;end;
if (ey=sy)and(ex=sx) then begin checkred:=false;exit;end;
case a[sy,sx] of
1:begin
if (ey=sy)or(ex=sx) then else begin checkred:=false;exit;end;
if sx=ex then
begin
if ey>sy then
begin
for i:=sy+1 to ey-1 do
if a[i,sx]>0 then begin checkred:=false;exit;end;
end
else if sy>ey then
begin
for i:=sy-1 downto ey+1 do
if a[i,sx]>0 then begin checkred:=false;exit;end;
end;
end
else
begin
if ex>sx then
begin
for i:=sx+1 to ex-1 do
if a[sy,i]>0 then begin checkred:=false;exit;end;
end
else if sy>ey then
begin
for i:=sx-1 downto ex+1 do
if a[sy,i]>0 then begin checkred:=false;exit;end;
end;
end;
end;
2:begin
i:=ey-sy;j:=ex-sx;
if ((abs(i)=1)and(abs(j)=2))or((abs(i)=2)and(abs(j)=1)) then
else begin checkred:=false;exit;end;
if (j=2) then
begin
if a[sy,sx+1]>0 then begin checkred:=false;exit;end;
end
else if (j=-2) then
begin
if a[sy,sx-1]>0 then begin checkred:=false;exit;end;
end
else if (i=2) then
begin
if a[sy+1,sx]>0 then begin checkred:=false;exit;end;
end
else if (i=-2) then
begin
if a[sy-1,sx]>0 then begin checkred:=false;exit;end;
end;
end;
3:begin
if (ey=sy)or(ex=sx) then else begin checkred:=false;exit;end;
if sx=ex then
begin
if ey>sy then
begin
t:=0;
for i:=sy+1 to ey-1 do
if a[i,sx]>0 then inc(t);
if ((t=0)and(a[ey,ex]=0))or((t=1)and(a[ey,ex]>0)) then
else begin checkred:=false;exit;end;
end
else if sy>ey then
begin
t:=0;
for i:=sy-1 downto ey+1 do
if a[i,sx]>0 then inc(t);
if ((t=0)and(a[ey,ex]=0))or((t=1)and(a[ey,ex]>0)) then
else begin checkred:=false;exit;end;
end;
end else
if sy=ey then
begin
if ex>sx then
begin
t:=0;
for i:=sx+1 to ex-1 do
if a[sy,i]>0 then inc(t);
if ((t=0)and(a[ey,ex]=0))or((t=1)and(a[ey,ex]>0)) then
else begin checkred:=false;exit;end;
end
else if sx>ex then
begin
t:=0;
for i:=sx-1 downto ex+1 do
if a[sy,i]>0 then inc(t);
if ((t=0)and(a[ey,ex]=0))or((t=1)and(a[ey,ex]>0)) then
else begin checkred:=false;exit;end;
end;
end;
end;
4:begin
i:=ey-sy;j:=ex-sx;
if (abs(i)=1)and(abs(j)=1) then else begin checkred:=false;exit;end;
if (ey in [7..9])and(ex in [4..6]) then else begin checkred:=false;exit;end;
end;
5:begin
i:=ey-sy;j:=ex-sx;
if (abs(i)=2)and(abs(j)=2) then else begin checkred:=false;exit;end;
if a[(ey+sy)div 2,(ex+sx)div 2]>0 then begin checkred:=false;exit;end;
if (ey in [9,7,5])and(ex in [1,3,5,7,9]) then else begin checkred:=false;exit;end;
end;
6:begin
i:=ey-sy;j:=ex-sx;
if (i=-1)and(j=0) then
else if (i=0)and(abs(j)=1)and(sy<5) then
else begin checkred:=false;exit;end;
end;
7:begin
i:=ey-sy;j:=ex-sx;
if ((abs(i)=1)and(j=0))or((abs(j)=1)and(i=0)) then
begin
if (ey in [7..9])and(ex in [4..6]) then else begin checkred:=false;exit;end;
end
else
begin
if a[ey,ex]<>14 then begin checkred:=false;exit;end;
for i:=sy-1 downto ey+1 do if a[i,ex]>0 then begin checkred:=false;exit;end;
end;
end;
end;
end;
function checkblack(a:qp;sx,sy,ex,ey:integer):boolean;
var i,j,t:integer;
begin
checkblack:=true;
if not(a[sy,sx] in [8..14]) then begin checkblack:=false;exit;end;
if a[ey,ex] in [8..14] then begin checkblack:=false;exit;end;
if (ey=sy)and(ex=sx) then begin checkblack:=false;exit;end;
case a[sy,sx] of
8:begin
if (ey=sy)or(ex=sx) then else begin checkblack:=false;exit;end;
if sx=ex then
begin
if ey>sy then
begin
for i:=sy+1 to ey-1 do
if a[i,sx]>0 then begin checkblack:=false;exit;end;
end
else if sy>ey then
begin
for i:=sy-1 downto ey+1 do
if a[i,sx]>0 then begin checkblack:=false;exit;end;
end;
end
else
begin
if ex>sx then
begin
for i:=sx+1 to ex-1 do
if a[sy,i]>0 then begin checkblack:=false;exit;end;
end
else if sx>ex then
begin
for i:=sx-1 downto ex+1 do
if a[sy,i]>0 then begin checkblack:=false;exit;end;
end;
end;
end;
9:begin
i:=ey-sy;j:=ex-sx;
if ((abs(i)=1)and(abs(j)=2))or((abs(i)=2)and(abs(j)=1)) then
else begin checkblack:=false;exit;end;
if (j=2) then
begin
if a[sy,sx+1]>0 then begin checkblack:=false;exit;end;
end
else if (j=-2) then
begin
if a[sy,sx-1]>0 then begin checkblack:=false;exit;end;
end
else if (i=2) then
begin
if a[sy+1,sx]>0 then begin checkblack:=false;exit;end;
end
else if (i=-2) then
begin
if a[sy-1,sx]>0 then begin checkblack:=false;exit;end;
end;
end;
10:begin
if (ey=sy)or(ex=sx) then else begin checkblack:=false;exit;end;
if sx=ex then
begin
if ey>sy then
begin
t:=0;
for i:=sy+1 to ey-1 do
if a[i,sx]>0 then inc(t);
if ((t=0)and(a[ey,ex]=0))or((t=1)and(a[ey,ex]>0)) then
else begin checkblack:=false;exit;end;
end
else if sy>ey then
begin
t:=0;
for i:=sy-1 downto ey+1 do
if a[i,sx]>0 then inc(t);
if ((t=0)and(a[ey,ex]=0))or((t=1)and(a[ey,ex]>0)) then
else begin checkblack:=false;exit;end;
end;
end;
if sy=ey then
begin
if ex>sx then
begin
t:=0;
for i:=sx+1 to ex-1 do
if a[sy,i]>0 then inc(t);
if ((t=0)and(a[ey,ex]=0))or((t=1)and(a[ey,ex]>0)) then
else begin checkblack:=false;exit;end;
end
else if sx>ex then
begin
t:=0;
for i:=sx-1 downto ex+1 do
if a[sy,i]>0 then inc(t);
if ((t=0)and(a[ey,ex]=0))or((t=1)and(a[ey,ex]>0)) then
else begin checkblack:=false;exit;end;
end;
end;
end;
11:begin
i:=ey-sy;j:=ex-sx;
if (abs(i)=1)and(abs(j)=1) then else begin checkblack:=false;exit;end;
if (ey in [0..2])and(ex in [4..6]) then else begin checkblack:=false;exit;end;
end;
12:begin
i:=ey-sy;j:=ex-sx;
if (abs(i)=2)and(abs(j)=2) then else begin checkblack:=false;exit;end;
if a[(ey+sy)div 2,(ex+sx)div 2]>0 then begin checkblack:=false;exit;end;
if (ey in [0,2,4])and(ex in [1,3,5,7,9]) then else begin checkblack:=false;exit;end;
end;
13:begin
i:=ey-sy;j:=ex-sx;
if (i=1)and(j=0) then
else if (i=0)and(abs(j)=1)and(sy>4) then
else begin checkblack:=false;exit;end;
end;
14:begin
i:=ey-sy;j:=ex-sx;
if ((abs(i)=1)and(j=0))or((abs(j)=1)and(i=0)) then
begin
if (ey in [0..2])and(ex in [4..6]) then else begin checkblack:=false;exit;end;
end
else
begin
if a[ey,ex]<>7 then begin checkblack:=false;exit;end;
for i:=sy+1 to ey-1 do if a[i,ex]=0 then begin checkblack:=false;exit;end;
end;
end;
end;
end;
procedure getline(var c1,c2,c3,c4:integer);
var st:string;
begin
while true do
begin
write('red:');
readln(st);
if not(st[1] in ['a'..'i']) then continue;
if not(st[2] in ['0'..'9']) then continue;
if not(st[3] in ['a'..'i']) then continue;
if not(st[4] in ['0'..'9']) then continue;
if copy(st,1,2)=copy(st,3,2) then continue;
c1:=es[st[1]];c2:=ci[st[2]];
c3:=es[st[3]];c4:=ci[st[4]];
if checkred(qipan,c1,c2,c3,c4) then break;
end;
end;
function fenzhi(q:qp):integer;
var i,j,i1,j1:integer;
begin
t:=0;
for i:=1 to 9 do
for j:=0 to 9 do
begin
if (q[j,i]=8)and(i in [2,4,6,8])and(bushu<30) then inc(t,10);
if (q[i,j]=8)and(j in [1,4,6,7]) then inc(t,10);
if (q[i,j]=8)and(j=3) then dec(t,5);
if (q[j,i]=yqp[j,i])and(q[j,i] in [8..14])and(bushu<50) then dec(t,2);
if (q[j,i] in [8..10,13])and(j>5)and(bushu>10) then inc(t,(14-q[j,i]));
if (q[j,i]=13)and(q[j+2,i]=6)and(q[j+3,i]=2) then inc(t,10);
if (q[j,i]=13)and(q[j-2,i]=9)and(q[j+2,i]=6) then inc(t,10);
if (q[j,i]=8)and(j=1)and(i=5) then dec(t,40);
case q[j,i] of
1:dec(t,100);
2:if bushu<30 then dec(t,40) else dec(t,50);
3:if bushu<50 then dec(t,50) else dec(t,40);
4,5:dec(t,20);
6:if bushu<50 then dec(t,10)
else if (j>5)or(j=0) then dec(t,20)
else dec(t,30);
7:dec(t,10000);
8:inc(t,100);
9:if bushu<30 then inc(t,40) else inc(t,50);
10:if bushu<50 then inc(t,50) else inc(t,40);
11,12:inc(t,20);
13:if bushu<50 then inc(t,10)
else if (j>5)or(j=0) then inc(t,20)
else inc(t,30);
14:inc(t,10000);
end;
end;
if q[1,5] in[8,9,10,14] then dec(t,10);
if (bushu<50)and(q[0,5]<>14) then dec(t,18);
if (q[3,5]=3)and checkred(q,5,3,5,1) and (bushu<50) then dec(t,30);
if (q[4,5]=3)and checkred(q,5,4,5,1) and (bushu<50) then dec(t,30);
if (q[5,5]=3)and checkred(q,5,5,5,1) and (bushu<50) then dec(t,30);
if (q[6,5]=3)and checkred(q,5,6,5,1) and (bushu<50) then dec(t,30);
if (q[7,5]=3)and checkred(q,5,7,5,1) and (bushu<50) then dec(t,30);
if (q[2,1]=12) then dec(t,18);
if (q[2,9]=12) then dec(t,18);
if (q[2,5]=12) then inc(t,10);
if (q[2,5] in [1..9,10..13,14])and(q[4,5]=13)and(q[7,5] in [0,3]) then dec(t,10);
if (bushu<10)and(q[2,5]=10) then inc(t,15);
if (q[0,1]=8) then dec(t,25);
if (q[0,9]=8) then dec(t,25);
if (q[0,2]=9) then dec(t,18);
if (q[0,8]=9) then dec(t,18);
if (q[2,1]=9)and(q[2,9]=9) then dec(t,10);
fenzhi:=t;
end;
function panfen(q:qp;dep:integer):integer;
var
qi1,qi2,hqi:qp;
i1,i2,i3,i4,j1,j2,j3,j4,t,t1,t2:integer;
begin
if dep=0 then
begin
panfen:=fenzhi(q);
exit;
end;
t:=-32768;
for i1:=1 to 9 do
for i2:=0 to 9 do
if q[i2,i1] in [8..14] then
for i3:=1 to 9 do
for i4:=0 to 9 do
if checkblack(q,i1,i2,i3,i4) then
begin
qi1:=q;
qi1[i4,i3]:=qi1[i2,i1];
qi1[i2,i1]:=0;
t1:=32767;
for j1:=1 to 9 do
for j2:=0 to 9 do
if q[j2,j1] in [1..7] then
for j3:=1 to 9 do
for j4:=0 to 9 do
if checkred(qi1,j1,j2,j3,j4) then
begin
qi2:=qi1;
qi2[j4,j3]:=qi2[j2,j1];
qi2[j2,j1]:=0;
t2:=panfen(qi2,0);
if t2<=t1 then begin t1:=t2;hqi:=qi2;end;
end;
if t1<-5000 then continue;
t1:=panfen(hqi,dep-1);
if t1>t then
begin
t:=t1;
end;
end;
panfen:=t;
end;
procedure searchblack(q:qp;var c1,c2,c3,c4:integer);
var
qi1,qi2,hqi:qp;
i1,i2,i3,i4,j1,j2,j3,j4,t,h1,h2,h3,h4,t1,t2:integer;
begin
t:=-32768;
for i1:=1 to 9 do
for i2:=0 to 9 do
if q[i2,i1] in [8..14] then
for i3:=1 to 9 do
for i4:=0 to 9 do
if checkblack(q,i1,i2,i3,i4) then
begin
qi1:=q;
qi1[i4,i3]:=qi1[i2,i1];
qi1[i2,i1]:=0;
if fenzhi(qi1)>5000 then begin c1:=i1;c2:=i2;c3:=i3;c4:=i4;exit;end;
t1:=32767;
for j1:=1 to 9 do
for j2:=0 to 9 do
if q[j2,j1] in [1..7] then
for j3:=1 to 9 do
for j4:=0 to 9 do
if checkred(qi1,j1,j2,j3,j4) then
begin
qi2:=qi1;
qi2[j4,j3]:=qi2[j2,j1];
qi2[j2,j1]:=0;
t2:=panfen(qi2,0);
if t2<=t1 then begin t1:=t2;hqi:=qi2;end;
end;
if t1<-5000 then continue;
t1:=panfen(hqi,1);
if t1>t then
begin
t:=t1;h1:=i1;h2:=i2;h3:=i3;h4:=i4;
end;
end;
c1:=h1;c2:=h2;c3:=h3;c4:=h4;
end;
begin
writeln('使用说明：输入包括4个字符，分别为字母和数字，字母数字');
writeln('前面两个表示你要移动的那个子现在的坐标，后面代表目标坐标');
initqp(qipan);
print(qipan);bushu:=1;
while true do
begin
getline(sx,sy,ex,ey);
qipan[ey,ex]:=qipan[sy,sx];qipan[sy,sx]:=0;
writeln('busy...');
searchblack(qipan,sx,sy,ex,ey);
writeln('black:',se[sx],sy,se[ex],ey);
qipan[ey,ex]:=qipan[sy,sx];qipan[sy,sx]:=0;
inc(bushu,2);
print(qipan);
end;
end.
去pascal吧找吧
歧霞伪麻： varn,i:longint; beginreadln(n);for i:=1 to n dobeginwrite(i,' ');end; end.
翔安区18356003266： 谁可以帮我用FREE PASCAL 写一个程序？
歧霞伪麻： 我编了一个,验证到n. program gdbh; var n,i,j:longint; w:boolean; function bz(q:longint):boolean; var i,j:longint; begin for i:=2 to q do begin bz:=true; for j:=2 to trunc(sqrt(i)); if i mod j=0 then bz:=false; end; end; begin readln(n); i:=6; repeat w:=true; for ...
翔安区18356003266： 用Free pascal编写个很简单的程序 - ？
歧霞伪麻： var i,j,x,y:longint;a,b,c,d:real; begin a:=8;b:=2;c:=1;d:=50; for i:=1 to d div a do for j:=1 to d div b do for x:=1 to d div c do if (i*a+j*b+x*c<=d) and (i+j+x>30) then writeln(i,' ',j,' ',x); end.自己漫漫理解吧
翔安区18356003266： 用Free Pascal 编一个如下形式的字母塔. - ？
歧霞伪麻： var i,j:integer; begin for i:=1 to 26 do begin for j:=1 to 26-i do write(' '); for j:=1 to i do write(chr(64+j)); for j:=i-1 downto 1 do write(chr(64+j)); writeln; end; end.
翔安区18356003266： 用free pascal编一个能打印如下图形的程序. - ？
歧霞伪麻： Program Bd;Var a,b,c:Integer;Begin For a:= 1 to 5 Do Begin For b:= 1 to 5-a Do Write(' '); For c:= 1 to 2*a-1 Do Write('*'); WriteLn; End; ReadLn;End.我这里可以运行!你试试吧!望采纳!
翔安区18356003266： 求用 free pascal 编一程序、 - ？
歧霞伪麻： var a,b,c:longint; p,s:double;begin readln(a,b,c); if (a+b<=c)or(b+c<=a)or(c+a<=b) then writeln('no answer')else begin p:=(a+b+c)/2; s:=sqrt(p*(p-...
翔安区18356003266： 用free pascal编写一个小程序 - ？
歧霞伪麻： 用数组:var a:array[1..3] of longint; i,j,t:longint; begin for i:=1 to 3 do read(a[i]); for i:=1 to 2 do for j:=i+1 to 3 do if a[i]>a[j] then begin t:=a[i]; a[i]:=a[j]; a[j]:=t; end; for i:=1 to 3 do write(a[i],' '); end. 不用数组的:var a,b,c,t:longint;begin readln(a,b,c); if a>...
翔安区18356003266： 用FreePascal编个程序？
歧霞伪麻： var i:integer; a,b,c,d,e,f,g:integer; s:array[1..7]of string = ('Monday', 'Tuesday', 'Wednesday','Thursday', 'Friday','Saturday','Sunday'); begin for c:=1 to 7 do begin a:=c+1; f:=4; for e:=1 to 7 do if(a<8)and(e<>a)and(e<>c)and(e<>f) then begin d:=e+2; for...
翔安区18356003266： 用freepascal编程 输入一个三位数的整数,将数字位置重新排列,组成一个尽可能大的三位数.例如输入213,重 - ？
歧霞伪麻： program make; var a:array[1..3] of char;i,j:integer;t:char; begin for i:=1 to 3 do read(a[i]); for i:=1 to 2 do for j:=1 to 3-i do if a[j]<a[j+1] then begin t:=a[j]; a[j]:=a[j+1]; a[j+1]:=t; end; for i:=1 to 3 do write(a[i]); writeln; end.
翔安区18356003266： 用free pascal 编写一个程序,在线等？
歧霞伪麻： 先附上运行截图, 程序运行无误 如果回答对如果回答错附上程序: const _operator: array[0..3] of Char = ('+', '-', '*', '/'); var m, n, r: Integer; res: Double; op: Char; begin Randomize;//初始化随机环境 res := 0; repeat m := Random(101);//0~100 n :...
