称球问题实现(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,,)