Метод грубой силы с использованием VBA для решения уравнения с девятью неизвестными переменными

Это уравнение: a+(13*b/c)+d+(12*e)-f+(g*h/i)=87 появляется при попытке решитьматематическую головоломку для вьетнамских восьмилетних детей , которая недавно стала вирусной во всем интернете. В математике такое уравнение называется недетерминированной системой. Конечно, у него есть несколько решений, и метод грубой силы, кажется, самый простой способ найти все решения.

Мне интересно знать, как решить уравнение с помощью VBA и представить решения на листе MS Excel, так как я не могу найти способ сделать такую программу из-за моего отсутствия знаний программирования VBA.

Я знаю о подобных сообщениях о переполнении стека, таких как this и this, но ответы там мне не очень помогают.

Вот моя попытка: 

Sub Vietnam_Problem()
Dim StartTime As Double

StartTime = Timer
j = 2   'initial value for number of rows
For a = 1 To 9
    For b = 1 To 9
        For c = 1 To 9
            For d = 1 To 9
                For e = 1 To 9
                    For f = 1 To 9
                        For g = 1 To 9
                            For h = 1 To 9
                                For i = 1 To 9
                                If a <> b And a <> c And a <> d And a <> e And a <> f And a <> g And a <> h And a <> i And b <> c And b <> d And b <> e And b <> f And b <> g And b <> h And b <> i And c <> d And c <> e And c <> f And c <> g And c <> h And c <> i And d <> e And d <> f And d <> g And d <> h And d <> i And e <> f And e <> g And e <> h And e <> i And f <> g And f <> h And f <> i And g <> h And g <> i And h <> i And a + (13 * b / c) + d + (12 * e) - f + (g * h / i) = 87 Then
                                Cells(j, 1) = a
                                Cells(j, 2) = b
                                Cells(j, 3) = c
                                Cells(j, 4) = d
                                Cells(j, 5) = e
                                Cells(j, 6) = f
                                Cells(j, 7) = g
                                Cells(j, 8) = h
                                Cells(j, 9) = i
                                j = j + 1
                                End If
                                Next i
                            Next h
                        Next g
                    Next f
                Next e
            Next d
        Next c
    Next b
Next a
Cells(2, 11) = j - 2 'number of solutions
Cells(2, 12) = Round(Timer - StartTime, 2)  'running time of VBA code
End Sub
Кажется, что это работает, но это не очень приятно и очень медленно.
5 3
excel vba excel-vba

5 ответов:

Анастасия-Романова, поскольку вы не объявляете переменные (от a до j), ваш код выполняется с этими переменными по умолчанию для типа Variant. Хотя варианты могут быть чрезвычайно полезны, они не должны использоваться здесь.

Я прогнал ваш код без изменений, и на моей машине это заняло 851 секунду.

Поскольку VBA оптимизирована для Longs, просто добавьте одну строку в свой код, чтобы объявить переменные (от a до j) как Longs, снизив время работы на моей машине до 120 секунд. Так что это в семь раз быстрее только для использования соответствующего типа переменной!

Мой удар по решению этой головоломки в VBA проходит значительно быстрее. На самом деле, это намного быстрее (и короче), чем все, что было опубликовано до сих пор на этой странице. На моей же машине он возвращает все 136 правильных комбинаций менее чем за одну секунду.

Там много чепухи (мир, сеть, даже здесь, на этой странице!) о том, что VBA слишком медлительна. Не верьте этому. Конечно, скомпилированные языки могут будьте быстрее, но большую часть времени это сводится к тому, насколько хорошо вы знаете, как обращаться с вашим языком. Я программирую на базовом языке с 1970-х годов.

Вот мое решение Вьетнамской головоломки, которую я создал для вашего вопроса. Пожалуйста, поместите это в новый модуль кода: 
Option Explicit
Private z As Long, v As Variant

Public Sub Vietnam()
    Dim s As String
    s = "123456789"
    ReDim v(1 To 200, 1 To 9)
    Call FilterPermutations("", s)
    [a1:i200] = v
    End
End Sub

Private Sub FilterPermutations(s1 As String, s2 As String)

    Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long, _
        g As Long, h As Long, i As Long, j As Long, m As Long, n As Long

    n = Len(s2)
    If n < 2 Then
        a = Mid$(s1, 1, 1):  b = Mid$(s1, 2, 1):  c = Mid$(s1, 3, 1)
        d = Mid$(s1, 4, 1):  e = Mid$(s1, 5, 1):  f = Mid$(s1, 6, 1)
        g = Mid$(s1, 7, 1):  h = Mid$(s1, 8, 1):  i = s2
        If a + (13 * b / c) + d + (12 * e) - f + (g * h / i) = 87 Then
            z = z + 1
            v(z, 1) = a:  v(z, 2) = b:  v(z, 3) = c
            v(z, 4) = d:  v(z, 5) = e:  v(z, 6) = f
            v(z, 7) = g:  v(z, 8) = h:  v(z, 9) = i
        End If
    Else
        For m = 1 To n
            FilterPermutations s1 + Mid$(s2, m, 1), Left$(s2, m - 1) + Right$(s2, n - m)
        Next
    End If

End Sub

Метод №2:

Анастасия, я постараюсь объяснить это позже сегодня, когда у меня будет больше времени. Но тем временем, пожалуйста, изучите мой следующий удар. Теперь он еще короче и завершается в примерно 1/10 секунды. Теперь я использую алгоритм перестановки кучи: 
Option Explicit
Private z As Long, v As Variant

Public Sub VietnamHeap()
    Dim a(0 To 8) As Long
    a(0) = 1:  a(1) = 2:  a(2) = 3:  a(3) = 4:  a(4) = 5:  a(5) = 6:  a(6) = 7:  a(7) = 8:  a(8) = 9
    ReDim v(1 To 200, 1 To 9)
    Generate 9, a
    [a1:i200] = v
    End
End Sub

Sub Generate(n As Long, a() As Long)
    Dim t As Long, i As Long
    If n = 1 Then
        If a(0) + (13 * a(1) / a(2)) + a(3) + (12 * a(4)) - a(5) + (a(6) * a(7) / a(8)) = 87 Then
            z = z + 1
            For i = 1 To 9:  v(z, i) = a(i - 1):  Next
        End If
    Else
        For i = 0 To n - 2
            Generate n - 1, a
            If n Mod 2 = 1 Then
                t = a(0):  a(0) = a(n - 1):  a(n - 1) = t
            Else
                t = a(i):  a(i) = a(n - 1):  a(n - 1) = t
            End If
        Next
        Generate n - 1, a
    End If
End Sub

Метод #3

А вот еще более короткая версия. Может ли кто-нибудь придумать более короткую версию или более быструю версию? 
Const q = 9
Dim z As Long, v(1 To 999, 1 To q)

Public Sub VietnamHeap()
    Dim a(1 To q) As Long
    For z = 1 To q: a(z) = z: Next: z = 0
    Gen q, a
    [a1].Resize(UBound(v), q) = v: End
End Sub

Sub Gen(n As Long, a() As Long)
    Dim i As Long, k As Long, t As Long
    If n > 1 Then
        For i = 1 To n - 1
            Gen n - 1, a
            If n Mod 2 = 1 Then k = 1 Else k = i
            t = a(k): a(k) = a(n): a(n) = t
        Next
        Gen n - 1, a
    Else
        If 87 = a(1) + 13 * a(2) / a(3) + a(4) + 12 * a(5) - a(6) + a(7) * a(8) / a(9) Then z = z + 1: For i = 1 To q: v(z, i) = a(i): Next
    End If
End Sub
9

Я собирался представить еще один ответ, но так как мой последний ответ был довольно ошибочным, я просто переписал его. Это все еще использует подход к случайным числам в стиле Монте-Карло, но он становится немного комковатым, когда вы должны убедиться, что вы еще не решили с помощью этой комбинации случайных чисел.

Sub MonteCarlo()

Dim startTime As Single
startTime = Timer

Dim trialSol As Double
Dim solCounter As Integer
solCounter = 0

Dim trialNums() As Integer

Dim solutions As Collection
Set solutions = New Collection

Dim existingSol As Boolean
existingSol = False

Do

    trialNums = CreateRandomArray

    trialSol = ToSolve(trialNums(1), trialNums(2), _
                       trialNums(3), trialNums(4), _
                       trialNums(5), trialNums(6), _
                       trialNums(7), trialNums(8), _
                       trialNums(9))

    If trialSol = 87 Then

        If Not ExistsIn(solutions, trialNums) Then
            solutions.Add (trialNums)
        End If

    End If

Loop Until (solutions.Count = 128)

Dim solutionTime As Single
solutionTime = Round(Timer - startTime, 5)

Dim i As Integer
For i = 1 To solutions.Count
    Debug.Print "Solution " & i & ":"; vbTab; _
                solutions.Item(i)(1); vbTab; _
                solutions.Item(i)(2); vbTab; _
                solutions.Item(i)(3); vbTab; _
                solutions.Item(i)(4); vbTab; _
                solutions.Item(i)(5); vbTab; _
                solutions.Item(i)(6); vbTab; _
                solutions.Item(i)(7); vbTab; _
                solutions.Item(i)(8); vbTab; _
                solutions.Item(i)(9)
Next i
Debug.Print "Solution time: " & solutionTime & " ms"

End Sub

Function ExistsIn(col As Collection, arr() As Integer) As Boolean

    Dim ei As Boolean
    ei = False
    Dim i As Integer
    Dim temparr() As Integer

    If col.Count > 0 Then
        For i = 1 To col.Count
            temparr = col.Item(i)
            ei = AreEqual(temparr, arr)
        Next i
    End If

    ExistsIn = ei

End Function


Function AreEqual(array1() As Integer, array2() As Integer) As Boolean

    Dim eq As Boolean
    eq = True

    For i = LBound(array1) To UBound(array1)
       If array1(i) <> array2(i) Then
          eq = False
          Exit For
       End If
    Next i

    AreEqual = eq

End Function

Function ToSolve(a As Integer, b As Integer, _
                 c As Integer, d As Integer, _
                 e As Integer, f As Integer, _
                 g As Integer, h As Integer, _
                 i As Integer) As Double

    ToSolve = a + (13 * b / c) + d + (12 * e) - f + (g * h / i)

End Function

Function CreateRandomArray() As Integer()

    Dim numbers As New Collection
    Dim i As Integer

    For i = 1 To 9
        numbers.Add i
    Next i

    Dim rndNums(9) As Integer
    Dim rndInd As Integer

    For i = 1 To 9
        rndInt = CInt(((numbers.Count - 1) * Rnd) + 1)
        rndNums(i) = numbers(rndInt)
        numbers.Remove (rndInt)
    Next i

    CreateRandomArray = rndNums

End Function

Мое время решения для всех комбинаций составляет около 3 с-3,5 с.

2

Ладно, вот моя попытка: 

Sub Vietnam_Problem()
Dim StartTime As Double

StartTime = Timer
j = 2   'initial value for number of rows
For a = 1 To 9
    For b = 1 To 9
        For c = 1 To 9
            For d = 1 To 9
                For e = 1 To 9
                    For f = 1 To 9
                        For g = 1 To 9
                            For h = 1 To 9
                                For i = 1 To 9
                                If a <> b And a <> c And a <> d And a <> e And a <> f And a <> g And a <> h And a <> i And b <> c And b <> d And b <> e And b <> f And b <> g And b <> h And b <> i And c <> d And c <> e And c <> f And c <> g And c <> h And c <> i And d <> e And d <> f And d <> g And d <> h And d <> i And e <> f And e <> g And e <> h And e <> i And f <> g And f <> h And f <> i And g <> h And g <> i And h <> i And a + (13 * b / c) + d + (12 * e) - f + (g * h / i) = 87 Then
                                Cells(j, 1) = a
                                Cells(j, 2) = b
                                Cells(j, 3) = c
                                Cells(j, 4) = d
                                Cells(j, 5) = e
                                Cells(j, 6) = f
                                Cells(j, 7) = g
                                Cells(j, 8) = h
                                Cells(j, 9) = i
                                j = j + 1
                                End If
                                Next i
                            Next h
                        Next g
                    Next f
                Next e
            Next d
        Next c
    Next b
Next a
Cells(2, 11) = j - 2 'number of solutions
Cells(2, 12) = Round(Timer - StartTime, 2)  'running time of VBA code
End Sub

Это, кажется, работает, но, как я уже упоминал в разделе комментариев ниже моего вопроса, это не очень приятно и очень медленно.

Выходные данные: 

a   b   c   d   e   f   g   h   i
1   2   6   4   7   8   3   5   9
1   2   6   4   7   8   5   3   9
1   3   2   4   5   8   7   9   6
1   3   2   4   5   8   9   7   6
1   3   2   9   5   6   4   7   8
1   3   2   9   5   6   7   4   8
1   3   4   7   6   5   2   9   8
1   3   4   7   6   5   9   2   8
1   3   6   2   7   9   4   5   8
1   3   6   2   7   9   5   4   8
1   3   9   4   7   8   2   5   6
1   3   9   4   7   8   5   2   6
1   4   8   2   7   9   3   5   6
1   4   8   2   7   9   5   3   6
1   5   2   3   4   8   7   9   6
1   5   2   3   4   8   9   7   6
1   5   2   8   4   7   3   9   6
1   5   2   8   4   7   9   3   6
1   5   3   9   4   2   7   8   6
1   5   3   9   4   2   8   7   6
1   9   6   4   5   8   3   7   2
1   9   6   4   5   8   7   3   2
1   9   6   7   5   2   3   4   8
1   9   6   7   5   2   4   3   8
2   1   4   3   7   9   5   6   8
2   1   4   3   7   9   6   5   8
2   3   6   1   7   9   4   5   8
2   3   6   1   7   9   5   4   8
2   4   8   1   7   9   3   5   6
2   4   8   1   7   9   5   3   6
2   8   6   9   4   1   5   7   3
2   8   6   9   4   1   7   5   3
2   9   6   3   5   1   4   7   8
2   9   6   3   5   1   7   4   8
3   1   4   2   7   9   5   6   8
3   1   4   2   7   9   6   5   8
3   2   1   5   4   7   8   9   6
3   2   1   5   4   7   9   8   6
3   2   4   8   5   1   7   9   6
3   2   4   8   5   1   9   7   6
3   2   8   6   5   1   7   9   4
3   2   8   6   5   1   9   7   4
3   5   2   1   4   8   7   9   6
3   5   2   1   4   8   9   7   6
3   6   4   9   5   8   1   7   2
3   6   4   9   5   8   7   1   2
3   9   2   8   1   5   6   7   4
3   9   2   8   1   5   7   6   4
3   9   6   2   5   1   4   7   8
3   9   6   2   5   1   7   4   8
4   2   6   1   7   8   3   5   9
4   2   6   1   7   8   5   3   9
4   3   2   1   5   8   7   9   6
4   3   2   1   5   8   9   7   6
4   3   9   1   7   8   2   5   6
4   3   9   1   7   8   5   2   6
4   9   6   1   5   8   3   7   2
4   9   6   1   5   8   7   3   2
5   1   2   9   6   7   3   4   8
5   1   2   9   6   7   4   3   8
5   2   1   3   4   7   8   9   6
5   2   1   3   4   7   9   8   6
5   3   1   7   2   6   8   9   4
5   3   1   7   2   6   9   8   4
5   4   1   9   2   7   3   8   6
5   4   1   9   2   7   8   3   6
5   4   8   9   6   7   1   3   2
5   4   8   9   6   7   3   1   2
5   7   2   8   3   9   1   6   4
5   7   2   8   3   9   6   1   4
5   9   3   6   2   1   7   8   4
5   9   3   6   2   1   8   7   4
6   2   8   3   5   1   7   9   4
6   2   8   3   5   1   9   7   4
6   3   1   9   2   5   7   8   4
6   3   1   9   2   5   8   7   4
6   9   3   5   2   1   7   8   4
6   9   3   5   2   1   8   7   4
7   1   4   9   6   5   2   3   8
7   1   4   9   6   5   3   2   8
7   2   8   9   6   5   1   3   4
7   2   8   9   6   5   3   1   4
7   3   1   5   2   6   8   9   4
7   3   1   5   2   6   9   8   4
7   3   2   8   5   9   1   6   4
7   3   2   8   5   9   6   1   4
7   3   4   1   6   5   2   9   8
7   3   4   1   6   5   9   2   8
7   5   2   8   4   9   1   3   6
7   5   2   8   4   9   3   1   6
7   6   4   8   5   9   1   3   2
7   6   4   8   5   9   3   1   2
7   9   6   1   5   2   3   4   8
7   9   6   1   5   2   4   3   8
8   2   4   3   5   1   7   9   6
8   2   4   3   5   1   9   7   6
8   3   2   7   5   9   1   6   4
8   3   2   7   5   9   6   1   4
8   5   2   1   4   7   3   9   6
8   5   2   1   4   7   9   3   6
8   5   2   7   4   9   1   3   6
8   5   2   7   4   9   3   1   6
8   6   4   7   5   9   1   3   2
8   6   4   7   5   9   3   1   2
8   7   2   5   3   9   1   6   4
8   7   2   5   3   9   6   1   4
8   9   2   3   1   5   6   7   4
8   9   2   3   1   5   7   6   4
9   1   2   5   6   7   3   4   8
9   1   2   5   6   7   4   3   8
9   1   4   7   6   5   2   3   8
9   1   4   7   6   5   3   2   8
9   2   8   7   6   5   1   3   4
9   2   8   7   6   5   3   1   4
9   3   1   6   2   5   7   8   4
9   3   1   6   2   5   8   7   4
9   3   2   1   5   6   4   7   8
9   3   2   1   5   6   7   4   8
9   4   1   5   2   7   3   8   6
9   4   1   5   2   7   8   3   6
9   4   8   5   6   7   1   3   2
9   4   8   5   6   7   3   1   2
9   5   3   1   4   2   7   8   6
9   5   3   1   4   2   8   7   6
9   6   4   3   5   8   1   7   2
9   6   4   3   5   8   7   1   2
9   8   6   2   4   1   5   7   3
9   8   6   2   4   1   7   5   3
Есть 128 решений, и это заняло время 984,61 секунды или 16 минут и 24,61 секунды.
1
Public j As Long '<--new line


Private Sub Permutate(list() As Long, ByVal pointer As Long)
  If pointer = UBound(list) Then
    Dim lower_bound As Long
    lower_bound = LBound(list)

    Validate list(lower_bound), list(lower_bound + 1), list(lower_bound + 2), list(lower_bound + 3), list(lower_bound + 4), list(lower_bound + 5), list(lower_bound + 6), list(lower_bound + 7), list(lower_bound + 8)

    Exit Sub
  End If

  Dim i As Long
  For i = pointer To UBound(list)
    Dim permutation() As Long
    permutation = list
    permutation(pointer) = list(i)
    permutation(i) = list(pointer)
    Permutate permutation, pointer + 1
  Next

End Sub

Private Sub Validate(ByVal a As Long, ByVal b As Long, ByVal c As Long, ByVal d As Long, ByVal e As Long, ByVal f As Long, ByVal g As Long, ByVal h As Long, ByVal i As Long)

  If a + (13 * b / c) + d + (12 * e) - f + (g * h / i) = 87 Then
        Cells(j, 1) = a '<--new line
        Cells(j, 2) = b '<--new line
        Cells(j, 3) = c '<--new line
        Cells(j, 4) = d '<--new line
        Cells(j, 5) = e '<--new line
        Cells(j, 6) = f '<--new line
        Cells(j, 7) = g '<--new line
        Cells(j, 8) = h '<--new line
        Cells(j, 9) = i '<--new line
        j = j + 1 '<--new line
    'Debug.Print a, b, c, d, e, f, g, h, i
  End If
End Sub
Public Sub Vietnam_Problem()
  Dim numbers(1 To 9) As Long
  Dim i As Long
Dim StartTime As Double

StartTime = Timer
  j = 1 '<--new line

  For i = 1 To 9
    numbers(i) = i
  Next

  Permutate numbers, LBound(numbers)

Cells(2, 12) = Round(Timer - StartTime, 2)
End Sub
1

Извините-не могу комментировать. Я бы не стал использовать VBA или что-то еще для этого. На мой взгляд, это работа для логических языков, таких как пролог. Вы можете увидеть некоторые примеры на нескольких языках на zebra-puzzle over здесь.

Единственный способ в VBA, который я знаю, это использование for-loops - который не быстр, который не хорош и который очень ограничен. Вот почему я бы посоветовал логические языки, такие как prolog или очень быстрые языки программирования, такие как C# / C++. Прости,что не могу тебе помочь.

0