数独（九宫格)

最新推荐文章于 2024-01-14 08:20:10 发布

tedzheng13

最新推荐文章于 2024-01-14 08:20:10 发布

阅读量1.6k

点赞数

分类专栏：实列

实列专栏收录该内容

2 篇文章

订阅专栏

Mark:此程序的关键记算来源于http://gundumw100.iteye.com/blog/760402,非本人原创。

Option Explicit
'/增加随机产生固定数
'|产生随机数的数独
'|来源：http://gundumw100.iteye.com/blog/760402
'|原理
'|       1.随机产生1-9之间数字
'|       2.检查所处行、列、3X3区域
'|       3.如果数字遍历1-9无解，退回第一列
'|       4.步数超过一定数，重新开始
'| 增加随机数初始化填充
'| 开始游戏后将n常驻内存,直至结束游戏

'产生初始数的最大量
Const Max_Begin_Num = 13
Const Min_Begin_Num = 5
Const w = 9
Const Begin_Color = 15
'/生成随机数字的源数组，10以内自然数
Public Num(1 To 9) As Integer
'/存储数字的数组,
'/0存储状态:1为初始化;0为手工录入
'/1存储数值
Public n(1 To w, 1 To w, 0 To 1) As Integer
Public t%

'/初始化数独数据
'/产生<13的随机1-9之间数据填入矩阵
Sub BeginGame()
'矩阵列的X/Y座标
Dim x As Integer, y As Integer
'产生随机数的量<Max_Begin_Num
Dim RndCount As Integer
Dim iX&, iY&  '变量
Dim i&
'随机数，X,Y
Dim RanN&, RanX&, RanY&
'初始化n
Erase n
Dim t
t = Timer
'随机数发生器
Randomize
'产生随机数量值
RndCount = Int((Max_Begin_Num - 1) * Rnd) + 1
'最小填充值>=5
If RndCount < Min_Begin_Num Then RndCount = Min_Begin_Num
For i = 1 To RndCount
   '产生随机数
   Do
      RanX = Int((w - 1) * Rnd) + 1
      RanY = Int((w - 1) * Rnd) + 1
      RanN = Int((w - 1) * Rnd) + 1
      n(RanX, RanY, 1) = RanN    '数值读入
      If IsCorrect(RanX, RanY) Then
         '标记为标始化
         'Stop
          n(RanX, RanY, 0) = 1
          Exit Do
      Else
          n(RanX, RanY, 0) = 0
      End If
   Loop
Next i
'Stop
'输出
For iX = 1 To 9
   For iY = 1 To 9
   Sheet2.Cells(iX, iY) = ""
   Sheet2.Cells(iX, iY).Interior.ColorIndex = xlNone
      '有初始值存在
      If n(iX, iY, 0) = 1 Then
         Sheet2.Cells(iX, iY) = n(iX, iY, 1)
         Sheet2.Cells(iX, iY).Interior.ColorIndex = Begin_Color   'gray
       End If
   Next iY
Next iX
   MsgBox ("Game Start " & Timer - t)
'Erase n
End Sub

'/Restart This Game
Sub RestartGame()
Dim iX%, iY%
'数据读入
Game_Data_In 1
For iX = 1 To w    'ROW
   For iY = 1 To w    'COLUMN
      '数据不是初始值
      If n(iX, iY, 0) = 0 Then
         n(iX, iY, 1) = 0
      End If
   Next iY
Next iX
Game_Data_Output
MsgBox ("Restart Game Done")
End Sub

'/check the result
Sub CheckGame()
Dim iX%, iY%
'变量,j=行;k=列
Dim j%, k%
Dim i%, m%
'EXCEL读入内存
Game_Data_In 0
For iX = 1 To w
   For iY = 1 To w
     If n(iX, iY, 1) = 0 Then
        '空单元格选中
        Sheet2.Cells(iX, iY).Select
        MsgBox ("请填满数据")
        Exit Sub
     Else
     '检查数据
     '检查行
        '最后一列,退出(不需检查)
        If iY = w Then Exit For
            For j = iY + 1 To w
               If n(iX, iY, 1) = n(iX, j, 1) Then
                  Union(Sheet2.Cells(iX, iY), Sheet2.Cells(iX, j)).Select
                  MsgBox ("未通过审核")
                  Exit Sub
               End If
             Next j
       '检查列
          '最后一行,退出（不需检查)
         If iX = w Then Exit For
            For k = iX + 1 To w
               If n(iX, iY, 1) = n(k, iY, 1) Then
                  Union(Sheet2.Cells(iX, iY), Sheet2.Cells(k, iY)).Select
                  MsgBox ("未通过审核")
                  Exit Sub
               End If
            Next k
        '检查3X3
            j = Int((iX - 1) / 3) * 3 + 1   '取整，3的倍数
            k = Int((iY - 1) / 3) * 3 + 1  '取整，3的倍数
             '/循环比较3X3
             For i = 1 To w
             '0值skip
                 If Not n(j + Int((i - 1) / 3), k + (i - 1) Mod 3, 1) = 0 Then
               '    If n(j + Int((i - 1) / 3), k + (i - 1) Mod 3) = 0 Then Exit Function
                     For m = i + 1 To w
                        '比较3X3区域
                        If n(j + Int((i - 1) / 3), k + (i - 1) Mod 3, 1) = n(j + Int((m - 1) / 3), k + (m - 1) Mod 3, 1) Then
                           Union(Sheet2.Cells(j + Int((i - 1) / 3), k + (i - 1) Mod 3), Sheet2.Cells(j + Int((m - 1) / 3), k + (m - 1) Mod 3)).Select
                           MsgBox ("未通过审核")
                           Exit Sub
                        End If
                     Next m
                  End If   'NOT=0
              Next i
      End If   'NOT=0
   Next iY
Next iX
MsgBox ("Check Done")
End Sub

Sub EndGame()
Dim i%, j%
Erase n
Erase Num
'清除单元格数据
For i = 1 To w
   For j = 1 To w
      Sheet2.Cells(i, j) = ""
      Sheet2.Cells(i, j).Interior.ColorIndex = xlNone
   Next j
Next i
MsgBox ("Game Clear")
End Sub

'矩阵区域读入
'公共参数n不能很好的常驻内存
'增加程序参数作为:
'1为只读入初始值
'0为读入所有值
Sub Game_Data_In(ByVal flag As Integer)
Dim iX%, iY%
 '矩阵数据读入
Erase n
For iX = 1 To w
   For iY = 1 To w
      '原始区域不为0
     If Sheet2.Cells(iX, iY) <> "" Then
         'FLAG=1
       If flag = 1 Then
          '初始化数据有数值,有颜色来辨别
          If Sheet2.Cells(iX, iY).Interior.ColorIndex = Begin_Color Then
             '数据读入
              n(iX, iY, 1) = Sheet2.Cells(iX, iY)
    '           '标记为初始值
              n(iX, iY, 0) = 1
          End If  'colorindex
       ElseIf flag = 0 Then
           '数据读入
           n(iX, iY, 1) = Sheet2.Cells(iX, iY)
          If Sheet2.Cells(iX, iY).Interior.ColorIndex = Begin_Color Then
 '           '标记为初始值
              n(iX, iY, 0) = 1
          End If  'colorindex
       End If  'flag
     End If '<>""
   Next iY
Next iX

End Sub

'矩阵输出
Sub Game_Data_Output()
Dim iX%, iY%
For iX = 1 To w
   For iY = 1 To w
      '如果为0，表示没有数据录入
      If n(iX, iY, 1) = 0 Then
         Sheet2.Cells(iX, iY) = ""
      Else
         '数据输出
         Sheet2.Cells(iX, iY) = n(iX, iY, 1)
      End If
   Next iY
Next iX
End Sub

'/产生九宫格（数独）数字
Sub Game_Done()
Dim iX%, iY%
'/数字的位置座标，x->横座标，y->纵座标
Dim x%, y%
'/填充数字的次数
Dim tm
Dim ST
'---------------------------------------------
'生成数字
tm = Timer
ST = 0

Game_Data_In 1

For x = 1 To w
   '尝试填充数字次数,每行开始初始化
   t = 1
   '填充数字
Redo:
   For y = 1 To w
      '不是初始值
      If n(x, y, 0) = 0 Then
         '产生数字
         n(x, y, 1) = GenerateNum(t)
         '//////////////////////////////////
         Game_Data_Output
         '////////////////////////////////////
         '如果步数超过某一数(梅森素数),无解
         ST = ST + 1
         If ST >= 1000 Then GoTo noAnswer
         '/如果返回值为0,则代表超过边界，退回处理
         '/退回处理的原则是:如果不是第一列，则先倒退到第一列;否则倒退到前一行的最后一列
         If n(x, y, 1) = 0 Then
            '不是第一列，退回第一列
            If y > 1 Then
               GoTo Redo
   '            y = y - 2
            Else  '是第一列，则退到上一行的最后一列
               x = x - 1
               y = 9
            End If
         End If   '返回0值
       '/填充成功
         If IsCorrect(x, y) Then
            '初始化time,为下次填充准备
            t = 1
         Else  '/继续填充
            t = t + 1
            y = y - 1
         End If
         'Stop
     End If
   '   WaitMoment (0.5)
   Next y
Next x
MsgBox (Timer - tm)
Exit Sub
noAnswer:
   MsgBox ("无解")
Erase n
End Sub

'
'产生1-9之间的随机数字 规则：生成的随机数字放置在数组8-time下标的位置，随着time的增加，已经尝试过的数字将不会在取到
'说明：即第一次次是从所有数字中随机，第二次时从前八个数字中随机，依次类推， 这样既保证随机，也不会再重复取已经不符合要求的数字，提高程序的效率
'这个规则是本算法的核心
'@param time
'填充的次数，1代表第一次填充

Function GenerateNum(ByVal t As Integer) As Integer
Dim i%
Dim RanNum As Integer
Dim temp As Integer
'第一次填充时，初始化随机数字源数组
If t = 1 Then
   For i = 1 To w
       Num(i) = i
   Next i
End If
'填充次数>=9次，表明位置已经超过边界，则返回0;由主程序处理退回
If t = w + 1 Then
   '返回0值
   GenerateNum = 0
   '退出
   Exit Function
End If
'/不是第一次填充
'/通过成随机数字，该数字是数组的下票，取数组num中该下标对应的烽字为随机数字
   Randomize
   '产生下标随机数
   RanNum = Int((w - t) * Rnd) + 1 '/j2me
   '把数字放置在数组倒数第time个位置,=换位
   temp = Num(w - t + 1)
   Num(w - t + 1) = Num(RanNum)
   Num(RanNum) = temp
   '返回数字
   GenerateNum = Num(w - t + 1)
End Function


'/是否满足行、列和3x3区域不重复的要求
' @param row
'@param col
'@return true代表符合要求
Function IsCorrect(ByVal r As Integer, ByVal col As Integer) As Boolean
  If CheckRow(r) And CheckLine(col) And CheckNine(r, col) Then
      IsCorrect = True
  End If
End Function

'/检查行是否符合要求
'@param row
'@return true代表符合要求
Function CheckRow(ByVal ro As Integer) As Boolean
Dim j As Integer  '列
Dim k As Integer
For j = 1 To w
   '0值skip
   If Not n(ro, j, 1) = 0 Then
'    If n(ro, j) = 0 Then Exit Function
      For k = j + 1 To w
         If n(ro, j, 1) = n(ro, k, 1) Then
            CheckRow = False
            Exit Function
         Else
            CheckRow = True
         End If
      Next k
   End If
Next j
End Function

'/检查行是否符合要求
'@param row
'@return true代表符合要求
Function CheckLine(ByVal col As Integer) As Boolean
Dim j As Integer  '列
Dim k As Integer
For j = 1 To w
   '0值skip
   If Not n(j, col, 1) = 0 Then
'    If n(j, col) = 0 Then Exit Function
      For k = j + 1 To w
         If n(j, col, 1) = n(k, col, 1) Then
            CheckLine = False
            Exit Function
         Else
            CheckLine = True
         End If
      Next k
   End If
Next j
End Function

'/检查3X3区域是否符合要求
' @param row
Function CheckNine(ByVal ro As Integer, ByVal col As Integer) As Boolean
'/获得左上角坐标
Dim j As Integer
Dim k As Integer
Dim i As Integer, m As Integer
'Stop
j = Int((ro - 1) / 3) * 3 + 1   '取整，3的倍数
k = Int((col - 1) / 3) * 3 + 1  '取整，3的倍数
'/循环比较
For i = 1 To w
   '0值skip
   If Not n(j + Int((i - 1) / 3), k + (i - 1) Mod 3, 1) = 0 Then
'    If n(j + Int((i - 1) / 3), k + (i - 1) Mod 3) = 0 Then Exit Function
      For m = i + 1 To w
         If n(j + Int((i - 1) / 3), k + (i - 1) Mod 3, 1) = n(j + Int((m - 1) / 3), k + (m - 1) Mod 3, 1) Then
            CheckNine = False
            Exit Function
         Else
            CheckNine = True
         End If
      Next
   End If
Next i
End Function

'Wait for showing movement
Sub WaitMoment(rMoment!)
    Dim rT!
    rT = Timer
    Do While Timer - rT < rMoment
        DoEvents
    Loop
End Sub