24点游戏的算法与源程序

一、 任务说明

24点游戏是一个大众化的益智游戏。任意给四张扑克牌（不包括大小王），只能够用加、减、乘、除以及适当的括号连接这四张牌，无论顺序，使计算结果为24，或者宣布根本就是无解的。需要注意的是，每张牌必须运算，并且只能运算一次，J、Q、K可设置为11、12、13。

本程序目的就是算出一组牌的所有解（不同形式的式子算不同解），如没有则输出无解。

二、 算法说明

首先解决图形扑克牌的显示问题。我选择了Qcard.dll。运用其中的DrawCard过程可轻松实现扑克的显示问题，在源程序中会有具体用法。

接下来是24点算法的讨论。首先想到的是用穷举表达式的方法，然后求值。然而，由于括号的存在，使穷举表达式并非易事。实际上，括号的作用仅仅是提高运算的优先级而已，如果我们规定符号的优先级，一样可以达到要求。具体来说，设四张牌为a、b、c、d，运算符为①、②、③，表达式为a ① b ② c ③ 。如果强制规定①、②、③的优先顺序，就不必考虑括号问题了。而这3个运算符的运算顺序有3！=6种，分别是：

1．①②③ 2.①③② 3.②①③ 4.②③① 5.③①② 6.③②①

等价的表达式分别是：

1.((a①b②)c③) 2.(a①b)②(c③d) 3.(a①(b②c))③d

4.a①((b②c)③d) 5.(a①b)②(c③d) 6. a①(b②(c③d))

显然，2和5是相同的，因此只考虑5种情况。这样，括号的问题就解决了。

接下来，就是生成a、b、c、d的全排列，注意去掉其中的相同排列。去除的方法很多，比如字典排序等，我用的是另一种方法。

用循环的嵌套生成a、b、c、d的24种全排列，记录在数组中。把每一组数当作一个四位的14进制数，把这24个数全部转化为十进制（如（6529）14=6*143+5*142+2*14+9）。这样，如果两个排列完全相同，则得到的十进制数是相等的。这样，通过对这些十进制的比较，就可以比较这些排列的相同情况。一旦遇到相同的排列，就标记上。最后生成一组没有重复的排列。

对这组排列进行以上方法的运算，就可以得到所有的结果了。注意在运算过程中除法的特殊性——除数不能为零。因为可能会用到除法，所以要考虑精度问题，这里通过结果减去24取绝对值与一个接近0的小数比较，如小于它，即可判定结果是24。

附：其他待决的问题：

1、 图形扑克牌的遮挡问题。当窗口中的扑克牌被遮挡后，扑克牌不会重新画上，造成扑克牌遮挡后显示不全问题。应寻找Qcard.dll的有关参数。

2、 形式不同而实质相同的解的问题。有些解虽然形式不同，但其实质是完全相同的。如3*((11+4)-7)和3*(11+(4-7))，实际上只是一种解。去掉这些相同解的问题情况较多，其较为繁琐，有待解决。

3、 多余括号好问题。有些解的括号是多余的，应在输出前去掉。

4、 改进程序的可玩性。增加玩家输入表达式的功能，并判断对错，还可以加上时间限制，使玩家参与到游戏中。

三、 程序框图

四、 VB源程序代码

'需要声明所有用到的变量

Option Explicit

'声明全局变量、数组

Dim cards(1 To 4) As Single, card(1 To 4) As Single

Dim result(1 To 24, 0 To 4) As Integer, final(1 To 24, 1 To 4) As Integer, temp(1 To 24) As Long

Dim nokey As Boolean, total As Integer, n1 As Integer, n2 As Integer, n3 As Integer, n4 As Integer, a As Integer, b As Integer, c As Integer, d As Integer, op1 As Integer, op2 As Integer, op3 As Integer, answer1 As Single, answer2 As Single, answer3 As Single, color As Integer

Dim i As Integer, j As Integer, t As Integer

'声明zero常量，设置0的标准，处理除法的精度问题

Const zero = 0.00001

'初始化QCARD32.DLL

Private Declare Function InitializeDeck Lib "qcard32.dll" (ByVal hwin As Long) As Integer

'DrawCard 子程序，画出扑克牌图样在FORM窗体及 窗体上的图片框

'用法：

'hwnd ---- 需要画图的对象句柄

'nCard --- 扑克牌编号 其编号如下

'1-13 梅花 14-26 方块 27-39 红心 40-52 黑桃 小王-110 大王-111

'x，y 位置

Private Declare Sub DrawCard Lib "qcard32.dll" (ByVal hwnd As Long, ByVal nCard As Integer, ByVal x As Integer, ByVal y As Integer)

'DrawBack 子程序，画出扑克牌的背面图案，共六种 按 1--6 编号

Private Declare Sub DrawBack Lib "qcard32.dll" (ByVal hwnd As Long, ByVal nCard As Long, ByVal x As Long, ByVal y As Long)

'GetCardSuit 函数，求 nCard 的点数 1-13

'Private Declare Function GetCardSuit Lib "qcard32.dll" (ByVal nCard As Long) As Long

'GetCardValue 函数，求 nCard 的花色 0∶鬼牌 1∶梅花 2∶方块 3∶红心 4∶黑桃

'Private Declare Function GetCardValue Lib "qcard32.dll" (ByVal nCard As Long) As Long

'Form_Load过程，初始化

Private Sub Form_Load()

Randomize Timer

Call InitializeDeck(Me.hwnd)

Command3.Enabled = False

End Sub

'answer函数，返回x与y做operator运算后的值，-100为错误标志

Private Function answer(x As Single, y As Single, operator As Integer) As Single

Select Case operator

Case 1

answer = x + y

Exit Function

Case 2

answer = x - y

Exit Function

Case 3

answer = x * y

Exit Function

Case 4

If y = 0 Then

answer = -100

Exit Function

Else

answer = x / y

Exit Function

End If

End Select

answer = -100

End Function

'operate函数，返回数值op所对应的四则运算符号

Private Function operate(op As Integer) As String

Select Case op

Case 1

operate = "+"

Case 2

operate = "-"

Case 3

operate = "*"

Case 4

operate = "/"

End Select

End Function

'search过程，去掉数组result中相同的元素，存入数组final中

Private Sub search()

For i = 1 To 24

result(i, 0) = 0

temp(i) = result(i, 1) * 14 ^ 3 + result(i, 2) * 14 ^ 2 + result(i, 3) * 14 + result(i, 4)

Next i

For i = 1 To 23

For j = i + 1 To 24

If temp(i) = temp(j) Then result(i, 0) = 1

Next j

Next i

For i = 1 To 24

If result(i, 0) = 1 Then GoTo 1

t = t + 1

For j = 1 To 4

final(t, j) = result(i, j)

Next j

1 Next i

End Sub

'Main过程，用于计算四个数通过不同运算得到24的所有情况，并输出结果

Private Sub Main()

For op1 = 1 To 4

For op2 = 1 To 4

For op3 = 1 To 4

'1·形如( a @ b ) @ c ) @ d 的表达式

answer1 = answer(cards(1), cards(2), op1)

answer2 = answer(answer1, cards(3), op2)

answer3 = answer(answer2, cards(4), op3)

If answer1 <> -100 And answer2 <> -100 And answer3 <> -100 Then

If Abs(answer3 - 24) < zero Then

nokey = False

total = total + 1

Text1.Text = Text1.Text + "((" + Trim$(Str$(cards(1))) + operate(op1) + Trim$(Str$(cards(2))) + ")" + operate(op2) + Trim$(Str$(cards(3))) + ")" + operate(op3) + Trim$(Str$(cards(4))) + " "

'若本行已有三个式子，就换行

If total Mod 3 = 0 Then

Text1.Text = Text1.Text + Chr$(13) + Chr$(10)

End If

End If

End If

'2·形如( a @ b ) @ (c @ d) 的表达式

answer1 = answer(cards(1), cards(2), op1)

answer2 = answer(cards(3), cards(4), op3)

answer3 = answer(answer1, answer2, op2)

If answer1 <> -100 And answer2 <> -100 And answer3 <> -100 Then

If Abs(answer3 - 24) < zero Then

nokey = False

total = total + 1

Text1.Text = Text1.Text + "(" + Trim$(Str$(cards(1))) + operate(op1) + Trim$(Str$(cards(2))) + ")" + operate(op2) + "(" + Trim$(Str$(cards(3))) + operate(op3) + Trim$(Str$(cards(4))) + ")" + " "

'若本行已有三个式子，就换行

If total Mod 3 = 0 Then

Text1.Text = Text1.Text + Chr$(13) + Chr$(10)

End If

End If

End If

'3·形如( a @ ( b @ c ) ) @ d 的表达式

answer1 = answer(cards(2), cards(3), op2)

answer2 = answer(cards(1), answer1, op1)

answer3 = answer(answer2, cards(4), op3)

If answer1 <> -100 And answer2 <> -100 And answer3 <> -100 Then

If Abs(answer3 - 24) < zero Then

nokey = False

total = total + 1

Text1.Text = Text1.Text + "(" + Trim$(Str$(cards(1))) + operate(op1) + "(" + Trim$(Str$(cards(2))) + operate(op2) + Trim$(Str$(cards(3))) + "))" + operate(op3) + Trim$(Str$(cards(4))) + " "

'若本行已有三个式子，就换行

If total Mod 3 = 0 Then

Text1.Text = Text1.Text + Chr$(13) + Chr$(10)

End If

End If

End If

'4·形如 a @ ( ( b @ c ) @ d ) 的表达式

answer1 = answer(cards(2), cards(3), op2)

answer2 = answer(answer1, cards(4), op3)

answer3 = answer(cards(1), answer2, op1)

If answer1 <> -100 And answer2 <> -100 And answer3 <> -100 Then

If Abs(answer3 - 24) < zero Then

nokey = False

total = total + 1

Text1.Text = Text1.Text + Trim$(Str$(cards(1))) + operate(op1) + "((" + Trim$(Str$(cards(2))) + operate(op2) + Trim$(Str$(cards(3))) + ")" + operate(op3) + Trim$(Str$(cards(4))) + ")" + " "

'若本行已有三个式子，就换行

If total Mod 3 = 0 Then

Text1.Text = Text1.Text + Chr$(13) + Chr$(10)

End If

End If

End If

'5·形如 a @ ( b @ ( c @ d ) ) 的表达式

answer1 = answer(cards(3), cards(4), op3)

answer2 = answer(cards(2), answer1, op2)

answer3 = answer(cards(1), answer2, op1)

If answer1 <> -100 And answer2 <> -100 And answer3 <> -100 Then

If Abs(answer3 - 24) < zero Then

nokey = False

total = total + 1

Text1.Text = Text1.Text + Trim$(Str$(cards(1))) + operate(op1) + "(" + Trim$(Str$(cards(2))) + operate(op2) + "(" + Trim$(Str$(cards(3))) + operate(op3) + Trim$(Str$(cards(4))) + "))" + " "

'若本行已有三个式子，就换行

If total Mod 3 = 0 Then

Text1.Text = Text1.Text + Chr$(13) + Chr$(10)

End If

End If

End If

Next op3

Next op2

Next op1

End Sub

'Card1_MouseDown过程，按左键点击纸牌加1，按右键减1

Private Sub Card1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

Select Case Button

'按左键

Case 1

If card(4) = 13 Then

card(4) = 1

Else

card(4) = card(4) + 1

End If

'按右键

Case 2

If card(4) = 1 Then

card(4) = 13

Else

card(4) = card(4) - 1

End If

End Select

'随机产生变化后的花色

color = Int(Rnd() * 4)

'重画纸牌

Call DrawCard(Me.hwnd, color * 13 + card(4), 10, 10)

End Sub

'Card2_MouseDown过程，按左键点击纸牌加1，按右键减1

Private Sub Card2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

Select Case Button

'按左键

Case 1

If card(3) = 13 Then

card(3) = 1

Else

card(3) = card(3) + 1

End If

'按右键

Case 2

If card(3) = 1 Then

card(3) = 13

Else

card(3) = card(3) - 1

End If

End Select

'随机产生变化后的花色

color = Int(Rnd() * 4)

'重画纸牌

Call DrawCard(Me.hwnd, color * 13 + card(3), 10 + 85, 10)

End Sub

'Card3_MouseDown过程，按左键点击纸牌加1，按右键减1

Private Sub Card3_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

Select Case Button

'按左键

Case 1

If card(2) = 13 Then

card(2) = 1

Else

card(2) = card(2) + 1

End If

'按右键

Case 2

If card(2) = 1 Then

card(2) = 13

Else

card(2) = card(2) - 1

End If

End Select

'随机产生变化后的花色

color = Int(Rnd() * 4)

'重画纸牌

Call DrawCard(Me.hwnd, color * 13 + card(2), 10 + 2 * 85, 10)

End Sub

'Card4_MouseDown过程，按左键点击纸牌加1，按右键减1

Private Sub Card4_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

Select Case Button

'按左键

Case 1

If card(1) = 13 Then

card(1) = 1

Else

card(1) = card(1) + 1

End If

'按右键

Case 2

If card(1) = 1 Then

card(1) = 13

Else

card(1) = card(1) - 1

End If

End Select

'随机产生变化后的花色

color = Int(Rnd() * 4)

'重画纸牌

Call DrawCard(Me.hwnd, color * 13 + card(1), 10 + 3 * 85, 10)

End Sub

'Command1_Click过程，点击洗牌按钮画出纸牌背面

Private Sub Command1_Click()

'随机产生纸牌背面的样式

color = Int(Rnd() * 6 + 1)

'画出纸牌背面

Call DrawBack(Me.hwnd, color, 10, 10)

Call DrawBack(Me.hwnd, color, 95, 10)

Call DrawBack(Me.hwnd, color, 180, 10)

Call DrawBack(Me.hwnd, color, 265, 10)

'禁用答案按钮

Command3.Enabled = False

End Sub

'Command2_Click过程，点击发牌按钮画出随机产生的纸牌

Private Sub Command2_Click()

'清空答案

Text1.Text = ""

'随机产生的纸牌，并画出

For i = 1 To 4

card(i) = Int(Rnd() * 13 + 1)

color = Int(Rnd() * 4)

Call DrawCard(Me.hwnd, color * 13 + card(i), 10 + (4 - i) * 85, 10)

Next i

'开启答案按钮

Command3.Enabled = True

End Sub

'Command3_Click过程，点击答案按钮计算结果

Private Sub Command3_Click()

'清空解的数量

Label1.Caption = ""

'默认设置为无解

nokey = True

'解的计数器清零

total = 0

'临时变量清零

i = 0

j = 0

t = 0

'产生24种全排列

For n1 = 1 To 4

For n2 = 1 To 4

If n2 = n1 Then GoTo 2

For n3 = 1 To 4

If n3 = n1 Or n3 = n2 Then GoTo 3

n4 = 10 - n1 - n2 - n3

i = i + 1

result(i, 1) = card(n1)

result(i, 2) = card(n2)

result(i, 3) = card(n3)

result(i, 4) = card(n4)

3 Next n3

2 Next n2

Next n1

'调用search过程，去掉重复排列

Call search

'调用Main过程,寻找答案

For i = 1 To t

For j = 1 To 4

cards(j) = final(i, j)

Next j

Call Main

Next i

'输出解的情况

If nokey = False Then Label1.Caption = "共有" + Trim$(Str$(total)) + "组解!" Else Label1.Caption = "无解!"

'禁止答案按钮

Command3.Enabled = False

End Sub

五、程序界面