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.
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.