Как победить Судоку

VERSION 5.00
Begin VB.Form frmM 
   Caption         =   "Судоку"
   ClientHeight    =   6090
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   8850
   Icon            =   "frmM.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   406
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   590
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdOpen 
      Caption         =   "Загрузить файл"
      BeginProperty Font 
         Name            =   "Times New Roman"
         Size            =   14.25
         Charset         =   204
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   915
      Left            =   6600
      TabIndex        =   3
      Top             =   4500
      Width           =   1815
   End
   Begin VB.Timer tmrR 
      Enabled         =   0   'False
      Interval        =   400
      Left            =   9300
      Top             =   5400
   End
   Begin VB.CommandButton cmdD 
      Caption         =   "Поехали"
      BeginProperty Font 
         Name            =   "Times New Roman"
         Size            =   15.75
         Charset         =   204
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   915
      Left            =   6600
      TabIndex        =   1
      Top             =   3000
      Width           =   1815
   End
   Begin VB.TextBox txtT 
      Alignment       =   2  'Center
      Appearance      =   0  'Flat
      BeginProperty Font 
         Name            =   "Microsoft Sans Serif"
         Size            =   21.75
         Charset         =   204
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   615
      Index           =   0
      Left            =   90
      TabIndex        =   0
      Top             =   90
      Width           =   615
   End
   Begin VB.Label lblL 
      Alignment       =   2  'Center
      BeginProperty Font 
         Name            =   "Times New Roman"
         Size            =   18
         Charset         =   204
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   465
      Left            =   6600
      TabIndex        =   2
      Top             =   750
      Width           =   1665
   End
   Begin VB.Shape Shape1 
      BackColor       =   &H00FFFFFF&
      FillColor       =   &H00C00000&
      FillStyle       =   0  'Solid
      Height          =   6045
      Left            =   0
      Top             =   0
      Width           =   6045
   End
End
Attribute VB_Name = "frmM"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Rem Эта программа решает Судоку
Rem она загружает судоку из файла Su.txt, который находится
Rem в текущем каталоге (где Exe-файл)
Rem текст в Su.txt должен выглядеть так (реальный пример)
 
Rem 010000080           (запись - строка за строкой)
Rem 460090053
Rem 000403000
Rem 007000200
Rem 040000030
Rem 008000500
Rem 000506000
Rem 680020071
Rem 030000040
 
Rem то есть вместо пустой клетки ставится 0 (нуль)
 
Option Explicit
Option Base 1
 
Dim i%, j%, k%, m%, n%, p%, q%, z%
Dim ind%, ik%, jk%, nm%, zp%, zq%
Dim O%(9, 9)
Dim Osch As Boolean
 
Private Sub cmdD_Click()
    For i = 0 To 80
        txtT(i).ForeColor = vbBlack
    Next i
    Call Copi(O())                           ' инициализация массива O()
    Call Fehler                                ' процедура ищет ошибку
    If Osch Then                              ' Osch=True - наличие ошибки
        tmrR.Enabled = True
        lblL.Caption = "Ошибка"
    End If
    Call Stroka                               ' Эти процедуры решают Судоку
    Call Stolbez
    Call Block
    Call Kletka
End Sub
 
Rem инициализация массива
Private Sub Copi(Yy%())
    For k = 0 To 80
        Call ijN(k, i, j)
        Yy(i, j) = Val(txtT(k).Text)
    Next k
End Sub
 
Rem процедура ищет: Нет ли где ошибки
Rem То есть проверяет все строки, столбцы и блоки
Rem Если есть две РАВНЫЕ цифры - ошибка!
Private Sub Fehler()
    Osch = False
    For i = 1 To 9
        For j = 1 To 9
            m = O(i, j)
            If m = 0 Then GoTo 100   ' Если поле пустое, переход на следующее
            
            n = 0                                          ' код для строки
            For k = 1 To 9
                If O(i, k) = m Then n = n + 1
            Next k
            If n > 1 Then
                Osch = True        ' Есть ошибка, значит
                Exit Sub             ' выход из процедуры
            End If
                
            n = 0                                         ' Столбец
            For k = 1 To 9
                If O(k, j) = m Then n = n + 1
            Next k
            If n > 1 Then
                Osch = True
                Exit Sub
            End If
                
            For k = 1 To 9                             ' проверка блока
                n = 0
                Call ijBlock(k, ik, jk)
                For p = ik To ik + 2
                    For q = jk To jk + 2
                        If O(p, q) = m Then n = n + 1
                    Next q
                Next p
                If n > 1 Then           ' число не одно - ошибка!!
                    Osch = True
                    Exit Sub
                End If
            Next k
100:
        Next j
    Next i
End Sub
 
Private Sub Stroka()
    For m = 1 To 9                      ' m - цифра
        For i = 1 To 9                    ' i - номер строки
            nm = 0                           ' столько раз можно поставить m
            For j = 1 To 9                ' j - номер столбца
                                    ' здесь цифра встречается - переходим к другой
                If O(i, j) = m Then GoTo 200
                                    ' здесь есть цифра, а нам надо пустое поле
                                    ' переходим на следующее поле
                If O(i, j) <> 0 Then GoTo 100
            
                For k = 1 To 9
                                      ' такая цифра есть, переход на следующее поле
                    If O(k, j) = m Then GoTo 100
                Next k
                                        ' функция вычисляет номер блока nBlock(i, j)
                                        ' процедура ijBlock() выдает начальные
                                        ' значения левого верхнего угла блока
                Call ijBlock(nBlock(i, j), ik, jk)
                                         ' двойной цикл (блок - не строка)
                For p = ik To ik + 2
                    For q = jk To jk + 2
                        If O(p, q) = m Then GoTo 100
                    Next q
                Next p
                nm = nm + 1
                z = j                           ' сохранение j
100:
            Next j
                                            ' если цифру можно поставить только
                                            ' один раз - то мы ее и ставим!!
            If nm = 1 Then Call SchH(i, z, m)
200:
        Next i
    Next m
End Sub
                                    Rem Эта процедура ПОЧТИ копия предыдущей
                                    Rem комментарии излишни
Private Sub Stolbez()
    For m = 1 To 9
        For j = 1 To 9
            nm = 0                           ' столько раз можно поставить m
            For i = 1 To 9
                If O(i, j) = m Then GoTo 200
                If O(i, j) <> 0 Then GoTo 100
            
                For k = 1 To 9
                    If O(i, k) = m Then GoTo 100
                Next k
          
                Call ijBlock(nBlock(i, j), ik, jk)
                For p = ik To ik + 2
                    For q = jk To jk + 2
                        If O(p, q) = m Then GoTo 100
                    Next q
                Next p
                nm = nm + 1
                z = i                         ' сохранение i
100:
            Next i
            If nm = 1 Then Call SchH(z, j, m)
200:
        Next j
    Next m
End Sub
                                            ' Почти тоже самое, НО
                                            ' сначала залается блок (переменная k)
                                            ' а далее все тоже самое
Private Sub Block()
    For m = 1 To 9
        For k = 1 To 9           ' здесь k - номер блока
            nm = 0
            Call ijBlock(k, ik, jk)
            For p = ik To ik + 2
                For q = jk To jk + 2
                    If O(p, q) = m Then GoTo 200
                    If O(p, q) <> 0 Then GoTo 100
                    
                    For n = 1 To 9
                        If O(n, q) = m Then GoTo 100
                    Next n
                    
                    For n = 1 To 9
                        If O(p, n) = m Then GoTo 100
                    Next n
                    nm = nm + 1
                    zp = p                         ' сохранение p, q
                    zq = q
100:
                Next q
            Next p
            If nm = 1 Then Call SchH(zp, zq, m)
200:
        Next k
    Next m
End Sub
 
Rem Суть этой процедуры проста:
Rem выбирается пустая (нулевая) клетка (пустое поле)
Rem и проверяется - Сколько цифр в нее можно поставит (!!)
Rem Если одну, то ее и ставим!!
Private Sub Kletka()
    For i = 1 To 9
        For j = 1 To 9
            If O(i, j) <> 0 Then GoTo 200
            nm = 0
            For m = 1 To 9
                For k = 1 To 9
                    If O(i, k) = m Then GoTo 100
                Next k
                
                For k = 1 To 9
                    If O(k, j) = m Then GoTo 100
                Next k
                
                Call ijBlock(nBlock(i, j), ik, jk)
                For p = ik To ik + 2
                    For q = jk To jk + 2
                        If O(p, q) = m Then GoTo 100
                    Next q
                Next p
                nm = nm + 1
                z = m                    ' сохранение m
100:
            Next m
            If nm = 1 Then Call SchH(i, j, z)
200:
        Next j
    Next i
End Sub
 
Private Sub cmdOpen_Click()            ' здесь все просто: загрузка данных
Dim Ss As String, Sd As String
    On Error GoTo 777
    Open "Su.txt" For Input As #1
    For i = 1 To 9
        Line Input #1, Ss
        For j = 1 To 9
            Sd = Mid(Ss, j, 1)
            If Sd = "0" Then txtT(Nij(i, j)).Text = " " Else txtT(Nij(i, j)).Text = Sd
        Next j
    Next i
    Close #1
    Exit Sub
777:                    ' Обработка ошибки
    lblL.Caption = "Su.txt??"
End Sub
 
Rem Создается текстовое поле txtT(0)
Rem Остальные поля загружаются динамически
Rem Нулевое поле не может быть дважды загружено
Private Sub Form_Load()
    For i = 1 To 9
        For j = 1 To 9
            ik = Choose(i, 6, 9, 12, 17, 20, 23, 28, 31, 34)
            jk = Choose(j, 6, 9, 12, 17, 20, 23, 28, 31, 34)
            ind = Nij(i, j)
            If ind = 0 Then GoTo 100             ' Это поле уже загружено
            Load txtT(ind)
            txtT(ind).Left = 40 * (j - 1) + jk
            txtT(ind).Top = 40 * (i - 1) + ik
            txtT(ind).Visible = True
100:
        Next j
    Next i
End Sub
                                                      ' ставит цифру в нужное место
                                                      ' и отмечает ее красным цветом
Private Sub SchH(ni%, nj%, nn%)
    txtT(Nij(ni, nj)).ForeColor = vbRed
    txtT(Nij(ni, nj)).Text = nn
End Sub
 
Rem вычисляет номер блока по координатам клетки
Private Function nBlock(ii%, jj%) As Integer
    nBlock = 3 * Fix((ii - 1) / 3) + Fix((jj - 1) / 3) + 1
End Function
 
Rem определяет по номеру блока левый верхний угол
Private Sub ijBlock(kk%, ii%, jj%)
    ii = Choose(kk, 1, 1, 1, 4, 4, 4, 7, 7, 7)
    jj = Choose(kk, 1, 4, 7, 1, 4, 7, 1, 4, 7)
End Sub
                                         ' вычисляет индекс текстового поля
Private Function Nij(ii As Integer, jj As Integer) As Integer
    Nij = 9 * (ii - 1) + jj - 1
End Function
                                         ' процедура обратная  функции Nij()
Private Sub ijN(kk%, ii%, jj%)
    ii = Int(kk / 9) + 1
    jj = kk Mod 9 + 1
End Sub
                                                     ' без комментариев
Private Sub tmrR_Timer()
    If lblL.ForeColor = vbBlack Then
        lblL.ForeColor = vbRed
    Else
        lblL.ForeColor = vbBlack
    End If
End Sub
 
Private Sub txtT_Change(Index As Integer)
    lblL.Caption = ""
    lblL.ForeColor = vbBlack
    tmrR.Enabled = False
End Sub