这是一个使用VB编程解决经典称球问题的程序，目标是在三次称量内确定十二个外观相同但有一个重量不同的球。通过分块穷举法和递归调用来确定不同情况下的球重，确保在三次称量后能确定哪个球是坏球以及其重量状态。
VB源码供大家参考
这个程序编起来挺麻烦的，goto都用上了
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 6960
ClientLeft = 165
ClientTop = 735
ClientWidth = 9900
LinkTopic = "Form1"
ScaleHeight = 6960
ScaleWidth = 9900
StartUpPosition = 3 'Windows Default
Begin VB.TextBox Text1
Height = 6840
Left = 30
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 0
Top = 60
Width = 9840
End
Begin VB.Menu start
Caption = "start"
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'问题描述：
'有十二个外表相同的球，其中有一个坏球，它的重量和其它十
'一个有轻微的（但是可以测量出来的）差别。现在有一架没有砝码的
'很灵敏的天平，问如何称三次就保证找出那个坏球，并知道它比标准
'球重还是轻。
Option Explicit
'分块穷举法
Dim BallData(3, 2, 5) As Long '各次取球数据,最多取5个
Dim WeightResult(3) As Long '3次称球结果 -1 左轻 0 相等 1 左重
Private Ball(12) As Long ' 小球重 ,值为0 、1 或 -1 ,分别表示正常球 比其它球重 比其它球轻
Private BallValue(12) As Long ' 冲突检测值 第一取球前置1，取球值后左＋10，右＋100 第二次取值后左+1000 右+10000
Private PartCount As Long '分组数
Private PartArray(12, 12) As Long '各组小球数据
Private PartNum(12) As Long '各组小球个数
Private PartGeted(12) As Long '各组已被取的小球个数
Private PartGeted2(12) As Long '各组已被取的小球个数
Private BallNum As Long, GetedNum As Long
'需要定义3个以避免数据冲突
Private ArrayDataCount(3) As Long
Private ArrayData(3, 10000, 2, 5) As Long
Private Get1 As Long, Get2 As Long
Private ResultArray(3, 3, 3, 2, 5) As Long '存放3次取值结果
'为了减少变量个数，使用多维数组，各维表示次数、WeightResult(1)、WeightResult(2)、L/R、BallData
'有效数据为 (1 1 1)
' (2 1 1) (2 2 1) (2 3 1)
' (311 312 313) (321 322 323) (331 332 333)
Private Sub Form_Resize()
Text1.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight
End Sub
Private Sub start_Click() 'ok
MainProc (0)
End Sub
Public Function MainProc(ByVal iStep As Long) As Boolean
'启动 MainProc(0)
Dim i As Long, j As Long, k As Long
Dim Num As Long, Sum As Long, OK As Boolean
MainProc = False
Num = GetNum(iStep) '基于0
If Num > 3 ^ (3 - iStep) Then Exit Function
iStep = iStep + 1
GetArray iStep
For i = 1 To ArrayDataCount(iStep) '基于1,取1 2 3共3组小球
'合法检测
Call SetArray(iStep, i) '设置取球数据BallData(iStep,,)
WeightResult(iStep) = -1 '设置结果 WeightResult(iStep)
Num = GetNum(iStep)
If Num > 3 ^ (3 - iStep) Then GoTo nexti
WeightResult(iStep) = 0
Num = GetNum(iStep)
If Num > 3 ^ (3 - iStep) Then GoTo nexti
WeightResult(iStep) = 1
Num = GetNum(iStep)
If Num > 3 ^ (3 - iStep) Then GoTo nexti
If iStep < 3 Then '没有取满
WeightResult(iStep) = -1 '设置结果
If Not MainProc(iStep) Then GoTo nexti
WeightResult(iStep) = 0
If Not MainProc(iStep) Then GoTo nexti
WeightResult(iStep) = 1
If Not MainProc(iStep) Then GoTo nexti
End If
Call SetResult(iStep, i) ' 根据iStep、BallData(iStep,,)、WeightResult(iStep)设置取球结果(13对)
MainProc = True
If iStep = 1 Then
PrintResult
End If
Exit Function '这里不退出，并且SetResult改为保存所有取法，即可得到所有组合
nexti:
Next i
End Function
'Completed
Public Function GetNum(ByVal iStep As Long) As Long
'根据BallData(3, 2, 5)、WeightResult取得需要推出的结果数
'第一次取球为GetNum(0)=24
Dim i As Long, j As Long, k As Long
Dim Num As Long, Sum As Long, OK As Boolean
For i = 0 To 12: Ball(i) = 0: Next
Num = 24 '最多24个符合
For i = 1 To 12
Ball(i - 1) = 0
Ball(i) = 1 '第i个球重
For k = 1 To iStep
Sum = 0
For j = 1 To 5
Sum = Sum + Ball(BallData(k, 1, j)) - Ball(BallData(k, 2, j))
Next
If Sum <> WeightResult(k) Then
Num = Num - 1
Exit For
End If
Next
Next i
Ball(12) = 0
For i = 1 To 12
Ball(i - 1) = 0
Ball(i) = -1 '第i个球重
For k = 1 To iStep
Sum = 0
For j = 1 To 5
Sum = Sum + Ball(BallData(k, 1, j)) - Ball(BallData(k, 2, j))
Next
If Sum <> WeightResult(k) Then
Num = Num - 1
Exit For
End If
Next
Next i
GetNum = Num
End Function
'Completed
Public Function GetArray(ByVal iStep As Long) '根据前iStep次取球，列出所有不重复取球组合
Dim i As Long, j As Long
Dim OK As Boolean
SetBall iStep - 1
GetPart
ArrayDataCount(iStep) = 0
For i = 1 To 5
BallNum = i
GetArrayByNum iStep, 1, i
Next i
End Function
'Completed
Public Function GetArrayByNum(ByVal iStep As Long, ByVal Part As Long, ByVal Num As Long) As Boolean
Dim i As Long, j As Long
Dim OK As Boolean
PartGeted(Part) = 0
If Num = 0 Then '结束
GetedNum = 0
For i = 1 To Part - 1
For j = 1 To PartGeted(i)
GetedNum = GetedNum + 1
ArrayData(iStep, 0, 1, GetedNum) = PartArray(i, j) '临时存放于ArrayData(iStep, 0, 1,）
Next j
Next i
GetArrayByNum2 iStep, 1, BallNum
Exit Function
End If
If Part > PartCount Or Num < 0 Then
Exit Function
End If
For i = 0 To 5
If i <= PartNum(Part) Then
PartGeted(Part) = i
GetArrayByNum iStep, Part + 1, Num - i
Else
Exit For
End If
Next i
End Function
'Completed
Public Function GetArrayByNum2(ByVal iStep As Long, ByVal Part As Long, ByVal Num As Long) As Boolean
Dim i As Long, j As Long
Dim OK As Boolean
PartGeted2(Part) = 0
If Num = 0 Then '结束
ArrayDataCount(iStep) = ArrayDataCount(iStep) + 1
GetedNum = 0
For i = 0 To 5
ArrayData(iStep, ArrayDataCount(iStep), 1, i) = 0
ArrayData(iStep, ArrayDataCount(iStep), 2, i) = 0
Next i
For i = 1 To Part - 1
For j = 1 To PartGeted2(i)
GetedNum = GetedNum + 1
ArrayData(iStep, ArrayDataCount(iStep), 1, GetedNum) = ArrayData(iStep, 0, 1, GetedNum)
ArrayData(iStep, ArrayDataCount(iStep), 2, GetedNum) = PartArray(i, j + PartGeted(i))
Next j
Next i
Exit Function
End If
If Part > PartCount Or Num < 0 Then
Exit Function
End If
For i = 0 To 5
If i <= PartNum(Part) - PartGeted(Part) Then
PartGeted2(Part) = i
GetArrayByNum2 iStep, Part + 1, Num - i
Else
Exit For
End If
Next i
End Function
'Completed
Public Function GetPart() '根据BallValue取得分组数据
Dim i As Long, j As Long
Dim OK As Boolean
PartCount = 0
For i = 1 To 12
OK = False
For j = 1 To PartCount
If BallValue(PartArray(j, 1)) = BallValue(i) Then
OK = True
PartNum(j) = PartNum(j) + 1
PartArray(j, PartNum(j)) = i
Exit For
End If
Next
If Not OK Then
PartCount = PartCount + 1
PartNum(PartCount) = 1
PartArray(PartCount, 1) = i
End If
Next
End Function
'Completed
Public Function SetBall(iStep As Long) '设置BallValue（12)
Dim i As Long, j As Long
Dim Value As Long
For i = 1 To 12
BallValue(i) = 1
Next i
For i = 1 To iStep
Value = 100 ^ i / 10
If WeightResult(i) = 0 Then
For j = 1 To 5
BallValue(BallData(i, 1, j)) = BallValue(BallData(i, 1, j)) + Value
BallValue(BallData(i, 2, j)) = BallValue(BallData(i, 2, j)) + Value
Next
Else
For j = 1 To 5
BallValue(BallData(i, 1, j)) = BallValue(BallData(i, 1, j)) + Value
BallValue(BallData(i, 2, j)) = BallValue(BallData(i, 2, j)) + Value * 10
Next
End If
Next
End Function
'未测试
Public Sub SetArray(ByVal iStep As Long, ByVal Num As Long)
'设置取球数据BallData(iStep,,)
Dim i As Long, j As Long
For i = 1 To 5
BallData(iStep, 1, i) = ArrayData(iStep, Num, 1, i)
BallData(iStep, 2, i) = ArrayData(iStep, Num, 2, i)
Next i
End Sub
Public Sub SetResult(ByVal iStep As Long, ByVal Num As Long)
'设置取数结果
Dim i As Long, j As Long
If iStep = 1 Then
For i = 1 To 5
ResultArray(1, 1, 1, 1, i) = ArrayData(iStep, Num, 1, i)
ResultArray(1, 1, 1, 2, i) = ArrayData(iStep, Num, 2, i)
Next
ElseIf iStep = 2 Then
For i = 1 To 5
ResultArray(2, WeightResult(1) + 2, 1, 1, i) = ArrayData(iStep, Num, 1, i)
ResultArray(2, WeightResult(1) + 2, 1, 2, i) = ArrayData(iStep, Num, 2, i)
Next
ElseIf iStep = 3 Then
For i = 1 To 5
ResultArray(3, WeightResult(1) + 2, WeightResult(2) + 2, 1, i) = ArrayData(iStep, Num, 1, i)
ResultArray(3, WeightResult(1) + 2, WeightResult(2) + 2, 2, i) = ArrayData(iStep, Num, 2, i)
Next
End If
End Sub
'输出结果
Public Function PrintResult()
Dim ls As String, rs As String, s As Variant
Dim i As Long, j As Long, k As Long
Const SP As Long = 30
s = Array("<", "=", ">")
' 1
ls = "": rs = ""
For i = 1 To 5
BallData(1, 1, i) = ResultArray(1, 1, 1, 1, i)
BallData(1, 2, i) = ResultArray(1, 1, 1, 2, i)
If ResultArray(1, 1, 1, 1, i) <> 0 Then
ls = ls & ResultArray(1, 1, 1, 1, i)
rs = rs & ResultArray(1, 1, 1, 2, i)
End If
Next i
Text1.Text = Text1.Text & ls & " V " & rs & vbCrLf
For i = 1 To 3
WeightResult(1) = i - 2
ls = "": rs = ""
For j = 1 To 5
BallData(2, 1, j) = ResultArray(2, i, 1, 1, j)
BallData(2, 2, j) = ResultArray(2, i, 1, 2, j)
If ResultArray(2, i, 1, 1, j) <> 0 Then
ls = ls & ResultArray(2, i, 1, 1, j)
rs = rs & ResultArray(2, i, 1, 2, j)
End If
Next j
Text1.Text = Text1.Text & Space(SP) & s(WeightResult(1) + 1) & ls & " V " & rs & vbCrLf
For j = 1 To 3
WeightResult(2) = j - 2
ls = "": rs = ""
For k = 1 To 5
BallData(3, 1, k) = ResultArray(3, i, j, 1, k)
BallData(3, 2, k) = ResultArray(3, i, j, 2, k)
If ResultArray(3, i, j, 1, k) <> 0 Then
ls = ls & ResultArray(3, i, j, 1, k)
rs = rs & ResultArray(3, i, j, 2, k)
End If
Next
Text1.Text = Text1.Text & Space(SP * 2) & s(WeightResult(2) + 1) & ls & " V " & rs & vbCrLf
For k = 1 To 3
WeightResult(3) = k - 2
Text1.Text = Text1.Text & Space(SP * 3) & s(WeightResult(3) + 1) & GetResultString & vbCrLf
Next k
Next
Next i
End Function
Public Function GetResultString() As String
Dim i As Long, j As Long, k As Long
Dim Sum As Long, OK As Boolean
For i = 0 To 12: Ball(i) = 0: Next
For i = 1 To 12
Ball(i - 1) = 0: Ball(i) = 1
OK = True
For k = 1 To 3
Sum = 0
For j = 1 To 5
Sum = Sum + Ball(BallData(k, 1, j)) - Ball(BallData(k, 2, j))
Next
If Sum <> WeightResult(k) Then
OK = False
Exit For
End If
Next
If OK Then GetResultString = "第" & i & "号球重"
Next i
Ball(12) = 0
For i = 1 To 12
Ball(i - 1) = 0: Ball(i) = -1
OK = True
For k = 1 To 3
Sum = 0
For j = 1 To 5
Sum = Sum + Ball(BallData(k, 1, j)) - Ball(BallData(k, 2, j))
Next
If Sum <> WeightResult(k) Then
OK = False
Exit For
End If
Next
If OK Then GetResultString = "第" & i & "号球轻"
Next i
If GetResultString = vbNullString Then GetResultString = "==========不可能"
End Function
扫一扫
1661
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
