i had test the code in vb6 ,and it do work. now i write it again in vb.net. i had not debug and test it.
to use the code ,it need build a class, and copy the code to the class.
Public 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
Private Shared ms(,,,,) As Integer
Private Shared MYM As Byte
Private Shared MYN As Byte
Private 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 < I And I4 < i7
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