2
\$\begingroup\$

Not satisfied with the Brute Force Solver that I wrote for All possible combinations of 1 to 9 in the same cells without repetition, I created an OOP Cross Sum Solver.

As expected my OOP Solver crushes the Brute Force Solver performace, 0.03-0.12 seconds compared to 109 - 400 seconds respectively.

I probably should post the Brute Force Solver instead but I found it boring.

Cross Sum Examples

The Contest Center:CROSS SUMS Rules

"Your job is to fill the numbers from 1 to 9 into the 9 empty boxes so that the arithmetic in each row is correct. The math operations are performed from left to right. So to evaluate 1+2×5 you first add 1+2 to get 3, and then multiply that by 5 to get 15. When performing the operations you may never go below zero, and each division must be even. Thus you could not have 5-7+4 because 5-7 goes below 0, and you could not have 7÷2+6 because 7÷2 is not an even division, it has a remainder."

Class Overview

  • Node: Basically a list of numbers. Each Node is linked to 2
  • Equations Equation: Processes a set of 3 Nodes, 2 operators, and an Answer
  • Solver: Links 9 Nodes to 6 Equations

Calculate

Initially the Solver will trigger each Equation to Calculate. As an Equation is calculated, each of its Nodes numbers lists are optimised by removing numbers that can not be used to solve the Equation. If a Node's list is reduced to 1 then the Nodes value is removed from all other Node's number lists. If an Equation causes a Node to change than all Equations are recalculated. This is necessary because each Node is linked to 2 Equations. At this point if an Equation is not solved then the ApplyBruteForce method of each Equation can be used to solve the Puzzle.

ApplyBruteForce

This method first saves each nodes state and then attempts to solve each Equation but testing all combinations of its Nodes number lists. If an answer can not be determined after an Equation is tested than the Nodes state are restored and the next Equation is evaluated.

Note: All problems were solved on or before the 3rd Equation was tested. It is possible that an this method will not solve all problems. If this is the case than a true Brute Force method will need to be added.

Class: Node

Attribute VB_Name = "Node"
Option Explicit
Private passed() As Boolean
Private numbers() As Long
Private saved() As Long
Private Index As Long
Public Dirty As Boolean

Private Sub Class_Initialize()
    ReDim passed(8)
    ReDim numbers(8)
    Dim n As Long
    For n = 0 To 8
        numbers(n) = n + 1
    Next
End Sub

Public Function Count() As Long
    Count = UBound(numbers) + 1
End Function

Public Function Current() As Long
    Current = numbers(Index)
End Function

Public Sub DeleteElementAt(ByVal Index As Integer, ByRef prLst As Variant)
       Dim i As Integer

        ' Move all element back one position
        For i = Index + 1 To UBound(prLst)
            prLst(i - 1) = prLst(i)
        Next

        ' Shrink the array by one, removing the last one
        ReDim Preserve prLst(Len(prLst) - 1)
End Sub

Public Function EOF() As Boolean
    EOF = Index <= UBound(numbers)
End Function

Public Sub MoveFirst()
    Index = 0
End Sub

Public Sub MoveNext()
    Index = Index + 1
End Sub

Public Sub Remove(Value As Long)
    Dim n1 As Long, n2 As Long
    If UBound(numbers) = 0 Then
        'Stop
        Exit Sub
    End If
    For n1 = UBound(numbers) To 0 Step -1
        If numbers(n1) = Value Then
            For n2 = n1 To UBound(numbers) - 1
                numbers(n2) = numbers(n2 + 1)
            Next

            ReDim Preserve numbers(UBound(numbers) - 1)
            ReDim passed(UBound(numbers))
            Exit Sub
        End If
    Next
End Sub

Public Sub RemoveBadNumbers()
    Dim oldCount As Long, n As Long, pIndex As Long
    oldCount = Count

    pIndex = -1
    For n = 0 To UBound(numbers)
        If passed(n) Then
            pIndex = pIndex + 1
            If pIndex < n Then numbers(pIndex) = numbers(n)
        End If
    Next

    If pIndex < UBound(numbers) And pIndex > -1 Then ReDim Preserve numbers(pIndex)

    ReDim passed(UBound(numbers))

    Dirty = oldCount <> Count
End Sub

Public Sub Restore()
    ReDim numbers(UBound(saved))
    ReDim passed(UBound(numbers))
    Dim n As Long
    For n = 0 To UBound(numbers)
        numbers(n) = saved(n)
    Next
End Sub

Public Sub Save()
    ReDim saved(UBound(numbers))
    Dim n As Long
    For n = 0 To UBound(numbers)
        saved(n) = numbers(n)
    Next
End Sub

Public Sub setValue(n As Long)
    ReDim passed(0)
    ReDim numbers(0)
    numbers(0) = n
End Sub

Public Function ToString() As String
    Dim n As Long
    ReDim results(UBound(numbers))

    For n = 0 To UBound(numbers)
        results(n) = numbers(n)
    Next

    ToString = "{" & Join(results, ",") & "}"
End Function

Public Sub ValidateCurrent()
    passed(Index) = True
End Sub

Public Function Value(ByVal Index As Long) As Long
    Index = Index - 1
    Value = numbers(Index)
End Function

Class: Equation

Attribute VB_Name = "Equation"
Option Explicit
Private Type Members
    answer As Long
    operator(1 To 2) As String
End Type
Private this As Members
Public Node1 As Node
Public Node2 As Node
Public Node3 As Node
Public Dirty As Boolean

Public Sub Init(operator1 As String, operator2 As String, answer As Long)
    this.operator(1) = operator1
    this.operator(2) = operator2
    this.answer = answer
End Sub

Public Function Solved() As Boolean
    Solved = Count = 3
End Function

Public Sub Calculate()
    Node1.MoveFirst
    While Node1.EOF
        Node2.MoveFirst
        While Node2.EOF
            Node3.MoveFirst
            While Node3.EOF
                If Node1.Current <> Node2.Current And Node1.Current <> Node3.Current And Node2.Current <> Node3.Current Then
                    Dim part1 As Long
                    Dim n1 As Long, n2 As Long, n3 As Long
                    n1 = Node1.Current
                    n2 = Node2.Current
                    n3 = Node3.Current

                    part1 = ev(Node1.Current, Node2.Current, this.operator(1))
                    If part1 >= 0 Then
                        If ev(part1, Node3.Current, this.operator(2)) = this.answer Then
                            'Debug.Print Node1.Current, Node2.Current, Node3.Current, ev(ev(Node1.Current, Node2.Current, this.operator(1)), Node3.Current, this.operator(2))
                            Node1.ValidateCurrent
                            Node2.ValidateCurrent
                            Node3.ValidateCurrent
                        End If
                    End If
                End If
                Node3.MoveNext
            Wend
            Node2.MoveNext
        Wend
        Node1.MoveNext
    Wend

    Dim oldCount As Long

    oldCount = Count

    RemoveBadNumbers

    Dirty = oldCount <> Count
End Sub

Public Function Count() As Long
    Count = Node1.Count + Node2.Count + Node3.Count
End Function

Private Sub RemoveBadNumbers()
    Node1.RemoveBadNumbers
    Node2.RemoveBadNumbers
    Node3.RemoveBadNumbers
End Sub

Private Function ev(v1 As Long, v2 As Long, operator As String) As Long
    Select Case operator
        Case "+"
            ev = v1 + v2
        Case "-"
            ev = v1 - v2
        Case "/", "÷"
            ev = v1 / v2
        Case "*", "×", "x", "X"
            ev = v1 * v2
        Case Else
        Debug.Print operator
    End Select
End Function

Public Function ToString() As String
    ToString = this.operator(1) & " " & this.operator(2) & " " & this.answer & ": " & Node1.ToString & "," & Node2.ToString & "," & Node3.ToString
End Function

Private Sub Class_Initialize()
    Set Node1 = New Node
    Set Node2 = New Node
    Set Node3 = New Node
End Sub

Class: Solver

Attribute VB_Name = "Solver"
Private Type Members
    answer As Long
    Data As Variant
    operator(1 To 2) As String
    Solved As Boolean
End Type
Private this As Members
Private Equations(1 To 6) As Equation
Private Test(1 To 2) As Node
Private Nodes(1 To 9) As New Node

Public Sub ApplyBruteForce()
    Save
    Dim n As Long
    For n = 1 To 6
        With Equations(n)
            If Not .Solved Then
                Dim n1 As Long, n2 As Long, n3 As Long
                For n1 = 1 To .Node1.Count
                    For n2 = 1 To .Node2.Count
                        For n3 = 1 To .Node3.Count
                            If .Node1.Value(n1) <> .Node2.Value(n2) And _
                               .Node1.Value(n1) <> .Node3.Value(n3) And _
                               .Node2.Value(n2) <> .Node3.Value(n3) Then

                                .Node1.setValue .Node1.Value(n1)
                                .Node2.setValue .Node2.Value(n2)
                                .Node3.setValue .Node3.Value(n3)

                                RemoveCompletedNumbers
                                Me.Calculate
                                If Solved Then Exit Sub
                                Restore
                            End If
                        Next
                    Next
                Next
            End If
        End With
        If Solved Then Exit Sub
        Restore
    Next
End Sub

Private Sub ForceNodeValues()
    Save
    Dim n As Long
    For n = 1 To 9
        If TestNode(Nodes(n)) Then Exit Sub
    Next
End Sub

Private Function TestNode(Node As Node) As Boolean
    Dim n As Long

    For n = 1 To Node.Count
        Node.setValue Node.Value(n)
        RemoveCompletedNumbers
        Me.Calculate
        If Solved Then
            TestNode = True
            Exit Function
        End If
        Restore
    Next
End Function

Public Sub Calculate()
    Dim n As Long
    For n = 1 To 6
        Equations(n).Calculate
        If Equations(n).Dirty Then
            RemoveCompletedNumbers
            n = 0
        End If
    Next
End Sub

Public Function getData() As Variant
    Dim results As Variant
    results = this.Data

    If Solved Then
        results(1, 1) = Nodes(1).Value(1)
        results(1, 3) = Nodes(2).Value(1)
        results(1, 5) = Nodes(3).Value(1)
        results(3, 1) = Nodes(4).Value(1)
        results(3, 3) = Nodes(5).Value(1)
        results(3, 5) = Nodes(6).Value(1)
        results(5, 1) = Nodes(7).Value(1)
        results(5, 3) = Nodes(8).Value(1)
        results(5, 5) = Nodes(9).Value(1)
    End If
    getData = results
End Function

Public Sub Init(Data As Variant)
    this.Data = Data
    this.Solved = False
    InitEquations
    Equations(1).Init CStr(Data(1, 2)), CStr(Data(1, 4)), CLng(Data(1, 7))
    Equations(2).Init CStr(Data(3, 2)), CStr(Data(3, 4)), CLng(Data(3, 7))
    Equations(3).Init CStr(Data(5, 2)), CStr(Data(5, 4)), CLng(Data(5, 7))
    Equations(4).Init CStr(Data(2, 1)), CStr(Data(4, 1)), CLng(Data(7, 1))
    Equations(5).Init CStr(Data(2, 3)), CStr(Data(4, 3)), CLng(Data(7, 3))
    Equations(6).Init CStr(Data(2, 5)), CStr(Data(4, 5)), CLng(Data(7, 5))

    With Equations(1)
        Set .Node1 = Nodes(1)
        Set .Node2 = Nodes(2)
        Set .Node3 = Nodes(3)
    End With

    With Equations(2)
        Set .Node1 = Nodes(4)
        Set .Node2 = Nodes(5)
        Set .Node3 = Nodes(6)
    End With

    With Equations(3)
        Set .Node1 = Nodes(7)
        Set .Node2 = Nodes(8)
        Set .Node3 = Nodes(9)
    End With

    With Equations(4)
        Set .Node1 = Nodes(1)
        Set .Node2 = Nodes(4)
        Set .Node3 = Nodes(7)
    End With

    With Equations(5)
        Set .Node1 = Nodes(2)
        Set .Node2 = Nodes(5)
        Set .Node3 = Nodes(8)
    End With

    With Equations(6)
        Set .Node1 = Nodes(3)
        Set .Node2 = Nodes(6)
        Set .Node3 = Nodes(9)
    End With
End Sub

Private Sub InitEquations()
    Dim n As Long
    For n = 1 To 6
        Set Equations(n) = New Equation
    Next
End Sub

Private Sub RemoveCompletedNumbers()
    Dim item1 As Variant, item2 As Variant
    For Each item1 In Nodes
        If item1.Count = 1 And item1.Dirty Then
            item1.Dirty = False
            For Each item2 In Nodes
                If Not item1 Is item2 Then
                    item2.Remove item1.Value(1)
                End If
            Next
        End If
    Next
End Sub

Public Sub Restore()
    Dim n As Long
    For n = 1 To 9
        Nodes(n).Restore
    Next
End Sub

Public Sub Save()
    Dim n As Long
    For n = 1 To 9
        Nodes(n).Save
    Next
End Sub

Public Function Solved() As Boolean
    Dim n As Long
    Dim dups As New Collection
    For n = 1 To 9
        If Nodes(n).Count > 1 Then Exit Function
        On Error Resume Next
        dups.Add 0, CStr(Nodes(n).Value(1))
        If Err.Number <> 0 Then
            Exit Function
        End If
        On Error GoTo 0
    Next
    Solved = True
End Function

Public Function ToString() As String
    Dim results(1 To 6) As String

    For n = 1 To 6
        results(n) = Equations(n).ToString
    Next

    ToString = Join(results, vbNewLine)
End Function

Module: TestMod

Attribute VB_Name = "TestMod"
Option Explicit
Const BaseRange As String = "A1:G7", ValueRange As String = "A1,C1,E1,A3,C3,E3,A5,C5,E5"

Sub TestCrossSum()
' C2, L2, U2, AD2, AM2, AV2, C11, L11, U11, AD11, AM11, AV11
    Dim t As Double: t = Timer
    TestSolver Range("C2")
    'TestSolver Range("U11")
    Debug.Print Round(Timer - t, 2)
End Sub

Sub TestAll()
    Application.ScreenUpdating = False
    Dim t As Double: t = Timer

    With ThisWorkbook.Worksheets("Cross Sums")
        Dim r As Long, c As Long
        For r = 1 To 2
            For c = 1 To 6
                TestSolver .Cells(r * 9 - 7, c * 9 - 6)
            Next
        Next
    End With
    Debug.Print Round(Timer - t, 2)
End Sub

Sub TestSolver(TopLeftCell As Range)
    Dim Solver As New Solver, Header As Range, Target As Range
    Set Target = TopLeftCell.Range(BaseRange)
    Set Header = Target.Offset(-1).Resize(1, 1)
    Target.Range(ValueRange).ClearContents
    Header.Value = ""

    Solver.Init Target.Value
    Solver.Calculate

    If Solver.Solved Then
        Header.Value = "Normal"
    Else
        Solver.ApplyBruteForce
        If Solver.Solved Then Header.Value = "Hard"
    End If

    If Solver.Solved Then
        Target.Value = Solver.getData
    Else
        Debug.Print Target.Address
        Debug.Print Solver.ToString
    End If
End Sub

I'm interested in any problem that might stump the Solver, a Cross Sum Generator if anyone cares to write one, any ideas on how to write a better Solver, and as always any tips on how to improve my code.

Cross Sum Solver.xlsm Download

\$\endgroup\$
2
\$\begingroup\$

Some quick comments. This reminds me of over 10 years ago when I was thinking of a solver for Soduku in VB6 (which I never finished writing because I always have trouble with interfaces/user forms)

Class Node

Why not use a Collection instead of arrays for numbers and passed. This will clean up (i.e. remove) the ReDim work. I think the refactoring that you would end up doing by this approach will make the Node class simpler and cleaner. Oh, and you can then use `For Each'.

You could also have property for Solved so that you return a single value instead of doing collection processing when you have actually solved this node.

Class Equation

You use Public Members instead of Properties Set and Get. I remember somewhere in all my OOP reading that this is a bad thing (tm) to do. Probably because if you want to tweak or do some data validation you can't.

You could check to see if a Node has been solved. This will enable shortcutting to solving the second Node. This means that you can start using Boolean logic instead of counting each time you want to check something. Probably not much difference in performance, but the programming logic is a lot clearer. Which, in turn means this would be easier to maintain.

Why not pass the nodes in with the initial Init? Then nodes are not going to change address or location. This, coupled with a Property Get means that you are less likely to overwrite a Node with a new location.

Make your life a little easier and add a public Evaluate function that takes three parameters. It can return a Boolean, either the inputs evaluate to the answer, or they don't. This would be used primarily by the Brute Force solver.

Under the subroutine Calculate to declare n1, n2 and n3. You even assign them a value. But then don't use that value.

Class Solver

As noted under Equation, passing the relevant nodes in as part of the Equation.Init would be cleaner.

Using Collections under the Nodes would make the brute force approach cleaner.

Brute force could be made a little easier by have the other Evaluate function in the Equation class.

I am not sure of your logic here. While a selection of 3 numbers may solve the equation, there may be multiple triplets. I haven't walked myself through the logic in detail here (I did say quick comments) but intuitively, I think this may shortcut the checking and may produce some wrong results. I don't see a way to walk back a series of calculations if there is found to be a conflicting set.

General

I don't see any validation of inputs - what if a range of 8 cells are passed? I have already mentioned the use of Public members instead of Propertys Some of your Subs can be Functions and form a double duty. For example, the subroutine Calculate could return a Boolean that represents Dirty. This approach will allow you to get rid of a "global" variable. Thinking this way allows you to chain your code logic into a logical process. A good and visible process should help with code readability.

\$\endgroup\$
  • \$\begingroup\$ I don't think that I have ever had a better review of my code. Your check is in the mail overnight express...lol. \$\endgroup\$ – TinMan Nov 23 '18 at 6:20
  • \$\begingroup\$ Just a couple of thoughts. I intentionally used arrays because I use Dictionaries in some much of my code. I was regretting it towards the end. I thought about using Properties. I noticed that Matt used them often in Batteship. I didn't link the Nodes in Equation.Init because of time restraints. I felt that the current setup would allow me to make all the correct links without mistakes. \$\endgroup\$ – TinMan Nov 23 '18 at 6:38
  • \$\begingroup\$ I think that shortcutting when a single Node is solved is counter-productive because the number lists of the other 2 Nodes in the equations will still need to be solved. Solving node1 might cause nodes 2 and 3 to solved. In this case, 3 numbers can be excluded from all the other nodes at once. This will greatly reduce the number of operations. \$\endgroup\$ – TinMan Nov 23 '18 at 6:45
  • \$\begingroup\$ Adding Solved to the Nodes and having brute force methods for each Equation is very interesting. I would like to roll-up Solved, Calculate and ApplyBruteForce into a single method. I didn't do it because I wasn't sure how long that it would take to apply brute force. \$\endgroup\$ – TinMan Nov 23 '18 at 6:50
  • \$\begingroup\$ Sorry if my random thought comments are annoying. I will definitely apply most of your tips to my rewrite. I'm thinking about writing a really solid Solver and than rewriting it in a different programming language each week as a challenge. If nothing out it would keep me from spewing code all over the VBA tag. Thanks again for your time. \$\endgroup\$ – TinMan Nov 23 '18 at 6:57

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.