Título: [Src] IsInArray
Publicado por: Psyke1 en 9 Mayo 2011, 14:24 pm
Bueno, aquí os dejo esta sencilla función. :) Su finalidad es devolver el Index de un Item que se encuentre en un array (acepta todo tipo de Arrays : String, Double, Long...), con la opción de devolver el primero que se encuentre en el array y con los parámetros lngStart y lngEnd podemos establecer límites en nuestra búsqueda. :D Para ordenarlo aconsejo usar esta maravillosa función que hizo mi amigo BlackZer0x (http://foro.elhacker.net/profiles/blackzerox961996199618961896179617-u59494.html) : http://goo.gl/RG4Bx Option Explicit '====================================================================== ' º Function : IsInArray ' º Author : Psyke1 ' º Country : Spain ' º Mail : vbpsyke1@mixmail.com ' º Date : 09/05/2011 ' º Twitter : http://twitter.com/#!/PsYkE1 ' º Dedicated : BlackZer0x ' º Reference : http://goo.gl/RDQhK ' º Recommended Websites : ' http://foro.h-sec.org ' http://www.frogcheat.com.ar ' http://InfrAngeluX.Sytes.Net '====================================================================== Public Static Function IsInArray&(varArr, _ varValue, _ Optional lngStart&, _ Optional lngEnd&, _ Optional bolFindFirst As Boolean, _ Optional bolIsSorted As Boolean) Dim lngLB&, lngUB&, Q&, C& If (IsArray(varArr) = True) And (IsArray(varValue) = False) Then lngLB = LBound(varArr) lngUB = UBound(varArr) If Not IsMissing(lngStart) Then If (lngStart > lngLB) And (lngStart < lngUB) Then lngLB = lngStart End If If Not IsMissing(lngEnd) Then If (lngEnd > lngLB) And (lngEnd < lngUB) Then lngUB = lngEnd End If If bolIsSorted Then If varArr(lngLB) = varValue Then IsInArray = lngLB Exit Function ElseIf varArr(lngUB) = varValue Then If bolFindFirst Then Do While (varArr(lngUB) = varArr(lngUB - 1)) And (Q > lngLB) lngUB = lngUB - 1 Loop End If IsInArray = lngUB Exit Function End If If lngUB - lngLB < 2 Then GoTo NotFound If (varArr(lngLB) > varValue) Or (varArr(lngUB) < varValue) Then GoTo NotFound C = 0 Do Q = (lngUB + lngLB) \ 2 If C = Q Then GoTo NotFound If varArr(Q) > varValue Then lngUB = Q ElseIf varArr(Q) < varValue Then lngLB = Q C = lngLB Else If bolFindFirst Then Do While (varArr(Q) = varArr(Q - 1)) And (Q > lngLB) Q = Q - 1 Loop End If IsInArray = Q Exit Function End If Loop Else For Q = lngLB To lngUB If varArr(Q) = varValue Then IsInArray = Q Exit Function End If Next Q GoTo NotFound End If End If Exit Function NotFound: IsInArray = -1 End Function
Un ejemplo: Option Explicit Private Const strLine$ = "------------------------------" Private Sub Form_Load() Dim L&(60), S(), Q& For Q = 0 To 60 L(Q) = Q * 2 Next Q Debug.Print strLine$, Time$, strLine$ Debug.Print IsInArray(L, 15) '---> -1 Debug.Print IsInArray(L, 40) '---> 20 Debug.Print IsInArray(L, 85) '---> -1 Debug.Print IsInArray(L, 100) '---> 50 S = Array("abba", "acero", "karcrack", "sereno", "silencio", "tonto", "tonto", "tonto", "tonto", "zalme") Debug.Print strLine$ Debug.Print IsInArray(S, "zalme") '---> 9 Debug.Print IsInArray(S, "zalme", , 4) '---> -1 Debug.Print IsInArray(S, "mesa") '---> -1 Debug.Print IsInArray(S, "besos") '---> -1 Debug.Print IsInArray(S, "karcrack") '---> 2 Debug.Print IsInArray(S, "karcrack", 3) '---> -1 Debug.Print IsInArray(S, "tonto") '---> 6 Debug.Print IsInArray(S, "tonto", , , True) '---> 5 End Sub
Retorna: ------------------------------ 18:59:54 ------------------------------ -1 20 -1 50 ------------------------------ 9 -1 -1 -1 2 -1 6 5
Si necesitamos especial velocidad y lo queremos para un tipo de variable en concreto, sólo hay que modificar un par de cosas. ;) Aquí un ejemplo para buscar en un array Long, comparado con el código de BlackZer0x ( http://goo.gl/RDQhK ) : Option Explicit '// Compilado sin la comprobación de límites en los arrays xP
Private Sub Form_Load() Dim L&(6000), Q&, t As New CTiming, y& If App.LogMode = 0 Then End For Q = 0 To 6000 L(Q) = Q * 2 Next Q Me.AutoRedraw = True t.Reset For Q = 1 To 1000 IsInArray L, 15 IsInArray L, 40 IsInArray L, 2001 IsInArray L, 5020 IsInArray L, 12000 Next Q Me.Print "IsInArray", , t.sElapsed t.Reset For Q = 1 To 1000 ExitsInArrayNR 15, L, y ExitsInArrayNR 40, L, y ExitsInArrayNR 2001, L, y ExitsInArrayNR 5020, L, y ExitsInArrayNR 12000, L, y Next Q Me.Print "ExitsInArrayNR", t.sElapsed End Sub
'// by Psyke1 Public Static Function IsInArray&(lngArr&(), lngValue&, Optional lngStart&, Optional lngEnd&, Optional bolFindFirst As Boolean) Dim lngLB&, lngUB&, lngItem&, Q&, C& lngLB = LBound(lngArr) lngUB = UBound(lngArr) If Not IsMissing(lngStart) Then If (lngStart > lngLB) And (lngStart < lngUB) Then lngLB = lngStart End If If Not IsMissing(lngEnd) Then If (lngEnd > lngLB) And (lngEnd < lngUB) Then lngUB = lngEnd End If If lngArr(lngLB) = lngValue Then IsInArray = lngLB Exit Function ElseIf lngArr(lngUB) = lngValue Then If bolFindFirst Then Do While (lngArr(lngUB) = lngArr(lngUB - 1)) And (Q > lngLB) lngUB = lngUB - 1 Loop End If IsInArray = lngUB Exit Function End If If lngUB - lngLB < 2 Then GoTo NotFound If (lngArr(lngLB) > lngValue) Or (lngArr(lngUB) < lngValue) Then GoTo NotFound C = 0 Do Q = (lngUB + lngLB) \ 2 If C = Q Then GoTo NotFound
If lngArr(Q) > lngValue Then lngUB = Q ElseIf lngArr(Q) < lngValue Then lngLB = Q C = lngLB Else If bolFindFirst Then Do While (lngArr(Q) = lngArr(Q - 1)) And (Q > lngLB) Q = Q - 1 Loop End If IsInArray = Q Exit Function End If Loop Exit Function
NotFound: IsInArray = -1 End Function
'// by BlackZer0x Public Function ExitsInArrayNR(ByRef vValue As Long, ByRef vBuff() As Long, ByRef p As Long) As Boolean Dim lng_lb As Long Dim lng_Ub As Long lng_lb = LBound(vBuff&()) lng_Ub = UBound(vBuff&()) If Not vBuff&(lng_Ub) > vBuff&(lng_lb) Then Dim t As Long t = lng_Ub lng_Ub = lng_lb lng_lb = t End If Do Until ExitsInArrayNR Select Case vValue Case vBuff&(lng_lb&) p& = lng_lb& ExitsInArrayNR = True Case vBuff&(lng_Ub&) p& = lng_Ub& ExitsInArrayNR = True Case Else p = (lng_lb& + lng_Ub&) / 2 If p <> lng_lb& And p& <> lng_Ub& Then If vBuff&(p&) < vValue& Then lng_lb = p ElseIf vBuff&(p&) > vValue& Then lng_Ub = p ElseIf vBuff&(p&) = vValue& Then ExitsInArrayNR = True End If Else Exit Do End If End Select Loop End Function Resultado: (http://infrangelux.sytes.net/FileX/view.php?InfraFile=/Banana-with-3D-glasses.png) DoEvents! :P
Título: Re: [Src] IsInArray
Publicado por: BlackZeroX en 9 Mayo 2011, 19:18 pm
. grandiosa, aun que ¿Con listas enormes es igual de rápida?.
P.D.: Te tardaste siglos xP.
Dulces Lunas!¡.
Título: Re: [Src] IsInArray
Publicado por: Psyke1 en 9 Mayo 2011, 19:31 pm
. grandiosa, aun que ¿Con listas enormes es igual de rápida?.
P.D.: Te tardaste siglos xP.
Dulces Lunas!¡. Gracias :) Sí, la velocidad es rápida incluso con arrays graandes. Cambié el tamaño del Array referente al test de 6000 a 99999999 y me devuelve esto: (http://infrangelux.sytes.net/FileX/view.php?InfraFile=/df.png) Ya sé que tardé un poco :silbar:, pero yo no rompo una promesa. :D DoEvents! :P
Título: Re: [Src] IsInArray
Publicado por: BlackZeroX en 9 Mayo 2011, 20:27 pm
. Gran trabajo xD, ahora a estudiar tu código por que es alucinante.
Dulces Lunas!¡.
Título: Re: [Src] IsInArray
Publicado por: Psyke1 en 27 Mayo 2011, 20:35 pm
. Código mejorado y ahora con la posibilidad de escanear arrays desordenados.
DoEvents! :P
Título: Re: [Src] IsInArray
Publicado por: BlackZeroX en 2 Junio 2011, 01:25 am
acabo de hacer el test de otra manera y resulta que ahora la mia es mas rapida que la tuya... Private Sub Form_Load() Dim L&(6000), Q&, t As New CTiming, y& If App.LogMode = 0 Then End For Q = 0 To 6000 L(Q) = Q * 2 Next Q Me.AutoRedraw = True t.Reset For Q = 1 To 1000 ExitsInArrayNR 15, L, y ExitsInArrayNR 40, L, y ExitsInArrayNR 2001, L, y ExitsInArrayNR 5020, L, y ExitsInArrayNR 12000, L, y Next Q Me.Print "ExitsInArrayNR", t.sElapsed t.Reset For Q = 1 To 1000 IsInArray L, 15 IsInArray L, 40 IsInArray L, 2001 IsInArray L, 5020 IsInArray L, 12000 Next Q Me.Print "IsInArray", , t.sElapsed
End Sub
Dulces Lunas!¡.
Título: Re: [Src] IsInArray
Publicado por: Psyke1 en 2 Junio 2011, 01:44 am
Supongo que me has dejado la función como Variant y las variables como Variant. :-\ Ya dije en el test que cambié un par de cosas en mi función. ¿Se puede saber que cambiaste en tu test? :huh:
DoEvents! :P
Título: Re: [Src] IsInArray
Publicado por: BlackZeroX en 2 Junio 2011, 02:22 am
. Así queda mejor (Todo lo demás es solo una expansion...): Revise nuevamente mi código y vi que no eran necesarias las comparaciones dentro del do-loop de los indices lbound y ubound o las sustituciones, ya que el que importa es el elemento medio. Código Fuente de prueba (Test Aleatorio) (http://infrangelux.sytes.net/filex/index.php?dir=/BlackZeroX/Programacion/vb6/Retos/find%20in%20array&file=test%20findinarray.zip) (http://infrangelux.sytes.net/filex/view.php?InfraFile=/BlackZeroX/Programacion/vb6/Retos/find%20in%20array/screentest.png) Private Sub SwapVals(ByRef lVal1 As Long, ByRef lval2 As Long) lval2 = lval2 Xor lVal1 lVal1 = lVal1 Xor lval2 lval2 = lval2 Xor lVal1 End Sub 'Return (Devuelve True si existe en el array) Public Function ExitsInArray(ByRef lFind As Long, ByRef avBuff() As Long, ByRef lpos As Long) As Boolean Dim llb As Long Dim lub As Long Dim lposa As Long 'If Itsarrayini(VarPtrA(avBuff())) Then llb = LBound(avBuff) lub = UBound(avBuff) If (avBuff(lub) < avBuff(llb)) Then SwapVals lub, llb End If If ((avBuff(llb) <= lFind) And (lFind <= avBuff(lub))) Then Select Case lFind Case avBuff(lub) lpos = lub ExitsInArray = True Case avBuff(llb) lpos = llb ExitsInArray = True Case Else lposa = llb Do lpos = (llb + lub) \ 2 If (lposa = lpos) Then Exit Do ElseIf (avBuff(lpos) > lFind) Then lub = lpos ElseIf (lFind > avBuff(lpos)) Then lposa = lpos llb = lpos ElseIf (avBuff(lpos) = lFind) Then ExitsInArray = True Exit Do End If Loop End Select End If 'End If End Function
Dulces Lunas!¡.
Título: Re: [Src] IsInArray
Publicado por: raul338 en 2 Junio 2011, 04:20 am
Wow, impresionante. Muy buen trabajo los 2. Mirare los codigos y los usare en mis proyectos :) Sigan asi
Título: Re: [Src] IsInArray
Publicado por: BlackZeroX en 2 Junio 2011, 04:47 am
. Actualice el código de mi función.
Temibles Lunas!¡.
Título: Re: [Src] IsInArray
Publicado por: Psyke1 en 2 Junio 2011, 15:30 pm
. Actualice el código de mi función.
Temibles Lunas!¡. Muy bueno, buen trabajo. :) Resulta muy divertido empezar a sacar versiones de una misma cosa a ver quien lo hace mejor. :) Veo que te basaste en la mía... :silbar: DoEvents! :P
Título: Re: [Src] IsInArray
Publicado por: BlackZeroX en 2 Junio 2011, 19:54 pm
. De hecho solo saque la lógica de comparar lpos, si se genera dos veces entonces se haría un bucle infinito que no tendría caso alguno, lo demás es lo mismo de mi código. Solo reemplace las lineas sombreadas... aun que si quitaba la 2da linea entonces tendria que meter un rango de comparacion... option explicit Public Function ExitsInArrayNR(ByRef vValue As Long, ByRef vBuff() As Long, ByRef p As Long) As Boolean Dim lng_lb As Long Dim lng_Ub As Long lng_lb = LBound(vBuff&()) lng_Ub = UBound(vBuff&()) If Not vBuff&(lng_Ub) > vBuff&(lng_lb) Then Dim t As Long t = lng_Ub lng_Ub = lng_lb lng_lb = t End If Do Until ExitsInArrayNR Select Case vValue Case vBuff&(lng_lb&) p& = lng_lb& ExitsInArrayNR = True Case vBuff&(lng_Ub&) p& = lng_Ub& ExitsInArrayNR = True Case Else p = (lng_lb& + lng_Ub&) / 2 If p <> lng_lb& And p& <> lng_Ub& Then If vBuff&(p&) < vValue& Then lng_lb = p ElseIf vBuff&(p&) > vValue& Then lng_Ub = p ElseIf vBuff&(p&) = vValue& Then ExitsInArrayNR = True End If Else Exit Do End If End Select Loop End Function
Para que veas también quedaría con una simple modificación sin aplicar nada ni sacar nada de tu código (aun que a mi me gusto la lógica de comparar lpos con su anterior valor); aun sigue siendo mas rápida que tu función con esta simple modificación... option explicit Private Sub SwapVals(ByRef lVal1 As Long, ByRef lval2 As Long) lval2 = lval2 Xor lVal1 lVal1 = lVal1 Xor lval2 lval2 = lval2 Xor lVal1 End Sub Public Function ExitsInArray(ByRef vValue As Long, ByRef vBuff() As Long, ByRef p As Long) As Boolean Dim lng_lb As Long Dim lng_Ub As Long lng_lb = LBound(vBuff&()) lng_Ub = UBound(vBuff&()) If Not vBuff&(lng_Ub) > vBuff&(lng_lb) Then SwapVals lng_lb, lng_Ub End If Select Case vValue Case vBuff&(lng_lb&) p& = lng_lb& ExitsInArray = True Case vBuff&(lng_Ub&) p& = lng_Ub& ExitsInArray = True Case Else Do Until ExitsInArray p = (lng_lb& + lng_Ub&) / 2 If p <> lng_lb& And p& <> lng_Ub& Then If vBuff&(p&) < vValue& Then lng_lb = p ElseIf vBuff&(p&) > vValue& Then lng_Ub = p ElseIf vBuff&(p&) = vValue& Then ExitsInArray = True End If Else Exit Do End If Loop End Select End Function
por otro lado en tu código: La variable c debería espesar desde lngLB ya que esta toma el valor desde lngStart, aun que aun asi estaría bien pero bueno no afecta en lo absoluto en nada. No entiendo para que es el parámetro bolFindStart deberías documentar un poco tu código (parámetros de entrada, trabajo de la función y resultados de la misma, mas no linea a linea) Dulces Lunas!¡.
|