如何用PASCAL编写数独程序 SUDOKU

空位用空格补齐（每用下划线）

可以文件输入（用编译好的程序打开文件），亦可键盘输入。

用打过CRT补丁的Turbo Pascal编译，或使用Free Pascal(这个不保证正常)

样例没有超时，但对于特殊数据可能超时（我还没有数据，自己写得太简单，但是，特殊数据基本不会不超过0.01s）

程序如下：

program sdjsq{数独解算器}

{-------------调用库------------------------------------------------USES}

uses CRT,Dos{使用CRT Dos库}

{-------------数据类型定义------------------------------------------TYPE}

type

sz=0..9{数字，byte类型的子界占一byte}

sy=1..9{same as sz}

sd=array [sy,sy] of sz{数独，占8×8×1byte=81byte}

ss=set of sy{数字的集合}

dot=

record

s:ss

n,x,y:byte

end

{-------------变量定义-----------------------------------------------VAR}

var

a:sd

x,y:byte

list:record

num:byte

dat:array [1..81] of dot

end

{=============打印边框============================================PRINTK}

procedure printk

var

i, k : byte

flag : boolean

begin

gotoxy(1,1)textcolor(15)textbackground(0)

write(#218)for k:=1 to 8 do write(#196#194)writeln(#196#191)

for i := 1 to 9 do begin

write(#179)for k:=1 to 9 do begin

textbackground(1-ord(((i-1) div 3+(k-1) div 3) mod 2=0))

write(#32)textbackground(0)write(#179)

end

writeln

if i<>9 then begin

write(#195)for k:=1 to 8 do write(#196#197)writeln(#196#180)

end

end

write(#192)for k:=1 to 8 do write(#196#193)writeln(#196#217)

gotoxy(1,1)

end

{=============可以填的数==============================================KY}

procedure ky(a:sdx,y:bytevar s:ss)

var

i,j:byte

begin

s:=[1,2,3,4,5,6,7,8,9]

for i:=1 to 9 do if i<>x then s:=s-[a[i,y]]

for i:=1 to 9 do if i<>y then s:=s-[a[x,i]]

for i:=1 to 3 do for j:=1 to 3 do

if ((x-1)div 3*3+i<>x) and ((y-1)div 3*3+j<>y)

then s:=s-[a[(x-1)div 3*3+i,(y-1)div 3*3+j]]

s:=s-[0]

end

{=============打印数据=============================================PRINT}

procedure print(xn,yn,color:byte)

begin

gotoxy(2*xn,2*yn)

textcolor(color)

textbackground(5+ord(not ((x=xn)and(y=yn)))*(-4-ord(((xn-1) div 3+(yn-1) div 3) mod 2=0)))

if a[xn,yn]<>0 then write(a[xn,yn]) else write(#32)

gotoxy(1,1)

end

{=============用键盘读入数据===========================INPUT BY KEYBOARD}

procedure inputbkb(var a:sd)

label 1

var

xi,yi:byte

c:char

s:ssi:byte

begin

printk

fillchar(a,sizeof(a),0)x:=1y:=1print(1,1,0)

textcolor(15)textbackground(0)

s:=[1..9]gotoxy(1,20)for i:=1 to 9 do write(i:2)

repeat

c:=readkey

xi:=xyi:=y

case c of

(*#13{Enter}, #27{Esc}*)

#27:halt

(*#72{Up}, #75{Left}, #77{Right}, #80{Down}*)

#0:begin

c:=readkey

case c of

#75:if x<>1 then x:=x-1 else write('')

#72:if y<>1 then y:=y-1 else write('')

#80:if y<>9 then y:=y+1 else write('')

#77:if x<>9 then x:=x+1 else write('')

#83:a[x,y]:=0

end

end

#48..#58:if (ord(c)-48 in s) or (c=#48)

then a[x,y]:=ord(c)-48 else write('')

end

print(xi,yi,12)print(x,y,12)

ky(a,x,y,s)

gotoxy(1,20)

textcolor(15)textbackground(0)delline

for i:=1 to 9 do if i in s then write(i:2)

until c=#13

x:=0y:=0print(xi,yi,12)

end

procedure noans

begin

gotoxy(1,20)

textbackground(0)dellinetextcolor(143)

write('No answer!')

readkey

halt

end

{=============用文件读入数据===============================INPUT BY FILE}

procedure inputbf(var a:sdconst path:string)

function Exist(Path:string):boolean

var

S: PathStr

begin

S := FSearch(Path, GetEnv(''))

Exist := S <>''

end

var

x,y:byte

c:char

f:text

begin

if not exist(path) then begin

inputbkb(a)

end else begin

assign(f,path)reset(f)printk

for y:=1 to 9 do begin

for x:=1 to 9 do begin

read(f,c)

if not (c in [#48..#58,#32]) then begin

inputbkb(a)exit

end

if c=#32 then a[x,y]:=0 else a[x,y]:=ord(c)-48print(x,y,12)

end

readln(f)

end

end

end

{=============填入固定数据============================================TC}

procedure tc

var

x,y,i,t,n,f:byte

s:ss

function tct:byte

var

i,j,k,l:byte

s1,s2,s3:ss

n1,n2,n3:array [1..9] of byte

begin

tct:=0

for i:=1 to 9 do begin

fillchar(n1,sizeof(n1),0)fillchar(n3,sizeof(n3),0)fillchar(n2,sizeof(n2),0)

for j:=1 to 9 do begin

ky(a,i,j,s)if a[i,j]<>0 then begin s:=[a[i,j]]n1[a[i,j]]:=10end

for k:=1 to 9 do if k in s then if n1[k]=0 then n1[k]:=j else n1[k]:=10

ky(a,j,i,s)if a[j,i]<>0 then begin s:=[a[j,i]]n2[a[j,i]]:=10end

for k:=1 to 9 do if k in s then if n2[k]=0 then n2[k]:=j else n2[k]:=10

ky(a,((i-1) mod 3)*3+((j-1) mod 3+1),((i-1) div 3)*3+((j-1) div 3+1),s)

if a[((i-1) mod 3)*3+((j-1) mod 3+1),((i-1) div 3)*3+((j-1) div 3+1)]<>0 then begin

s:=[a[((i-1) mod 3)*3+((j-1) mod 3+1),((i-1) div 3)*3+((j-1) div 3+1)]]

n3[a[((i-1) mod 3)*3+((j-1) mod 3+1),((i-1) div 3)*3+((j-1) div 3+1)]]:=10

end

for k:=1 to 9 do if k in s then if n3[k]=0 then n3[k]:=j else n3[k]:=10

end

for k:=1 to 9 do begin

j:=n1[k]

if j in [1..9] then begin

a[i,j]:=kprint(i,j,6)tct:=1exit

end

end

for k:=1 to 9 do begin

j:=n2[k]

if j in [1..9] then begin

a[j,i]:=kprint(j,i,6)tct:=1exit

end

end

for k:=1 to 9 do begin

j:=n3[k]

if j in [1..9] then begin

a[((i-1) mod 3)*3+((j-1) mod 3+1),((i-1) div 3)*3+((j-1) div 3+1)]:=k

print(((i-1) mod 3)*3+((j-1) mod 3+1),((i-1) div 3)*3+((j-1) div 3+1),6)

tct:=1exit

end

end

end

end

procedure check

var

i,j,k:byte

s,s1,s2,s3:ss

begin

for i:=1 to 9 do begin

s1:=[]s2:=[]s3:=[]

for j:=1 to 9 do begin

if a[i,j]=0 then begin ky(a,i,j,s)s1:=s1+send else s1:=s1+[a[i,j]]

if a[j,i]=0 then begin ky(a,j,i,s)s2:=s2+send else s2:=s2+[a[j,i]]

if a[((i-1) mod 3)*3+((j-1) mod 3+1),((i-1) div 3)*3+((j-1) div 3+1)]=0 then begin

ky(a,((i-1) mod 3)*3+((j-1) mod 3+1),((i-1) div 3)*3+((j-1) div 3+1),s)s3:=s3+s

end else s3:=s3+[a[((i-1) mod 3)*3+((j-1) mod 3+1),((i-1) div 3)*3+((j-1) div 3+1)]]

end

for j:=1 to 9 do begin

if not (j in s1) then noans

if not (j in s2) then noans

if not (j in s3) then noans

end

end

end

begin

repeat

f:=0

for x:=1 to 9 do

for y:=1 to 9 do

if a[x,y]=0 then begin

ky(a,x,y,s)t:=0

if s=[] then

noans

for i:=1 to 9 do if i in s then begin

t:=t+1n:=i

end

if t=1 then begin a[x,y]:=nprint(x,y,14)f:=f+1end

end

f:=f+tctcheck

until f=0

end

{=============递归求解===============================================TRY}

function answer:boolean

var

ans:boolean

procedure try(num:byte)

var

i,j,n,x,y:byte

s:ss

begin

if keypressed then case readkey of #27:halt#0:if readkey=#107 then haltend

if num<=list.num then begin

x:=list.dat[num].xy:=list.dat[num].y

ky(a,x,y,s)if s=[] then exit

n:=random(8)+1

for j:=n to n+8 do begin

i:=j mod 9+1

if i in s then begin

a[x,y]:=iprint(x,y,10)

try(num+1)

a[x,y]:=0print(x,y,0)

end

end

end else begin

gotoxy(1,20)textcolor(15)textbackground(0)dellinewrite('Complete!')answer:=trueans:=true

case readkey of #27:halt#0:if readkey=#107 then haltend

textcolor(15)textbackground(0)gotoxy(1,20)dellinewriteln('Trying...')

end

end

begin

answer:=falseans:=false

try(1)

end

procedure crtinit

var

OrigMode: Word

begin

OrigMode:=LastMode { Remember original video mode }

TextMode(Lo(LastMode)+Font8x8) { use 43 or 50 lines on EGA/VGA }

end

procedure px

var

l:array [1..9] of record

num:byte

dat:array [1..81] of dot

end

i,j,k:byte

d:dot

begin

for i:=1 to 9 do l[i].num:=0

for i:=1 to 9 do for j:=1 to 9 do if a[i,j]=0 then begin

d.x:=id.y:=jky(a,i,j,d.s)d.n:=0for k:=1 to 9 do if k in d.s then inc(d.n)

inc(l[d.n].num)l[d.n].dat[l[d.n].num]:=d

end

list.num:=0

for i:=1 to 9 do for j:=1 to l[i].num do begin

inc(list.num)list.dat[list.num]:=l[i].dat[j]

end

end

begin

randomize

crtinit

textbackground(0)clrscr

if ParamCount=0 then inputbkb(a) else inputbf(a,ParamStr(1))

textcolor(15)textbackground(0)gotoxy(1,20)dellinewriteln('Thinking...')tc

textcolor(15)textbackground(0)gotoxy(1,20)dellinewriteln('Checking...')px

textcolor(15)textbackground(0)gotoxy(1,20)dellinewriteln('Trying...')gotoxy(1,1)

if not answer then noans

textcolor(15)textbackground(0)gotoxy(1,20)dellinewriteln('That''s all!')readkey

end.

目前我知道的就2147483647这么多```

这个数是我在电脑上的一个游戏里看到的,后来又找了下详细的资料

合格的数独是有解，而解是唯一解

一般是运用回溯演算法，这是试误法，通常是以电脑程序检查。

以人去检查不如程序检查快！

著名的程序是 爱尔兰数学教授麦盖尔 博士（Gary McGuire）的无偿程序 SOLVER.EXE ，计算机专业的学生都可以写的出这个程序，但是程序的执行速度仍有优劣之分。

http://www.math.ie/checker.html

合格的数独解(Sudoku grids )有 6,670,903,752,021,072,936,960 (9! × 72^2 × 2^7 × 27,704,267,971)这是这是贝米耳（Stanley E. Bammel）与罗思坦（Jerome Rothstein）二位数学家计算除来的，有专门研究的报告

http://www.afjarvis.staff.shef.ac.uk/sudoku/

由于同一个数独可以变形，例如左右纵列交换、上下横行交换、数字代码交换(例如1和5交换，2和8、3和4...)重复前面几次之后，就分不清是来自同一个数独，但是专家们还是有法子的。

澳大利亚的大学(The University of Western Australia )教授Gordon Royle 博士利用图形理论，发展出辨识数独变形的方法。将数独谜题利用 Nauty 程序图形转化，然后作比对。

http://people.csse.uwa.edu.au/gordon/sudokumin.php

如果考虑经过变形的数独不算是新数独，那么数独解的数目会少很多！

这些都是数独专业的研究，有数学、计算机、...等专家们在研究，

特别刊载于专业学报

---