Ciao, sono alla ricerca di una routine per velocizzare il confronto tra Array. In un forum di programmatori ho trovato un thread interessante, ma incompleto. Un utente chiedeva aiuto per una routine di riduzione di un sistema per il 10 e lotto. Al termine della discussione è stato postato il seguente codice, sicuramente incompleto, che ho mandato in esecuzione ma non riesco a comprendere cosa fa.
1 Form
name=fMain
Size=Bello alto
1 text boxt = txt
name=txt
Multiline=true
Scrool=Vertical
1 Command Button
1 Module
Name = Come vi pare e piace
fMain Code
Module1 Code
1 Form
name=fMain
Size=Bello alto
1 text boxt = txt
name=txt
Multiline=true
Scrool=Vertical
1 Command Button
1 Module
Name = Come vi pare e piace
fMain Code
Codice:
Private Sub Command1_Click()
Dim b(2) As String
b(0) = App.Path & "\" & App.EXEName & ".exe"
b(1) = "3"
b(2) = "90"
TestMain UBound(b) + 1, b()
End Sub
Module1 Code
Codice:
Public Function BinCoef(ByVal n As Long, ByVal r As Long) As Long
Dim i As Long, b As Long
If (r < 0) Or (n < r) Then Exit Function
If (2 * r) > n Then r = n - r
b = 1
If r > 0 Then
For i = 0 To r - 1
b = (b * (n - i)) / (i + 1)
Next
End If
BinCoef = b
End Function
Public Sub PrintkSubset(ByVal k As Long, T() As Long)
Dim i As Long
With Fmain.txt
.SelText = "["
If k > 0 Then
.SelText = CStr(T(0)) & " " & CStr(T(1))
For i = 2 To k
.SelText = "," & CStr(T(i))
Next
End If
.SelText = "]"
End With
End Sub
Public Function kSubsetRevDoorRank(T() As Long, ByVal k As Long) As Long
Dim i As Long, r As Long, s As Long
s = 1
For i = k To 1 Step -1
r = r + BinCoef(T(i), i) * s
s = -s
Next
If (k Mod 2) = 1 Then r = r - 1
kSubsetRevDoorRank = r
End Function
Public Sub kSubsetRevDoorUnrank(ByVal r As Long, ByVal k As Long, ByVal n As Long, T() As Long)
Dim x As Long, i As Long, y As Long
x = n
For i = k To 1 Step -1
y = BinCoef(x, i)
Do While (y > r)
x = x - 1
y = BinCoef(x, i)
Loop
T(i) = x + 1
r = BinCoef(x + 1, i) - r - 1
Next
End Sub
Public Sub kSubsetRevDoorSuccessor(T() As Long, ByVal k As Long, ByVal n As Long)
Dim j As Long
T(k + 1) = n + 1
j = 1
Do While ((j <= k) And (T(j) = j))
j = j + 1
Loop
If ((k - j) Mod 2) <> 0 Then
If j = 1 Then
T(1) = T(1) - 1
Else
T(j - 1) = j
T(j - 2) = j - 1
End If
Else
If T(j + 1) <> T(j) + 1 Then
T(j - 1) = T(j)
T(j) = T(j) + 1
Else
T(j + 1) = T(j)
T(j) = j
End If
End If
End Sub
Public Sub TestMain(ByVal ac As Long, av() As String)
Dim NN As Long, n As Long, k As Long, r As Long, s As Long, done As Boolean
Dim T() As Long
If ac <> 3 Then
Fmain.txt.SelText = "Error,usage: " & av(0) & " k n" & vbCrLf
Exit Sub
End If
k = CLng(av(1))
n = CLng(av(2))
If k < 0 Then
Fmain.txt.SelText = "Error,Sorry k must be greater than 0" & vbCrLf & "Usage: " & av(0) & " k n" & vbCrLf
Exit Sub
End If
If k > n Then
Fmain.txt.SelText = "Error,There are no " & CStr(k) & "-subset of an " & CStr(n) & "-set?" & vbCrLf & "Usage: " & av(0) & " k n" & vbCrLf
Exit Sub
End If
ReDim T(k + 2) As Long
NN = BinCoef(n, k)
Fmain.txt.SelText = "Testing rank/unrank." & vbCrLf & " " & CStr(n) & " " & CStr(k) & " " & CStr(NN) & vbCrLf
For r = 0 To NN - 1
With Fmain.txt
.SelText = " " & CStr(r)
kSubsetRevDoorUnrank r, k, n, T()
PrintkSubset k, T
.SelText = " "
s = kSubsetRevDoorRank(T, k)
.SelText = "rank = " & CStr(s) & vbCrLf
End With
Next
Fmain.txt.SelText = "Testing successor." & vbCrLf
kSubsetRevDoorUnrank 0, k, n, T()
s = kSubsetRevDoorRank(T, k)
T(0) = 0
Do While (done = False)
PrintkSubset k, T
Fmain.txt.SelText = "rank = " & CStr(s) & vbCrLf
kSubsetRevDoorSuccessor T(), k, n
s = kSubsetRevDoorRank(T, k)
If s = 0 Then done = True
Loop
End Sub
Ultima modifica: