Foro de elhacker.net

Regla 1: hay que completar las casillas vacías con un solo número del 1 al 9.

Regla 2: en una misma fila no puede haber números repetidos.

Regla 3: en una misma columna no puede haber números repetidos.

Regla 4: en una misma región no puede haber números repetidos.

Regla 5: la solución de un sudoku es única.

 
Option Explicit
 
Private Sub Form_Load()
Dim bSudoku(8, 8)   As Byte '   //  (nFilas, nColumnas)
    bSudoku(0, 0) = 5
    bSudoku(0, 1) = 3
    bSudoku(0, 4) = 7
 
    bSudoku(1, 0) = 6
    bSudoku(1, 3) = 1
    bSudoku(1, 4) = 9
    bSudoku(1, 5) = 5
 
    bSudoku(2, 1) = 9
    bSudoku(2, 2) = 6
    bSudoku(2, 7) = 1
 
    bSudoku(3, 0) = 8
    bSudoku(3, 4) = 6
    bSudoku(3, 8) = 3
 
    bSudoku(4, 0) = 4
    bSudoku(4, 3) = 8
    bSudoku(4, 5) = 3
    bSudoku(4, 8) = 1
 
    bSudoku(5, 0) = 7
    bSudoku(5, 4) = 2
    bSudoku(5, 8) = 6
 
    bSudoku(6, 1) = 6
    bSudoku(6, 6) = 2
    bSudoku(6, 7) = 8
 
    bSudoku(7, 3) = 4
    bSudoku(7, 4) = 1
    bSudoku(7, 5) = 9
    bSudoku(7, 8) = 5
 
    bSudoku(8, 4) = 8
    bSudoku(8, 7) = 7
    bSudoku(8, 8) = 9
 
    Debug.Print "Inicial"
    showSudoku bSudoku
 
    MsgBox solveSudoku(bSudoku, 0, 0)  '   //  Por BackTracking
 
    Debug.Print "Resuelto"
    showSudoku bSudoku
 
End Sub
 
Public Sub showSudoku(ByRef bArray() As Byte)
Dim i As Integer
Dim j As Integer
    For i = 0 To UBound(bArray, 1)
        For j = 0 To UBound(bArray, 2)
            Debug.Print bArray(i, j);
        Next
        Debug.Print
    Next
    Debug.Print
    Debug.Print
End Sub
 
Public Function solveSudoku(ByRef bArray() As Byte, ByVal iRow As Long, ByVal iCol As Long) As Boolean
'   //  Me falta optimizar el proceso... Version 1.0.
Dim lVal        As Long
Dim i           As Long
    If (iRow >= 9) Then
        solveSudoku = True
        Exit Function
    End If
    Do While Not (bArray(iRow, iCol) = &H0)    '   //  Nos posicionamos en la 1ra celda de iRow vacia (con valor 0).
        iCol = (iCol + &H1)
        If (iCol = 9) Then
            iCol = &H0
            iRow = (iRow + &H1)
            If (iRow >= &H9) Then
                solveSudoku = True
                Exit Function
            End If
        End If
    Loop
    For lVal = 1 To 9                           '   //  Buscamos un valor valido para la celda...
        For i = 0 To 8                          '   //  Verificamos cada celda de la columna iCol.
            If (bArray(i, iCol) = lVal) Then
                i = (-1)
                Exit For
            End If
        Next
        If Not (i = (-1)) Then
            For i = 0 To 8                      '   //  Verificamos cada celda de la Fila iRow.
                If (bArray(iRow, i) = lVal) Then
                    i = (-1)
                    Exit For
                End If
            Next
            If Not (i = (-1)) Then
                bArray(iRow, iCol) = lVal       '   //  Seteamos su valor.
                If (iCol < 8) Then              '   //  Avazamos a la siguiente celda a resolver.
                    solveSudoku = solveSudoku(bArray, iRow, iCol + 1)
                    If Not solveSudoku Then
                        bArray(iRow, iCol) = 0  '   //  Error entonces volvemos atras.
                    End If
                Else
                    solveSudoku = solveSudoku(bArray, iRow + 1, 0)
                    If Not solveSudoku(bArray, iRow + 1, 0) Then
                        bArray(iRow, iCol) = 0  '   //  Error entonces volvemos atras.
                    End If
                End If
            End If
        End If
    Next
 
End Function
 
 

Inicial
 5  3  0  0  7  0  0  0  0 
 6  0  0  1  9  5  0  0  0 
 0  9  6  0  0  0  0  1  0 
 8  0  0  0  6  0  0  0  3 
 4  0  0  8  0  3  0  0  1 
 7  0  0  0  2  0  0  0  6 
 0  6  0  0  0  0  2  8  0 
 0  0  0  4  1  9  0  0  5 
 0  0  0  0  8  0  0  7  9 


Resuelto
 5  3  1  2  7  6  4  9  8 
 6  2  4  1  9  5  8  3  7 
 3  9  6  5  4  8  7  1  2 
 8  5  2  9  6  7  1  4  3 
 4  7  9  8  5  3  6  2  1 
 7  1  8  3  2  4  9  5  6 
 9  6  5  7  3  1  2  8  4 
 2  8  7  4  1  9  3  6  5 
 1  4  3  6  8  2  5  7  9 

bSudoku(2, 2) = 6
 bSudoku(2, 7) = 1

 
'
'   /////////////////////////////////////////////////////////////
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandecido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////
 
Option Explicit
 
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Dim bSudoku(8, 8)   As Byte '   //  (nColumnas, nFilas)
 
'Private Sub cmdSolve_Click()
'    fillSudoku bSudoku
'    Caption = solveSudoku(bSudoku, 0, 0) '   //  Por BackTracking
'    showSudoku bSudoku
'End Sub
 
Private Sub Form_Load()
    bSudoku(0, 0) = 5
    bSudoku(0, 1) = 3
    bSudoku(0, 4) = 7
 
    bSudoku(1, 0) = 6
    bSudoku(1, 3) = 1
    bSudoku(1, 4) = 9
    bSudoku(1, 5) = 5
 
    bSudoku(2, 1) = 9
    bSudoku(2, 2) = 6
    bSudoku(2, 7) = 1
 
    bSudoku(3, 0) = 8
    bSudoku(3, 4) = 6
    bSudoku(3, 8) = 3
 
    bSudoku(4, 0) = 4
    bSudoku(4, 3) = 8
    bSudoku(4, 5) = 3
    bSudoku(4, 8) = 1
 
    bSudoku(5, 0) = 7
    bSudoku(5, 4) = 2
    bSudoku(5, 8) = 6
 
    bSudoku(6, 1) = 6
    bSudoku(6, 6) = 2
    bSudoku(6, 7) = 8
 
    bSudoku(7, 3) = 4
    bSudoku(7, 4) = 1
    bSudoku(7, 5) = 9
    bSudoku(7, 8) = 5
 
    bSudoku(8, 4) = 8
    bSudoku(8, 7) = 7
    bSudoku(8, 8) = 9
 
    Debug.Print "Matrix inicial."
    showSudoku bSudoku
    If solveSudoku(bSudoku, 0, 0) Then
        Debug.Print "Sudoku Resuelto"
        showSudoku bSudoku
    Else
        Debug.Print "No se puede resolver, revisa la matrix."
    End If
End Sub
 
Public Sub showSudoku(ByRef bArray() As Byte)
Dim i As Integer
Dim j As Integer
    Show
    For i = 0 To UBound(bArray, 1)          '   //  Fila
        For j = 0 To UBound(bArray, 2)      '   //  Columa
            'txtCell((i * 9) + j).Text = bArray(j, i)
            If (((j + &H1) Mod &H3) = &H0) Then
                Debug.Print bArray(j, i); "|";
            Else
                Debug.Print bArray(j, i);
            End If
        Next
        Debug.Print
        If (((i + &H1) Mod &H3) = &H0) Then Debug.Print String(32, "-")
    Next
End Sub
 
'Public Sub fillSudoku(ByRef bArray() As Byte)
'Dim i As Integer
'Dim j As Integer
'    Show
'    For i = 0 To UBound(bArray, 1)          '   //  Fila
'        For j = 0 To UBound(bArray, 2)      '   //  Columa
'            bArray(j, i) = txtCell((i * 9) + j).Text
'        Next
'    Next
'End Sub
 
Public Function chkRow(ByRef bArray() As Byte, ByVal lIndex As Long, ByVal lVal As Long) As Boolean
'   //  Revisa la existencia de lVal en una Fila (lIndex).
Dim i           As Long
    Do While (i < 8) And (chkRow = False)
        If (bArray(i, lIndex) = lVal) Then chkRow = True
        i = (i + &H1)
    Loop
End Function
 
Public Function chkCol(ByRef bArray() As Byte, ByVal lIndex As Long, ByVal lVal As Long) As Boolean
'   //  Revisa la existencia de lVal en una Columna (lIndex).
Dim i           As Long
    Do While (i < 8) And (chkCol = False)
        If (bArray(lIndex, i) = lVal) Then chkCol = True
        i = (i + &H1)
    Loop
End Function
 
Public Function chkRect(ByRef bArray() As Byte, ByVal lCol As Long, ByVal lRow As Long, ByVal lVal As Long) As Boolean
'   //  Revisa la existencia de lVal en el cuadrante desde la celda superior izquierda respectiva dados por (lCol, lRow).
Dim i           As Long
Dim j           As Long
    '   //  Obtenemos los indices de la celda superior izquierda del cuadrante inicial respectivo.
    lRow = ((lRow \ 3) * 3)
    lCol = ((lCol \ 3) * 3)
    Do          '   //  Filas
        j = &H0
        Do          '   //  Columnas
            If (bArray(lCol + j, lRow + i) = lVal) Then chkRect = True
            j = (j + &H1)
        Loop While (j < &H3) And (chkRect = False)
        i = (i + &H1)
    Loop While (i < &H3) And (chkRect = False)
End Function
 
Public Function solveSudoku(ByRef bArray() As Byte, ByVal lCol As Long, ByVal lRow As Long) As Boolean
'   //  Resuelve una Matrix de Sudoku de 9x9 celdas.
'   //  Si se retorna true, entonces la matrix ya esta Completa y/o Resuelta.
Dim lVal        As Long
Dim i           As Long
 
    '   //  Termino de filas.
    If (lRow >= 9) Then solveSudoku = True: Exit Function
 
    '   //  Nos posicionamos en la 1ra celda de lRow vacia (con valor 0).
    Do While Not (bArray(lCol, lRow) = &H0) And (solveSudoku = False)
        lCol = (lCol + &H1)
        If (lCol = &H9) Then
            lCol = &H0
            lRow = (lRow + &H1)
            If (lRow >= &H8) Then solveSudoku = True
        End If
    Loop
 
    '   //  Recorremos TODOS LOS VALORES desde 1 a 9 para la celda (lCol, lRow).
    For lVal = 1 To 9
        If Not chkRect(bArray, lCol, lRow, lVal) Then       '   //  Cuadro de 3x3.
            If Not (chkRow(bArray, lRow, lVal)) Then        '   //  Fila.
                If Not (chkCol(bArray, lCol, lVal)) Then    '   //  Columnas.
                    bArray(lCol, lRow) = lVal
                    If (lCol < 8) Then                      '   //  Aun no llegamos al final de la fila?
                        solveSudoku = solveSudoku(bArray, (lCol + 1), lRow)
                    Else                                    '   //  Iniciamos otra llamada si mismo pero en la siguiente fila
                        solveSudoku = solveSudoku(bArray, 0, (lRow + 1))
                    End If
                    If Not solveSudoku Then bArray(lCol, lRow) = 0  '   //  Seteamos la celda a 0 para realizar el BackTracking.
                End If
            End If
        End If
    Next
 
End Function
 
 

Matrix inicial.
 5  6  0 | 8  4  7 | 0  0  0 |
 3  0  9 | 0  0  0 | 6  0  0 |
 0  0  6 | 0  0  0 | 0  0  0 |
--------------------------------
 0  1  0 | 0  8  0 | 0  4  0 |
 7  9  0 | 6  0  2 | 0  1  8 |
 0  5  0 | 0  3  0 | 0  9  0 |
--------------------------------
 0  0  0 | 0  0  0 | 2  0  0 |
 0  0  1 | 0  0  0 | 8  0  7 |
 0  0  0 | 3  1  6 | 0  5  9 |
--------------------------------
No se puede resolver, revisa la matrix.

    bSudoku(5, 0) = 5
    bSudoku(6, 0) = 2
    
    bSudoku(1, 1) = 6
    bSudoku(2, 1) = 5
    bSudoku(4, 1) = 3
    
    bSudoku(0, 2) = 9
    bSudoku(1, 2) = 3
    bSudoku(5, 2) = 1
    
    bSudoku(1, 3) = 9
    bSudoku(3, 3) = 4
    bSudoku(4, 3) = 6
    bSudoku(5, 3) = 3
    
    bSudoku(8, 4) = 8
    
    bSudoku(1, 5) = 7
    bSudoku(3, 5) = 8
    bSudoku(6, 5) = 6
    
    bSudoku(1, 6) = 8
    bSudoku(3, 6) = 1
    bSudoku(7, 6) = 3
    bSudoku(8, 6) = 2
    
    bSudoku(4, 7) = 8
    bSudoku(8, 7) = 4
    
    bSudoku(0, 8) = 5
    bSudoku(4, 8) = 9

Matrix inicial.
 0  0  0 | 0  0  5 | 2  0  0 |
 0  6  5 | 0  3  0 | 0  0  0 |
 9  3  0 | 0  0  1 | 0  0  0 |
--------------------------------
 0  9  0 | 4  6  3 | 0  0  0 |
 0  0  0 | 0  0  0 | 0  0  8 |
 0  7  0 | 8  0  0 | 6  0  0 |
--------------------------------
 0  8  0 | 1  0  0 | 0  3  2 |
 0  0  0 | 0  8  0 | 0  0  4 |
 5  0  0 | 0  9  0 | 0  0  0 |
--------------------------------
Sudoku Resuelto
 1  4  8 | 6  7  5 | 2  9  3 |
 2  6  5 | 9  3  8 | 4  1  7 |
 9  3  7 | 2  4  1 | 8  5  6 |
--------------------------------
 8  9  2 | 4  6  3 | 1  7  5 |
 4  5  6 | 7  1  9 | 3  2  8 |
 3  7  1 | 8  5  2 | 6  4  9 |
--------------------------------
 6  8  9 | 1  2  7 | 5  3  2 |
 7  1  3 | 5  8  4 | 9  6  4 |
 5  2  4 | 3  9  6 | 7  8  1 |
--------------------------------