[原]算法程序-数独解题程序-总程序266行
计算机的速度比人脑要快得多,不过它仅仅是能依照程序进行操作
而人脑相当于一个自己根据自己需求会编程序的计算机
所以具有十分的想象力,人脑甚至于对较为复杂的多线程都无法很好的处理
计算机充当了这样一个角色,它输入了一个算法,然后让它高速循环求解
最终得到结果
算法概述CMlr数独解题算法:
对每一个空白位置(需要去填写的)都有一系列可能的值,
我们在解题时常常会在角上记上小的编号去辅助记忆,分析
这里我对每一个空白位置的可能的数都去进行了分析,
然后可以解出来的是两种结果
1.只有一个可能的,那么结果一定是这个数
2.在其所在范围内(横行,纵列,九格区域)的任意一一个范围中存在唯一的一个数,结果就是这个唯一的数
那么循环遍历所有的空白位置,就可以解出来每个空白位置的值了
最终得到结果
测试题(这个用来测试,可以随意设置几个为0,然后测试结果,我在写代码时用的就是这个来测试的) 1,2,3,4,5,6,7,8,9 4,5,6,7,8,9,1,2,3 7,8,9,1,2,3,4,5,6 2,1,4,3,6,5,8,9,7 3,6,5,8,9,7,2,1,4 8,9,7,2,1,4,3,6,5 5,3,1,6,4,2,9,7,8 6,4,2,9,7,8,5,3,1 9,7,8,5,3,1,6,4,2 简单(不到1s就出来了) 8,0,0,0,0,2,4,7,0 0,0,2,0,0,9,0,0,5 4,5,0,0,6,7,0,8,0 5,4,0,3,1,0,0,9,0 0,0,3,9,0,0,6,0,0 0,6,0,0,0,8,0,3,7 0,3,0,7,5,0,0,2,6 7,0,0,6,0,0,3,0,0 0,2,4,8,0,0,0,0,1 中等(也不过1s的解题速度) 0,0,1,3,0,0,0,0,5 0,0,7,0,0,4,6,0,9 0,6,0,0,5,0,4,0,0 0,4,0,0,1,6,9,0,0 2,0,0,9,0,0,0,0,7 0,0,3,0,0,7,0,5,0 0,0,5,0,3,0,0,9,0 1,0,2,8,0,0,3,0,0 8,0,0,0,0,2,5,0,0 困难(极快,不到1s) 0,0,7,0,2,0,9,5,0 0,9,0,0,0,5,4,0,0 0,0,3,0,8,0,1,0,0 0,0,6,9,0,4,0,0,7 1,0,0,0,0,6,0,0,2 8,0,0,0,3,0,5,0,0 0,0,4,0,6,0,7,0,0 0,0,1,5,0,0,0,8,0 0,8,2,0,9,0,6,0,0 困难++(这题解不出来,只是解出很不完全的结果) 0,0,8,0,0,7,0,0,0 0,9,0,0,4,0,7,0,0 5,0,0,0,0,0,0,0,6 2,0,0,0,0,0,6,0,0 6,0,0,0,0,3,0,0,5 0,0,1,0,0,8,0,0,2 1,0,0,0,0,0,0,0,8 0,0,2,0,7,0,0,7,0 0,0,0,1,0,0,4,0,0 这解出来的结果(解出个位置) 4,0,8,0,0,7,0,0,0 3,9,6,0,4,0,7,0,1 5,0,7,0,0,0,0,0,6 2,0,0,0,0,0,6,0,0 6,0,0,0,0,3,0,0,5 0,0,1,0,0,8,0,0,2 1,0,0,0,0,0,0,0,8 0,0,2,0,7,0,0,7,0 0,0,0,1,0,0,4,0,0
全部程序代码如下(控件textbox1,2,button1):
为方便复制,我就不用行号了
Imports System.Text.RegularExpressions
Public Class Form1
Dim a As New List(Of Posnum)
Dim _left As Short = 81
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
a = Nothing
_left = 81
TextBox2.Text = ""
a = getlist(TextBox1.Text)
a = maybeall(a)
a = findwhatcanifound(a)
TextBox2.Text = getstring(a)
End Sub
''' <summary>
''' 这个类型包含
''' pos:位置:短整型
''' xpos:X坐标,从1开始:短整型
''' ypos:Y坐标,以下为正,从1开始:短整型
''' num:这个位置所包含的数字(0~9):短整型
''' hasvalue:是否有值,如果num为零则没有值,返回False:布尔值
''' area:九宫格区域(1~9)如下
'''_______
'''|1|2|3|
'''-------
'''|4|5|6|
'''-------
'''|7|8|9| :短整型
'''-------
''' </summary>
''' <remarks></remarks>
Structure Posnum
Dim pos As Short
Dim xpos As Short
Dim ypos As Short
Dim num As Short
Dim hasvalue As Boolean
Dim area As Short
Dim maybe As List(Of Short)
End Structure
''' <summary>
''' 获得列表,以Posnum为类型
''' </summary>
''' <param name="text">全部字符串,可以直接从Textbox.text调用</param>
''' <returns>返回一个List(Of Posnum)类型的列表</returns>
''' <remarks></remarks>
Function getlist(ByVal text As String) As List(Of Posnum)
Dim txt As MatchCollection
Dim n As New List(Of Posnum)
Dim npos As Short = 0
Dim a As New List(Of Posnum)
Dim re As New Regex("\d")
txt = re.Matches(text)
For Each i As Match In txt
Dim w As New Posnum
With w
.num = Val(i.Value)
.pos = (npos + 1)
.xpos = npos Mod 9 + 1
.ypos = npos \ 9 + 1
.hasvalue = .num
If .hasvalue = True Then
_left -= 1
End If
.area = ((.ypos - 1) \ 3) * 3 + (.xpos + 2) \ 3
.maybe = New List(Of Short)
.maybe.Clear()
End With
a.Add(w)
npos += 1
Next
Return a
End Function
''' <summary>
''' 不可能有的数字,按1~9排列
''' </summary>
''' <param name="list"></param>
''' <param name="pos"></param>
''' <returns></returns>
''' <remarks></remarks>
Function cannotbe(ByVal list As List(Of Posnum), ByVal pos As Posnum) As List(Of Short)
Dim lst As New List(Of Short)
If Not pos.hasvalue Then
For Each i As Posnum In list
If i.hasvalue Then
If i.area = pos.area Then
If Not lst.Contains(i.num) Then
lst.Add(i.num)
End If
ElseIf i.xpos = pos.xpos Then
If Not lst.Contains(i.num) Then
lst.Add(i.num)
End If
ElseIf i.ypos = pos.ypos Then
If Not lst.Contains(i.num) Then
lst.Add(i.num)
End If
End If
End If
Next
lst.Sort()
End If
Return lst
End Function
''' <summary>
''' 可能有的数字,按1~9排列
''' </summary>
''' <param name="list">整个数列</param>
''' <param name="pos">需要获得那个位置上的可能的数字</param>
''' <returns>返回一个list(of short)</returns>
''' <remarks></remarks>
Function maytobe(ByVal list As List(Of Posnum), ByVal pos As Posnum) As List(Of Short)
Dim lst As New List(Of Short)
lst.AddRange({1, 2, 3, 4, 5, 6, 7, 8, 9})
If Not pos.hasvalue Then
For Each i As Short In cannotbe(list, pos)
If lst.Contains(i) Then lst.Remove(i)
Next
lst.Sort()
End If
Return lst
End Function
''' <summary>
''' 把所有的数字自动排列了
''' </summary>
''' <param name="list">传入全部数字的数组</param>
''' <returns>全部修改过数组</returns>
''' <remarks></remarks>
Function maybeall(ByVal list As List(Of Posnum)) As List(Of Posnum)
Dim lst As New List(Of Posnum)
lst = list
For i As Short = 0 To lst.Count - 1
If Not lst(i).hasvalue Then
lst.Item(i).maybe.Clear()
lst.Item(i).maybe.AddRange(maytobe(lst, lst.Item(i)))
End If
Next
Return lst
End Function
''' <summary>
''' 可以设置看他是否包含仅有一个可能的项,那么就采用它.
''' </summary>
''' <param name="list">传入整个list</param>
''' <returns>返回转换后的结果</returns>
''' <remarks>还有一点没有完成,可以查看函数中的注释</remarks>
Function setonce(ByVal list As List(Of Posnum)) As List(Of Posnum)
Dim lst As New List(Of Posnum)
lst = list
For i As Short = 0 To lst.Count - 1
If Not lst.Item(i).hasvalue Then
If lst.Item(i).maybe.Count = 1 Then
Dim tmp As Posnum = lst.Item(i)
tmp.num = lst.Item(i).maybe.Item(0)
tmp.hasvalue = True
lst.Item(i) = tmp
_left -= 1
'ElseIf lst.Item(i).maybe.Count = 8 Then
' Dim tmp As Posnum = lst.Item(i)
' For j = 1 To 9
' Next
'还有一种情况,那就是在所有他所在的位置(包括X,Y和area里)只有它包含一个唯一的数字,这种情况不太容易写,我稍后就去解决
'上面所述在下面解决
ElseIf haveonlyvalue(lst, lst.Item(i)) > 0 Then
Dim tmp As Posnum = lst.Item(i)
tmp.num = haveonlyvalue(lst, lst.Item(i))
tmp.hasvalue = True
lst.Item(i) = tmp
_left -= 1
ElseIf lst.Item(i).maybe.Count = 0 Then
Throw New Exception("不能继续,这个数独题没有解,至少因为某一个位置没有可能的解")
End If
End If
Next
Return lst
End Function
''' <summary>
''' 找到所有计算机能找到的解
''' </summary>
''' <param name="list">这是一个列表,即传入的数字列表</param>
''' <returns>返回处理过解的列表</returns>
''' <remarks>此功能可能也不太完善</remarks>
Function findwhatcanifound(ByVal list As List(Of Posnum)) As List(Of Posnum)
Dim lst As New List(Of Posnum)
lst = list
Dim lstup As New List(Of Posnum)
lstup = list
Dim con As Boolean = True
Dim lefts As Short = _left
While con
lst = setonce(lstup)
If _left = 0 Then
'全部计算成功
con = False
Exit While
ElseIf lefts = _left Then
'没有可能做进一步的解了
con = False
Exit While
Else
lefts = _left
End If
lstup = lst
End While
Return lst
End Function
''' <summary>
''' 从列表返回数字的字串
''' </summary>
''' <param name="list">传入列表</param>
''' <returns>输出字串</returns>
''' <remarks></remarks>
Function getstring(ByVal list As List(Of Posnum)) As String
Dim nowline As Short = 1
Dim nowlinestring As String = ""
Dim allstring As String = ""
For Each i In list
If i.ypos = nowline + 1 Then
allstring &= nowlinestring.Substring(0, nowlinestring.Length - 1) & vbNewLine & i.num & ","
nowlinestring = ""
nowline += 1
Else
nowlinestring &= i.num & ","
End If
Next
allstring &= nowlinestring.Substring(0, nowlinestring.Length - 1) & vbNewLine
allstring = allstring.Substring(0, allstring.Length - 1)
Return allstring
End Function
''' <summary>
''' 这个解决了另一种可以直接得出解的方法,他所在的位置(包括X,Y和area里)只有它包含一个唯一的数字,就采用它
''' </summary>
''' <param name="list">传入的列表</param>
''' <param name="pos">传入一个posnum信息</param>
''' <returns>如果存在这样一个值,就返回这个值,否则返回0</returns>
''' <remarks></remarks>
Function haveonlyvalue(ByVal list As List(Of Posnum), ByVal pos As Posnum) As Short
Dim lst As New List(Of Posnum)
lst = list
If Not pos.hasvalue Then
For Each i As Posnum In lst
If i.hasvalue Then
If i.area = pos.area Then
For Each j In i.maybe
If pos.maybe.Contains(j) Then pos.maybe.Remove(j)
Next
ElseIf i.xpos = pos.xpos Then
For Each j In i.maybe
If pos.maybe.Contains(j) Then pos.maybe.Remove(j)
Next
ElseIf i.ypos = pos.ypos Then
For Each j In i.maybe
If pos.maybe.Contains(j) Then pos.maybe.Remove(j)
Next
End If
End If
Next
End If
If pos.maybe.Count = 1 Then
Return pos.maybe.Item(0)
Else
Return 0
End If
End Function
End Class
Code By CMlr.
浙公网安备 33010602011771号