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

[Psyke1]

Me he tomado la libertad de ir testeando, aunque habria que probarlo en más PCs...
Utilizando:
cTiming.cls

Código (vb) [Seleccionar] Expandir

Private tmr     As CTiming

Option Explicit
Option Base 1

'Karcrack
Public Static Function IsItLucky(ByVal lNumb As Long) As Boolean
    Dim bvSieve()   As Byte
    Dim lJump       As Long
    Dim lLastNumb   As Long
    Dim i           As Long
    Dim iCount      As Long
    Dim xCount      As Long
    Dim x           As Long

    If lNumb = 1 Or lNumb = 3 Then IsItLucky = True: Exit Function

    If (lNumb And 1 = 0) Then Exit Function

    If lJump = 0 Then lJump = 2

    If lLastNumb < lNumb Then
        ReDim Preserve bvSieve(lNumb)

        iCount = 0
        xCount = 1

        Do
            For i = 1 To lNumb
                If bvSieve(i) = False Then iCount = iCount + 1
                If iCount = lJump Then
                    bvSieve(i) = True
                    iCount = 0
                End If
            Next i
            iCount = 0
            xCount = xCount + 1
            For i = 1 To lNumb
                If bvSieve(i) = False Then
                    x = x + 1
                    If x = xCount Then
                        lJump = i
                        x = 0
                        Exit For
                    End If
                End If
            Next i
        Loop Until xCount > lJump
    End If

    IsItLucky = Not bvSieve(lNumb)

    lLastNumb = lNumb
End Function

'*PsYkE1*
Public Function Check_Lucky_Number(ByVal lNumber As Long) As Boolean
    Dim cTemp                   As New Collection
    Dim NextElim                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
        With cTemp
            For x = 1 To lNumber Step 2
                .Add x
            Next
            NextElim = 3: m = 2
            Do
                x = NextElim
                Do While x <= .Count
                    .Remove (x)
                    x = x + (NextElim - 1)
                Loop
                If .Item(.Count) = lNumber Then
                    m = m + 1
                    NextElim = .Item(m)
                Else
                    Exit Function
                End If
            Loop While Not NextElim > .Count
        End With
IsLucky: Check_Lucky_Number = True
    End If
End Function

' LeandroA
Private Function IsLuckyNumber(ByVal Num As Long) As Boolean

    Dim lCount As Long, lPos As Long
    Dim c As New Collection

    If Num < 1 Then Exit Function
    If Num Mod 2 = 0 Then Exit Function

    For lPos = 1 To Num Step 2
        c.Add lPos
    Next

    lCount = 1

    Do While c.Count > lCount

        lCount = lCount + 1
        lPos = c(lCount)

        Do
            If lPos > c.Count Then Exit Do
            c.Remove lPos
            lPos = lPos + c(lCount) - 1
        Loop

        If c(c.Count) <> Num Then Exit Function
    Loop

    IsLuckyNumber = True

End Function

Private Sub Form_Load()
    Dim x           As Long
    Dim sResult     As String
   
    Set tmr = New CTiming
    tmr.Reset
   
    For x = 1 To 500
        If IsLuckyNumber(x) Then ' Aqui los voy probando uno a uno... :P
            sResult = sResult & x & " "
        End If
    Next
    MsgBox tmr.sElapsed
   
    Debug.Print sResult
End Sub


Mis resultados:

LeandroA: 28,734
Karcrack : 69,309
*PsYkE1* : 19,923

DoEvents¡!

[ssccaann43 ©]

Jajajajaja...! *PsYkE1* te has vuelto un adicto al Collection...!

Excelente trabajo...! Me gustó..!

[Karcrack]

Mi codigo todavia no es funcional, tiene varios fallos, por ejemplo, en la segunda llamada da errores, debido a que dejo las variables llenas de basura... a ver si consigo mañana algo de tiempo y hago la version raaaapida

Buen trabajo Psyke, veo que has exprimido al maximo las neuronas, a mi me dejo con dolor de cabeza , tanto tiempo sin pensar...

[Psyke1]

Jajajajaja...! *PsYkE1* te has vuelto un adicto al Collection...!

Excelente trabajo...! Me gustó..!

Jajajajajaja 
Eso es por culpa de Karcrack! 
Él me volvió adicto...

Mi codigo todavia no es funcional, tiene varios fallos, por ejemplo, en la segunda llamada da errores, debido a que dejo las variables llenas de basura... a ver si consigo mañana algo de tiempo y hago la version raaaapida

Buen trabajo Psyke, veo que has exprimido al maximo las neuronas, a mi me dejo con dolor de cabeza , tanto tiempo sin pensar...

Gracias¡!
Si te digo la verdad, en un momento me pareció tan desesperante que pense en mandarlo a la m****a...
Aun asi el reto me gustó, de paso planteo una pregunta:
Esto que hemos hecho tiene alguna utilidad?¿

DoEvents¡!

[Dessa]

Bueno, como se dijo, no me impota el tiempo, me conformo con que funcione... espero ...porque la verdad es que me costó un huevo (el izquierdo). ,  lo dicho con que funcione está bien para mí.

Código [Seleccionar] Expandir



Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long

Private Sub Form_Load()
 
   
    Dim t1 As Long
    Dim t2 As Long
    t1 = GetTickCount
 
    Me.AutoRedraw = True
   
    Me.Print IsLucky(45235)
   
    t2 = GetTickCount
   
    Me.Print t2 - t1
   
   
   
End Sub

Function IsLucky(lngNum As Long) As Boolean

Dim x As Long, cont As Long, contStep As Long, Indice As Long, numLuck() As String

If lngNum < 1 Then Exit Function
If lngNum Mod 2 = 0 Then Exit Function
If lngNum = 1 Or lngNum = 3 Then IsLucky = True: Exit Function
If lngNum = 5 Then 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)
  End If
  cont = 0
  contStep = 0
  Indice = Indice + 1
Wend

For x = 0 To UBound(numLuck)
If numLuck(x) = lngNum Then
   IsLucky = True
   Exit For
End If
Next

End Function




[Psyke1]

Hola Dessa!!

He mirado el code, puedes ganar un poco de velocidad si haces esto:

Código (vb) [Seleccionar] Expandir

If numLuck(UBound(numLuck)) = lngNum Then IsLucky = True

En vez de esto:

Código (vb) [Seleccionar] Expandir

For x = 0 To UBound(numLuck)
If numLuck(x) = lngNum Then
  IsLucky = True
  Exit For
End If
Next

Teniendo en cuenta que el número que buscas siempre estara el ultimo,y te evitas recorrer tooooooodo el array, mas tarde lo miro con mas detenimiento que tengo prisa...

DoEvents¡!

[LeandroA]

Aca otra version mas rapida de la mia pero sin collection y con array. esta utiliza CopyMemory segun como esta aqui

Código (Vb) [Seleccionar] Expandir


Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Function IsLuckyNumber(ByVal Num As Long) As Boolean

    Dim lCount As Long, lPos As Long, i As Long
    Dim Arr() As Long

    If Num < 1 Then Exit Function
    If Num Mod 2 = 0 Then Exit Function

    For lPos = 1 To Num Step 2
         i = i + 1
         ReDim Preserve Arr(i)
         Arr(i) = lPos
    Next

    lCount = 1

    Do While UBound(Arr) > lCount

        lCount = lCount + 1
        lPos = Arr(lCount)

        Do
            If lPos > UBound(Arr) Then Exit Do
            If lPos < UBound(Arr) Then CopyMemory Arr(lPos), Arr(lPos + 1), 4 * (UBound(Arr) - lPos)
            ReDim Preserve Arr(UBound(Arr) - 1)
            lPos = lPos + Arr(lCount) - 1
        Loop

        If Arr(UBound(Arr)) <> Num Then Exit Function
    Loop

    IsLuckyNumber = True

End Function


[LeandroA]

a con esto es mas rapido

Código [Seleccionar] Expandir


    ReDim Preserve Arr(CLng(Num / 2) + (Num Mod 2))
   
    For lPos = 1 To Num Step 2
         i = i + 1
         Arr(i) = lPos
    Next


[Psyke1]

Oops LeandroA, nuestras funciones van practicamente igual de rapido... 

DoEvents¡!

[Dessa]

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 ?



PsYkE1, si en teoria tenes razon, pero probando no cambia en mucho, después pruebo mejor, me quedó la cabeza "quemada"