德国开元华人社区开元周游

标题: 构造相邻矩阵的代码(vb.net) [打印本页]

作者: zansan 时间: 3.5.2006 00:23
玩彩票的人大概用过旋转矩阵,现在这些矩阵是固定的. 下面的代码可以将一个矩阵的所有相邻矩阵找出.现在好象还没有哪个软件作到这一步. 我的英语不好,如果有什么问题请与我联系: XUZIJIEWZ@YAHOO.COM.CN

ublic Class closewheel 'If you have a wheel name "firwheel". the "firwheel" is of "M pick N" and "L if K". 'Then you can use this class to get all close wheel of "firwheel". 'those close wheels differ from "firwheel" at only one line. 'in fact there are some close wheels to "firwheel". ' 'How to use the class? '1,dim a new object myclosewheel: dim myclosewheel as new closewheel '2,initialize the object myclosewheel: myclosewheel.inims(m,n,k,l) '3,get you close wheels eith myclosewheel: myclosewheel.getwheel(firwheel,endwheel) 'must run at the order. or it will do wrong. ' 'the firwheel is 2 dimension array. it include some lines. 'exp: ' the wheel include 3 lines. (1 2 3 4) (2 3 4 5) ( 1 3 4 6) ' the firwheel is : 1 2 3 4 ' 2 3 4 5 ' 1 3 4 6 ' 'the endwheel is 3 dimension array. the modul is : endwheel(the i wheel, the j line, the k number) ' 'the class can be ameliorated to do other thing. ' 'i must provide for exam, so i had not debug it. the principle is not difficult to know. you can debug it. ' ' good luck! 'MAIL: xuzijiewz@yahoo.com.cn

rivate Shared ms(,,,,) As Integer

rivate Shared MYM As Byte

rivate Shared MYN As Byte

rivate Shared MYK As Byte Private Shared MYL As Byte Public Sub inims(ByVal M As Byte, ByVal N As Byte, ByVal K As Byte, ByVal L As Byte) If M < N Or N < K Or K < L Or L < 1 Then MsgBox("there is somee wrong with input wheel .", MsgBoxStyle.OKOnly, "CLOSE LOTTO WHEEL") Exit Sub End If Dim I1 As Integer, I2 As Integer, IWS As Long = 1 MYM = M : MYK = K : MYN = N : MYL = L If L < M / 2 And N > M / 2 Then I2 = Int(M / 2) ElseIf L > M / 2 Then I2 = L ElseIf N < M / 2 Then I2 = N End If For I1 = 1 To I2 IWS = IWS * (M - I1 + 1) / I1 Next ReDim ms(M, 1, 1, IWS, N - 1) For I1 = L To K Call creams(N, I1, 1, 1) Call creams(M - N, N - I1, 1, 0) Call creams(K, I1, 0, 1) Call creams(M - K, K - I1, 0, 0) Next End Sub Public Sub GETWHEEL(ByVal INWHEEL(,) As Byte, ByRef OUTWHEEL(,,) As Byte) Dim FIRWHEEL(UBound(INWHEEL, 1), MYN - 1) As Byte, I As Byte, MIDLINES(,) As Byte, ENDLINES(,) As Byte, i1 As Byte, I2 As Byte, I3 As Byte, IWHEEL As Integer = -1 For I = 0 To UBound(INWHEEL, 1) For i1 = 0 To MYN - 1 FIRWHEEL(I, i1) = INWHEEL(I, i1) - 1 Next Next For I = 0 To UBound(INWHEEL, 1) 10: i1 = 0 For I2 = 0 To MYN - 1 If FIRWHEEL(I, I2) = FIRWHEEL(I, I2 + 1) Then MsgBox("there is somee wrong with input wheel.", MsgBoxStyle.OKOnly, "CLOSE LOTTO WHEEL") Exit Sub ElseIf FIRWHEEL(I, I2) > FIRWHEEL(I, I2 + 1) Then I3 = FIRWHEEL(I, I2) FIRWHEEL(I, I2) = FIRWHEEL(I, I2 + 1) FIRWHEEL(I, I2 + 1) = I3 i1 = i1 + 1 End If Next If i1 > 0 Then GoTo 10 Next For I = 0 To UBound(INWHEEL, 1) Call FIT(FIRWHEEL, I, 1, MIDLINES) Call FIT(MIDLINES, 1, 0, ENDLINES) For i1 = 0 To UBound(ENDLINES, 1) For I2 = 0 To MYN - 1 If FIRWHEEL(I, I2) <> ENDLINES(i1, I2) Then GoTo 100 Next GoTo 200 100: ReDim Preserve OUTWHEEL(IWHEEL + 1, UBound(FIRWHEEL, 1), MYN - 1) For I2 = 0 To UBound(FIRWHEEL, 1) For I3 = 0 To MYN - 1 OUTWHEEL(IWHEEL, I2, I3) = FIRWHEEL(I2, I3) + 1 Next Next For I3 = 0 To MYN - 1 OUTWHEEL(IWHEEL, I, I3) = ENDLINES(i1, I3) + 1 Next IWHEEL = IWHEEL + 1 200: Next Next End Sub Private Sub FIT(ByVal INWHEEL1(,) As Byte, ByVal IN1 As Byte, ByVal IN2 As Byte, ByRef OUTLINES(,) As Byte) Dim LINES(UBound(INWHEEL1, 2)) As Byte, OTHERNUM(MYM - 1) As Byte, OTHERNUM1(MYM - 1) As Integer Dim I As Byte, i1 As Long, I2 As Long, I3 As Long, I4 As Byte, i5 As Byte, IFJ As Long, IBC As Byte, IBCI As Long, i6 As Byte, i7 As Byte Dim LINEFJ(MYN) As Byte, LINEBC(MYN) As Byte, LINE(MYN) As Byte, ILINES As Integer = -1 For I = 0 To MYM - 1 OTHERNUM1(I) = I Next For I = 0 To UBound(INWHEEL1, 2) LINES(I) = INWHEEL1(IN1, I) OTHERNUM1(LINES(I)) = -1 Next i1 = 0 For I = 0 To MYM - 1 If OTHERNUM1(I) > -1 Then OTHERNUM(i1) = OTHERNUM1(I) i1 = i1 + 1 End If Next For I = MYL To MYK For i1 = 0 To ms(I, IN2, 1, 0, 0) For I2 = 0 To I - 1 LINEFJ(I2) = LINES(ms(I, IN2, 1, i1, I2)) Next I2 If (IN2 = 1 And MYK = I) Or (IN2 = 0 And MYN = I) Then IBCI = 0 Else If IN2 = 1 Then IBCI = ms(MYK - I, 0, 0, 0, 0) Else IBCI = ms(MYN - I, 1, 0, 0, 0) End If End If For I2 = 0 To IBCI If IBCI = 0 Then For I3 = 0 To I - 1 LINE(I3) = LINEFJ(I3) Next GoTo 50 Else If IN2 = 1 Then For I3 = 0 To MYK - I - 1 LINEBC(I3) = OTHERNUM(ms(MYK - I, 0, 0, I2, I3)) Next I3 Else For I3 = 0 To MYN - I - 1 LINEBC(I3) = OTHERNUM(ms(MYN - I, 1, 0, I2, I3)) Next I3 End If End If I3 = 0 : I4 = 0 : i6 = 0 If IN2 = 1 Then i7 = MYK - I Else i7 = MYN - I End If Do While I3 If LINEFJ(I3) < LINEBC(I4) Then LINE(i6) = LINEFJ(I3) I3 = I3 + 1 Else LINE(i6) = LINEBC(I4) I4 = I4 + 1 End If i6 = i6 + 1 Loop If I3 = I Then For i5 = I4 To i7 - 1 LINE(i6 + i5 - I4) = LINEBC(i5) Next Else For i5 = I3 To I - 1 LINE(i6 + i5 - I3) = LINEFJ(i5) Next End If 50: If IN2 = 1 Then i7 = MYN Else i7 = MYK End If For I3 = 0 To UBound(INWHEEL1, 1) I4 = 0 : i5 = 0 : i6 = 0 Do While i5 < i7 And I4 < i7 If LINE(I4) < INWHEEL1(I3, i5) Then I4 = I4 + 1 ElseIf LINE(I4) > INWHEEL1(I3, i5) Then i5 = i5 + 1 ElseIf LINE(I4) = INWHEEL1(I3, i5) Then I4 = I4 + 1 : i5 = i5 + 1 : i6 = i6 + 1 End If Loop If IN2 = 1 Then If i6 > MYL - 1 Then GoTo 100 Else If i6 < MYL Then GoTo 100 End If Next ILINES = ILINES + 1 ReDim Preserve OUTLINES(ILINES, i7 - 1) For I3 = 0 To i7 - 1 OUTLINES(ILINES, I3) = LINE(I3) Next 100: Next Next i1 Next I End Sub Private Sub creams(ByVal m As Byte, ByVal n As Byte, ByVal in1 As Byte, ByVal in2 As Byte) Dim num(n + 1) As Byte, i As Byte, iP As Byte = n, IWS As Long = 1 If n = 0 Then Exit Sub For i = 1 To n num(i) = i Next Do While iP > 0 For i = 1 To n ms(n, in1, in2, IWS, i - 1) = num(i) - 1 Next 100: num(iP) = num(iP) + 1 If num(iP) > m - n + iP Then iP = iP - 1 If iP = 0 Then ms(n, in1, in2, 0, 0) = IWS Exit Sub End If GoTo 100 End If For i = iP To n - 1 num(i + 1) = num(i) + 1 Next IWS = IWS + 1 iP = n Loop End Sub End Class

欢迎光临德国开元华人社区开元周游 (https://forum.kaiyuan.de/)

德国开元华人社区 开元周游

德国开元华人社区开元周游