Закрасить значения в матрице так, чтобы закрашенная была единственная в строке и столбце

Question

Дана матрица 9 на 9, заполненная нулями и единицами. Нужно написать алгоритм закрашивания единиц таким образом, чтобы эта закрашенная единица была единственной в строке и столбце(как на рисунке).

Предположения:

Создать массив, который будет запоминать индекс уже закрашенной ячейки.
Проверять столбец на единицу и закрашивать ее.
Последующие проверки совершать на основе анализа несовпадения с данными в массиве.

Может быть есть решение лучше?

Answer 1

Решение для таких задач обычно не сложно. Оно трудоёмкое для компьютера (очень много попыток нужно сделать пока доберёшься до результата), но в коде всё довольно просто:

Option Explicit

' Эти переменные будут использоваться внутри рекурсивной части - поэтому объявлены здесь:
Dim aRange As Range     ' Исходный диапазон
Dim nSize As Integer    ' Размер доски (по умолчанию 9)
Dim aData As Variant    ' Значения ячеек (1 или "не 1") на доске
' Два одномерных массива - размеры будут переопределены после получения размера доски nSize
Dim bFree() As Boolean  ' для быстрой проверки есть ли уже ладья в этой строке
Dim aRes() As Integer   ' для координат ладей по строкам

Sub place_N_Towers()
Dim sStartCell As String ' Верхняя левая ячейка квадратного диапазона
Dim isGoog As Boolean    ' Результат расстановки ладей оказался успешным?
Dim i As Integer

    sStartCell = InputBox("Адрес верхней левой ячейки доски", "Положение данных на текущем листе", "B2")
    nSize = InputBox("Количество расставляемых ладей", "Размер доски", 9)
    If nSize < 2 Then Exit Sub
    On Error Resume Next
    Set aRange = Range(sStartCell).Resize(nSize, nSize)
    On Error GoTo 0
    If aRange Is Nothing Then Exit Sub
    aData = aRange.Value
    ReDim bFree(1 To nSize)
    ReDim aRes(1 To nSize)
    For i = 1 To nSize
        bFree(i) = True
    Next i
    Call TryNext(1, isGoog)
    If isGoog Then  ' Успешно - закрасить нужные ячейки
        For i = 1 To nSize
            aRange.Cells(aRes(i), i).Interior.Color = rgbOrangeRed
        Next i
    Else    ' Не получилось - огорчить пользователя:
        Call MsgBox("Для такого набора единиц решение не может быть найдено", vbCritical, "Не в этот раз")
    End If
End Sub

Sub TryNext(ByVal nColumn As Integer, ByRef isGoog As Boolean)
' Эта процедура практически такая же как у Вирта
' Только добавлена проверка "в этой ячейке единица?"
Dim nRow As Integer
    nRow = 0
    Do
        nRow = nRow + 1
        If aData(nRow, nColumn) = 1 Then
            isGoog = False
            If bFree(nRow) Then
                aRes(nColumn) = nRow
                bFree(nRow) = False
                If nColumn < nSize Then
                    Call TryNext(nColumn + 1, isGoog)
                    If Not isGoog Then
                        bFree(nRow) = True
                    End If
                Else
                    isGoog = True
                End If
            End If
        End If
    Loop Until isGoog Or nRow = nSize
End Sub

БЛОГ НА HUSL

Закрасить значения в матрице так, чтобы закрашенная была единственная в строке и столбце

Ответы (1 шт):