注册 登录
编程论坛 → VB6论坛

24 点问题

风吹过b 发布于 2015-06-14 21:23， 1959 次点击
在想，如何列出 24 点的所有答案，或者说 给 4个数，然后给出是否组合成 24 点。想啊想，就想到先把表达式列出来，然后再测试。代码如下：
程序代码：
Option Explicit

'工程需要引用microsoft script control

Dim rs As String                '所有的表达式

Private Sub Command1_Click()
'列出所有的可能
Dim a As Long, b As Long, c As Long, d As Long
Dim s As String
Dim FJ() As String


Open App.Path & "\24点.txt" For Output As #1

For a = 1 To 10
For b = 1 To 10
For c = 1 To 10
For d = 1 To 10

    s = Test24(a, b, c, d)          '测试去
    If Len(s) > 0 Then
        Print #1, s;                '有结果就写入，因为结果是带回车的，所以不能再写入回车了
    End If
   
Next d
Next c
Next b
Next a

Close #1
MsgBox "计算完成！请检查 24点.txt 文件。", vbInformation

End Sub

Private Sub Command2_Click()
'测试4个数
Dim s2 As String
Dim a As Long, b As Long, c As Long, d As Long

'先读数
a = Val(IntTXT(0))
b = Val(IntTXT(1))
c = Val(IntTXT(2))
d = Val(IntTXT(3))

'判断范围
If a < 0 Or a > 10 Then Exit Sub
If b < 0 Or b > 10 Then Exit Sub
If c < 0 Or c > 10 Then Exit Sub
If d < 0 Or d > 10 Then Exit Sub

Text1.Text = "运算中..."
DoEvents
   
'按排列组合去测试
s2 = s2 & Test24(a, b, c, d)
s2 = s2 & Test24(a, b, d, c)
s2 = s2 & Test24(a, c, b, d)
s2 = s2 & Test24(a, c, d, b)
s2 = s2 & Test24(a, d, b, c)
s2 = s2 & Test24(a, d, c, b)

s2 = s2 & Test24(b, a, c, d)
s2 = s2 & Test24(b, a, d, c)
s2 = s2 & Test24(b, c, d, a)
s2 = s2 & Test24(b, c, a, d)
s2 = s2 & Test24(b, d, a, c)
s2 = s2 & Test24(b, d, c, a)

s2 = s2 & Test24(c, b, a, d)
s2 = s2 & Test24(c, b, d, a)
s2 = s2 & Test24(c, a, b, d)
s2 = s2 & Test24(c, a, d, b)
s2 = s2 & Test24(c, d, b, a)
s2 = s2 & Test24(c, d, a, b)

s2 = s2 & Test24(d, b, c, a)
s2 = s2 & Test24(d, b, a, c)
s2 = s2 & Test24(d, c, b, a)
s2 = s2 & Test24(d, c, a, b)
s2 = s2 & Test24(d, a, b, c)
s2 = s2 & Test24(d, a, c, b)

'检查测试结果
If Len(s2) > 0 Then
    Text1.Text = s2
Else
    Text1.Text = "无解！"
End If

End Sub

Private Sub Form_Load()

    Open App.Path & "\表达式.txt" For Binary As #1
        rs = StrConv(InputB$(LOF(1), #1), vbUnicode)
    Close #1
   
End Sub

Public Function Test24(a As Long, b As Long, c As Long, d As Long) As String

Dim s As String
Dim o As Long
Dim m As Long
Dim s2 As String
Dim FJ() As String

Dim ScriptControl1 As New scriptcontrol
ScriptControl1.Language = "VBScript"

s = rs                          '所有的表达式
s = Replace(s, "a", a)          '把数字填进去
s = Replace(s, "b", b)
s = Replace(s, "c", c)
s = Replace(s, "d", d)

FJ = Split(s, vbCrLf)           '分解成一个一个的表达式
For o = 0 To UBound(FJ)
    If Len(FJ(o)) > 0 Then      '是有效表达式
        m = ScriptControl1.Eval(FJ(o))      '运算
        If m = 24 Then                      '结果是24吗
            s2 = s2 & FJ(o) & " = 24" & vbCrLf
        End If
    End If
Next o

Test24 = s2                     '返回结果

End Function
29 回复
#2
风吹过b2015-06-14 21:24
我想出来的表达式有：

程序代码：
a + b + c + d
a + b + c - d

a * b + c + d
a * b * c + d

a * b + c - d
a * b * c - d

a * b - c - d

(a + b) * c + d
(a + b) * c - d
(a + b) * (c + d)
(a + b) * (c - d)

(a - b) * c + d
(a - b) * c - d
(a - b) * (c + d)
(a - b) * (c - d)

(a + b) * c * d
(a + b) * c / d

(a - b) * c * d
(a - b) * c / d

保存为txt文件，放到工程一起。
#3
lianyicq2015-06-15 08:54
这是个遍历算法问题，给你一个思路，看行不行。
首先四个数的全排列，保存入1个24行，4列的2维数组中，以后的每次计算按序取其中1行的4个数。
构建1个递归函数。完成2个数的运算，2个数有2种排列，考虚到首位可能有负号，操作符有2*4=8种，因此2个数运算有16种结果。
得到前2个数结果后，有2个分支，第1个是将结果继续和第3个数运算，得到16*16种结果，再和第4个数运算得到16*16*16种结果；第2个分支是，第1、2个数得到的16种结果和第3、第4个数运算的16种结果再进行2个数的计算。
有了思路一步一步来，有问题再一起讨论。
#4
风吹过b2015-06-15 11:32
我也就是想过这个问题，所以把 算法的排列写到文本里面去。
修改TEST24函数，以便支持注释
程序代码：
Public Function Test24(a As Long, b As Long, c As Long, d As Long) As String
On Error Resume Next

Dim s As String
Dim o As Long
Dim m As Long
Dim s2 As String
Dim FJ() As String

Dim ScriptControl1 As New ScriptControl
ScriptControl1.Language = "VBScript"

s = rs                          '所有的表达式
s = Replace(s, "a", a)          '把数字填进去
s = Replace(s, "b", b)
s = Replace(s, "c", c)
s = Replace(s, "d", d)

FJ = Split(s, vbCrLf)           '分解成一个一个的表达式
For o = 0 To UBound(FJ)
    If Len(FJ(o)) > 0 Then    '是有效表达式
        If Left(FJ(o), 1) <> ";" Then           '非注释
            m = ScriptControl1.Eval(FJ(o))      '运算
            If m = 24 Then                      '结果是24吗
                s2 = s2 & FJ(o) & " = 24" & vbCrLf
            End If
        End If
    End If
Next o

Test24 = s2                     '返回结果

End Function


按照你说的，我重新排列过了表达式：
(a + b) + (c + d)
(a + b) + (c - d)
(a + b) + (c * d)
(a + b) + (c / d)

(a - b) + (c + d)
(a - b) + (c - d)
(a - b) + (c * d)
(a - b) + (c / d)

(a * b) + (c + d)
(a * b) + (c - d)
(a * b) + (c * d)
(a * b) + (c / d)

(a / b) + (c + d)
(a / b) + (c - d)
(a / b) + (c * d)
(a / b) + (c / d)

(a + b) - (c + d)
(a + b) - (c - d)
(a + b) - (c * d)
(a + b) - (c / d)

(a - b) - (c + d)
(a - b) - (c - d)
(a - b) - (c * d)
(a - b) - (c / d)

(a * b) - (c + d)
(a * b) - (c - d)
(a * b) - (c * d)
(a * b) - (c / d)

(a / b) - (c + d)
(a / b) - (c - d)
(a / b) - (c * d)
(a / b) - (c / d)

(a + b) * (c + d)
(a + b) * (c - d)
(a + b) * (c * d)
(a + b) * (c / d)

(a - b) * (c + d)
(a - b) * (c - d)
(a - b) * (c * d)
(a - b) * (c / d)

(a * b) * (c + d)
(a * b) * (c - d)
(a * b) * (c * d)
(a * b) * (c / d)

(a / b) * (c + d)
(a / b) * (c - d)
(a / b) * (c * d)
(a / b) * (c / d)

(a + b) / (c + d)
(a + b) / (c - d)
(a + b) / (c * d)
(a + b) / (c / d)

(a - b) / (c + d)
(a - b) / (c - d)
(a - b) / (c * d)
(a - b) / (c / d)

(a * b) / (c + d)
(a * b) / (c - d)
(a * b) / (c * d)
(a * b) / (c / d)

(a / b) / (c + d)
(a / b) / (c - d)
(a / b) / (c * d)
(a / b) / (c / d)

((a + b) + c) + d
((a + b) + c) - d
((a + b) + c) * d
((a + b) + c) / d

((a - b) + c) + d
((a - b) + c) - d
((a - b) + c) * d
((a - b) + c) / d

((a * b) + c) + d
((a * b) + c) - d
((a * b) + c) * d
((a * b) + c) / d

((a / b) + c) + d
((a / b) + c) - d
((a / b) + c) * d
((a / b) + c) / d

((a + b) - c) + d
((a + b) - c) - d
((a + b) - c) * d
((a + b) - c) / d

((a - b) - c) + d
((a - b) - c) - d
((a - b) - c) * d
((a - b) - c) / d

((a * b) - c) + d
((a * b) - c) - d
((a * b) - c) * d
((a * b) - c) / d

((a / b) - c) + d
((a / b) - c) - d
((a / b) - c) * d
((a / b) - c) / d

((a + b) * c) + d
((a + b) * c) - d
((a + b) * c) * d
((a + b) * c) / d

((a - b) * c) + d
((a - b) * c) - d
((a - b) * c) * d
((a - b) * c) / d

((a * b) * c) + d
((a * b) * c) - d
((a * b) * c) * d
((a * b) * c) / d

((a / b) * c) + d
((a / b) * c) - d
((a / b) * c) * d
((a / b) * c) / d

((a + b) / c) + d
((a + b) / c) - d
((a + b) / c) * d
((a + b) / c) / d

((a - b) / c) + d
((a - b) / c) - d
((a - b) / c) * d
((a - b) / c) / d

((a * b) / c) + d
((a * b) / c) - d
((a * b) / c) * d
((a * b) / c) / d

((a / b) / c) + d
((a / b) / c) - d
((a / b) / c) * d
((a / b) / c) / d


仔细考虑一下，还是使用这种写好了的表达式来检索好写程序。如果把这些算法写到程序里，会好烦好烦，太多分支了。
如果是 发布的工程，可以使用 资源编辑器，写到程序内部去。

[ 本帖最后由 风吹过b 于 2015-6-15 11:57 编辑 ]
#5
风吹过b2015-06-15 11:35
还有如：
a+(b+c)+d
a+(b+c)-d
a+(b+c)*d
a+(b+c)/d

可以转化为
(b+c)+d+a
(b+c)-d+a
(b+c)*d+a
(b+c)/d+a

因为 程序里会把 abcd 互换位置，所以这种的排列就没有意义了。
#6
wmf20142015-06-15 13:44
个人觉得还是穷举吧，顶多根据交换律规则加个判断，去除相同的式子。
另：abcd有上下限吧，肯定不能为0.
#7
风吹过b2015-06-15 16:48
按我最后排列的 表达式来穷举的。

如果是 输入的4个数。
范围判断在这：
'先读数
a = Val(IntTXT(0))
b = Val(IntTXT(1))
c = Val(IntTXT(2))
d = Val(IntTXT(3))

'判断范围
If a < 0 Or a > 10 Then Exit Sub
If b < 0 Or b > 10 Then Exit Sub
If c < 0 Or c > 10 Then Exit Sub
If d < 0 Or d > 10 Then Exit Sub

这4个数，按 24种排列，代入这些表达式求值。
'按排列组合去测试
s2 = s2 & Test24(a, b, c, d)
s2 = s2 & Test24(a, b, d, c)
s2 = s2 & Test24(a, c, b, d)
s2 = s2 & Test24(a, c, d, b)
s2 = s2 & Test24(a, d, b, c)
s2 = s2 & Test24(a, d, c, b)

s2 = s2 & Test24(b, a, c, d)
s2 = s2 & Test24(b, a, d, c)
s2 = s2 & Test24(b, c, d, a)
s2 = s2 & Test24(b, c, a, d)
s2 = s2 & Test24(b, d, a, c)
s2 = s2 & Test24(b, d, c, a)

s2 = s2 & Test24(c, b, a, d)
s2 = s2 & Test24(c, b, d, a)
s2 = s2 & Test24(c, a, b, d)
s2 = s2 & Test24(c, a, d, b)
s2 = s2 & Test24(c, d, b, a)
s2 = s2 & Test24(c, d, a, b)

s2 = s2 & Test24(d, b, c, a)
s2 = s2 & Test24(d, b, a, c)
s2 = s2 & Test24(d, c, b, a)
s2 = s2 & Test24(d, c, a, b)
s2 = s2 & Test24(d, a, b, c)
s2 = s2 & Test24(d, a, c, b)

如果是 测试所有的结果：
那 就不区分 24种组合了，因为四层循环，就会使所有的可能都会去测试。
For a = 1 To 10
For b = 1 To 10
For c = 1 To 10
For d = 1 To 10
#8
lianyicq2015-06-15 17:17
回复 4楼 风吹过b
遍历,递归对wmf2014版主来说肯定是小菜一碟。
我按3楼的思路写了一个，很初步，没有完善，包括输出重复的情况。脑子早就不好使了，转递归转不出来，就没有采用。
"~-"表示两数交换位置相减，"~/"表示两数交换位置相除。
程序代码：
Option Explicit
Dim DataTab(1 To 4, 1 To 24) As Single
Dim Orgin(1 To 4) As Single


Private Sub Command1_Click()
  Dim i As Integer
  Dim temp() As String
  Text1.Text = ""
  temp = Split(Text2.Text, " ")
  For i = 0 To UBound(temp)
    Orgin(i + 1) = Val(temp(i))
  Next
  permutation
  For i = 1 To 24
    Getone (i)
  Next

End Sub
Sub permutation() 'Get all permutation of Orgin to DataTab
  Dim i As Integer
  Dim j As Integer
  Dim m As Integer
  Dim n As Integer
  Dim k As Integer
  k = 1
  For i = 1 To 4
    For j = 1 To 4
      If j <> i Then
        For m = 1 To 4
          If m <> i And m <> j Then
            For n = 1 To 4
              If n <> i And n <> j And n <> m Then
                DataTab(1, k) = Orgin(i): DataTab(2, k) = Orgin(j): DataTab(3, k) = Orgin(m): DataTab(4, k) = Orgin(n)
                k = k + 1
              End If
            Next
          End If
        Next
      End If
    Next
  Next
End Sub

Private Sub Form_Load()
  Dim i As Integer
  Me.Show

 

End Sub

Sub calculate(ByVal x As Single, ByVal y As Single, output() As Single)
  ReDim output(1 To 6) As Single
  output(1) = x + y
  output(2) = x - y
  output(3) = x * y
  If y = 0 Then
    output(4) = 99.99
    Else
     output(4) = x / y
  End If
  output(5) = y - x
  If x = 0 Then
    output(6) = 99.99
  Else
    output(6) = y / x
  End If
End Sub

Function Convert(a As Integer) As String
  Select Case a
    Case Is = 1
      Convert = "+"
    Case Is = 2
      Convert = "-"
    Case Is = 3
      Convert = "*"
    Case Is = 4
      Convert = "/"
    Case Is = 5
      Convert = "~-"
    Case Is = 6
      Convert = "~/"
    Case Is = 0
      Convert = "~/"
  End Select
End Function

Sub Getone(x As Integer) 'Get outputs of x row
  Dim i As Integer
  Dim j As Integer
  Dim k As Integer
  Dim temp21() As Single
  Dim temp22() As Single
  Dim temp23() As Single
  Dim temp3() As Single
  Dim temp4() As Single
  Dim temp() As Single
  
  ReDim temp21(1 To 6) 'Combination of 1 and 2
  calculate DataTab(1, x), DataTab(2, x), temp21

 
  ReDim temp22(1 To 6) 'combination of 3 and 4
  calculate DataTab(3, x), DataTab(4, x), temp22

  ReDim temp23(1 To 216) 'combination of temp21 and temp22
  For i = 1 To 6
    For j = 1 To 6
      calculate temp21(i), temp22(j), temp
      For k = 1 To 6
        temp23(36 * (i - 1) + 6 * (j - 1) + k) = temp(k)
      Next
    Next
  Next
  For i = 1 To 216
    If temp23(i) = 24 Then
      Text1.Text = Text1.Text & "(" & DataTab(1, x) & Convert(1 + Int((i - 1) / 36)) & DataTab(2, x) & ")" & Convert(i Mod 6) & "(" & DataTab(3, x) & Convert(1 + Int(((i Mod 36) - 1) / 6)) & DataTab(4, x) & ")" & vbCrLf
    End If
  Next
  


 
  ReDim temp3(1 To 36) 'combination of temp21 and 3
  For i = 1 To 6
    calculate temp21(i), DataTab(3, x), temp
    For j = 1 To 6
      temp3(6 * (i - 1) + j) = temp(j)
    Next
  Next


 
  ReDim temp4(1 To 216) 'combination of temp3 and 4
  For i = 1 To 36
    calculate temp3(i), DataTab(4, x), temp
    For j = 1 To 6
      temp4(6 * (i - 1) + j) = temp(j)
    Next
  Next

  For i = 1 To 216
    If temp4(i) = 24 Then
      Text1.Text = Text1.Text & "((" & DataTab(1, x) & Convert(1 + Int((i - 1) / 36)) & DataTab(2, x) & ")" & Convert(1 + Int(((i Mod 36) - 1) / 6)) & DataTab(3, x) & ")" & Convert(i Mod 6) & DataTab(4, x) & vbCrLf
    End If
  Next
   
End Sub

 
#9
风吹过b2015-06-15 17:27
回复 8楼 边小白
24点的规则是：

4个 1-10 的数字，可以重复。使用四则运算符，可以使用括号，计算出 24 来。

临时去掉数据范围得出来的结果，里面有因为取整造成错误的情况，看来要修正程序。
((7 / 12) * 10) + 18 = 24
((7 * 10) / 12) + 18 = 24
(7 + 18) - (12 / 10) = 24
(7 + 18) - (10 / 12) = 24
((10 * 7) / 12) + 18 = 24
((10 / 12) * 7) + 18 = 24
((10 * 18) - 12) / 7 = 24
(18 + 7) - (10 / 12) = 24
(18 + 7) - (12 / 10) = 24
((18 * 10) - 12) / 7 = 24

修正的结果为 浮点数，得到了是：
((18 * 10) - 12) / 7 = 24
((10 * 18) - 12) / 7 = 24

[ 本帖最后由 风吹过b 于 2015-6-15 17:28 编辑 ]
#10
vbyou1262015-06-16 17:36
有更厉害的算法，
#11
风吹过b2015-06-16 22:33
不考虑交换，按二种情况写过了，现在写成了模块。代码如下：

Option Explicit

Public Type T24type
    s As String
    v As Long
End Type

Public Function Test24_2(a As Long, b As Long, c As Long, d As Long) As String

Dim r1(4) As T24type, r2(4) As T24type, r3(4) As T24type
Dim l1 As T24type, l2 As T24type
Dim l3 As T24type, l4 As T24type
Dim i As Long, j As Long, m As Long
Dim s As String

'第一个数
l1.s = CStr(a)
l1.v = a
'第二个数
l2.s = CStr(b)
l2.v = b
'第三个数
l3.s = CStr(c)
l3.v = c
'第四个数
l4.s = CStr(d)
l4.v = d

'第一个数与第二个数计算
Call operation(l1, l2, r1)

'第一分支，第1、2数运算后与第3、4数运算

'第三个数与第四个数计算
Call operation(l3, l4, r2)
For i = 1 To 4
    For j = 1 To 4
        If r1(i).v >= 0 And r2(i).v >= 0 Then
            Call operation(r1(j), r2(i), r3)
            For m = 1 To 4
                If r3(m).v = 24 Then
                    s = s & r3(m).s & " = 24" & vbCrLf
                End If
            Next m
        End If
    Next j
Next i

'第二分支，第1、2数运算后与第3数运算,再与第4数运算
For i = 1 To 4
    If r1(i).v >= 0 Then
        Call operation(r1(i), l3, r2)
        For j = 1 To 4
            If r2(j).v >= 0 Then
                Call operation(r2(j), l4, r3)
                For m = 1 To 4
                    If r3(m).v = 24 Then
                        s = s & r3(m).s & " = 24" & vbCrLf
                    End If
                Next m
            End If
        Next j
    End If
Next i

Test24_2 = s

End Function

Public Sub operation(a As T24type, b As T24type, r() As T24type)

Dim t As Single

'加法
r(1).v = a.v + b.v
r(1).s = "( " & a.s & " + " & b.s & " )"

'减法，不考虑负数
If a.v > b.v Then
    r(2).v = a.v - b.v
    r(2).s = "( " & a.s & " - " & b.s & " )"
Else
    r(2).v = -1
End If

'乘法
r(3).v = a.v * b.v
r(3).s = "( " & a.s & " * " & b.s & " )"

'除法，只允许整除
If a.v >= b.v And b.v > 0 Then
    If a.v Mod b.v = 0 Then
        r(4).v = a.v / b.v
        r(4).s = "( " & a.s & " / " & b.s & " )"
    Else
        r(4).v = -1
    End If
   
Else
    r(4).v = -1
End If

End Sub


如输入 1 2 3 4
结果为：
( ( 1 * 2 ) * ( 3 * 4 ) ) = 24
( ( ( 1 + 2 ) + 3 ) * 4 ) = 24
( ( ( 1 * 2 ) * 3 ) * 4 ) = 24
( ( 1 * 2 ) * ( 4 * 3 ) ) = 24
( ( ( 1 * 2 ) * 4 ) * 3 ) = 24
( ( 1 + 3 ) * ( 2 + 4 ) ) = 24
( ( 1 * 3 ) * ( 2 * 4 ) ) = 24
( ( ( 1 + 3 ) + 2 ) * 4 ) = 24
( ( ( 1 * 3 ) * 2 ) * 4 ) = 24
( ( 1 + 3 ) * ( 4 + 2 ) ) = 24
( ( 1 * 3 ) * ( 4 * 2 ) ) = 24
( ( ( 1 * 3 ) * 4 ) * 2 ) = 24
( ( 1 * 4 ) * ( 2 * 3 ) ) = 24
( ( ( 1 * 4 ) * 2 ) * 3 ) = 24
( ( 1 * 4 ) * ( 3 * 2 ) ) = 24
( ( ( 1 * 4 ) * 3 ) * 2 ) = 24
( ( 2 * 1 ) * ( 3 * 4 ) ) = 24
( ( 2 / 1 ) * ( 3 * 4 ) ) = 24
( ( ( 2 + 1 ) + 3 ) * 4 ) = 24
( ( ( 2 * 1 ) * 3 ) * 4 ) = 24
( ( ( 2 / 1 ) * 3 ) * 4 ) = 24
( ( 2 * 1 ) * ( 4 * 3 ) ) = 24
( ( 2 / 1 ) * ( 4 * 3 ) ) = 24
( ( ( 2 * 1 ) * 4 ) * 3 ) = 24
( ( ( 2 / 1 ) * 4 ) * 3 ) = 24
( ( 2 * 3 ) * ( 4 * 1 ) ) = 24
( ( ( 2 * 3 ) * 4 ) * 1 ) = 24
( ( ( 2 * 3 ) * 4 ) / 1 ) = 24
( ( 2 * 3 ) * ( 1 * 4 ) ) = 24
( ( ( 2 + 3 ) + 1 ) * 4 ) = 24
( ( ( 2 * 3 ) * 1 ) * 4 ) = 24
( ( ( 2 * 3 ) / 1 ) * 4 ) = 24
( ( 2 + 4 ) * ( 1 + 3 ) ) = 24
( ( 2 * 4 ) * ( 1 * 3 ) ) = 24
( ( ( 2 * 4 ) * 1 ) * 3 ) = 24
( ( ( 2 * 4 ) / 1 ) * 3 ) = 24
( ( 2 + 4 ) * ( 3 + 1 ) ) = 24
( ( 2 * 4 ) * ( 3 * 1 ) ) = 24
( ( ( 2 * 4 ) * 3 ) * 1 ) = 24
( ( ( 2 * 4 ) * 3 ) / 1 ) = 24
( ( 3 * 2 ) * ( 1 * 4 ) ) = 24
( ( ( 3 + 2 ) + 1 ) * 4 ) = 24
( ( ( 3 * 2 ) * 1 ) * 4 ) = 24
( ( ( 3 * 2 ) / 1 ) * 4 ) = 24
( ( 3 * 2 ) * ( 4 * 1 ) ) = 24
( ( ( 3 * 2 ) * 4 ) * 1 ) = 24
( ( ( 3 * 2 ) * 4 ) / 1 ) = 24
( ( 3 + 1 ) * ( 2 + 4 ) ) = 24
( ( 3 * 1 ) * ( 2 * 4 ) ) = 24
( ( 3 / 1 ) * ( 2 * 4 ) ) = 24
( ( ( 3 + 1 ) + 2 ) * 4 ) = 24
( ( ( 3 * 1 ) * 2 ) * 4 ) = 24
( ( ( 3 / 1 ) * 2 ) * 4 ) = 24
( ( 3 + 1 ) * ( 4 + 2 ) ) = 24
( ( 3 * 1 ) * ( 4 * 2 ) ) = 24
( ( 3 / 1 ) * ( 4 * 2 ) ) = 24
( ( ( 3 * 1 ) * 4 ) * 2 ) = 24
( ( ( 3 / 1 ) * 4 ) * 2 ) = 24
( ( 3 * 4 ) * ( 2 * 1 ) ) = 24
( ( ( 3 * 4 ) * 2 ) * 1 ) = 24
( ( ( 3 * 4 ) * 2 ) / 1 ) = 24
( ( 3 * 4 ) * ( 1 * 2 ) ) = 24
( ( ( 3 * 4 ) * 1 ) * 2 ) = 24
( ( ( 3 * 4 ) / 1 ) * 2 ) = 24
( ( 4 + 2 ) * ( 3 + 1 ) ) = 24
( ( 4 * 2 ) * ( 3 * 1 ) ) = 24
( ( 4 * 2 ) * ( 3 / 1 ) ) = 24
( ( ( 4 * 2 ) * 3 ) * 1 ) = 24
( ( ( 4 * 2 ) * 3 ) / 1 ) = 24
( ( 4 + 2 ) * ( 1 + 3 ) ) = 24
( ( 4 * 2 ) * ( 1 * 3 ) ) = 24
( ( ( 4 * 2 ) * 1 ) * 3 ) = 24
( ( ( 4 * 2 ) / 1 ) * 3 ) = 24
( ( 4 * 3 ) * ( 2 * 1 ) ) = 24
( ( ( 4 * 3 ) * 2 ) * 1 ) = 24
( ( ( 4 * 3 ) * 2 ) / 1 ) = 24
( ( 4 * 3 ) * ( 1 * 2 ) ) = 24
( ( ( 4 * 3 ) * 1 ) * 2 ) = 24
( ( ( 4 * 3 ) / 1 ) * 2 ) = 24
( ( 4 * 1 ) * ( 2 * 3 ) ) = 24
( ( 4 / 1 ) * ( 2 * 3 ) ) = 24
( ( ( 4 * 1 ) * 2 ) * 3 ) = 24
( ( ( 4 / 1 ) * 2 ) * 3 ) = 24
( ( 4 * 1 ) * ( 3 * 2 ) ) = 24
( ( 4 / 1 ) * ( 3 * 2 ) ) = 24
( ( ( 4 * 1 ) * 3 ) * 2 ) = 24
( ( ( 4 / 1 ) * 3 ) * 2 ) = 24
#12
风吹过b2015-06-16 22:58
手工对比了一下， 使用表达式时，运算过程中出现负数。而使用算法时，可以把负数丢弃。
如果出现负数时，后面有交换过结果来运算的情况，也不需要，答案更适合小学生看了。
运算速度，算法快很多很多。 不错。

为什么我不考虑 交换呢。是因为我调用时，会把这4个数 重新排列组合 24 种进行调用，所以不需要考虑交换的问题。
为什么这么多的括号，是为了排版的表示运算的先后。

增加去重功能。先要把多余的括号干掉，然后再来去重。 其中，如果是加法的话，去括号就很烦，需要修改运算函数的组合算法。
'去掉括号之间的空格
s = Replace(s, "( (", "((")
'去多余的空格
Do
    i = Len(s)
    s = Replace(s, "  ", " ")
Loop While Len(s) <> i

'去重
Dim fj() As String
'分行
fj = Split(s, vbCrLf)

'扫描
For i = 1 To UBound(fj)
    For j = i + 1 To UBound(fj)
        If fj(i) = fj(j) Then       '扫描到后面有相同的
            fj(j) = ""              '后面的清空
        End If
    Next j
Next i
'重新组合，不能使用 join 函数是因为有空行在
s = ""
For i = 1 To UBound(fj)
    If Len(fj(i)) > 0 Then
        s = s & fj(i) & vbCrLf
    End If
Next i


r(3).s = "  " & a.s & " * " & b.s & "  "

        r(4).s = "  " & a.s & " / " & b.s & "  "
#13
lianyicq2015-06-17 08:55
回复 12楼 风吹过b
必须考虑两数交换的减和除。因为按我贴的代码的第2种情况，首先是第1和第2个数运算，得到的结果再和第3个数运算...
不交换就不能出现(c¤(a¤b))¤d 其中¤是任意运算符.
比如5 5 5 1。
按我贴的代码输出是((5~/1)~-5)*5
转化正规输出是(5-(1/5))*5

按12楼代码就不能出现结果

我贴的代码用列表的方法把运算结果都包含了,继续要做的只是代码优化和输出格式化的问题
#14
风吹过b2015-06-17 09:49
我明确要排除计算过程中的非整数。

(5-(1/5))*5
这里面：1/5 ，得到的小数，我计算过程中就会丢弃。

你说这种情况，先计算 2和3，然后再结合 1 ，再结合 4 ，
如果是1@(2?3) 1和2、3做 减法，除法，我前面是没有涉及到。这点是我考虑不周。

按我前面的调用方法，我确实不需要考虑交换
如：（假设不丢弃 非整数 ）
5 5 1 5 ,你可以得出  (5-(1/5))*5 这种情况，我得不出。
但我 后面调用里，有  5 1 5 5 这个调用，，如果补充算法后，我就得出这个式子了。
#15
wmf20142015-06-17 10:39
回复 17楼 风吹过b
复制了你的代码，我怎么只拿到3个算式？
( ( 1 * 2 ) * ( 3 * 4 ) ) = 24
( ( ( 1 + 2 ) + 3 ) * 4 ) = 24
( ( ( 1 * 2 ) * 3 ) * 4 ) = 24
#16
风吹过b2015-06-17 10:53
调用代码在这。在调用代码里 组合的。

'测试4个数
Dim s2 As String
Dim a As Long, b As Long, c As Long, d As Long

'先读数
a = Val(IntTXT(0))
b = Val(IntTXT(1))
c = Val(IntTXT(2))
d = Val(IntTXT(3))

'判断范围
If a < 0 Or a > 10 Then Exit Sub
If b < 0 Or b > 10 Then Exit Sub
If c < 0 Or c > 10 Then Exit Sub
If d < 0 Or d > 10 Then Exit Sub

Text1.Text = "运算中..."
DoEvents
   
'按排列组合去测试
s2 = s2 & Test24_2(a, b, c, d)
s2 = s2 & Test24_2(a, b, d, c)
s2 = s2 & Test24_2(a, c, b, d)
s2 = s2 & Test24_2(a, c, d, b)
s2 = s2 & Test24_2(a, d, b, c)
s2 = s2 & Test24_2(a, d, c, b)

s2 = s2 & Test24_2(b, a, c, d)
s2 = s2 & Test24_2(b, a, d, c)
s2 = s2 & Test24_2(b, c, d, a)
s2 = s2 & Test24_2(b, c, a, d)
s2 = s2 & Test24_2(b, d, a, c)
s2 = s2 & Test24_2(b, d, c, a)

s2 = s2 & Test24_2(c, b, a, d)
s2 = s2 & Test24_2(c, b, d, a)
s2 = s2 & Test24_2(c, a, b, d)
s2 = s2 & Test24_2(c, a, d, b)
s2 = s2 & Test24_2(c, d, b, a)
s2 = s2 & Test24_2(c, d, a, b)

s2 = s2 & Test24_2(d, b, c, a)
s2 = s2 & Test24_2(d, b, a, c)
s2 = s2 & Test24_2(d, c, b, a)
s2 = s2 & Test24_2(d, c, a, b)
s2 = s2 & Test24_2(d, a, b, c)
s2 = s2 & Test24_2(d, a, c, b)

'检查测试结果
If Len(s2) > 0 Then
    Text1.Text = s2
Else
    Text1.Text = "无解！"
End If
#17
风吹过b2015-06-17 10:54
模块完整的代码：
程序代码：
Option Explicit

Public Type T24type
    s As String
    v As Long
End Type

Public Function Test24_2(a As Long, b As Long, c As Long, d As Long) As String

Dim r1(4) As T24type, r2(4) As T24type, r3(4) As T24type
Dim l1 As T24type, l2 As T24type
Dim l3 As T24type, l4 As T24type
Dim i As Long, j As Long, m As Long
Dim s As String

'第一个数
l1.s = CStr(a)
l1.v = a
'第二个数
l2.s = CStr(b)
l2.v = b
'第三个数
l3.s = CStr(c)
l3.v = c
'第四个数
l4.s = CStr(d)
l4.v = d

'第一个数与第二个数计算
Call operation(l1, l2, r1)

'第一分支，第1、2数运算后与第3、4数运算

'第三个数与第四个数计算
Call operation(l3, l4, r2)
For i = 1 To 4
    If r1(i).v > 0 Then
        For j = 1 To 4
            If r2(j).v >= 0 Then
                Call operation(r1(i), r2(j), r3)
                For m = 1 To 4
                    If r3(m).v = 24 Then
                        s = s & r3(m).s & " = 24" & vbCrLf
                    End If
                Next m
            End If
        Next j
    End If
Next i

'第二分支，第1、2数运算后与第3数运算,再与第4数运算
For i = 1 To 4
    If r1(i).v >= 0 Then
        Call operation(r1(i), l3, r2)
        For j = 1 To 4
            If r2(j).v >= 0 Then
                Call operation(r2(j), l4, r3)
                For m = 1 To 4
                    If r3(m).v = 24 Then
                        s = s & r3(m).s & " = 24" & vbCrLf
                    End If
                Next m
            End If
        Next j
    End If
Next i

'先第2、3数运算后，再与第1数运算，第4数运算。
Call operation(l2, l3, r1)
For i = 1 To 4
    If r1(i).v > 0 Then
        Call operation(l1, r1(i), r2)
        For j = 1 To 4
            If r2(j).v > 0 Then
                Call operation(r2(j), l4, r3)
                For m = 1 To 4
                    If r3(m).v = 24 Then
                        s = s & r3(m).s & " = 24" & vbCrLf
                    End If
                Next m
            End If
        Next j
    End If
Next i


'去掉括号之间的空格
s = Replace(s, "( (", "((")
'去多余的空格
Do
    i = Len(s)
    s = Replace(s, "  ", " ")
Loop While Len(s) <> i

'去重
Dim fj() As String
'分行
fj = Split(s, vbCrLf)

'扫描
For i = 1 To UBound(fj)
    For j = i + 1 To UBound(fj)
        If fj(i) = fj(j) Then       '扫描到后面有相同的
            fj(j) = ""              '后面的清空
        End If
    Next j
Next i
'重新组合，不能使用 join 函数是因为有空行在
s = ""
For i = 0 To UBound(fj)
    If Len(fj(i)) > 0 Then
        s = s & fj(i) & vbCrLf
    End If
Next i

Test24_2 = s

End Function

Public Sub operation(a As T24type, b As T24type, r() As T24type)

Dim t As Single

'加法
r(1).v = a.v + b.v
r(1).s = "( " & a.s & " + " & b.s & " )"

'减法，不考虑负数
If a.v > b.v Then
    r(2).v = a.v - b.v
    r(2).s = "( " & a.s & " - " & b.s & " )"
Else
    r(2).v = -1
End If

'乘法
r(3).v = a.v * b.v
'r(3).s = "( " & a.s & " * " & b.s & " )"
r(3).s = "  " & a.s & " * " & b.s & "  "

'除法，只允许整除
If a.v >= b.v And b.v > 0 Then
    If a.v Mod b.v = 0 Then
        r(4).v = a.v / b.v
'        r(4).s = "( " & a.s & " / " & b.s & " )"
        r(4).s = "  " & a.s & " / " & b.s & "  "
    Else
        r(4).v = -1
    End If
   
Else
    r(4).v = -1
End If

End Sub


[ 本帖最后由 风吹过b 于 2015-6-17 20:31 编辑 ]
#18
wmf20142015-06-17 11:19
还是只有3个，另5,6,7,8没有答案，应该有(5+7-8)*6=24
1 * 2 * 3 * 4 = 24
 (( 1 + 2 ) + 3 ) * 4 = 24
 ( 1 + ( 2 + 3 ) ) * 4 = 24

即使是1,2,3,4应该还有（1+3）*（4+2）的组合

[ 本帖最后由 wmf2014 于 2015-6-17 11:29 编辑 ]
#19
风吹过b2015-06-17 11:27
你看一下我 19楼 的调用代码，我是调用了 24次。

我函数分工∶调用过程中完成变换，test24 完成当前4个数的组合，然后另一个函数负责计算。
#20
wmf20142015-06-17 11:36
回复 22楼 风吹过b
嗯，知道额，不过你（5,6,7,8）的确无解，你测试下。
#21
风吹过b2015-06-17 13:43
经检查， 代码里变量写错了。
 (( 5 + 7 ) - 8 ) * 6 = 24
 (( 7 + 5 ) - 8 ) * 6 = 24
 8 * 6 / ( 7 - 5 ) = 24

这行：
            Call operation(r1(i), r2(j), r3)
写成
            Call operation(r1(j), r2(j), r3)
了，上午那个时候是没时间了，没怎么仔细检查。郁闷。
#22
wmf20142015-06-17 15:26
5678可以了，“6、7、8、9”，“4、6、7、9”，“3、7、7、9”等又无解。6*8/(9-7)应该是可以整除的。
#23
lianyicq2015-06-17 16:53
上次是将所有结果计算后列表，再查找24。这次是用递归全排列作大循环，大循环内再考虑3个运算符优先权算24。还是没考虑重复的情况。
程序代码：
Option Explicit

Private Sub Command1_Click()
  Dim arr(1 To 4) As Single
  Dim temp() As String
  Dim i As Integer
  List1.Clear
  temp = Split(Text1.Text, " ") '注1<得到4个操作数,赋值到arr中.
  For i = 0 To UBound(temp)
    arr(i + 1) = Val(temp(i))
  Next '>注1
  permutation arr, 1, 4

End Sub

Sub permutation(a() As Single, m As Integer, n As Integer)
  Dim i As Integer
  Dim temp As Integer
  Dim operator1 As Byte
  Dim operator2 As Byte
  Dim operator3 As Byte
  If m = n Then '注2:判断当前排列是否完成.
    For operator1 = 0 To 3 '注3<三重循环得到3个操作符的全排列.
      For operator2 = 0 To 3
        For operator3 = 0 To 3
          '注4:判断操作符的各种估先权组合得到地计算结果是否为24
          '5种操作符优先权顺序是: 1 2 3,1 3 2,2 1 3,2 3 1 ,3 2 1.(3 1 2 等同于1 3 2)
          If operate(operator3, operate(operator2, operate(operator1, a(1), a(2)), a(3)), a(4)) = 24 Then
            List1.AddItem "((" & a(1) & convert(operator1) & a(2) & ")" & convert(operator2) & a(3) & ")" & convert(operator3) & a(4)
          End If
        
          If operate(operator2, operate(operator1, a(1), a(2)), operate(operator3, a(3), a(4))) = 24 Then
            List1.AddItem "(" & a(1) & convert(operator1) & a(2) & ")" & convert(operator2) & "(" & a(3) & convert(operator3) & a(4) & ")"
          End If
        
          If operate(operator3, operate(operator1, a(1), operate(operator2, a(2), a(3))), a(4)) = 24 Then
            List1.AddItem "(" & a(1) & convert(operator1) & "(" & a(2) & convert(operator2) & a(3) & "))" & convert(operator3) & a(4)
          End If
        
          If operate(operator1, a(1), operate(operator3, operate(operator2, a(2), a(3)), a(4))) = 24 Then
            List1.AddItem a(1) & convert(operator1) & "((" & a(2) & convert(operator2) & a(3) & ")" & convert(operator3) & a(4) & ")"
          End If

          If operate(operator1, a(1), operate(operator2, a(2), operate(operator3, a(3), a(4)))) = 24 Then
            List1.AddItem a(1) & convert(operator1) & "(" & a(2) & convert(operator2) & "(" & a(3) & convert(operator3) & a(4) & "))"
          End If
        
        Next
      Next
    Next '>注3

    Exit Sub
  Else
    For i = m To n '注5<得到a()全排列
      swap a(m), a(i)
      permutation a(), m + 1, n
      swap a(m), a(i)
    Next '>注5
  End If
End Sub


Sub swap(a1 As Single, b1 As Single)
  Dim temp As Single
  temp = a1
  a1 = b1
  b1 = temp
End Sub
Function operate(i As Byte, x As Single, y As Single) As Single '按操作符索引号得到2个操作数的计算结果.注意顺序无误.
  Select Case i
   Case Is = 0
     operate = x + y
   Case Is = 1
     operate = x - y
   Case Is = 2
     operate = x * y
   Case Is = 3
     If y = 0 Then
       operate = 99.9
     Else
       operate = x / y
     End If
   End Select
End Function

Function convert(i As Byte) As String '按操作符索引转化为"+-*/"
  Select Case i
    Case Is = 0
      convert = "+"
    Case Is = 1
      convert = "-"
    Case Is = 2
      convert = "*"
    Case Is = 3
      convert = "/"
  End Select
End Function



如果把注3对应的内容删掉换成显示a(1)-a(4)就能看到遍历效果了.

[ 本帖最后由 lianyicq 于 2015-6-18 12:10 编辑 ]
#24
风吹过b2015-06-17 20:29
好吧，还是粗心造成的。
二个地方有问题。
1、这里判断与循环的顺序有问题
'第三个数与第四个数计算
Call operation(l3, l4, r2)
For i = 1 To 4
    For j = 1 To 4
        If r1(i).v >= 0 And r2(i).v >= 0 Then
            Call operation(r1(j), r2(j), r3)
            For m = 1 To 4
                If r3(m).v = 24 Then
                    s = s & r3(m).s & " = 24" & vbCrLf
                End If
            Next m
        End If
    Next j
Next i
改为：
'第三个数与第四个数计算
Call operation(l3, l4, r2)
For i = 1 To 4
    If r1(i).v > 0 Then
        For j = 1 To 4
            If r2(j).v >= 0 Then
                Call operation(r1(i), r2(j), r3)
                For m = 1 To 4
                    If r3(m).v = 24 Then
                        s = s & r3(m).s & " = 24" & vbCrLf
                    End If
                Next m
            End If
        Next j
    End If
Next i

2、'重新组合，不能使用 join 函数是因为有空行在
s = ""
For i = 1 To UBound(fj)
应该是：
'重新组合，不能使用 join 函数是因为有空行在
s = ""
For i = 0 To UBound(fj)
原来的代码把 第一个 结果给抛弃了。

-------------------------
 6 * 8 / ( 9 - 7 ) = 24
 6 / ( 9 - 7 ) * 8 = 24
 8 * 6 / ( 9 - 7 ) = 24
 8 / ( 9 - 7 ) * 6 = 24
-------------------------
 6 * ( 7 + 9 ) / 4 = 24
 6 * ( 9 + 7 ) / 4 = 24
 ( 7 + 9 ) * 6 / 4 = 24
 ( 7 + 9 ) / 4 * 6 = 24
 ( 9 + 7 ) * 6 / 4 = 24
 ( 9 + 7 ) / 4 * 6 = 24
--------------------------
 ( 9 - 7 / 7 ) * 3 = 24
 ( 9 - 7 / 7 ) * 3 = 24
#25
风吹过b2015-06-17 20:48
lianyicq 的代码 写的很精练，比我的 优化好多了，占用内存也比我的小。
建议 lianyicq 的代码写点注释进去，我看起来都有点吃力。看了好几遍，跟踪了才大体上搞清楚运行流程。

特别这一段：
    For i = m To n
      swap a(m), a(i)
      permutation a(), m + 1, n
      swap a(m), a(i)
    Next
比我傻傻的写 24 行 精练多了。
#26
风吹过b2015-06-17 21:02
发现重复数据，郁闷之极。
经过调试，程序流程有问题， 去重代码只征对 一组数据 起作用，而不是对 24组数据同时起作用，所以输入相同数据时，我的代码还是会出现相同的数据。

需要去重代码段，从 运算模块 移到 调用 模块里去。


----------------------------
新手多调试程序吧。只有调试程序，才知道 错误出在什么地方。

代码编写 只占整个工作的小部分，大头是算法规划，另一部分就是 调试。
我最开始，算法规划不行， 虽然结果大体上对了，但错误的结果无法排除，这就是算法规划的失误。
然后修改过了算法，代码 写起来，很简单，但组合起来，就是BUG到处都是，经过调试，才能知道如何去修改错误，去除BUG。
#27
wmf20142015-06-17 21:24
为风版主和lianyicq点赞！！！
正如风版主所说的，lianyicq版主的代码干练缜密，值得学习！只是我还没咋看懂，不知道你们怎么就处理了带括号的四则运算的
待我抽空想一个另类的穷举做这题（vb语法不太熟，估计还是要师兄援手完成了）。
#28
风吹过b2015-06-18 09:16
好吧，我来解释一下，核心运算调用代码是这个。
          If operate(operator3, operate(operator2, operate(operator1, a(1), a(2)), a(3)), a(4)) = 24 Then
            List1.AddItem "((" & a(1) & convert(operator1) & a(2) & ")" & convert(operator2) & a(3) & ")" & convert(operator3) & a(4)
          End If

operate(operator3, _                    '第三次调用
   operate(operator2, _                 '第二次调用
   operate(operator1, a(1), a(2)_       '第一次调用  从右到左，先计算 1 和 2     
   ), a(3) _        第二次调用的第二个参数：再计算 1和2  与 3
   ), a(4) )        第三镒调用的第二个参数：最后再 和 4 进行计算
#29
lianyicq2015-06-18 09:17
回复 28楼 风吹过b
我脑子已经不够用不好使，才想到哪儿写哪儿，不过每一个没有把握的模块都要独立测试没问题了才加进去。
26楼代码也是同样方法做的。
确实应该添加一些注释，26楼的注释加上了。
#30
风吹过b2015-06-18 11:52
我英文不行。
2级才考 31 分。
1
©2025, BC-CN.NET
电脑版