目录
1. 最小数字子串
2. 邮票面值
3. 字符移动
4. 子集定和问题
5. 素数方阵
6. 全排列问题
7. 移盘子问题
8. N 女王问题
9. 组合问题
10. 电子锁
11. 高精度数加减法
12. 高精度数乘法
13. 高精度数除法(一)
14. 高精度数除法(二)
15. 高精度数阶乘
16. P×S=11...1
17. P×S=987654321...
18. 受控时钟
19. 高精度八进制除法
20. 八数码问题
21. 取火柴游戏
22. 取奇数游戏
23. 最长公共子串
1. 键盘输入一个高精度正整数t(不超过240位),去掉其中S个数字后,剩下的
数字按原顺序组成一个新数,试对给定的 t 与 S, 寻找一种方案,使剩下的数字
组成的新数最小.
program lxw001;
var t1,t2:string[250];
a,b:array[1..250] of integer;
i,j,r,s,s1:integer;
begin
writeln('输入数字串:'); readln(t1);
writeln('输入删除数字个数:');readln(s);
s1:=s; r:=0; t2:='';
for i:=1 to length(t1) do a:=i;
repeat
i:=1;
for j:=1 to s1+1 do if t1[j]<t1 then i:=j;
if i>1 then
for j:=1 to i-1 do begin inc(r); b[r]:=a[j] end;
t2:=t2+copy(t1,i,1);
delete(t1,1,i);
for j:=1 to length(t1) do a[j]:=a[j+i];
s1:=s1-(i-1);
if length(t1)=s1 then {处理尾部应删的数}
begin
for j:=1 to s1 do begin inc(r);b[r]:=a[j] end;
s1:=0; t1:='';
end;
until s1=0;
t2:=t2+t1;
writeln('最小数:',t2);
write('删除数字的位置: ');
for i:=1 to s do write(b,' ');
writeln;
end.
2. 发行一套四种不同面值的邮票,限定使用时不超过3枚,为了能连续贴出
1,2,...,r的面值, 如何确定四种面值,使 r 最大?
program lxw002;
var
s1,s2,s3,s4: integer;
r,r0,r1,r2,r3,r4: integer;
stamp: set of 1..100;
function workr(s1,s2,s3,s4:integer):integer;
var n1,n2,n3,n4,f:integer;
begin
stamp:=[];
for n1:=0 to 3 do
for n2:=0 to 3-n1 do
for n3 :=0 to 3-n1-n2 do
for n4:=0 to 3-n1-n2-n3 do
begin
f:=n1*s1+n2*s2+n3*s3+n4*s4;
stamp:=stamp+[f]
end;
f:=1;
while f in stamp do f:=f+1;
workr:=f-1
end;
begin{main};
s1:=1; r0:=0;
for s2:=s1+1 to 3*s1+1 do
for s3:=s2+1 to 3*s2+1 do
for s4:=s3+1 to 3*s3+1 do
begin
r:=workr(s1,s2,s3,s4);
if r>r0 then
begin
r0:=r;
r1:=s1; r2:=s2; r3:=s3; r4:=s4
end;
end;
writeln('s1=',r1,', s2=',r2,', s3=',r3,', s4=',r4);
writeln('The max Value is: ',r0)
end.
3. n个A与n个B(n≥4)排成一排, 开始时, 字符B全排在A的后面,然后将它移成
A,B 相间的情形: AAAABBBB → ABABABAB. 要求如下:
(1) 每次同时移动两相邻字符, 不得调换顺序.
(2) 总步数应尽量少.
program lxw003;
var i,n,step:integer;
s:array [1..100] of char;
procedure display;
var i:integer;
begin
write('No.',step:2,' ');
for i:=1 to 2*n+2 do write(s);
writeln
end;
procedure move(i,k:integer);
var j:integer;
begin
step:=step+1;
for j:=0 to 1 do
begin s[k+j]:=s[i+j]; s[i+j]:=' ' end;
display
end;
begin{main}
repeat writeln('input n:'); readln(n) until n>3;
step:=0;
for i:=1 to n do s:='A';
for i:=n+1 to 2*n do s:='B';
s[2*n+1]:=' '; s[2*n+2]:=' ';
display;
if n>4 then
for i:=n downto 5 do
begin move(i,2*i+1); move(2*i-1,i) end;
move(4,9); move(8,4); move(2,8);
move(7,2); move(1,7)
end.
4. 由键盘输入N, B={1,2,...,N}为连续N个整数的集合, 取B中若干不同的整
数, 使这些整数之和为给定的M, 共有多少种不同的取法?
program lxw004;
var m,n,i:integer;
s:longint;
function aa(k,m:integer):longint;
var i,t1,kz:integer;
temp:longint;
begin
if (k>m) or (k=1)and(m>1) or (k=0)and(m>0) then
begin aa:=0; exit end;
if k=m then begin aa:=1; exit end;
temp:=0; {处理 k<m的情形}
t1:=m-k; kz:=k-1;
if kz>m-k then kz:=m-k;
for i:=1 to kz do temp:=temp+aa(i,t1);
aa:=temp;
end;
begin
writeln('输入最大整数:'); readln(n);
writeln('输入定和数:'); readln(m);
s:=0;
for i:=1 to n do s:=s+aa(i,m);
writeln('计算结果:',s);
end.
5. 设 D 为5行5列的方阵, 其元素表示为D(I,J), 每个D(I,J)皆是0--9中的
某个数字,D(1,1)=r为已知. 试求满足以下条件的全部方阵 D:
(1) D 的每行,每列,每条对角线均为一个五位素数.
(2) 由键盘输入S, 上述各素数的各位数字之和均等于S.
program lxw005; {素数矩阵}
const s:array [1..4] of integer= (1,3,7,9);
type arr2=array [0..50000] of boolean;
e5=array [1..5] of shortint;
var x: array [1..2] of ^arr2;
limit,k,k1,t,ss,tt,r,sum1:longint;
a1:array[1..1000] of e5;
d1:array[1..5] of e5;
g1,temp:e5;
procedure p2;forward;
procedure p3;forward;
procedure p4;forward;
procedure p5;forward;
procedure p6;forward;
procedure look(p, w:integer;st:e5;var tr:boolean);
{p=1:处理行,w:行号. p=2:处理列w:列号. 不处理对角线 }
label 10;
var i:integer;
j,k:shortint;
begin
tr:=false;
for i:=1 to tt do
begin
for j:=1 to 5 do if a1[i,j]<>st[j] then goto 10;
case p of
1: for k:=1 to 5 do d1[w,k]:=st[k];
2: for k:=1 to 5 do d1[k,w]:=st[k];
end;
tr:=true; exit;
10:
end;
end;
function plac(ad:longint;i:integer):integer;
var
pl2,sta:integer;
ad2:string[5];
ad3:string[1];
begin
str(ad:5,ad2); ad3:=copy(ad2,i,1);
val(ad3,pl2,sta); plac:=pl2;
end;
procedure assign_g(a1,a2,a3,a4,a5:shortint);
begin
g1[1]:=a1; g1[2]:=a2; g1[3]:=a3; g1[4]:=a4; g1[5]:=a5;
end;
procedure prim1;
{ 求 100000 以内的素数及取定和的五位素数 }
var i,j,t,t1,t2,t3,pr,ii:longint;
pl:e5;
begin{1}
limit:=50000;
for j:=1 to 2 do getmem(x[j],sizeof(x[j]^));
for i:=1 to limit do x[1]^:=true;
x[2]^:=x[1]^; x[1]^[1]:=false;
for i:=1 to round(sqrt(limit)) do
if x[1]^ then
begin{2}
t:=i;
t2:=limit div t;
for j:=2 to t2 do x[1]^[t*j]:=false;
t3:=2*limit div t;
for j:=t2+1 to t3 do x[2]^[j*t-limit]:=false;
end;{2}
tt:=0;
for j:=1 to 2 do
begin {3}
t:=10000;
if j=2 then t:=1;
for i:=t to limit do
if x[j]^ then
begin
ii:=i+(j-1)*limit;
for k:=1 to 5 do pl[k]:=plac(ii,k);
if pl[1]+pl[2]+pl[3]+pl[4]+pl[5]=sum1 then
begin inc(tt); a1[tt]:=pl; end;
end;
end; {3}
writeln('tt=',tt);
for j:=1 to 2 do freemem(x[j],sizeof(x[j]^));
end;{1}
procedure p1; { 第 1 行 }
var i,j:integer;
begin{3}
d1[1,1]:=r;
for j:=1 to tt do
if (a1[j,1]=r) then
begin{5}
temp:=a1[j];
d1[1,2]:=temp[2]; d1[1,3]:=temp[3];
d1[1,4]:=temp[4]; d1[1,5]:=temp[5];
p2;
end;{5}
end;{3}
procedure p2; {第 5 列}
var i1,i2,i3,i4:integer;
tr2:boolean;
begin
for i1:=1 to 4 do
for i2:=1 to 4 do
for i3:=1 to 4 do
for i4:=1 to 4 do
if (d1[1,5]+s[i1]+s[i2]+s[i3]+s[i4])=sum1 then
begin
assign_g(d1[1,5],s[i1],s[i2],s[i3],s[i4]);
look(2,5,g1,tr2);
if tr2 then p3;
end;
end;
procedure p3; {主对角线}
var temp1,temp2:shortint;
j:integer;
begin{3}
temp1:=d1[1,1]; temp2:=d1[5,5];
for j:=1 to tt do
begin{5}
temp:=a1[j];
if (temp[1]=temp1)and(temp[5]=temp2) then
begin
d1[2,2]:=temp[2]; d1[3,3]:=temp[3]; d1[4,4]:=temp[4];
p4;
end;
end;{5}
end;{3}
procedure p4; {第 5 行 }
var i1,i2,i3,i4:integer;
tr4:boolean;
begin
for i1:=1 to 4 do
for i2:=1 to 4 do
for i3:=1 to 4 do
for i4:=1 to 4 do
if (s[i1]+s[i2]+s[i3]+s[i4]+d1[5,5])=sum1 then
begin
assign_g(s[i1],s[i2],s[i3],s[i4],d1[5,5]);
look(1,5,g1,tr4);
if tr4 then p5;
end;
end;
procedure p5; {次对角线及第 4 列,第 2 列,第 3 行}
label 50;
var temp1,temp2,temp3,t31,t32,t34,t5:shortint;
tr5,tr52,tr53:boolean;
j:integer;
begin
temp1:=d1[5,1]; temp2:=d1[3,3]; temp3:=d1[1,5];
for j:=1 to tt do
begin
temp:=a1[j];
if (temp[1]=temp1) and (temp[3]=temp2)
and (temp[5]=temp3) then
begin {p5.3}
d1[4,2]:=temp[2];
d1[2,4]:=temp[4];
t34:=sum1-(d1[1,4]+d1[2,4]+d1[4,4]+d1[5,4]);
if (t34<0)or(t34>9) then goto 50;
assign_g(d1[1,4],d1[2,4],t34,d1[4,4],d1[5,4]);
look(2,4,g1,tr5);
if tr5=false then goto 50;
t32:=sum1-(d1[1,2]+d1[2,2]+d1[4,2]+d1[5,2]);
if (t32<0)or(t32>9) then goto 50;
assign_g(d1[1,2],d1[2,2],t32,d1[4,2],d1[5,2]);
look(2,2,g1,tr52);
if tr52=false then goto 50;
t31:=sum1-(d1[3,2]+d1[3,3]+d1[3,4]+d1[3,5]);
if (t31<=0)or(t31>9) then goto 50;
assign_g(t31,d1[3,2],d1[3,3],d1[3,4],d1[3,5]);
look(1,3,g1,tr53);
if tr53 then p6;
end;{p5.3}
50:
end;
end;
procedure p6; { 第 1 列, 第 2,4 行, 第 3 列 }
label 60;
var i1,i2,i3,i4:integer;
t23,t43:shortint;
tr6:boolean;
begin
for i1:=1 to 9 do
for i2:=1 to 9 do
begin
assign_g(d1[1,1],i1,d1[3,1],i2,d1[5,1]);
look(2,1,g1,tr6);
if tr6=false then goto 60;
t23:=sum1-(d1[2,1]+d1[2,2]+d1[2,4]+d1[2,5]);
if (t23<0)or(t23>=9) then goto 60;
assign_g(d1[2,1],d1[2,2],t23,d1[2,4],d1[2,5]);
look(1,2,g1,tr6);
if tr6=false then goto 60;
t43:=sum1-(d1[4,1]+d1[4,2]+d1[4,4]+d1[4,5]);
if (t43<0)or(t43>9) then goto 60;
assign_g(d1[4,1],d1[4,2],t43,d1[4,4],d1[4,5]);
look(1,4,g1,tr6);
if tr6=false then goto 60;
if (d1[1,3]+d1[2,3]+d1[3,3]+d1[4,3]+d1[5,3])<>sum1
then goto 60;
for i3:=1 to 5 do g1[i3]:=d1[i3,3];
look(2,3,g1,tr6);
if tr6=false then goto 60;
inc(ss); writeln('No.',ss);
for i3:=1 to 5 do
begin for i4:=1 to 5 do write(d1[i3,i4]:2); writeln; end;
60:;
end;
end;
begin
write('d[1,1]='); readln(r);
write('sum of row='); readln(sum1);
ss:=0; prim1; p1;
if ss=0 then writeln('No Solution!');
end.
6. 求 1,2,...,n 这n个数字的全部可能的排列.
program lxw006;
const nn=20;
type row=array [1..20] of shortint;
var p: row;
n,i: integer;
num:longint;
procedure wrtperm(n:integer; var s:row);
var i:integer;
begin
for i:=1 to n do write(s:3);
writeln;
end;
procedure perm(n:integer; var p:row; var i:integer);
var j,j1,j2,t,m:integer;
begin
i:=n;
repeat dec(i) until (p<p[i+1]) or (i<1);
if i>0 then
begin
j:=i+1;
for t:=i+1 to n do
if p<p[t] then j:=t;
m:=p; p:=p[j]; p[j]:=m;
t:=(n-i) div 2;
for j:=1 to t do
begin
j1:=i+j; j2:=n-j+1;
m:=p[j1]; p[j1]:=p[j2]; p[j2]:=m;
end;
end;
end;
begin {main}
writeln('输入N:(<=20)'); readln(n);
num:=1;
for i:=1 to n do p:=i;
i:=1;
while i>0 do
begin
wrtperm(n,p);
perm(n,p,i);
if i>0 then inc(num);
end;
writeln('num=',num);
end.
7. 从左向右依次安放 3 根细柱 A,B,C. 在 A 上套有 N (N≤20) 个直径相同
的圆盘, 从下到上依次编为1,2,,,,,N, 将这些圆盘经过 B 单向地移入 C (即不
允许从右向左移动). 圆盘可在 B 中暂存. 从键盘输入 N, 问将圆盘全部移入C
后,在C柱上共有多少种排列方式?
┃ ┃ ┃
1 ━╋━ ┃ ┃
2 ━╋━ ┃ ┃
3 ━╋━ ┃ ┃
4 ━╋━ ┃ ┃
━━┻━━━┻━━━┻━
A B C
program lxw007;
type row=array[1..100] of shortint;
var b,c,d: row;
i,j,j1,j2,m,n,n2: integer;
s,sum,t,pa,pb,pc:integer;
procedure prt2(u:shortint);
begin
if u=1 then
begin
inc(pa); inc(pb); b[pb]:=pa;
write('A(',pa:2,')=>B(',pb:2,') ');
end
else
begin
inc(pc); c[pc]:=b[pb];
write('B(',pb:2,')=>C(',pc:2,') ');
dec(pb);
end
end;
procedure perm(n:integer; var p:row; var i:integer);
var j,j1,j2,t,m:integer;
begin
i:=n;
repeat dec(i) until (p<p[i+1]) or (i<1);
if i>0 then
begin
j:=i+1;
for t:=i+1 to n do
if p<p[t] then j:=t;
m:=p; p:=p[j]; p[j]:=m;
t:=(n-i) div 2;
for j:=1 to t do
begin
j1:=i+j; j2:=n-j+1;
m:=p[j1]; p[j1]:=p[j2]; p[j2]:=m;
end;
end;
end;
procedure process;
begin
m:=0; j:=0;
repeat inc(j); m:=m+d[j]; until (m<0) or (j=n2);
if m>=0 then
begin
inc(sum); s:=0;
pa:=0; pb:=0; pc:=0;
writeln('No.',sum:5);
for j:=1 to n2 do
begin
inc(s); prt2(d[j]);
if (s mod 5)=0 then writeln;
end; writeln;
for j:=1 to n do write(c[j]:2,' ');
writeln;
end;
end;
begin {main}
writeln('输入圆盘数 N:(<=50)'); readln(n);
n2:=n*2; sum:=0;
for i:=1 to n do begin d:=-1; d[n+i]:=1 end;
i:=1;
while i>0 do
begin
perm(n2,d,i);
if i>0 then process;
end;
writeln('排列总数:',sum:6,' 圆盘数:',n:2);
end.
8. 在N*N的国际象棋的棋盘上放置N个女王,使其不能互相攻击,即任意两个
女王不能处在同一行,同一列,同一斜线上,试问共有多少种摆法?
program lxw008_1;
{ "八女王问题" 解法之一: 递归回溯算法 }
var count,i:integer;
queen:array [1..8] of byte;
column,left,right:array [-7..16] of boolean;
procedure prt1;
var i:integer;
begin
for i:=1 to 8 do write(queen:4);
inc(count); writeln('count=',count);
end;
procedure try(i:integer);
var j:integer;
begin
for j:=1 to 8 do
if column[j] and left[i-j] and right[i+j] then
begin
queen:=j; column[j]:=false;
left[i-j]:=false; right[i+j]:=false;
if i<8 then try(i+1)
else prt1;
column[j]:=true; left[i-j]:=true; right[i+j]:=true;
end
end;
begin{main}
for i:=-7 to 16 do
begin
column:=true; left:=true; right:=true;
end;
count:=0; i:=1; try;
readln;
end.
program lxw008_2;
{ "八女王问题" 解法之二: 利用排列的非递归算法 }
const nn=20;
label 20;
type row=array[1..nn] of shortint;
var p: row;
n,i,i1,j1,num: integer;
bl:boolean;
procedure perm(n:integer; var p:row; var i:integer);
var j,j1,j2,t,m:integer;
begin
i:=n;
repeat dec(i) until (p<p[i+1]) or (i<1);
if i>0 then
begin
j:=i+1;
for t:=i+1 to n do
if p<p[t] then j:=t;
m:=p; p:=p[j]; p[j]:=m;
t:=(n-i) div 2;
for j:=1 to t do
begin
j1:=i+j; j2:=n-j+1;
m:=p[j1]; p[j1]:=p[j2]; p[j2]:=m;
end;
end;
end;
procedure wrtperm(s,n:integer;var p:row);
var i:integer;
begin
write('No. ',s:3,' ');
for i:=1 to n do write(i:2,'(',p:2,')',' ');
writeln;
end;
begin{main}
writeln('输入N:(<=20)'); readln(n);
num:=0;
for i:=1 to n do p:=i;
i:=1;
while i>0 do
begin
for i1:=1 to n-1 do
for j1:=i1+1 to n do
if ((i1+p[i1])=(j1+p[j1])) or ((i1-p[i1])=(j1-p[j1]))
then goto 20;
inc(num); wrtperm(num,n,p);
20: perm(n,p,i)
end;
end.
9. 求从 1,2,...,N 这N个不同数字中任取 r 个数字的全部的组合.
program lxw009;
type row=array [1..20] of shortint;
var p: row;
n,i,r: integer;
num:longint;
procedure wrtperm(r:integer; var s:row);
var i:integer;
begin
for i:=1 to r do write(s:3);
writeln;
end;
procedure comb(n,r:integer; var p:row; var i:integer);
var j,k:integer;
begin
i:=1;
for j:=r downto 1 do
if (p[j]<n+j-r) then
begin
inc(p[j]);
for k:=j+1 to r do p[k]:=p[k-1]+1;
exit
end;
i:=0;
end;
begin {main}
writeln('求C(N,R),输入N,R:(<=20,R<=N),'); readln(n,r);
num:=1;
for i:=1 to r do p:=i; p[r+1]:=n+1;
i:=1;
while i>0 do
begin
wrtperm(r,p);
comb(n,r,p,i);
if i>0 then inc(num);
end;
writeln('num=',num);
end.
10. 某机要部门安装了电子锁。Ｍ个工作人员每人发一张磁卡，卡上有开锁的密码
特征。为了确保安全，规定至少要有Ｎ个人同时使用各自的磁卡才能将锁打开。问
电子锁上至少要有多少种特征? 每个人的磁卡上至少要有多少特征? 如果特征的编
号以小写英文字母表示，将每个人的磁卡的特征编号打印出来，要求输出的电子锁
的总特征数最少。
设 3<=M<=7, 1<=N<=4, Ｍ与Ｎ由键盘输入，工作人员编号用 1#,2#,...表示.
program lxw010;
type row=array [1..20] of shortint;
set1=set of char;
var p: row;
m,n,n2,i,j: integer;
c1,c2:longint;
s1:set1;
s2:array [1..10] of set1;
a1:char;
procedure comb2(m,n:integer; var cmn:longint);
var c:longint;
i:integer;
begin
n2:=n;
if n>(m div 2) then n2:=m-n;
c:=1;
for i:=1 to n2 do
c:=c*(m-i+1) div i;
cmn:=c;
end;
procedure comb1(n,r:integer; var p:row; var i:integer);
var j,k:integer;
begin
i:=1;
for j:=r downto 1 do
if (p[j]<n+j-r) then
begin
inc(p[j]);
for k:=j+1 to r do p[k]:=p[k-1]+1;
exit
end;
i:=0;
end;
procedure process;
var i:integer;
begin
a1:=succ(a1);
for i:=1 to n-1 do
s2[p]:=s2[p]+[a1];
end;
begin {main}
writeln('输入人员总数 M(<8), 开锁必需人数 N:(<=M),'); readln(m,n);
comb2(m,n-1,c1);
comb2(m-1,n-1,c2);
writeln('特征总数:',c1, ' 每个磁卡特征数:',c2);
a1:=pred('A'); s1:=[];
for i:=1 to m do s2:=[];
for i:=1 to c1 do
begin a1:=succ(a1); s1:=s1+[a1] end;
for i:=1 to n-1 do p:=i; p[n]:=m+1;
i:=1; a1:=pred('A');
while i>0 do
begin
process;
comb1(m,n-1,p,i);
end;
for i:=1 to m do
begin
s2:=s1-s2;
a1:=pred('A'); write(i,'# ');
for j:=1 to c1 do
begin
a1:=succ(a1);
if a1 in s2 then write(a1:2);
end;
writeln;
end;
end.
11. 编程实现两个高精度实数减法，两数分别由键盘输入，均不超过２４０位。
program lxw011;
const n1=250; n2=500;
type strn=string[250];
intn2=array [0..500] of shortint;
var a1,b1,c1:intn2;
ch1,ch2:strn;
operch:char;
i,t1:integer;
procedure chtoint(ch:strn; var a:intn2);
{ 将字符串量转换为整型数组 }
var i,j,t,dot:integer;
begin
for i:=1 to n2 do a:=0;
a[0]:=1; j:=0; dot:=0;
for i:=1 to length(ch) do
case ch of
'0'..'9': begin j:=j+1; a[j]:=ord(ch)-ord('0') end;
'.': dot:=j;
'-': a[0]:=-1
else
end;
if dot=0 then dot:=j;
t:=n1-dot;
for i:=j downto 1 do a[i+t]:=a;
for i:=1 to t do a:=0;
end;
procedure plus(var a1,b1,c1:intn2);
{ 加法运算 }
var i:integer;
begin
for i:=1 to n2 do c1:=a1+b1;
for i:=n2 downto 2 do
if c1>9 then
begin c1:=c1-10; c1[i-1]:=c1[i-1]+1 end;
c1[0]:=a1[0];
end;
procedure minus(var a1,b1,c1:intn2);
{ 减法运算 }
var i,max:integer;
a2,b2:intn2;
begin
max:=1; i:=0;
repeat
i:=i+1;
if b1>a1 then max:=2
until (b1<>a1) or (i=n2);
a2:=a1; b2:=b1;
if max=2 then begin a2:=b1; b2:=a1 end;
for i:=n2 downto 2 do
begin
if a2<b2 then
begin
a2:=a2+10;
a2[i-1]:=a2[i-1]-1
end;
c1:=a2-b2
end;
c1[1]:=a2[1]-b2[1];
c1[0]:=1;
if((max=2)and(a1[0]=1))or((max=1)and(a1[0]=-1))
then c1[0]:=-1
end;
procedure prtc1(var c1:intn2);
var t,i:integer;
begin
if c1[0]=-1 then write('-');
t:=0;
repeat t:=t+1 until c1[t]>0;
if t>n1 then t:=n1;
for i:=t to n1 do write(c1);
write('.');
t:=n2+1;
repeat t:=t-1 until c1[t]>0;
if t<n1+1 then t:=n1+1;
for i:=n1+1 to t do write(c1);
end;
begin { main }
for i:=1 to n1 do ch1:=' ';
ch2:=ch1; writeln;
writeln('输入被加数 (<=250 位):'); readln(ch1);
repeat
writeln('输入运算符 (+/-):'); readln(operch);
until (operch='-') or (operch='+');
writeln('输入加数 (<=250 位):'); readln(ch2);
chtoint(ch1,a1); chtoint(ch2,b1);
writeln; writeln('计算结果:');
prtc1(a1); writeln(operch);
if b1[0]<0
then begin write('('); prtc1(b1); write(')') end
else prtc1(b1);
writeln('=');
t1:=1;
if operch='-' then t1:=-1;
if a1[0]=t1*b1[0] then plus(a1,b1,c1)
else minus(a1,b1,c1);
prtc1(c1); writeln;
end.
12. 计算两高精度实数的乘法.
program lxw012;
const n1=250; n2=500;
type strn=string[250];
intn22=array [-1..500] of integer;
var a1,b1,c1:intn22;
ch1,ch2:strn;
i:integer;
procedure chtoint2(ch:strn; var a:intn22);
var i,j,t,dot:integer;
begin
for i:=1 to n2 do a:=0;
a[0]:=1; j:=0; dot:=0;
for i:=1 to length(ch) do
case ch of
'0'..'9': begin j:=j+1; a[j]:=ord(ch)-ord('0') end;
'.': dot:=j;
'-': a[0]:=-1
else
end;
if dot=0 then dot:=j;
t:=0;
repeat t:=t+1 until a[t]>0;
a[-1]:=dot-t+1;
if t>1 then
begin
for i:=1 to j-t do a:=a[i+t-1];
for i:=j-t+1 to j do a:=0
end;
end;
procedure frmt(var f:intn22);
var j,fj,fj1:integer;
begin
for j:=n2 downto 2 do
begin
fj:=f[j];
if(fj>9) then
begin
fj1:=fj div 10;
f[j-1]:=f[j-1]+fj1;
f[j]:=fj-(fj1*10)
end;
end
end;
procedure multy(d,e:intn22; var f:intn22);
{ d*e → f }
var k,j,dj:integer;
begin
for j:=1 to n2 do f[j]:=0;
for j:=1 to n1 do
begin
dj:=d[j];
if dj>0 then
for k:=j+1 to n1+j do f[k]:=f[k]+dj*e[k-j];
if (j mod 100 =0) then frmt(f);
end;
frmt(f); f[0]:=d[0]*e[0]; f[-1]:=d[-1]+e[-1]
end;
procedure prtc2(var c1:intn22);
var t,i,j:integer;
begin
if c1[0]=-1 then write('-');
t:=n2+1;
repeat t:=t-1 until c1[t]>0;
if c1[-1]>0
then
begin
j:=1;
if c1[1]=0 then j:=2;
for i:=j to c1[-1] do write(c1);
write('.');
for i:=c1[-1]+1 to t do write(c1)
end
else
begin
write('0.');
if c1[-1]<0 then
for i:=1 to abs(c1[-1]) do write('0');
for i:=1 to t do write(c1)
end;
end;
begin { main }
for i:=1 to n1 do ch1:=' ';
ch2:=ch1; writeln;
writeln('输入被乘数 (<=250 位):'); readln(ch1);
writeln('输入乘数 (<=250 位):'); readln(ch2);
chtoint2(ch1,a1); chtoint2(ch2,b1);
writeln; writeln('计算结果:');
prtc2(a1); writeln('*');
if b1[0]<0
then begin write('('); prtc2(b1); write(')'); end
else prtc2(b1);
writeln('=');
multy(a1,b1,c1);
prtc2(c1); writeln;
end.
13. 求 1/a, 其中 a 是不超过10,000,000的正整数,其结果保留500位小数.
program lxw013;
const n2=1000;
type intn22=array [-1..1000] of integer;
var c1:intn22; a:longint;
i,n3:integer;
procedure recp1(a:longint;var s:intn22);
var i,j:integer; m:longint;
begin
for i:=1 to n3 do s:=0;
m:=1; j:=0;
repeat
j:=j+1; m:=m*10;
s[j]:=m div a;
m:=m-s[j]*a
until (m=0) or (j=n3);
end;
procedure prtc2(var c1:intn22);
var t,i,j:integer;
begin
if c1[0]=-1 then write('-');
t:=n3+1;
repeat t:=t-1 until c1[t]>0;
if c1[-1]>0 then
begin
j:=1;
if c1[1]=0 then j:=2;
for i:=j to c1[-1] do write(c1);
write('.');
for i:=c1[-1]+1 to t do write(c1)
end
else
begin
write('0.');
if c1[-1]<0 then
for i:=1 to abs(c1[-1]) do write('0');
for i:=1 to t do write(c1)
end;
end;
begin{main}
writeln;
writeln('输入分母 a:(1-10,000,000):'); readln(a);
writeln('输入结果的小数位数(<=1000)'); readln(n3);
c1[-1]:=0; c1[0]:=1;
recp1(a,c1);
prtc2(c1); writeln;
end.
14. 求 1/a, 其中 a 和计算结果均为高精度数,有效数字位数不超过500,
且0<a<1.
program lxw014;
{ 1>a>=0.1 }
{ 公式: f[k+1]=f[k]*(2-a*f[k]); f[k] => 1/a(n) }
const n=250; n2=500;
type strn=string[250];
intn22=array [-1..500] of integer;
var a1,f:intn22;
ch1,ch2:strn;
i,n3,n4:integer;
procedure chtoint2(ch:strn;var a:intn22);
{ 将字符串变量转换成整型数组 }
var i,j,t,dot:integer;
begin
{为简单计,将输入数据处理成 ( 0.1, 1 ) 内的数, 用a[0]存放整数部分}
for i:=1 to n4 do a:=0;
j:=0; a[0]:=0; a[-1]:=0;
for i:=1 to length(ch) do
case ch of
'0'..'9': begin j:=j+1; a[j]:=ord(ch)-48 end;
else
end;
t:=0;
repeat t:=t+1 until a[t]>0;
if t>1 then
begin
for i:=1 to j-t+1 do a:=a[i+t-1];
for i:=j-t+2 to j do a:=0;
end;
end;
procedure frmt(var f:intn22; n4:integer);
{ 将数组 f(n4) 规格化 }
var j,fj,fj1:integer;
begin
for j:=n4 downto 1 do
begin
fj:=f[j];
if(fj>9) then
begin fj1:=fj div 10;
f[j-1]:=f[j-1]+fj1;
f[j]:=fj-(fj1*10)
end;
end
end;
procedure multy(var d,e:intn22;var f:intn22; n4:integer);
{ 乘法运算 }
var k,j,dj,nj:integer;
begin
for j:=0 to n4 do f[j]:=0;
for j:=0 to n4 do
begin
dj:=d[j];
if dj>0 then
begin
nj:=n+j;
if nj>n4 then nj:=n4;
for k:=j to nj do
f[k]:=f[k]+dj*e[k-j];
end;
if (j mod 100 =0) then frmt(f,n4);
end;
frmt(f,n4);
f[-1]:=d[-1]+e[-1]
end;
procedure prtc4(var c1:intn22; n3:integer);
{ 打印结果 }
var i:integer;
begin
write(c1[0]:2,'.');
for i:=1 to n3 do write(c1);
end;
procedure initial(a:intn22;var f0:intn22);
{求 f(n2) 的初值, 用 f0 存放}
var d1,d2,e1,e2:real;
k10,i:integer;
begin
k10:=10;
if k10>n3 then k10:=n3;
for i:=1 to n4 do f0:=1;
d1:=0; d2:=0.1;
for i:=1 to k10 do
begin d1:=d1+a*d2; d2:=d2/10 end;
e1:=1/d1;
for i:=1 to k10 do
begin
e2:=e1;
f0[i-1]:=trunc(e2);
e1:=(e1-f0[i-1])*10
end;
f0[-1]:=0;
end;
procedure divid(var a1,f:intn22; n4:integer);
{ a1:分母,f:结果, f1 f2:工作数组 }
var f1,f2: intn22;
i,j,k,kz,t1,t2:integer;
bl:boolean;
begin
initial(a1,f1);
kz:=1;
repeat
inc(kz);
multy(a1,f1,f2,n4);
for i:=1 to n4 do f2:=9-f2;
f2[n2]:=f2[n2]+1; f2[0]:=1-f2[0];
multy(f1,f2,f,n4);
bl:=true;
t1:=1; t2:=n4-2;
if n4>30 then
begin t1:=n4-25; t2:=n4-15; end;
for i:=t1 to t2 do
if f1<>f2 then bl:=false;
if not bl then f1:=f;
until bl or (kz>20);
end;
begin{main}
for i:=1 to n do ch1:=' ';
writeln;
writeln('输入计算位数:(<250)'); readln(n3);
n4:=n3+10;
if n4<n3*1.05 then n4:=trunc(n3*1.05);
writeln('输入分母 a: ( 1>a>=0.1 小数位<250) '); readln(ch1);
chtoint2(ch1,a1);
write('1/'); prtc4(a1,n3); writeln('=');
divid(a1,f,n4);
prtc4(f,n3); writeln;
end.
15. 准确计算 N 的阶乘: N! (N<=200).
program lxw015;
const n2=500;
type intn2=array[1..500] of integer;
var a:intn2; i,n,t,s1,j:integer;
s2:real;
procedure frmt2(var f:intn2;n:integer);
var j,fj,fj1:integer;
begin
for j:=1 to n do
begin
fj:=f[j];
if fj>9 then
begin
fj1:=fj div 10;
f[j+1]:=f[j+1]+fj1;
f[j]:=fj-(fj1*10)
end;
end
end;
procedure multy2 (var f:intn2; n,e:integer);
var i:integer;
begin
for i:=1 to n do
f:=f*e;
for i:=n+1 to n2 do f:=0;
frmt2(f,n)
end;
begin {main}
writeln('输入 n:(<=200, 计算阶乘 n!):'); readln(n);
for i:=1 to n2 do a:=0;
s2:=0;
for i:=n downto 2 do s2:=s2+ln(i);
s2:=s2/ln(10)+2;
a[1]:=n;
s1:=round(ln(n)/ln(10))+1;
frmt2(a,s1);
for i:=n-1 downto 2 do
begin
s1:=s1+round(ln(i)/ln(10))+1;
if s1>s2 then s1:=round(s2);
multy2(a,s1,i)
end;
t:=s1+1;
repeat t:=t-1 until a[t]>0;
writeln; writeln('计算结果:');
write(n,'!='); j:=0; writeln;
for i:=t downto 1 do
begin
inc(j); write(a);
if(j mod 50) =0 then writeln;
end;
writeln
end.
16. 输入一个奇数 P (P<100,000,000), 其个位数字不是 5, 求一个整数 S,
使 P×S = 1111...1. ( 在给定的条件下, 解 S 必存在, 不必判断可解性).
输入输出要求:
(1) P 由键盘输入.
(2) 在屏幕上依次输出以下结果:
① S 的全部数字. 除最后一行外, 每行输出 50 位数字.
② S 的数字位数.
③ 积的数字位数
program lxw016;
var p,a,b,c,t,n:longint;
bl: boolean;
begin
repeat
bl:=true;
writeln('输入 p, 最后一位为 1 或 3 或 7 或 9:');
readln(p);
if (p mod 2=0) or (p mod 5=0) then bl:=false;
until bl;
a:=0; n:=0;
while a<p do
begin a:=a*10+1; inc(n) end;
t:=0;
repeat
b:=a div p; write(b:1); inc(t);
if t mod 50=0 then writeln;
c:=a-p*b; a:=c*10+1; inc(n);
until c=0;
dec(n); writeln;
writeln('n=',n)
end.
17. 输入一个奇数 P (P<100,000,000), 其个位数字不是 5, 求一个整数 S,
使 P×S = 987654321...987654321. ( 在给定的条件下, 解 S 必存在, 不必
判断可解性).
输入输出要求:
(1) P 由键盘输入.
(2) 在屏幕上依次输出以下结果:
① S 的全部数字. 除最后一行外, 每行输出 50 位数字.
② S 的数字位数.
③ 积的数字位数(应该是9的倍数)
program lxw017;
var p,a,b,c,n,n2,i:longint;
bl:boolean;
begin
repeat
bl:=true;
writeln('input p,the last place is 1 or 3 or 7 or 9:');
readln(p);
if (p mod 2=0) or (p mod 5=0) then bl:=false;
until bl;
a:=0; n:=0; i:=10;
while a<p do
begin dec(i); a:=a*10+i; inc(n); end;
n2:=0;
repeat
b:=a div p; write(b:1); inc(n2);
if n2 mod 50=0 then writeln;
c:=a-p*b; dec(i);
if (i=0)and(c>0) then i:=9;
a:=c*10+i; inc(n);
until (c=0)and(i=0);
dec(n); writeln;
writeln('The places of s: ',n2);
writeln('The places of p*s: ',n)
end.
18. (时钟问题) 对 9 个时钟作受控整体移动, 设一个时钟只有四种状态:
3点,6点,9点,12点, 分别用数字 1,2,3,0 表示. 给定 10 个一维整型数组
A0(1..9), A1(1..9), ..., A9(1..9), 其中 A0 表示 9 个时钟的初始状态,
A1--A9 表示 9 种不同的控制时钟移动的方法. 在每个方法中, 每个时钟只有
两种可能:①不动,用数字0表示. ②顺时针旋转90°,用数字1表示. 例如:
A1=(0,1,1,0,0,1,1,1,0) 表示第一种方法规定: 第 2,3,6,7,8 这几个时钟顺
时针旋转90°,其余时钟不动. 我们的任务是用给定的方法, 旋转时钟指针,最
终使所有时钟的指针都指向 12 点.
输入输出要求:
(1) 由键盘读入存放原始数据的文本文件全名.
(2) 读入该文本文件的内容: 共10行,每行有 9 个用空格分隔的数字, 为一
个一维数组各元素的值.(可参看给定的示例文件 EXAM1.TXT)
(3) 在屏幕上依次输出各方法执行的次数(0--3), 或输出 'NO SOLUTION!',
表示此题无解.
示例文件: EXAM1.TXT
3 3 0 2 2 2 2 1 2
0 0 1 0 0 1 1 1 1
0 0 0 1 0 1 1 1 1
1 0 0 1 0 0 1 1 1
0 1 1 0 1 1 0 1 1
1 0 1 0 0 0 1 0 1
1 1 0 1 1 0 1 1 0
1 1 1 0 0 1 0 0 1
1 0 1 1 0 1 0 0 0
1 0 1 1 0 0 1 0 0
program lxw018;
const kk=9;
type bnn=array[1..9] of integer;
ann=array[1..9,1..10] of integer;
var a0,x0:bnn;
var aa:ann;
file1:string[20];
text1:text;
kz,i,j,ji,ti,p,temp,ii,jj,nn:integer;
{求余: MOD2=X MOD Y}
function mod2(x,y:integer):integer;
var z:integer;
begin
z:=x;
while z>=y do z:=z-y;
while z<0 do z:=z+y;
mod2:=z;
end;{fun mod2}
{解同余方程: a*x≡b mod 4, y=1:有解, y=0:无解}
procedure axb(a,b:integer;var x,y:integer);
label 50;
var i:integer;
begin
y:=1;
for i:=0 to 3 do
begin
if mod2(a*i-b,4)=0 then
begin x:=i;goto 50 end;
end;
y:=0;
50:
end;{proc axb}
{解线代数方程组(n*n),结果用 x0[n] 存放, kz=1:有解, kz=0:无解}
procedure linear(an:ann;var x0:bnn;var n,kz:integer);
label 20,30;
var i,j,ti,p,ii,ji,xi:integer;
begin
kz:=1;
xi:=0;
for i:=1 to n-1 do
begin{1}
inc(xi); j:=xi;ti:=xi;
{选主元}
while (an[j,i]=0) and(j<n) do begin inc(j); ti:=j end;
if (ti=n)and(an[ti,i]=0) then dec(xi);
if (ti>xi) and (an[ti,i]<>0) then
for j:=i to n+1 do
begin{2}
p:=an[xi,j]; an[xi,j]:=an[ti,j];an[ti,j]:=p;
end;{2}
{消元}
for j:=xi+1 to n do
if an[j,i]<>0 then
begin
ii:=an[xi,i]; ji:=an[j,i];
for p:=i to n+1 do
an[j,p]:=mod2(an[j,p]*ii-an[xi,p]*ji,4);
end;
end;{1}
{回代}
axb(an[n,n],an[n,n+1],x0[n],kz);
if kz=0 then goto 20;
for i:=n-1 downto 1 do
begin
p:=an[i,n+1];
for j:=i+1 to n do p:=p-x0[j]*an[i,j];
p:=mod2(p,4);
axb(an[i,i],p,x0,kz);
if kz=0 then goto 20;
end;
goto 30;
20: kz:=0;
30:
end;{proc linear}
{主程序}
begin
writeln('input filename:');
readln(file1);
assign(text1,file1); reset(text1);
for i:=1 to kk do read(text1,a0);
readln(text1);
for i:=1 to kk do
begin
for j:=1 to kk do read(text1,aa[j,i]);
readln(text1);
end;
close(text1);
for i:=1 to kk do aa[i,kk+1]:=(4-a0) mod 4;
for i:=1 to kk do
begin
for j:=1 to kk+1 do write(' ',aa[i,j]);
writeln;
end;
nn:=kk; kz:=1;
linear(aa,x0,nn,kz);
if kz=1 then
begin
for i:=1 to kk do write(' ',x0:2);
writeln;
end
else
writeln('NO SOLUTION!');
end.
19. 以字符串形式由键盘输入两个高精度的８进制正整数，串长小于２５５，以
第一个数为被除数，第二个数为除数，进行高精度除法运算，并显示按 8 进制表
示的商和余数。
program lxw019;
const
str2:string[32]='000 001 010 011 100 101 110 111 ';
str8:string[32]='0 1 2 3 4 5 6 7 ';
var a1,a2: string;
flag2:boolean; i:integer;
function s8to2(s8:string):string;
var i,j:integer; s:string;
begin
s:='';
for i:=1 to length(s8) do
begin
j:=-3;
repeat j:=j+4 until str8[j]=s8;
s:=s+copy(str2,j,3)
end;
s8to2:=s
end;
function s2to8(s2:string):string;
var i,j:integer; s,t: string;
begin
while (length(s2) mod 3)>0 do s2:='0'+s2; s:='';
for i:=1 to (length(s2) div 3) do
begin
t:=copy(s2,1,3); delete(s2,1,3);
j:=-3;
repeat j:=j+4 until copy(str2,j,3)=t;
s:=s+str8[j]
end;
s2to8:=s
end;
procedure minus(a,b:string; var c:string; var flag:boolean);
var i,i1,j,lb:integer;
begin
flag:=true; lb:=length(b);
while length(a)<lb do a:='0'+a;
while (length(a)>lb) and (a[1]='0') do delete(a,1,1);
if (a<b) and (length(a)=lb)
then begin flag:=false; exit end;
c:='';
for i:=lb downto 1 do
begin
i1:=i;
if length(a)>lb then i1:=i+1;
if a[i1]=b then c:='0'+c
else if a[i1]>b then c:='1'+c
else begin
j:=i1;
repeat
a[j]:=succ(succ(a[j]));
a[j-1]:=pred(a[j-1]);
j:=j-1;
until a[j]='0';
c:='1'+c
end;
end;
while (c[1]='0') and (length(c)>1) do delete(c,1,1)
end;
procedure divid(a,b:string);
var c,d,e:string;
flag:boolean; lb:integer;
begin
while (b[1]='0')and(length(b)>0) do delete(b,1,1);
lb:=length(b);
if lb=0 then begin
writeln('数据错: 除数为零 !');
exit
end;
d:=copy(a,1,lb-1); delete(a,1,lb-1); c:='';
if length(a)>0 then
repeat
d:=d+a[1]; delete (a,1,1);
minus(d,b,e,flag);
if not flag then c:=c+'0'
else begin c:=c+'1'; d:=e; end;
until length(a)=0;
if c='' then c:='0';
e:=s2to8(c);
while (e[1]='0') and (length(e)>1) do delete(e,1,1);
writeln(e);
e:=s2to8(d);
while (e[1]='0') and (length(e)>1) do delete(e,1,1);
writeln('..........',e);
end;
begin{main}
repeat
flag2:=true;
writeln('输入被除数 (0..7, <=250 位):'); readln(a1);
for i:=1 to length(a1) do
if not(a1 in ['0'..'7']) then flag2:=false;
writeln('输入除数 (0..7, <=250 位):'); readln(a2);
for i:=1 to length(a2) do
if not(a2 in ['0'..'7']) then flag2:=false;
if not flag2 then writeln('数据错(只能使用数字 0-7), 重新输入 !')
until flag2;
writeln; writeln('计算结果:');
writeln(a1,' / ');
writeln(a2,' =');
a1:=s8to2(a1); a2:=s8to2(a2);
divid(a1,a2)
20. (八数码问题) ８个编有数码１￣８的滑牌，能在３＊３的井字格中滑动。井
字格中有一格是空格，用０表示，因而空格周围的数码滑牌都可能滑到空格中去.
下图是数码滑牌在井字格中的两种状态：
┎─┬─┬─┒ ┏━┯━┯━┓
┃2 │8 │3 ┃ ┃1 │2 │3 ┃
┠─┼─┼─┨ ┠─┼─┼─┨
┃1 │6 │4 ┃ －－－－＞ ┃8 │0 │4 ┃
┠─┼─┼─┨ ┠─┼─┼─┨
┃7 │0 │5 ┃ ┃7 │6 │5 ┃
┗━┷━┷━┛ ┗━┷━┷━┛
初始状态 目标状态
以左图为初始状态，右图为目标状态，请找出从初始状态到目标状态的滑牌移步序
列，具体要求：
（１）输入初始状态和目标状态的数据；
ａ、分别用两行输入上述两项数据：
ｂ、对输入数据应有查错和示错功能；
（２）实现从初始状态到目标状态的转换（如不能实现，程序应输出不能实现
的提示信息）；
（３）输出结果，每移动一步都必须在屏幕上显示:
ａ、移动每一步时的序号，最后一步的序号即为移动总步数；
ｂ、每一步移动后以３＊３表格形式显示状态。
（４）要求能使移动步数尽可能少；
program lxw020;
uses crt;
type a33=array [1..3,1..3] of byte;
a4=array [1..4] of shortint;
node=record
ch:a33;
si,sj,pnt,dep:byte;
end;
const goal:a33=((1,2,3),(8,0,4),(7,6,5));
start:a33=((2,8,3),(1,6,4),(7,0,5));
di:a4=(0,-1,0,1);
dj:a4=(-1,0,1,0);
var data: array [1..100] of node;
temp:node;
k,r,ni,nj,closed,open,depth:integer;
function check(k:integer):boolean;
begin
check:=false;
ni:=temp.si+di[k]; nj:=temp.sj+dj[k];
if(ni in[1..3])and(nj in[1..3]) then check:=true;
if(ni=data[temp.pnt].si)and(nj=data[temp.pnt].sj)
then check:=false;
end;
function dupe:boolean;
var i,j,k: integer;
buf:boolean;
begin
buf:=false; i:=0;
repeat
inc(i); buf:=true;
for j:=1 to 3 do
for k:=1 to 3 do
if data.ch[j,k]<>data[open].ch[j,k]
then buf:=false;
until buf or (i>=open-1);
dupe:=buf;
end;
function goals:boolean;
var i,j:integer;
begin
goals:=true;
for i:=1 to 3 do
for j:=1 to 3 do
if data[open].ch[i,j]<>goal[i,j]
then goals:=false;
end;
procedure print;
var buf: array [1..100] of integer;
i,j,k,n:integer;
begin
n:=1; i:=open; buf[1]:=i;
repeat
j:=data.pnt;
inc(n); buf[n]:=j; i:=j;
until i=0;
writeln('steps:',depth-1);
for i:=1 to 3 do
begin
for k:=n-1 downto 1 do
begin
for j:=1 to 3 do
write(data[buf[k]].ch[i,j]);
if i=2 then write('->') else write(' ');
end;
writeln;
end;
readln; halt;
end;
begin{main}
closed:=0; open:=1;
with data[1] do
begin
ch:=start; si:=3; sj:=2;
pnt:=0; dep:=0;
end;
repeat
inc(closed); temp:=data[closed];
depth:=temp.dep;
for r:=1 to 4 do
if check(r) then
begin
inc(open);
data[open]:=temp;
with data[open] do
begin
ch[si,sj]:=ch[ni,nj];
ch[ni,nj]:=0; si:=ni; sj:=nj;
pnt:=closed; dep:=depth+1;
end;
if dupe then dec(open)
else if goals then print;
end;
until closed>=open;
writeln('no solution!'); readln
end.
21. 设有Ｎ根火柴，由人和计算机轮流从中取走若干根。每方每次最多取Ｋ根，
最少取１根 (Ｋ值不能超过总数的一半，也不能小于１)。试编写一程序使计算
机有较多的获胜机会。
program lxw021;
var x,y,N,p:integer;
begin
writeln('input n:p, 1<p<n');
readln(N,p);
Repeat
Repeat
writeln('Your move is:');
Readln(x);
until (x>=1) and (x<=p);
N:=N-x;
if N=0 then writeln('I win !! ');
if n>0 then
begin
y:=(N-1)mod(p+1);
if y=0 then y:=1;
N:=N-y;
writeln('x=',x,' y=',y,' Remains=',N);
if N=0 then writeln('** You beat me !!');
end;
until N=0;
end.
22.(取奇数游戏) 该游戏规则如下: 操作者先输入一个奇数 N(<200)表示N个石
子. 设计算机为 A 方,操作者为 B 方, 双方轮流取石子,每次取1-3个. 最后取
到石子总数为奇数的一方获胜. 编制程序使计算机有较多的获胜机会,
program lxw022;
uses crt;
type
setab=set of 0..200;
var
evena,evenb,odda,oddb:setab;
i,j,n,na,nb,k,kz,r,t:integer;
ab,ll:char;
procedure init0(var n:integer);
begin
clrscr;
gotoxy(1,1);
writeln('***************************************');
writeln(' 取奇数游戏 规则如下: ');
writeln(' 1.操作者先输入一个奇数 N(<200).');
writeln(' 2.设计算机为 A 方,操作者为 B 方,双方轮流取数,每次取1-3个.');
writeln(' 3.最后取到奇数的一方为胜方. ');
writeln('***************************************');
n:=400;
while not odd(n)or(n>200) do
begin
gotoxy(10,7);
writeln('输入一个奇数 N(<200):');
gotoxy(10,8); readln(n);
end;
end;
procedure prt1;
begin
gotoxy(1,17);
writeln(' 总计 计算机已取得 操作手已取得 剩余 ');
gotoxy(50,19);
writeln(' ');
gotoxy(1,19);
writeln(' ',n,' ',na,' ',nb,
' ',r);
end;
procedure prt2(var ll:char);
begin
gotoxy(10,21);
if odd(na) then writeln('可惜, 你输了!')
else writeln ('祝贺你的成功!');
gotoxy(10,22);
writeln('再玩一次吗 ? (Y/N)');
gotoxy(10,23); readln(ll);
end;
procedure aget(var r,t,na:integer);
var k,kz:integer;
begin
kz:=0; k:=0;
while (k<3)and(kz=0)and(k<r) do
begin
k:=k+1;
if (not odd(na+k))and(r-k in evena) then
begin kz:=1; t:=k end;
if (odd(na+k))and(r-k in odda) then
begin kz:=1; t:=k end;
end;
if kz=0 then t:=1;
gotoxy(50,14);
writeln(' 计算机这次取 ',t,' 个.');
na:=na+t; r:=r-t;
end;
procedure bget(var r,t,nb,i:integer);
begin
t:=0;
while not(t in[1,2,3])or(t>r) do
begin
gotoxy(30,13); writeln(' ');
gotoxy(2,13);
writeln('第',i:2,' 轮: 输入你的选择 (1/2/3) 并且不得超过 ',r);
gotoxy(5,14); write(' ');
gotoxy(5,14); readln(t); gotoxy(20,14);
if not(t in[1,2,3])or(t>r)
then write('数据错! 请重新输入.')
else write(' ');
end;
nb:=nb+t; r:=r-t;
end;
begin{main}
ll:='y';
while (ll='Y')or(ll='y') do
begin{2}
init0(n);
r:=n;
{ 1. 建立获胜策略集 EVENA,EVENB,ODDA,ODDB }
evena:=[4,5]; evenb:=[0,1,2,3];
odda:=[0,1]; oddb:=[2..5];
for i:=6 to n do
begin{3}
nb:=0;
if not odd(i) then nb:=1;
kz:=0; k:=0;
while (k<3)and(kz=0) do
begin
k:=k+1;
if odd(nb+k)and (i-k in odda) then kz:=1;
if (not odd(nb+k))and(i-k in evena) then kz:=1;
end;
if kz=0
then evena:=evena+
else evenb:=evenb+;
nb:=0;
if odd(i) then nb:=1;
kz:=0; k:=0;
while (k<3)and(kz=0) do
begin
k:=k+1;
if odd(nb+k)and (i-k in odda) then kz:=1;
if (not odd(nb+k))and(i-k in evena) then kz:=1;
end;
if kz=0
then odda:=odda+
else oddb:=oddb+;
end;{3}
{ 2. 开始取数. }
na:=0; nb:=0; t:=0; ab:=' ';
while not (ab in ['a','b','A','B']) do
begin
gotoxy(10,9);
writeln('输入: "谁先开始 (A/B) ?" A: 计算机, B:操作手.');
gotoxy(10,10); readln(ab);
end;
i:=1;
if (ab='B')or(ab='b') then bget(r,t,nb,i);
repeat
if r>0 then
begin {5}
aget(r,t,na);
prt1;
if r>0 then bget(r,t,nb,i);
i:=i+1;
end;{5}
until r=0;
gotoxy(3,16); writeln(' 最后结果:');
prt1; prt2(ll);
end{2}
end.{main}
23. 求Ｎ个字符串的最长公共子串，Ｎ＜＝２０，字符串长度不超过２５５。
例如：Ｎ＝３，由键盘依次输入三个字符串为
What is local bus ?
Name some local buses.
local bus is a high speed I/O bus close to the processer.
则最长公共子串为"local bus"。
program lxw023;
label 10;
var str20:array[1..20] of string;
str1,str2: string;
t,i,j,k,n,ki,kz,kn: integer;
find1,find2: boolean;
begin
writeln('输入字符串的个数 n:'); readln(n);
writeln('输入 ',n,' 个字符串:');
for i:=1 to n do readln(str20);
kz:=300;
for i:=1 to n do
if length(str20)<kz then
begin
kz:=length(str20);
ki:=i;
end;
str1:=str20[ki];
t:=kz; find1:=false;
while(t>0) and (not find1) do
begin{2}
for i:=1 to kz-t+1 do
begin{3}
str2:=copy(str1,i,t); find2:=true;
j:=1;
while find2 and (j<=n) do
begin{4}
find2:=false;
kn:=length(str20[j]);
k:=1;
while not find2 and (k<=kn-t+1) do
if str2=copy(str20[j],k,t)
then find2:=true
else k:=k+1;
j:=j+1;
end;{4}
if find2 then
begin find1:=true; goto 10; end
end;{3}
t:=t-1
end;{2}
10: writeln('最大公共子串是:');
writeln(str2); writeln('The length=',t)
end.
