本程序目的就是算出壹組牌的所有解(不同形式的式子算不同解),如沒有則輸出無解.
算法說明
首先解決圖形撲克牌的顯示問題.我選擇了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.
附:其他待決的問題:
圖形撲克牌的遮擋問題.當窗口中的撲克牌被遮擋後,撲克牌不會重新畫上,造成撲克牌遮擋後顯示不全問題.應尋找Qcard.dll的有關參數.
形式不同而實質相同的解的問題.有些解雖然形式不同,但其實質是完全相同的.如3*((11+4)-7)和3*(11+(4-7)),實際上只是壹種解.去掉這些相同解的問題情況較多,其較為繁瑣,有待解決.
多余括號好問題.有些解的括號是多余的,應在輸出前去掉.
改進程序的可玩性.增加玩家輸入表達式的功能,並判斷對錯,還可以加上時間限制,使玩家參與到遊戲中.
程序框圖
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
五,程序界面
N
Y
比較temp(i)與temp(j)是否相等
For j=i+1 to 24
For i=1 to 23
初始化變量,數組
For i=1 to 24
初始化重復排列的標誌result(1..24,0)=0
排列存入數組result(1..24,1..4)
全排列循環終止
3重循環產生24種全排列
隨機產生四張撲克牌
將全排列所對應的十進制數存入temp(1..24)
Next i
設置重復排列的標誌result(i,0)=1
計數器t=t+1
Next j
Next i
結束
輸出解的個數或無解
結束循環final中的排列
計算形如 a @ ( b @ ( c @ d ) ) 的表達式
如等於24則輸出
計算形如 a @ ( ( b @ c ) @ d ) 的表達式
如等於24則輸出
計算形如( a @ ( b @ c ) ) @ d的表達式
如等於24則輸出
計算形如( a @ b ) @ ( c @ d ) 的表達式
如等於24則輸出
計算形如( a @ b ) @ c ) @ d 的表達式
如等於24則輸出
結束循環3個運算符
循環3個運算符
循環final中的全部排列
Next i
把result存入final
Y
N
檢驗result(i,0)標誌
是否為1
For i=1 to t