Question

PASCAL语言的编程问题

我这有3编程题，大家能解几道就解几道（是PASCAL语言的）：
1、纯粹素数是这样定义的：一个素数，去掉最高位，剩下的数仍是素数，再去掉剩下的最高位，余下的数还是素数。这样下去一直到最后剩下的个位数也还是素数。求所有小于3000的四位的纯粹素数。

2、纯粹合数是这样定义的：一个合数，去掉最低位，剩下的数仍是合数，再去掉剩下的最低位，余下的数还是合数。这样下去一直到最后剩下的个位数也还是合数。求所有的三位纯粹合数。

3、左右对称的自然数称作回文数。有人猜测：从任意一个两位或两位以上的自然数开始，将该数与它的逆序数（1992的逆序数是2991）相加，得到一个新数，再用这个新数与它的逆序数相加，不断重复操作，经过若干步的逆序相加之后，总可得到一个回文数，例如：从1992开始，1992+2991=4983 4983+3894=8877 8877+7788=16665 16665+56661=73326 73326+62337=135663
135663+366531=502194 502194+491205=993399.经过7步得到了回文数993399
设计一个程序，由计算机在局部范围内验证回文数的猜测，并将寻找回文数的每一个步骤都显示出来。

Answer 1

先做第一题，其余有时间再做：(加我分啊）
const maxn=3000;
var i,j:integer;
k:longint;
a:array[1..maxn] of integer;
begin
for i:=2 to maxn do
a[i]:=1;
j:=2;
while j<maxn do begin
if a[j]=1 then begin
k:=j+j;
while k<=maxn do begin
a[k]:=0;
k:=k+j;
end;
end;
inc(j);
end;
for i:=1000 to maxn do
if a[i]=1 then begin
j:=i;
while j>0 do begin
case j of
1000..3000: k:=j mod 1000;
100..999: k:=j mod 100;
10..99: k:=j mod 10;
0..9: k:=j;
end;
j:=k;
if a[k]=0 then break
else if k<10 then begin writeln(i);break;end;
end;
end;
end.
2.const maxn=3000;
var i,j:integer;
k:longint;
a:array[1..maxn] of integer;
begin
for i:=1 to maxn do
a[i]:=1;
j:=2;
while j<maxn do begin
if a[j]=1 then begin
k:=j+j;
while k<=maxn do begin
a[k]:=0; k:=k+j;
end;
end;
inc(j);
end;
for i:=100 to 999 do
if a[i]=0 then begin
j:=i div 10;
if a[j]=0 then
if a[j div 10]=0 then write(i:5)
end;
end.

Answer 2

1.
program dsf;
var k,j,i:integer;
x:boolean;
function p(ss:integer):boolean;
var b:boolean;
begin
b:=true;
for i:=2 to (ss-1) do
if ss mod i=0 then b:=false;
p:=b;
end;
function q(xx:integer):integer;
var s:string;
a:integer;
begin
a:=0;
str(xx,s);
for i:=2 to length(s) do
a:=a*10+ord(s[i])-ord('0');
q:=a;
end;
begin
for j:=1000 to 3000 do
begin
x:=true;
k:=j;
repeat
if p(k) then k:=q(k)
else x:=false;
until (x=false)or ((k<10)and(p(k)=true));
x:=p(k);
if x and(k<>1) then writeln(j);
end;
end.
2.
program df;
var k,j,i:integer;
x:boolean;
function p(ss:integer):boolean;
var b:boolean;
begin
b:=false;
for i:=2 to (ss-1) do
if ss mod i=0 then b:=true;
p:=b;
end;
function q(xx:integer):integer;
var s:string;
a:integer;
begin
a:=0;
str(xx,s);
for i:=2 to length(s) do
a:=a*10+ord(s[i])-ord('0');
q:=a;
end;
begin
for j:=100 to 999 do
begin
x:=true;
k:=j;
repeat
if p(k) then k:=q(k)
else x:=false;
until (x=false)or ((k<10)and(p(k)=true));
x:=p(k);
if x and(k<>1) then writeln(j);
end;
end.
3.
program ssa;
var i,j,n,f,m,l,k:longint;
a:array[1..100]of integer;
function p(x:integer):boolean;
var s:string;
b:boolean;
begin
b:=true;
str(x,s);
j:=length(s);
for i:=1 to j do
if s[i]<>s[j+1-i] then b:=false;
p:=b;
end;
begin
for k:=10 to 75 do
begin
i:=k;
m:=i;
repeat
f:=0;
n:=1;
l:=m;
repeat
a[n]:=l mod 10;
n:=n+1;
l:=l div 10;
until l<10;
a[n]:=l;
for j:=1 to n do
f:=f*10+a[j];
writeln(m,'+',f,'=',m+f);
m:=m+f;
until p(m);
end;
end.
可以更改for来更改范围，不要太大，要不然会提示栈溢出，当然k也可以直接赋值。