VB:一个2维数组的组合排列

Jan 13th,2006 in Tips

Tag: VB

前几天帮研究室内的先辈编了一个VB程序。先辈的研究课题有一个工作台、员工的一个组合方案。要求输入初始值后能自动生成组合结果，也就是工作台和员工的具体安排方法。也是属于最优化管理里面一个内容吧。自己以后也有可能用上，并且自己目前为止还没实际运用过VB的数组运算还有排列组合，通过这个编程，对数组操作也实际运用了下。还想有时间作个矩阵的加减乘除算法吧。行列数相等的矩阵算法应该是很简单的，运用2个循环就可以解决了。现在问题是如 m*n和n*k之类的行列数目不相等矩阵的算法还不明白，过几天有空看下矩阵运算的书后再编吧。这东西我想以后自己的研究肯定会用的上的。其实对于编程，我觉得关键是掌握算法，对于具体用什么语言来编，这都无所谓。因为语言只是算法的一个表现而已了。各个语言的区别只是在于语法的不同，他们实现的功能都是一样的（就是你的目的）。具体内容就是一个2维数组的排列组合问题。
有这个一个2×5数组，如
1 1 1 1 0
1 0 0 1 1，初始值可任意输入，元素全部由0和1组成。上下行中可允许存在1和1，但不允许同时有0和0存在。求这个数组的排列组合。
条件，
a.上下2个元素的和必须为1，即上行为1，下行必须为0，或下行为1，上行必须为0。
b.初始值为0的列，不能变化，如初始值为
1 1 1 1 0
1 0 0 1 1，意味，第2，3，5列的位置不能变化，该数组的有效组合有4个。分别为：
1 1 1 1 0
0 0 0 0 1，

1 1 1 0 0
0 0 0 1 1，

0 1 1 1 0
1 0 0 0 1，

0 1 1 0 0
1 0 0 1 1。
换句话说，初始值中0的位置，决定了可产生有效组合的数量，有效组合数量＝2^(5-0的个数)。如，初始值中有2个0，则可产生排列数组有8个，1个0的话，可产生16个，如果没有0的话，产生32个。

目的是就是求给定一个初始值，能产生多少个数组。
如给定初始值为：
11011
01111或
01111
10111之类的，求能产生多少个类似
11011
00100的组合，条件就是
a.上下2个元素的和必须为1，即上行为1，下行必须为0，或下行为1，上行必须为0。
b.初始值为0的列，不能变化，如初始值为
1 1 1 1 0
1 0 0 1 1，意味，第2，3，5列的位置不能变化，该数组的有效组合有4个。

虽然还是自己弄出来了。但是觉得算法不是很好。个人感觉这个不是计算机在算，是自己算好后，强加上去的。没法了，先凑合吧。
思路是，先判断列中1的位置，然后用几个变量记住。并获得总数。然后将原始数据（可能包括非法数据），格式成上1，下0，用一个数组存放。接着判断1的总数，然后在这个数组基础上输出可变组合。判断可变列的总数；
如果是0，无可变列，代表输入初始值有问题，
如果是1，代表有2个可变组合。用一个循环获得含1的列号，然后输出1，0和0，1，2个组合变化。
如果是2，代表有4个可变组合。用2个循环来解决，第一循环找第一个可变列1的列号，然后在此基础上进行第二个循环找第二个可变列1的列号，分别变化，输出可变数组。
如果是3，代表有8个可变组合。如果用循环，判断就太罗嗦复杂了。于是简单点，设置n1，n2，n3分别代表3个可变列的列号，然后设置一个循环从1-5，分别设置3个判断，当循环到n1，n2，n3的时候分别设置变化，输出可变数组。
如果是4，代表有16个可变组合。用上面的方法解决。
如果是5，则是全变化，32个可变组合。由于不存在不可变列。就分别对元素进行变化，输出。

具体代码：

Option Explicit
Dim Oarray(1, 4) As Integer ‘original array value
Dim Sarray() As String ’set of combined array
Dim n As Integer ‘number of combinability array
Dim x As Integer ‘number of original array value 0
Dim z(4) As Integer ’set of position of 0 in original array, use as hand

Private Sub cmdinput_Click()
Dim i As Integer
Dim j As Integer

For i = 0 To 4 ‘get original value
Oarray(0, i) = Val(Text1(i).Text)
Oarray(1, i) = Val(Text2(i).Text)
Next i

For i = 0 To 4 ’set z()=1
z(i) = 1
Next i

x = 0
For i = 0 To 1
For j = 0 To 4
If Oarray(i, j) = 0 Then
z(j) = Oarray(i, j)
x = x + 1
End If
Next j
Next i

If x < 5 Then
n = 2 ^ (5 – x)
Label3.Caption = n ‘calculate number of combinability arrays
Else
n = 0
Label3.Caption = n
MsgBox (“no combinability arrays, input error. Please check data.”)
Exit Sub
End If

ReDim Sarray(n – 1) ‘redim Sarray
For i = 0 To n – 1
Sarray(i) = “”
Next i

End Sub

Private Sub cmdcalculate_Click()
Dim one As Integer
Dim i As Integer
Dim j As Integer
Dim m As Integer ‘Sarray(m)
Dim n1 As Integer
Dim n2 As Integer
Dim n3 As Integer
Dim n4 As Integer
Dim T1(1, 4) As Integer
Dim T2(1, 4) As Integer
Dim tz(4) As Integer

one = 5 – x

Call value2(z(), tz(), 4)
Call value1(Oarray(), T1(), 1, 4)
For i = 0 To 4
If tz(i) = 1 Then
T1(0, i) = 1
T1(1, i) = 0
End If
Next i
Call value1(T1(), T2(), 1, 4)
‘MsgBox (output1(1, 4, T2()))

Select Case one
Case 0
MsgBox (“no combinability arrays, input error. Please check data.”)

Case 1
For i = 0 To 4
If tz(i) = 1 Then
Sarray(0) = output1(1, 4, T2())
T2(0, i) = 0
T2(1, i) = 1
Sarray(1) = output1(1, 4, T2())
‘MsgBox (output3(1, Sarray()))
End If
Next i

Case 2
‘MsgBox (output2(4, tz()))
m = 0
Sarray(m) = output1(1, 4, T2())
m = m + 1
For i = 0 To 4
If tz(i) = 1 Then
n1 = i
For j = n1 + 1 To 4
If tz(j) = 1 Then
T2(0, j) = 0
T2(1, j) = 1
Sarray(m) = output1(1, 4, T2())
‘MsgBox (m & vbCrLf & output1(1, 4, T2()))
Call value1(T1(), T2(), 1, 4)
m = m + 1
End If
Next j

T2(0, i) = 0
T2(1, i) = 1
Sarray(m) = output1(1, 4, T2())
‘MsgBox (m & vbCrLf & output1(1, 4, T2()))
m = m + 1
End If
Next i

Case 3
n1 = 0
n2 = 0
n3 = 0

For i = 0 To 4
If tz(i) = 1 Then
If n1 = 0 Then
n1 = i + 1
Else
If n2 = 0 Then
n2 = i + 1
Else
n3 = i + 1
End If
End If
End If
Next i
n1 = n1 – 1
n2 = n2 – 1
n3 = n3 – 1

m = 0
Sarray(m) = output1(1, 4, T2())
m = m + 1

For i = 0 To 4
If i = n1 Then
Call value1(T1(), T2(), 1, 4)
T2(0, i) = 0
T2(1, i) = 1
Sarray(m) = output1(1, 4, T2())
m = m + 1

T2(0, n2) = 0
T2(1, n2) = 1
Sarray(m) = output1(1, 4, T2())
m = m + 1

T2(0, n3) = 0
T2(1, n3) = 1
Sarray(m) = output1(1, 4, T2())
m = m + 1

T2(0, n2) = 1
T2(1, n2) = 0
Sarray(m) = output1(1, 4, T2())
m = m + 1
End If

If i = n2 Then
Call value1(T1(), T2(), 1, 4)
T2(0, i) = 0
T2(1, i) = 1
Sarray(m) = output1(1, 4, T2())
m = m + 1

T2(0, n3) = 0
T2(1, n3) = 1
Sarray(m) = output1(1, 4, T2())
m = m + 1
End If

If i = n3 Then
Call value1(T1(), T2(), 1, 4)
T2(0, i) = 0
T2(1, i) = 1
Sarray(m) = output1(1, 4, T2())
End If
Next i

Case 4
n1 = 0
n2 = 0
n3 = 0
n4 = 0

For i = 0 To 4
If tz(i) = 1 Then
If n1 = 0 Then
n1 = i + 1
Else
If n2 = 0 Then
n2 = i + 1
Else
If n3 = 0 Then
n3 = i + 1
Else
n4 = i + 1
End If
End If
End If
End If
Next i
n1 = n1 – 1
n2 = n2 – 1
n3 = n3 – 1
n4 = n4 – 1
m = 0
Sarray(m) = output1(1, 4, T2())
m = m + 1

For i = 0 To 4
If i = n1 Then
Call value1(T1(), T2(), 1, 4)
T2(0, i) = 0
T2(1, i) = 1
Sarray(m) = output1(1, 4, T2())
m = m + 1

T2(0, n2) = 0
T2(1, n2) = 1
Sarray(m) = output1(1, 4, T2())
m = m + 1

T2(0, n3) = 0
T2(1, n3) = 1
Sarray(m) = output1(1, 4, T2())
m = m + 1

T2(0, n4) = 0
T2(1, n4) = 1
Sarray(m) = output1(1, 4, T2())
m = m + 1

T2(0, n3) = 1
T2(1, n3) = 0
Sarray(m) = output1(1, 4, T2())
m = m + 1

T2(0, n2) = 1
T2(1, n2) = 0
T2(0, n3) = 0
T2(1, n3) = 1
T2(0, n4) = 1
T2(1, n4) = 0
Sarray(m) = output1(1, 4, T2())
m = m + 1

T2(0, n4) = 0
T2(1, n4) = 1
Sarray(m) = output1(1, 4, T2())
m = m + 1

T2(0, n3) = 1
T2(1, n3) = 0
Sarray(m) = output1(1, 4, T2())
m = m + 1
End If

If i = n2 Then
Call value1(T1(), T2(), 1, 4)
T2(0, i) = 0
T2(1, i) = 1
Sarray(m) = output1(1, 4, T2())
m = m + 1

T2(0, n3) = 0
T2(1, n3) = 1
Sarray(m) = output1(1, 4, T2())
m = m + 1

T2(0, n4) = 0
T2(1, n4) = 1
Sarray(m) = output1(1, 4, T2())
m = m + 1

T2(0, n3) = 1
T2(1, n3) = 0
Sarray(m) = output1(1, 4, T2())
m = m + 1
End If

If i = n3 Then
Call value1(T1(), T2(), 1, 4)
T2(0, i) = 0
T2(0, i) = 1
Sarray(m) = output1(1, 4, T2())
m = m + 1

T2(0, n4) = 0
T2(1, n4) = 1
Sarray(m) = output1(1, 4, T2())
m = m + 1
End If

If i = n4 Then
Call value1(T1(), T2(), 1, 4)
T2(0, i) = 0
T2(1, i) = 1
Sarray(m) = output1(1, 4, T2())
End If
Next i
Case 5
Sarray(0) = “1,1,1,1,1″ & vbCrLf & “0,0,0,0,0″
Sarray(1) = “0,1,1,1,1″ & vbCrLf & “1,0,0,0,0″
Sarray(2) = “0,0,1,1,1″ & vbCrLf & “1,1,0,0,0″
Sarray(3) = “0,0,0,1,1″ & vbCrLf & “1,1,1,0,0″
Sarray(4) = “0,0,0,0,1″ & vbCrLf & “1,1,1,1,0″
Sarray(5) = “0,0,0,0,0″ & vbCrLf & “1,1,1,1,1″
Sarray(6) = “0,0,0,1,0″ & vbCrLf & “1,1,1,0,1″
Sarray(7) = “0,0,1,0,1″ & vbCrLf & “1,1,0,1,0″
Sarray(8) = “0,0,1,1,0″ & vbCrLf & “1,1,0,0,1″
Sarray(9) = “0,0,1,0,0″ & vbCrLf & “1,1,0,1,1″
Sarray(10) = “0,1,0,1,1″ & vbCrLf & “1,0,1,0,0″
Sarray(11) = “0,1,0,0,1″ & vbCrLf & “1,0,1,1,0″
Sarray(12) = “0,1,0,0,0″ & vbCrLf & “1,0,1,1,1″
Sarray(13) = “0,1,0,1,0″ & vbCrLf & “1,0,1,0,1″
Sarray(14) = “0,1,0,1,1″ & vbCrLf & “1,0,1,0,0″

Sarray(15) = “0,1,1,1,0″ & vbCrLf & “1,0,0,0,1″
Sarray(16) = “0,1,1,0,1″ & vbCrLf & “1,0,0,1,0″

Sarray(17) = “1,0,1,1,1″ & vbCrLf & “0,1,0,0,0″
Sarray(18) = “1,0,0,1,1″ & vbCrLf & “0,1,1,0,0″
Sarray(19) = “1,0,0,0,1″ & vbCrLf & “0,1,1,1,0″
Sarray(20) = “1,0,0,0,0″ & vbCrLf & “0,1,1,1,1″
Sarray(21) = “1,0,0,1,0″ & vbCrLf & “0,1,1,0,1″
Sarray(22) = “1,0,1,0,1″ & vbCrLf & “0,1,0,1,0″
Sarray(23) = “1,0,1,0,0″ & vbCrLf & “0,1,0,1,1″
Sarray(24) = “1,0,1,1,0″ & vbCrLf & “0,1,0,0,1″

Sarray(25) = “1,1,0,1,1″ & vbCrLf & “0,0,1,0,0″
Sarray(26) = “1,1,0,0,1″ & vbCrLf & “0,0,1,1,0″
Sarray(27) = “1,1,0,0,0″ & vbCrLf & “0,0,1,1,1″
Sarray(28) = “1,1,0,1,0″ & vbCrLf & “0,0,1,0,1″

Sarray(29) = “1,1,1,0,1″ & vbCrLf & “0,0,0,1,0″
Sarray(30) = “1,1,1,0,0″ & vbCrLf & “0,0,0,1,1″

Sarray(31) = “1,1,1,1,0″ & vbCrLf & “0,0,0,0,1″

End Select
End Sub
Private Sub cmddisplay_Click()
Dim b As String
b = output3(n – 1, Sarray())
MsgBox (b)
End Sub

Private Sub cmdtofile_Click()
Dim i As Integer
Dim a, b
Open App.Path & “\output.txt” For Output As 1#
For i = 0 To n – 1 Step 1
a = “No.” & i + 1 & vbCrLf & Sarray(i) & vbCrLf
Print #1, a
Next i
b = “Total output ” & n & ” arrays”
MsgBox b
Close #1
End Sub

Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
If KeyAscii < 48 Or KeyAscii > 49 Then
MsgBox (“input 0 or 1″)
KeyAscii = 0
End If
End Sub

Private Sub Text2_KeyPress(Index As Integer, KeyAscii As Integer)
If KeyAscii < 48 Or KeyAscii > 49 Then
MsgBox (“input 0 or 1″)
KeyAscii = 0
End If
End Sub

Private Function output1(i As Integer, j As Integer, a() As Integer) As String
Dim b As String ‘ output i*j matric to string
Dim m, n As Integer
For m = 0 To i
For n = 0 To j
If m > 0 And n = 0 Then
b = b & vbCrLf & a(m, n)
Else
If b = “” Then
b = a(m, n)
Else
b = b & “,” & a(m, n)
End If
End If
Next n
Next m
output1 = b
End Function
Private Function output2(i As Integer, a() As Integer) As String
Dim b As String ‘output array(i) to string
Dim m As Integer
For m = 0 To i
If m = 0 Then
b = a(m)
Else
b = b & “,” & a(m)
End If
Next m
output2 = b
End Function

Private Function output3(i As Integer, a() As String) As String
Dim b As String ‘output array(i) to string
Dim m As Integer
For m = 0 To i
If m = 0 Then
b = a(m)
Else
b = b & vbCrLf & vbCrLf & a(m)
End If
Next m
output3 = b
End Function

Private Function value1(a() As Integer, b() As Integer, i As Integer, j As Integer) As Integer
Dim m, n As Integer
For m = 0 To i
For n = 0 To j
b(m, n) = a(m, n)
Next n
Next m
End Function

Private Function value2(a() As Integer, b() As Integer, i As Integer) As Integer
Dim m As Integer
For m = 0 To i
b(m) = a(m)
Next m
End Function

转载文章请注明转载自：ThinkAgain - Let's Blog!

引用地址：http://www.thinkagain.cn/archives/37.html

发表一条评论

姓名 (必填) 没搞错，自己的名字也会忘记？Oops，是火星人！

Email (不会被公开) (必填) 火星人，地球人也可以用email和你联系！

网站火星人有没有网址，有的话就填吧！

XHTML: 您可以使用如下标签: <a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <strike> <strong>

可是我看不懂火星语，只好委屈你学地球语了，不会中文？英文呢？要不日文吧！

注意: 评论者允许使用'@user空格'的方式将自己的评论通知另外评论者。例如， ABC是本文的评论者之一，则使用'@ABC '(不包括单引号)将会自动将您的评论发送给ABC。使用'@all '，将会将评论发送给之前所有其它评论者。请务必注意user必须和评论者名相匹配(大小写一致)。或者，简单地按下@图片就可以啦。