[RETO] Comprobar si un numero es Oblongo/Pronico

BlackZeroX · 17 Agosto 2010, 08:27 AM

no participe en el anterior reto pero dejo lña mia



Private Function IsOblongo(ByVal lNumb As Long, ByRef n As Long) As Boolean
Dim a   As Long
    If lNumb < 0 Then n = -1: Exit Function
    If (lNumb And 1) = 0 Then
        If lNumb = 0 Then
            IsOblongo = True
        ElseIf lNumb = 2 Then
            n = 1
            IsOblongo = True
        ElseIf lNumb = 6 Then
            n = 2
            IsOblongo = True
        ElseIf lNumb = 12 Then
            n = 3
            IsOblongo = True
        Else
            For n = lNumb \ 4 To lNumb ^ (0.5) Step -1
                If n * (n - 1) = lNumb Then
                    IsOblongo = True
                    Exit Function
                End If
            Next
        End If
    Else
        IsOblongo = False
        n = -1
    End If
End Function

P.D.: Aun no la he optimisado!¡.

Dulces Lunas!¡.

BlackZeroX · 17 Agosto 2010, 09:08 AM

@LeandroA

La funcion sqr() no permite numeros negativos xP

@General

n deberia devolver -1 u otro, razonando que 0 pertenece a el numero 0, al igual que 1 pertenece a 2, 2 a 6, 3 a 12, 4 a 20, 5 a 30, etc (Siendo n a X)!¡..

Dulces Lunas!¡.

BlackZeroX · 17 Agosto 2010, 09:48 AM

Hay funciones que se indican erroneas:

Karcrack y la Funcion de LeandroA

Karcrack corrige el HOrror (step 2, sqr(X-1), y (n=3) [sqr(6)=2.444.. ] el 6 no esta contemplado) --> Que paso ?

Indicare los numeros:

LeandroA

Solo son desde apartir de 11772

Código [Seleccionar]



LeandroA       11772 
LeandroA       11990 
LeandroA       12210 
LeandroA       12432 
LeandroA       12656 
LeandroA       12882 
LeandroA       13110 
LeandroA       13340 
LeandroA       13572 
LeandroA       13806 
LeandroA       14042 
LeandroA       14280 
LeandroA       14520 
LeandroA       14762 
LeandroA       15006 
LeandroA       15252 
LeandroA       15500 
LeandroA       15750 
LeandroA       16002 
LeandroA       16256 
LeandroA       16512 
LeandroA       16770 
LeandroA       17030 
LeandroA       17292 
LeandroA       17556 
LeandroA       17822 
LeandroA       18090 
LeandroA       18360 
LeandroA       18632 
LeandroA       18906 
LeandroA       19182 
LeandroA       19460 
LeandroA       19740 
LeandroA       20022 
LeandroA       20306 
LeandroA       20592 
LeandroA       20880 
LeandroA       21170 
LeandroA       21462 
LeandroA       21756 
LeandroA       22052 
LeandroA       22350 
LeandroA       22650 
LeandroA       22952 
LeandroA       23256 
LeandroA       23562 
LeandroA       23870 
LeandroA       24180 
LeandroA       24492 
LeandroA       24806 
LeandroA       25122 
LeandroA       25440 
LeandroA       25760 
LeandroA       26082 
LeandroA       26406 
LeandroA       26732 
LeandroA       27060 
LeandroA       27390 
LeandroA       27722 
LeandroA       28056 
LeandroA       28392 
LeandroA       28730 
LeandroA       29070 
LeandroA       29412 
LeandroA       29756 
LeandroA       30102 
LeandroA       30450 
LeandroA       30800 
LeandroA       31152 
LeandroA       31506 
LeandroA       31862 
LeandroA       32220 
LeandroA       32580 
LeandroA       32942 
LeandroA       33306 
LeandroA       33672 
LeandroA       34040 
LeandroA       34410 
LeandroA       34782 
LeandroA       35156 
LeandroA       35532 
LeandroA       35910 
LeandroA       36290 
LeandroA       36672 
LeandroA       37056 
LeandroA       37442 
LeandroA       37830 
LeandroA       38220 
LeandroA       38612 
LeandroA       39006 
LeandroA       39402 
LeandroA       39800 
LeandroA       40200 
LeandroA       40602 
LeandroA       41006 
LeandroA       41412 
LeandroA       41820 
LeandroA       42230 
LeandroA       42642 
LeandroA       43056 
LeandroA       43472 
LeandroA       43890 
LeandroA       44310 
LeandroA       44732 
LeandroA       45156 
LeandroA       45582 
LeandroA       46010 
LeandroA       46440 
LeandroA       46872 
LeandroA       47306 
LeandroA       47742 
LeandroA       48180 
LeandroA       48620 
LeandroA       49062 
LeandroA       49506 
LeandroA       49952 
LeandroA       50400 
LeandroA       50850 
LeandroA       51302 
LeandroA       51756 
LeandroA       52212 
LeandroA       52670 
LeandroA       53130 
LeandroA       53592 
LeandroA       54056 
LeandroA       54522 
LeandroA       54990 
LeandroA       55460 
LeandroA       55932 
LeandroA       56406 
LeandroA       56882 
LeandroA       57360 
LeandroA       57840 
LeandroA       58322 
LeandroA       58806 
LeandroA       59292 
LeandroA       59780 
LeandroA       60270 
LeandroA       60762 
LeandroA       61256 
LeandroA       61752 
LeandroA       62250 
LeandroA       62750 
LeandroA       63252 
LeandroA       63756 
LeandroA       64262 
LeandroA       64770 
LeandroA       65280 
LeandroA       65792 
LeandroA       66306 
LeandroA       66822 
LeandroA       67340 
LeandroA       67860 
LeandroA       68382 
LeandroA       68906 
LeandroA       69432 
LeandroA       69960 
LeandroA       70490 
LeandroA       71022 
LeandroA       71556 
LeandroA       72092 
LeandroA       72630 
LeandroA       73170 
LeandroA       73712 
LeandroA       74256 
LeandroA       74802 
LeandroA       75350 
LeandroA       75900 
LeandroA       76452 
LeandroA       77006 
LeandroA       77562 
LeandroA       78120 
LeandroA       78680 
LeandroA       79242 
LeandroA       79806 
LeandroA       80372 
LeandroA       80940 
LeandroA       81510 
LeandroA       82082 
LeandroA       82656 
LeandroA       83232 
LeandroA       83810 
LeandroA       84390 
LeandroA       84972 
LeandroA       85556 
LeandroA       86142 
LeandroA       86730 
LeandroA       87320 
LeandroA       87912 
LeandroA       88506 
LeandroA       89102 
LeandroA       89700 
LeandroA       90300 
LeandroA       90902 
LeandroA       91506 
LeandroA       92112

Código (vb) [Seleccionar]



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

Private Sub Form_Load()
Dim i           As Long
Dim t(1)        As Long

    t(0) = GetTickCount
    For i = 0 To 92681
        If IsOblongo01(i, 0) <> IsOblongo02(i) Then
            Debug.Print "Karcrack", i
        End If
    Next i
    t(1) = GetTickCount
    text1.text = text1.text & vbNewLine & "Karcrack --> " & t(1) - t(0)
    
    t(0) = GetTickCount
    For i = 0 To 92681
        If EsOblongo(i, 0) <> IsOblongo02(i) Then
            Debug.Print "Tokes", i
        End If
    Next i
    t(1) = GetTickCount
    text1.text = text1.text & vbNewLine & "Tokes --> " & t(1) - t(0)
    
    t(0) = GetTickCount
    For i = 0 To 92681
        If IsOblongo(i, 0) <> IsOblongo02(i) Then
            Debug.Print "BlackZeroX", i
        End If
    Next i
    t(1) = GetTickCount
    text1.text = text1.text & vbNewLine & "BlackZeroX --> " & t(1) - t(0)
    
    t(0) = GetTickCount
    For i = 0 To 92681
        If IsOblongoLeo(i, 0) <> IsOblongo02(i) Then
            Debug.Print "LeandroA", i
        End If
    Next i
    t(1) = GetTickCount
    text1.text = text1.text & vbNewLine & "LeandroA --> " & t(1) - t(0)
    
    
End Sub

'BlackZeroX
Private Function IsOblongo(ByVal lNumb As Long, ByRef n As Long) As Boolean
Dim a   As Long
    If lNumb < 0 Then n = -1: Exit Function
    If (lNumb And 1) = 0 Then
        If lNumb = 0 Then
            IsOblongo = True
        ElseIf lNumb = 2 Then
            n = 1
            IsOblongo = True
        ElseIf lNumb = 6 Then
            n = 2
            IsOblongo = True
        ElseIf lNumb = 12 Then
            n = 3
            IsOblongo = True
        Else
            For n = lNumb \ 4 To lNumb ^ (0.5) Step -1
                If n * (n - 1) = lNumb Then
                    IsOblongo = True
                    Exit Function
                End If
            Next
        End If
    Else
        IsOblongo = False
        n = -1
    End If
End Function

' Karcrack
Private Function IsOblongo01(ByVal lNumb As Long, ByRef n As Long) As Boolean
    If (lNumb = 0) Or (lNumb = 2) Then n = lNumb \ 2: IsOblongo01 = True: Exit Function
 
    If (lNumb And 1) Then
        For n = 3 To Sqr(lNumb + 1) Step 2
            If lNumb = n * (n + 1) Then
                IsOblongo01 = True
                Exit For
            End If
        Next n
    End If
End Function
 
'Tokes
Private Function EsOblongo(ByVal num As Long, ByRef n As Long) As Boolean
Dim max As Long, i As Long
    If (num And 1) Then Exit Function
 
    max = Sqr(num)
    For i = 0 To max
        If num = i * i + i Then 'i * (i + 1) Then
            EsOblongo = True
            n = i
            Exit Function
        End If
    Next
End Function

'raul338
Private Function EsCasiCuadrado(ByVal lNumb As Long, ByRef n As Long) As Boolean
    If lNumb < 0 Or (lNumb And 1) = 1 Then Exit Function
    If lNumb = 2 Then
        n = 1
        EsCasiCuadrado = True
    End If
 
    Dim i As Long
    Dim fin As Long
    fin = Sqr(lNumb)
    For i = 2 To fin
        If lNumb / i = i + 1 Then
            n = i
            EsCasiCuadrado = True
            Exit Function
        End If
    Next
End Function

'LeandroA
Private Function IsOblongoLeo(ByVal lNumb As Long, ByRef n As Long) As Boolean
    Dim R As Long
    Dim lSum As Long
 
    If (lNumb And 1) Then Exit Function
 
    lSum = lNumb + 1
 
    R = lSum ^ 0.48
    If lNumb = R * (R + 1) Then
        IsOblongoLeo = True
        n = R
    Else
        R = lSum ^ 0.49
        If lNumb = R * (R + 1) Then
            IsOblongoLeo = True
            n = R
        Else
            R = lSum ^ 0.495
            If lNumb = R * (R + 1) Then
                IsOblongoLeo = True
                n = R
            Else
                R = lSum ^ 0.498
                If lNumb = R * (R + 1) Then
                    IsOblongoLeo = True
                    n = R
                Else
                    R = lSum ^ 0.499
                    If lNumb = R * (R + 1) Then
                        IsOblongoLeo = True
                        n = R
                    Else
                        If (lNumb = 0) Or (lNumb = 2) Then n = lNumb \ 2: IsOblongoLeo = True: Exit Function
                        If (lNumb = 6) Then n = 2: IsOblongoLeo = True
                    End If
                End If
            End If
        End If
    End If
End Function

' Karcrack, no cumple el requisito de devolver n
Private Function IsOblongo02(ByVal lNumb As Long) As Boolean
    IsOblongo02 = (Round(Sqr(lNumb + 1)) - Round(Sqr(lNumb)) = 1)
End Function

P.D.: la mia es la mas lenta xP

Ducles Lunas!¡.

Karcrack · 17 Agosto 2010, 12:54 PM

1- Raul338 aplicas mal el algoritmo, como ha dicho Cobein (n * (n+1)) <> (n * n + 1)
2- La velocidad ha de comprobarse compilada siempre.
3- Algunos de vosotros no incluis el 2 como numero Oblongo, y lo es: 2 = 1*(1+1)
4- Aqui pongo los resultados del test que he corrido en mi PC (Con la llamada que puse yo, que es con la que hay que probar ):

Código [Seleccionar]

Karcrack -> 5,729 msec
Tokes -> 6,236 msec
LeandroA -> 24,102 
B0X -> 76,071 msec
raul338 -> Funcion no valida

He actualizado mi funcion, tenia un gran fallo

Código [Seleccionar]

' Karcrack
Private Function IsOblongo01(ByVal lNumb As Long, ByRef n As Long) As Boolean
    If (lNumb = 0) Then n = 0: IsOblongo01 = True: Exit Function
 
    If (lNumb And 1) = 0 Then
        For n = 1 To Sqr(lNumb + 1)
            If lNumb = n * (n + 1) Then
                IsOblongo01 = True
                Exit For
            End If
        Next n
    End If
End Function

79137913 · 17 Agosto 2010, 14:55 PM

HOLA!!!

QUISIERA SABER QUE ES MAS RAPIDO:

Código (vb) [Seleccionar]


If Not (lNumb And 1) = 0 Then Exit Function

' O

If Not (lNumb Mod 2) = 0 Then Exit Function

Gracias!!!

raul338 · 17 Agosto 2010, 16:22 PM

Cita de: cobein en 17 Agosto 2010, 05:56 AM
Algo que vi en algunos algoritmos

6 = 2*(2+1) no es lo mismo que 2 * 2+1

Cita de: Karcrack en 17 Agosto 2010, 12:54 PM
1- Raul338 aplicas mal el algoritmo, como ha dicho Cobein (n * (n+1)) <> (n * n + 1)

Citar
6 = 2 * (2 + 1)
// pasamos el 2 dividiendo a 6
6 / 2 = 2 + 1
// en otros lados dicen "dividimos ambos mienbros por 2
6 / 2 = ~~2 * (~~2 + 1)
2
6 / 2 = 2 + 1

Cosa que eso es lo que hago yo

Cambien "lNumb / i = i + 1" por "lNumb = i * (i + 1)" y les dara exactamente los mismos resultados

Tokes · 17 Agosto 2010, 17:51 PM

raul338 tiene toda la razón del universo.

Saludos...

raul338 · 17 Agosto 2010, 18:08 PM

Ufff.... para mi LeandroA ha ganado el reto!, es rapidisima su funcion!!!!

Karcrack · 17 Agosto 2010, 19:01 PM

@79137913: Es mucho mas rapido el primero, siempre trabajar con Bits es mas rapido.

Tokes · 17 Agosto 2010, 19:07 PM

Hola a todos. No proclamen un ganador sin primero ver esto.

Código [Seleccionar]

Option Explicit

Dim n As Long
Private Declare Function GetTickCount Lib "Kernel32" () As Long

Private Sub Form_Load()
    Label1.Caption = ""
    Label1.AutoSize = True
    Text1 = ""
    Command1.Caption = "Calcular"
End Sub

Private Sub Command1_Click()
Dim i As Long, t1 As Long, t2 As Long, c As Long

    On Error Resume Next
    Label1.Caption = ""
    
    'BlackZeroX
    c = 0
    t1 = GetTickCount
    For i = 1 To Val(Text1)
        If IsOblongo(i, n) Then
            c = c + 1
        End If
    Next
    t2 = GetTickCount
    Label1.Caption = Label1.Caption & "'BlackZeroX --> " & t2 - t1 & Chr(13) _
    & c & " números oblongos encontrados" & Chr(13) & Chr(13)
    
    'Karcrack
    c = 0
    t1 = GetTickCount
    For i = 1 To Val(Text1)
        If IsOblongo01(i, n) Then
            c = c + 1
        End If
    Next
    t2 = GetTickCount
    Label1.Caption = Label1.Caption & "Karcrack --> " & t2 - t1 & Chr(13) _
    & c & " números oblongos encontrados" & Chr(13) & Chr(13)
    
    'Tokes
    c = 0
    t1 = GetTickCount
    For i = 1 To Val(Text1)
        If EsOblongo(i, n) Then
            c = c + 1
        End If
    Next
    t2 = GetTickCount
    Label1.Caption = Label1.Caption & "Tokes --> " & t2 - t1 & Chr(13) _
    & c & " números oblongos encontrados" & Chr(13) & Chr(13)
    
    'Tokes 2
    c = 0
    t1 = GetTickCount
    For i = 1 To Val(Text1)
        If EsOblongo2(i, n) Then
            c = c + 1
        End If
    Next
    t2 = GetTickCount
    Label1.Caption = Label1.Caption & "Tokes 2 --> " & t2 - t1 & Chr(13) _
    & c & " números oblongos encontrados" & Chr(13) & Chr(13)
    
    'raul338
    c = 0
    t1 = GetTickCount
    For i = 1 To Val(Text1)
        If EsCasiCuadrado(i, n) Then
            c = c + 1
        End If
    Next
    t2 = GetTickCount
    Label1.Caption = Label1.Caption & "raul338 --> " & t2 - t1 & Chr(13) _
    & c & " números oblongos encontrados" & Chr(13) & Chr(13)
    
    'LeandroA
    c = 0
    t1 = GetTickCount
    For i = 1 To Val(Text1)
        If IsOblongoLeo(i, n) Then
            c = c + 1
        End If
    Next
    t2 = GetTickCount
    Label1.Caption = Label1.Caption & "LeandroA --> " & t2 - t1 & Chr(13) _
    & c & " números oblongos encontrados" & Chr(13) & Chr(13)
    
    'Karcrack sin retorno de n
    c = 0
    t1 = GetTickCount
    For i = 1 To Val(Text1)
        If IsOblongo02(i) Then
            c = c + 1
        End If
    Next
    t2 = GetTickCount
    Label1.Caption = Label1.Caption & "Karcrack (IsOblongo02) = " & t2 - t1 & Chr(13) _
    & c & " números oblongos encontrados" & Chr(13) & Chr(13)
End Sub


'----------------------
'BlackZeroX
Private Function IsOblongo(ByVal lNumb As Long, ByRef n As Long) As Boolean
Dim a   As Long
    If lNumb < 0 Then n = -1: Exit Function
    If (lNumb And 1) = 0 Then
        If lNumb = 0 Then
            IsOblongo = True
        ElseIf lNumb = 2 Then
            n = 1
            IsOblongo = True
        ElseIf lNumb = 6 Then
            n = 2
            IsOblongo = True
        ElseIf lNumb = 12 Then
            n = 3
            IsOblongo = True
        Else
            For n = lNumb \ 4 To lNumb ^ (0.5) Step -1
                If n * (n - 1) = lNumb Then
                    IsOblongo = True
                    Exit Function
                End If
            Next
        End If
    Else
        IsOblongo = False
        n = -1
    End If
End Function
 
'------------------
' Karcrack
Private Function IsOblongo01(ByVal lNumb As Long, ByRef n As Long) As Boolean
    If (lNumb = 0) Then n = 0: IsOblongo01 = True: Exit Function
 
    If (lNumb And 1) = 0 Then
        For n = 1 To Sqr(lNumb + 1)
            If lNumb = n * (n + 1) Then
                IsOblongo01 = True
                Exit For
            End If
        Next n
    End If
End Function

'--------------------
'Tokes
Private Function EsOblongo(ByVal num As Long, ByRef n As Long) As Boolean
Dim max As Long, i As Long
    If (num And 1) Then Exit Function
 
    max = Sqr(num)
    For i = 0 To max
        If num = i * i + i Then 'i * (i + 1) Then
            EsOblongo = True
            n = i
            Exit Function
        End If
    Next
End Function
 
'-----------------
'Tokes 2
Private Function EsOblongo2(ByVal num As Long, ByRef n As Long) As Boolean
Dim max As Long
    If (num And 1) Or (num And &H80000000) Then Exit Function
    
    max = Sqr(num)
    If num = max * max + max Then
        EsOblongo2 = True
        n = max
        Exit Function
    End If
End Function
 
'raul338
Private Function EsCasiCuadrado(ByVal lNumb As Long, ByRef n As Long) As Boolean
    If lNumb < 0 Or (lNumb And 1) = 1 Then Exit Function
    If lNumb = 2 Then
        n = 1
        EsCasiCuadrado = True
    End If
 
    Dim i As Long
    Dim fin As Long
    fin = Sqr(lNumb)
    For i = 2 To fin
        If lNumb / i = i + 1 Then
            n = i
            EsCasiCuadrado = True
            Exit Function
        End If
    Next
End Function
 
'LeandroA
Private Function IsOblongoLeo(ByVal lNumb As Long, ByRef n As Long) As Boolean
    Dim R As Long
    Dim lSum As Long
 
    If (lNumb And 1) Then Exit Function
 
    lSum = lNumb + 1
 
    R = lSum ^ 0.48
    If lNumb = R * (R + 1) Then
        IsOblongoLeo = True
        n = R
    Else
        R = lSum ^ 0.49
        If lNumb = R * (R + 1) Then
            IsOblongoLeo = True
            n = R
        Else
            R = lSum ^ 0.495
            If lNumb = R * (R + 1) Then
                IsOblongoLeo = True
                n = R
            Else
                R = lSum ^ 0.498
                If lNumb = R * (R + 1) Then
                    IsOblongoLeo = True
                    n = R
                Else
                    R = lSum ^ 0.499
                    If lNumb = R * (R + 1) Then
                        IsOblongoLeo = True
                        n = R
                    Else
                        If (lNumb = 0) Or (lNumb = 2) Then n = lNumb \ 2: IsOblongoLeo = True: Exit Function
                        If (lNumb = 6) Then n = 2: IsOblongoLeo = True
                    End If
                End If
            End If
        End If
    End If
End Function
 
' Karcrack, no cumple el requisito de devolver n
Private Function IsOblongo02(ByVal lNumb As Long) As Boolean
    IsOblongo02 = (Round(Sqr(lNumb + 1)) - Round(Sqr(lNumb)) = 1)
End Function

Saludos.