[RETO] Comprobar si un numero dado es un numero de la suerte

[Psyke1]

Leandro, probando como dice Karcrack (que devuelva un Boolean ingresando un numero Long) es un "Misil", muy buena, no era que las matematicas no eran tu fuerte ?

Oh dios!!
Es verdad, va como un tiro!!
Las Collections son mas apropiadas cuando se trabaja con poca cantidad de Items...
Por eso acabo de hacer esta tercera versión, es la mas rápida de las mias, y de velocidad anda pareja con la de LeandroA  :

Código (vb) [Seleccionar] Expandir


Option Explicit
Private Declare Sub RtlMoveMemory Lib "Kernel32" (ByVal Destination As Any, ByVal Source As Any, ByVal length As Long)

Public Function Check_Lucky_Number3(ByVal lNumber As Long) As Boolean
   Dim lTempArray()            As Long
   Dim NextElim                As Long
   Dim lArrayUBound            As Long
   Dim m                       As Long
   Dim x                       As Long

   If lNumber = 1 Or lNumber = 3 Then
       GoTo IsLucky
   ElseIf (lNumber > 1) And (lNumber Mod 2 <> 0) Then
       m = 1
       For x = 1 To lNumber Step 2
           ReDim Preserve lTempArray(m)
           lTempArray(m) = x
           m = m + 1
       Next
       NextElim = 3: m = 2
       Do
           x = NextElim
           Do While x <= UBound(lTempArray)
               lArrayUBound = UBound(lTempArray)
               If Not x = lArrayUBound Then
                   RtlMoveMemory VarPtr(lTempArray(x)), VarPtr(lTempArray(x + 1)), (lArrayUBound - x) * 4
                   ReDim Preserve lTempArray(lArrayUBound - 1)
               Else
                   Exit Function
               End If
               x = x + (NextElim - 1)
           Loop
           m = m + 1
           NextElim = lTempArray(m)
       Loop While Not NextElim > lArrayUBound
IsLucky: Check_Lucky_Number3 = True
   End If
End Function

Testeado con GetTickCount:

LeandroA IsLuckyNumber ---> 125
PsyKe1 Check_Lucky_Number3 ---> 125

@Dessa
Me referia a que hicieses algo asi:

Código (vb) [Seleccionar] Expandir

Option Explicit

Function IsLucky2(lngNum As Long) As Boolean
   Dim x As Long, cont As Long, contStep As Long, Indice As Long, numLuck() As String
   
   If lngNum < 1 Or lngNum Mod 2 = 0 Or lngNum = 5 Then Exit Function
   If lngNum = 1 Or lngNum = 3 Then IsLucky2 = True: Exit Function
   
   For x = 1 To lngNum Step 2
         ReDim Preserve numLuck(contStep)
         numLuck(contStep) = x
         contStep = contStep + 1
   Next
   contStep = 0: cont = 0: Indice = 1
   While numLuck(Indice) <= UBound(numLuck)
     For x = 0 To UBound(numLuck)
         If cont = numLuck(Indice) - 1 Then
           cont = 0
         Else
           numLuck(contStep) = numLuck(x)
           cont = cont + 1
           contStep = contStep + 1
         End If
     Next
     If contStep = numLuck(Indice + 1) Then ReDim Preserve numLuck(contStep - 2) Else ReDim Preserve numLuck(contStep - 1)
     If numLuck(UBound(numLuck)) <> lngNum Then Exit Function
      cont = 0
     contStep = 0
     Indice = Indice + 1
   Wend
   
   IsLucky2 = True
End Function

IsLucky : 147,75 ms
IsLucky2 : 87,45 ms



@Karcrack
Una duda con tu code:

Código (vb) [Seleccionar] Expandir

If (lNumb And 1 = 0) Then Exit Function
Esto para que es?¿  
Es como hacer Mod?¿


DoEvents¡!

[Karcrack]

Puff, me descuido un dia y me dejais completamente atras , ya os descuidareis y despertare a todas mis neuronas muahahahhaha!

@Psyke: Es para comprobar que sea par, es muchiiiisimo mas rapido que hacer un Mod, es lo que te dije, trabajar con Bits

[Tokes]

Hola a todos:

No pude evitar hacer un código después de ver el ímpetu que demuestran.

Hice un código que recibe un número y despliega un mensaje, informando si ese número es o no es de la suerte. El mensaje también muestra el tiempo transcurrido en realizar las operaciones; muestra el tiempo antes de iniciar las operaciones, el tiempo después de realizar las operaciones y por último, la diferencia entre ambos, es decir, el tiempo total empleado en realizar las operaciones.

Sólo lo probé con los números del 1 al 37, ya que me dió flojera probar con más números.

Pero bueno, se necesita un cuadro de texto Text1 y un botón de comando Command1. El código es el siguiente:


Option Explicit

Private Sub Command1_Click()
Dim esdesuerte As Boolean
Dim t1 As Long, t2 As Long, tdif As Long
    t1 = timeGetTime()
    esdesuerte = verifnum(Val(Text1.Text))
    t2 = timeGetTime()
    tdif = t2 - t1
    If esdesuerte = False Then
        MsgBox ("El número " & Val(Text1.Text) & " no es de la suerte" _
        & Chr(13) & "t1 = " & t1 & Chr(13) & "t2 = " & t2 & Chr(13) _
        & "Tiempo = " & tdif)
    Else
        MsgBox ("El número " & Val(Text1.Text) & " es de la suerte" _
        & Chr(13) & "t1 = " & t1 & Chr(13) & "t2 = " & t2 & Chr(13) _
        & "Tiempo = " & tdif)
    End If
End Sub

Private Function verifnum(ByVal num As Long) As Boolean
Dim bufA(33000) As Long
Dim bufB(33000) As Long
Dim indElim As Long
Dim iniciales As Long
Dim i As Long
Dim i_auxA As Long
Dim i_auxB As Long
   
    If num Mod 2 = 0 Then
        verifnum = False
        Exit Function
    End If
   
    indElim = 2
    iniciales = 1
    i = 1
    Do While iniciales <= num
        bufA(i) = iniciales
        iniciales = iniciales + 2
        i = i + 1
    Loop
    i = i - 1
   
    If indElim >= i Then
        verifnum = True
    Else
        Do
            indElim = bufA(indElim)
            If indElim > i Then
                verifnum = True
                Exit Function
            End If
            i_auxA = indElim
            While i_auxA <= i
                If bufA(i_auxA) = num Then
                    verifnum = False
                    Exit Function
                End If
                bufA(i_auxA) = bufA(i_auxA) * -1
                i_auxA = i_auxA + indElim
            Wend
       
            i_auxA = 1
            i_auxB = 1
            While i_auxA <= i
                If bufA(i_auxA) > 0 Then
                    bufB(i_auxB) = bufA(i_auxA)
                    i_auxB = i_auxB + 1
                End If
                i_auxA = i_auxA + 1
            Wend
            i = i_auxB - 1
       
            indElim = bufB(indElim)
            If indElim > i Then
                verifnum = True
                Exit Function
            End If
            i_auxB = indElim
            While i_auxB <= i
                If bufB(i_auxB) = num Then
                    verifnum = False
                    Exit Function
                End If
                bufB(i_auxB) = bufB(i_auxB) * -1
                i_auxB = i_auxB + indElim
            Wend
           
            i_auxA = 1
            i_auxB = 1
            While i_auxB <= i
                If bufB(i_auxB) > 0 Then
                    bufA(i_auxA) = bufB(i_auxB)
                    i_auxA = i_auxA + 1
                End If
                i_auxB = i_auxB + 1
            Wend
            i = i_auxA - 1
        Loop
    End If
End Function


Y en el módulo el código es el siguiente:


Option Explicit

Public Declare Function timeGetTime Lib "winmm.dll" () As Long

En fín, si alguien quiere hacerme el favor de revisarlo  para números arriba del 37 se los agradeceré. Es que es demasiado fastidioso estar generando a mano los números de la suerte.

                    Saludos

[Psyke1]

Puff, me descuido un dia y me dejais completamente atras , ya os descuidareis y despertare a todas mis neuronas muahahahhaha!

@Psyke: Es para comprobar que sea par, es muchiiiisimo mas rapido que hacer un Mod, es lo que te dije, trabajar con Bits

Jajajajaja
Tengo ganas de ver tu nueva version, pero espero que no quedemos todos empate...
@Tokes

No te ofendas, pero tu codigo esta bastante desorganizado, pon el codigo entre
[ code=vb ] aqui tu codigo [ /code ] 'Sin espacios
El code es demasiado largo y lento...

Código [Seleccionar] Expandir

Dim bufA(33000) As Long
Dim bufB(33000) As Long

o_O
Aún asi creo que te esforzaste...

DoEvents¡!

[Dessa]

Si Pyske1   , te entendí pero probé 45235 (compilado), con gettickcount y las dos van parejas... por supuesto que tendría que ser mas rapida con tu sugerencia (sin el último For). intentaré mejorar con RtlMoveMemory  

En fín, si alguien quiere hacerme el favor de revisarlo  para números arriba del 37 se los agradeceré.

Tokes, el 45 lo da como true y no lo es, tambien entre 1 y 200 hay 8 numeros mas que no son Lucky, saludos







   

[Psyke1]

@Dessa
Creo que ya se por que no hay apenas diferencia:
Al utilizar tu metodo para contar el tiempo solo tienes que realizar una comprobacion, pero probandolo de esta otra manera si que se nota la diferencia porque tiene que hacer 500 comprobaciones...
Lo ideal es probar la funcion de las dos maneras...



@Karcrack

Código (vb) [Seleccionar] Expandir

Private Sub Form_Load()
   Dim x As Long
   For x = 0 To 10000
       If (x And 1 = 0) Then MsgBox "Funciona"
   Next
End Sub


DoEvents¡!

[Tokes]

Bueno, he hecho una pequeña correción en el código y queda así. Me parece que ahora si da los números bien y es un poquitín más rápido.

Se necesitan 2 command buttons (Command1 y Command2) y textbox Text1 y una label Label1. El Command1 dice si el número del Text1 es de la suerte. El command2 da los números de la suerte desde el 1 hasta el especificado en Text1.

La Label1 debe ser un tantito grande para que le quepan todos los números.
La función que verifica si el número es de la suerte se llama verifnum.

Código [Seleccionar] Expandir

Option Explicit

Private Sub Command1_Click()
Dim esdesuerte As Boolean
Dim t1 As Long, t2 As Long, tdif As Long
    t1 = timeGetTime()
    esdesuerte = IsLucky2(Val(Text1.Text))
    t2 = timeGetTime()
    tdif = t2 - t1
    If esdesuerte = False Then
        MsgBox ("El número " & Val(Text1.Text) & " no es de la suerte" _
        & Chr(13) & "t1 = " & t1 & Chr(13) & "t2 = " & t2 & Chr(13) _
        & "Tiempo = " & tdif)
    Else
        MsgBox ("El número " & Val(Text1.Text) & " es de la suerte" _
        & Chr(13) & "t1 = " & t1 & Chr(13) & "t2 = " & t2 & Chr(13) _
        & "Tiempo = " & tdif)
    End If
End Sub

Private Function verifnum(ByVal num As Long) As Boolean
Dim bufA() As Long
Dim bufB() As Long
Dim indElim As Long
Dim ordenElim As Long
Dim iniciales As Long
Dim i As Long
Dim i_auxA As Long
Dim i_auxB As Long


    If (num And 1) = 0 Then
        verifnum = False
        Exit Function
    End If
   
    ReDim bufA(0 To num)
    ReDim bufB(0 To num)
    ordenElim = 2
    iniciales = 1
    i = 1
    Do While iniciales <= num
        bufA(i) = iniciales
        iniciales = iniciales + 2
        i = i + 1
    Loop
    i = i - 1
   
        Do
            If ordenElim >= i Then
                verifnum = True
                Exit Function
            End If
            indElim = bufA(ordenElim)
            ordenElim = ordenElim + 1
            i_auxA = indElim
            While i_auxA <= i
                If bufA(i_auxA) = num Then
                    verifnum = False
                    Exit Function
                End If
                bufA(i_auxA) = 0
                i_auxA = i_auxA + indElim
            Wend
       
            i_auxA = 1
            i_auxB = 1
            While i_auxA <= i
                If bufA(i_auxA) > 0 Then
                    bufB(i_auxB) = bufA(i_auxA)
                    i_auxB = i_auxB + 1
                End If
                i_auxA = i_auxA + 1
            Wend
            i = i_auxB - 1
       
            If ordenElim >= i Then
                verifnum = True
                Exit Function
            End If
            indElim = bufB(ordenElim)
            ordenElim = ordenElim + 1
            i_auxB = indElim
            While i_auxB <= i
                If bufB(i_auxB) = num Then
                    verifnum = False
                    Exit Function
                End If
                bufB(i_auxB) = 0
                i_auxB = i_auxB + indElim
            Wend
           
            i_auxA = 1
            i_auxB = 1
            While i_auxB <= i
                If bufB(i_auxB) > 0 Then
                    bufA(i_auxA) = bufB(i_auxB)
                    i_auxA = i_auxA + 1
                End If
                i_auxB = i_auxB + 1
            Wend
            i = i_auxA - 1
        Loop
    'End If
End Function

Private Sub Command2_Click()
Dim strvis As String
Dim i As Long
Dim t1 As Long, t2 As Long
    t1 = timeGetTime
    strvis = "Los números de la suerte entre el 1 y el " & Text1.Text & " son:" & Chr(13)
    If verifnum(1) = True Then
        strvis = strvis & CStr(1)
    End If
    For i = 2 To Text1.Text
        If verifnum(i) = True Then
            strvis = strvis & ", " & Str(i)
        End If
    Next i
    t2 = timeGetTime
    strvis = strvis & Chr(13) & "Tiempo = " & t2 - t1
    'MsgBox (strvis)
    Label1 = strvis
End Sub

Y el código del módulo es:

Código [Seleccionar] Expandir

Option Explicit

Public Declare Function timeGetTime Lib "winmm.dll" () As Long

Bueno, el código es un poco largo pero me parece que va un poquitín más rápido.

[cobein]

Ahi va mi aporte, perdon por la descarga pero es un poco grande para pegar aca.
Posiblemente no sea tan rapido como otros que vi por aca porque priorice el uso de memoria (simplemente por gusto) en vez de utilizar un array de longs como vi que usaban muchos me parecio mas entretenido hacer algo diferente, asi que utilice un array de bytes que a su vez los utilizo como array de bits para guardar 8 valores por byte, lo malo de hacerlo de esta manera es que hay que recorrer el array para encontrar los indices pero trate de optimizarlo un poco, por ejemplo el loop principal utiliza un tercio de las iteraciones que vi que los demas utilizan y otras cositas mas.

[http://cobein.com/shares/LuckyNumbs.rar]

Edit: Me olvide de quitar un pedazo de codigo que estaba utilizando... nada importante pero aca pego uno mas limpio.

Código [Seleccionar] Expandir

Private Function TestNum(ByVal lVal As Long) As Boolean
   
   If lVal < 1 Then Exit Function
   If Not lVal And 1 Then Exit Function
   
   mBitArray.AllocateBuffer lVal
   
   Dim i As Long
   For i = 1 To lVal Step 6
       mBitArray.SetValue i, True
       mBitArray.SetValue i + 2, True
   Next
   
   Dim lIncrement As Long
   Dim lPos As Long
   
   lPos = 3
   Dim lRet As Long
   
   Do
       lIncrement = mBitArray.FindPositive(lPos)
       If lIncrement = -1 Then Exit Do
       lRet = 1
       Do
           lRet = mBitArray.FindPositive(lIncrement, lRet) 'Save the last pos to not loop from start
           If lRet = -1 Then Exit Do
           mBitArray.SetValue lRet, False
       Loop
       If Not FindPositiveRev(1) = lVal Then Exit Function
       lPos = lPos + 1
   Loop
   If FindPositiveRev(1) = lVal Then TestNum = True
       
End Function

[Angeldj27]

No se si es una forma chapucera de hacerlo pero asi de una forma rapido fue k se me ocurrio con arrays se k ess mas facil con los collection pero esa es la norma con los arrays pense k con un par de arrays anidados se podia como hice algo en la escuela una vez pero no tenia vastante tiempo haci k esta es la forma mas facil k pude hacerlo pork no tengo destrezas con usar datos en memoria jeje

Código (vb) [Seleccionar] Expandir

Public Function LuckyNumber(ByVal N As Long) As Boolean
       Dim ANumero()    As Long
       Dim AText1()       As Long
       Dim i                   As Integer
       Dim X                  As Integer        
       
       i = 1
       X = 1
       If N Mod 2 = 0 Then Exit Function  

       For i = 1 To N Step 2
          ANumero(X) = i
          X = X + 1
       Next
       For i = 0 To UBound(ANumero) Step 3
           If ANumero(i) = N Then Exit Function
           ANumero(i) = 0
       Next
       X = 1
       For i = 1 To UBound(ANumero)
            If ANumero(i) <> 0 Then
               AText1(X) = ANumero(i)
               X = X + 1
            End If
       Next
       For i = 0 To UBound(AText1) Step 7
           If AText1(i) = N Then Exit Function            
       Next
       
       LuckyNumber = True
       
End Function

No se si es muy rapida pero funciona bien  

[Psyke1]

@Angeldj27
No funciona bien me da varios errores en las matrices, y solo haces tres bucles para quitar numeros el resultado no sera correcto, leete bien el link que puso karcrack al principio...

DoEvents¡!