用pascal设计一个可以解数独的程序；
发布网友
发布时间：2022-04-20 08:51
共5个回答
热心网友
时间：2022-05-08 00:09
i,j,s,x,y,k,l:integer;
t:boolean;
a:array [1..9,1..9] of integer;
b,d:array [1..82] of integer;
st:string;
begin
for i:=1 to 9 do begin
readln(st);
for j:=1 to 9 do a[i,j]:=ord(st[j])-48;
end;
s:=0;
for i:=1 to 9 do
for j:=1 to 9 do
if a[i,j]=0 then begin
s:=s+1;
d[s]:=(i-1)*9+j;
end;
k:=0;l:=0;x:=(d[1]-1) div 9+1;y:=(d[1]-1) mod 9+1;
while l<>s do begin
k:=k+1;
if k>9 then begin
if l=0 then begin
writeln('No Answer!');
halt;
end;
k:=b[l];
a[x,y]:=0;
x:=(d[l]-1) div 9+1;y:=(d[l]-1) mod 9+1;
b[l]:=0;
l:=l-1;
end
else begin
t:=true;
for i:=1 to 9 do
if a[i,y]=k then begin t:=false;break;end;
if t then
for i:=1 to 9 do
if a[x,i]=k then begin t:=false;break;end;
if t then begin
case x of
1,2,3:begin
if (y=1) or (y=2) or (y=3) then
for i:=1 to 3 do
for j:=1 to 3 do
if a[i,j]=k then t:=false;
if (y=4) or (y=5) or (y=6) then
for i:=1 to 3 do
for j:=4 to 6 do
if a[i,j]=k then t:=false;
if (y=7) or (y=8) or (y=9) then
for i:=1 to 3 do
for j:=7 to 9 do
if a[i,j]=k then t:=false;
end;
4,5,6:begin
if (y=1) or (y=2) or (y=3) then
for i:=4 to 6 do
for j:=1 to 3 do
if a[i,j]=k then t:=false;
if (y=4) or (y=5) or (y=6) then
for i:=4 to 6 do
for j:=4 to 6 do
if a[i,j]=k then t:=false;
if (y=7) or (y=8) or (y=9) then
for i:=4 to 6 do
for j:=7 to 9 do
if a[i,j]=k then t:=false;
end;
7,8,9:begin
if (y=1) or (y=2) or (y=3) then
for i:=7 to 9 do
for j:=1 to 3 do
if a[i,j]=k then t:=false;
if (y=4) or (y=5) or (y=6) then
for i:=7 to 9 do
for j:=4 to 6 do
if a[i,j]=k then t:=false;
if (y=7) or (y=8) or (y=9) then
for i:=7 to 9 do
for j:=7 to 9 do
if a[i,j]=k then t:=false;
end;
end;
if t then begin
a[x,y]:=k;
l:=l+1;
b[l]:=k;
k:=0;
x:=(d[l+1]-1) div 9+1;y:=(d[l+1]-1) mod 9+1;
end;
end;
end;
end;
for i:=1 to 9 do begin
for j:=1 to 9 do write(a[i,j]);
writeln;
end;
end.
热心网友
时间：2022-05-08 01:27
{$optimization on}
{$inline on}
const
m = 324;
var
i, j, k, tot, t, min: longint;
l, r, u, d, col, rr, cc, lab: array [0..m * (9 * 9 * 9 + 1)] of longint;
map: array [1..9, 1..9] of longint;
size: array [1..m] of longint;
ch: char;
f: boolean;
procere Remove(x: longint); inline;
var
i, j: longint;
begin
r[l[x]] := r[x];
l[r[x]] := l[x];
i := d[x];
while i <> x do
begin
j := r[i];
while j <> i do
begin
Dec(size[col[j]]);
u[d[j]] := u[j];
d[u[j]] := d[j];
j := r[j];
end;
i := d[i];
end;
end;
procere Resume(x: longint); inline;
var
i, j: longint;
begin
i := u[x];
while i <> x do
begin
j := l[i];
while j <> i do
begin
Inc(size[col[j]]);
u[d[j]] := j;
d[u[j]] := j;
j := l[j];
end;
i := u[i];
end;
l[r[x]] := x;
r[l[x]] := x;
end;
procere print; inline;
var
i, j: longint;
begin
f := True;
for i := 1 to 9 do
begin
for j := 1 to 9 do
Write(map[i, j]);
writeln;
end;
end;
procere DFS;
var
x, i, j: longint;
begin
if r[0] = 0 then
begin
print;
exit;
end;
min := maxlongint;
i := r[0];
while i <> 0 do
begin
if size[i] < min then
begin
min := size[i];
x := i;
end;
i := r[i];
end;
Remove(x);
i := d[x];
while i <> x do
begin
map[rr[i], cc[i]] := lab[i];
j := r[i];
while j <> i do
begin
Remove(col[j]);
j := r[j];
end;
DFS;
if f then
exit;
j := l[i];
while j <> i do
begin
Resume(col[j]);
j := l[j];
end;
i := d[i];
end;
Resume(x);
end;
procere Insert_(x, y, i, n: longint); inline;
begin
Inc(size[i]);
Inc(tot);
rr[tot] := x;
cc[tot] := y;
lab[tot] := n;
col[tot] := i;
r[tot] := tot + 1;
l[tot] := tot - 1;
u[tot] := u[i];
d[tot] := i;
d[u[i]] := tot;
u[i] := tot;
end;
procere Insert(x, y, k, n: longint); inline;
begin
t := tot + 1;
Insert_(x, y, (x - 1) * 9 + y, n);
Insert_(x, y, 81 + (x - 1) * 9 + n, n);
Insert_(x, y, 162 + (y - 1) * 9 + n, n);
Insert_(x, y, 243 + (k - 1) * 9 + n, n);
r[tot] := t;
l[t] := tot;
end;
begin
f := False;
for i := 1 to m do
begin
l[i] := i - 1;
r[i] := i + 1;
u[i] := i;
d[i] := i;
size[i] := 0;
end;
l[0] := m;
r[0] := 1;
r[m] := 0;
tot := m;
for i := 1 to 9 do
begin
for j := 1 to 9 do
begin
read(ch);
if ch = '0' then
for k := 1 to 9 do
Insert(i, j, (i - 1) div 3 * 3 + (j + 2) div 3, k)
else
Insert(i, j, (i - 1) div 3 * 3 + (j + 2) div 3, Ord(ch) - 48);
end;
readln;
end;
DFS;
if f=false then writeln('No Answer!');
readln;
end.
热心网友
时间：2022-05-08 03:02
热心网友
时间：2022-05-08 04:53
热心网友
时间：2022-05-08 07:01
