118 lines
3.0 KiB
VB.net
118 lines
3.0 KiB
VB.net
'VBScript Sudoku solver. Fast recursive algorithm adapted from the C version
|
|
'It can read a problem passed in the command line or from a file /f:textfile
|
|
'if no problem passed it solves a hardwired problem (See the prob0 string)
|
|
'problem string can have 0's or dots in the place of unknown values. All chars different from .0123456789 are ignored
|
|
|
|
Option explicit
|
|
Sub print(s):
|
|
On Error Resume Next
|
|
WScript.stdout.Write (s)
|
|
If err= &h80070006& Then WScript.Echo " Please run this script with CScript": WScript.quit
|
|
End Sub
|
|
|
|
function parseprob(s)'problem string to array
|
|
Dim i,j,m
|
|
print "parsing: " & s & vbCrLf & vbcrlf
|
|
j=0
|
|
For i=1 To Len(s)
|
|
m=Mid(s,i,1)
|
|
Select Case m
|
|
Case "0","1","2","3","4","5","6","7","8","9"
|
|
sdku(j)=cint(m)
|
|
j=j+1
|
|
Case "."
|
|
sdku(j)=0
|
|
j=j+1
|
|
Case Else 'all other chars are ignored as separators
|
|
End Select
|
|
Next
|
|
' print j
|
|
If j<>81 Then parseprob=false Else parseprob=True
|
|
End function
|
|
|
|
sub getprob 'get problem from file or from command line or from
|
|
Dim s,s1
|
|
With WScript.Arguments.Named
|
|
If .exists("f") Then
|
|
s1=.item("f")
|
|
If InStr(s1,"\")=0 Then s1= Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, "\"))&s1
|
|
On Error Resume Next
|
|
s= CreateObject("Scripting.FileSystemObject").OpenTextFile (s1, 1).readall
|
|
If err Then print "can't open file " & s1 : parseprob(prob0): Exit sub
|
|
If parseprob(s) =True Then Exit sub
|
|
End if
|
|
End With
|
|
With WScript.Arguments.Unnamed
|
|
If .count<>0 Then
|
|
s1=.Item(0)
|
|
If parseprob(s1)=True Then exit sub
|
|
End if
|
|
End With
|
|
parseprob(prob0)
|
|
End sub
|
|
|
|
function solve(x,ByVal pos)
|
|
'print pos & vbcrlf
|
|
'display(x)
|
|
|
|
Dim row,col,i,j,used
|
|
solve=False
|
|
If pos=81 Then solve= true :Exit function
|
|
row= pos\9
|
|
col=pos mod 9
|
|
If x(pos) Then solve=solve(x,pos+1):Exit Function
|
|
used=0
|
|
For i=0 To 8
|
|
used=used Or pwr(x(i * 9 + col))
|
|
Next
|
|
For i=0 To 8
|
|
used=used Or pwr(x(row*9 + i))
|
|
next
|
|
row = (row\ 3) * 3
|
|
col = (col \3) * 3
|
|
For i=row To row+2
|
|
For j=col To col+2
|
|
' print i & " " & j &vbcrlf
|
|
used = used Or pwr(x(i*9+j))
|
|
Next
|
|
Next
|
|
'print pos & " " & Hex(used) & vbcrlf
|
|
For i=1 To 9
|
|
If (used And pwr(i))=0 Then
|
|
x(pos)=i
|
|
'print pos & " " & i & " " & num2bin((used)) & vbcrlf
|
|
solve= solve(x,pos+1)
|
|
If solve=True Then Exit Function
|
|
'x(pos)=0
|
|
End If
|
|
Next
|
|
x(pos)=0
|
|
solve=False
|
|
End Function
|
|
|
|
Sub display(x)
|
|
Dim i,s
|
|
For i=0 To 80
|
|
If i mod 9=0 Then print s & vbCrLf :s=""
|
|
If i mod 27=0 Then print vbCrLf
|
|
If i mod 3=0 Then s=s & " "
|
|
s=s& x(i)& " "
|
|
Next
|
|
print s & vbCrLf
|
|
End Sub
|
|
|
|
Dim pwr:pwr=Array(1,2,4,8,16,32,64,128,256,512,1024,2048)
|
|
Dim prob0:prob0= "001005070"&"920600000"& "008000600"&"090020401"& "000000000" & "304080090" & "007000300" & "000007069" & "010800700"
|
|
Dim sdku(81),Time
|
|
getprob
|
|
print "The problem"
|
|
display(sdku)
|
|
Time=Timer
|
|
If solve (sdku,0) Then
|
|
print vbcrlf &"solution found" & vbcrlf
|
|
display(sdku)
|
|
Else
|
|
print "no solution found " & vbcrlf
|
|
End if
|
|
print vbcrlf & "time: " & Timer-Time & " seconds" & vbcrlf
|