博文
整理我以前的PASCAL源程序-马的遍历(2010-08-22 22:12:00)
摘要：和八皇后问题同样有名的，是马的遍历问题。
中国象棋的棋盘(9*10的棋盘)，指定起点位置放上一只马。要求马不重复地跳完棋盘每个格子一次，最后刚好落在指定终点上。
如果指定起点和指定终点形成一个马步，则遍历后刚好能回到起点。
算法和八皇后问题的最后一个程序一样，采用了改进的拉斯维加斯算法(j.t.chang's LV)。
例如下面是从(1,1)遍历棋盘到(3,2)的一种解法：
01 04 35 80 89 28 37 26 31
82 79 90 03 36 33 30 23 38
05 02 81 34 29 88 27 32 25
78 83 18 87 20 57 24 39 22
17 06 77 84 09 86 21 58 55
76 49 08 19 72 59 56 65 40
07 16 75 10 85 66 41 54 43
48 13 50 73 60 71 44 67 64
15 74 11 46 51 62 69 42 53
12 47 14 61 70 45 52 63 68
{
中国象棋的棋盘上，指定起点，放一只马，马不重复跳完棋盘各格一次，最后落在指定终点上。
}
Const maxx = 9;
maxy = 10;
dn = maxx*maxy;
dx :array[1..8] of integer = (1,2,-1,-2,-2,-1, 1, 2);
dy :array[1..8] of integer = (2,1, 2, 1,-1,-2,-2,-1);
Type
point_rec = record
x, y : integer;
......
整理我以前的PASCAL源程序-八皇后问题(5)改进的拉斯维加斯算法(2010-08-22 21:26:00)
摘要：拉斯维加斯算法有个特点，一旦发现算不下去了，便会全部推倒重来。也许，没必要全部推倒重来。如果象“回溯”一样退回几步重算，可能答案就出来了。
下面是我自己改进的拉斯维加斯算法，在算100皇后或者更多皇后的问题上，比原来的算法效率要高出很多。我称这样方法为“伪回溯”。
(*
One Answer Of N Queens Problem.
Arithmetic Of j.t.Chang's LV.
*)
program LV_Queens;
const
N=100;
var
x:array[1..N] of integer;
i:integer;
procedure PrintResult;
var
i,j: integer;
t1,t2:longint;
f:text;
ch: char;
begin
for i:=1 to N do write(x[i]:5);
Readln;
end;
function place(k,a:integer):boolean;
var
i:integer;
begin
for i:=1 to k-1 do
if (k-i)=abs(a-x[i]) then
begin
place:=false;
......
整理我以前的PASCAL源程序-八皇后问题(4)拉斯维加斯算法(2010-08-22 17:40:00)
摘要：在N*N的棋盘上放上N个皇后，使任意两个皇后都不会互相攻击。
有时一个问题的情况比较复杂、答案又很多，我们却苦于连一种解都找不到。用回溯法未必能等得来。用拉斯维加斯算法不失为一个好办法。
(*
Question Eight Queens.
Arithmetic Las Vegas.
Programmed by j.t.Chang.
*)
program LV_queens;
const
N=50;
var
x:array[1..N] of integer;
i:integer;
procedure PrintResult;
var
i: integer;
begin
for i:=1 to N do write(x[i]:4);
Readln;
end;
function place(k: integer): boolean;
var
j:integer;
begin
for j:=1 to k-1 do
if (abs(k-j)=abs(x[k]-x[j])) or (x[k]=x[j]) then
begin
place:=false......
整理我以前的PASCAL源程序-高精度计算(5)计算2的算术立方根(2010-08-21 18:06:00)
摘要：program Cube_Root_2;
{ This program is computing the cube root of 2.
(1-x)^(-m) = 1 + mx + m(m+1)/2! * x^2 + m(m+1)(m+2)/3! * x^3 +...
when m=1/3
1/(1-x)^(1/3) = 1 + 1/3 * x + 1*4/(3*6) * x^2 + 1*4*7/(3*6*9) * x^3 +...
Let x = 375/16000
At last, Answer = sum*25/20
Note: Last some digits may be Wrong.
}
label ext;
const
dn=336;
var
i,k:longint;
sum,a:array[1..dn] of integer;
ip:integer;
procedure outp;
var
i:integer;
procedure writep(num:integer);
begin
write(num div 1000);
write(num div 100 mod 10);
write(num div 10 mod 10);
write(num mod 10,' ');
end;
begin
writeln('Cube_root(2)=');
writeln(sum[1],'.');
for i:=2 to dn do
writep(sum[i]) ;
writeln;
&n......
整理我以前的PASCAL源程序-八皇后问题(3)基本解(2010-08-20 20:17:00)
摘要：排除对称、旋转，八皇后问题的基本解其实只有12种。
(*
求八皇后问题排除对称、旋转后的基本摆法。
*)
const N=8;
type
queentype=array[1..N] of integer;
var
x,y:queentype;
sum: longint;
function place(k: integer):boolean;
var
i: integer;
begin
for i:=1 to k-1 do
if (k-i=abs(x[k]-x[i])) or (x[k]=x[i]) then
begin
place:=false;
exit;
end;
place:=true;
end;
function trialed:boolean;
var
i: integer;
begin
for i:=1 to N do
if y[i]<x[i] then
begin
......
整理我以前的PASCAL源程序-八皇后问题(2)非递归算法(2010-08-20 20:12:00)
摘要：const
N=8;
var
k: integer;
x: array[1..N] of integer;
sum: longint;
procedure PrintChessboard;
var
i,j:integer;
begin
writeln;
writeln('No. ',sum);
for i:=1 to N do
begin
for j:=1 to N do
if j=x[i] then write('Q':2)
else write('.':2);
writeln;
end;
readln;
end;
function place(k: integer): boolean;
var
j:integer;
begin
for j:=1 to k-1 do
if (k-j=abs(x[k]-x[j])) or (x[k]=x[j]) then
......
整理我以前的PASCAL源程序-八皇后问题(1)递归算法(2010-08-20 18:44:00)
摘要： 八皇后问题是一个经典的问题。从解问题中产生出很多种经典的算法。下面是递归算法：
const N=8;
type
queentype=array[1..N] of integer;
var
x,y:queentype;
sum: longint;
function place(k: integer):boolean;
var
i: integer;
begin
for i:=1 to k-1 do
if (k-i=abs(x[k]-x[i])) or (x[k]=x[i]) then
begin
place:=false;
exit;
end;
place:=true;
end;
procedure PrintChessboard;
var
i,j:integer;
begin
writeln('No. ',sum, ' :');
for i:=1 to N do
begin
for j:=1 to N do
......
整理我以前的PASCAL源程序-高精度计算(4)计算Ln(3)(2010-08-20 00:41:00)
摘要：公式就不多说了，注释写得很清楚。
program Ln_3;
{ This program is computing Ln(3)
Ln(1-z) = -(z+z^2/2+z^3/3+...)
-Ln(1-z) = z+z^2/2+z^3/3+...
Let z =2/3
Ln(3) = -Ln(1-2/3) = (2/3) + (2/3)^2/2 + (2/3)^3/3 + ...
}
label ext;
const
dn=307;
var
i,k:longint;
sum,a:array[1..dn] of integer;
ip:integer;
procedure outp;
var
i:integer;
procedure writep(num:integer);
begin
write(num div 1000);
write(num div 100 mod 10);
write(num div 10 mod 10);
write(num mod 10,' ');
end;
begin
writeln('Ln(3)=');
writeln(sum[1],'.');
for i:=2 to dn do
writep(sum[i]) ;
writeln;
writeln('Programmed by j.t.chang');
end;
procedure m_div(k:longint);
var
i:integer;
r1,c:longint;......
整理我以前的PASCAL源程序-高精度计算(3)计算Sqrt(2)和黄金分割(2010-08-19 23:18:00)
摘要：1、计算sqrt(2)
利用公式：1/sqrt(1-x)=1 + 1/2*x + 1*3/(2*4)*x^2 + (1*3*5)/(2*4*6)*x^3 + ……
当x=1/57122时，代入左边算算得到什么数。Sqrt(2)前多一个系数没关系，最后做一步简单的系数乘除就行了。
选择x=1/57122，是为了让级数收敛更快些。当然，选1/50、1/1682 也是可以的，慢一点而已。
program sqrt_2;
label ext;
const
dn=2504;
var
i,k:longint;
sum,a:array[1..dn] of integer;
ip:integer;
procedure outp;
var
i,m:integer;
procedure testm;
begin
if m mod 10=0 then write(' ');
if (m mod 50=0) and (m mod 1000<>0) then
writeln(':',m:8);
if m mod 1000<>0 then exit;
writeln(':',m:8,' Press Enter..');
readln;
end;
procedure writep(num:integer);
begin
write(num div 1000); m:=m+1; testm;
writ......
整理我以前的PASCAL源程序-高精度计算(2)计算自然对数底e(2010-08-19 22:17:00)
摘要： 算自然对数底e，比起算圆周率甚至还要简单。直接利用e的级数算就行。下面的程序算到e的小数点后一万位。
program se;
label ext;
const
dn=2504;
var
n,i,ip,k:integer;
sum,a:array[1..dn] of integer;
procedure testk;
var
ch:char;
begin
if k mod 10=0 then write(' ');
if (k mod 50=0) and (k mod 1000<>0) then
writeln(':',k:8);
if k mod 1000<>0 then exit;
writeln(':',k:8,' Press Enter..');
readln;
end;
procedure outp;
var
i:integer;
begin
writeln('e=');
writeln(sum[1],'.');
k:=0;
for i:=2 to dn do
begin
write(sum[i] div 1000); k:=k+1; testk;
&nbs......