[RETO] Comprobar si un numero es Oblongo/Pronico

[Karcrack]

Seguimos con los retos de velocidad y numeros Ahora han tocado los numeros pronicos/oblongos... que no requieren un algoritmo muy complejo, pero si que tocara pensar para augmentar la velocidad

Mas informacion:

Código [Seleccionar] Expandir

http://en.wikipedia.org/wiki/Pronic_number
http://oeis.org/classic/A002378
Se trata de comprobar si un numero puede ser expresado como el producto de dos enteros consecutivos... es decir:

Código [Seleccionar] Expandir

numero_oblongo = n*(n+1)
Ejemplo:

Código [Seleccionar] Expandir

6 = 2*(2+1)

Se trata de comprobar que el numero es oblongo y devolver el valor de n... La funcion ha de estar declarada de este modo:

Código (vb) [Seleccionar] Expandir

Private Function IsOblongo(ByVal lNumb As Long, ByRef n As Long) As Boolean

Tal vez la velocidad de aparicion de nuevos retos sea elevada, pero es que por las noches me aburro

Se el mas rapido del oeste, vaquero!

[Karcrack]

Esta seria la forma habitual y logica de realizar el algoritmo:

Código (vb) [Seleccionar] Expandir

Private Function IsOblongo(ByVal lNumb As Long, ByRef n As Long) As Boolean
   Dim i   As Long
   
   For i = 0 To lNumb
       If lNumb = i * (i + 1) Then
           IsOblongo = True
           n = i
           Exit For
       End If
   Next i
End Function

Por cierto, la velocidad se medira llamando a la funcion con un rango de 10000 numeros, tal que asi:

Código [Seleccionar] Expandir

   Dim i   As Long
   Dim n   As Long

   For i = 0 To 10000
       Call IsOblongo(i, n)
   Next i

[Karcrack]

Aqui esta mi codigo

Código (vb) [Seleccionar] Expandir

' 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

Si simplemente se quiere comprobar si es oblongo sin calcular n, se puede hacer asi:

Código [Seleccionar] Expandir

' 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
Es mas corta, pero no mas rapida

[raul338]

Propongo esta pero no es tan rapida

Código (vb) [Seleccionar] Expandir


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


[OFFTOPIC]Primera vez que me sale algo para participar!!! [/OFFTOPIC]

[Karcrack]

@raul338: Para mejorar la velocidad te recomiendo que te saltes los pares, ya que ningun par mayor que 2 es pronico, tambien te recomiendo que hagas el bucle con la n; Te ahorras una variable y ganas velocidad... Y por ultimo te recomiendo que aqui:

Código [Seleccionar] Expandir

        If lNumb / i = i + 1 Then
Hagas la division entera (\) que es mas rapida

Saludos

[Tokes]

Aquí dejo mi código.

Código [Seleccionar] Expandir

'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]

He agregado un filtro al codigo tokes, es mas rapido por unas milesimas de segundo XD (se nota en casos grandes y solo EN EL IDE )
@Karcrack Tu codigo no devuelve nada o al menos yo pruebo asi:

Código (vb) [Seleccionar] Expandir

Option Explicit
Dim i As Integer
Dim tim As New CTiming

Private Sub Form_Load()
   Dim i   As Long
   Dim j As Long
   Dim s As String
   
   s = ""
   tim.Reset
   For i = 1 To 100000
       If EsOblongo(i, j) Then s = s & i & ","
   Next i
   Text1.Text = Text1.Text & "Tokes: " & tim.Elapsed & vbCrLf & s & vbCrLf
   
   s = ""
   tim.Reset
   For i = 1 To 100000
       If EsCasiCuadrado(i, j) Then s = s & i & ","
   Next i
   Text1.Text = Text1.Text & "Tokes Mod Raul338: " & tim.Elapsed & vbCrLf & s & vbCrLf
   
   s = ""
   tim.Reset
   For i = 1 To 100000
       If IsOblongo01(i, j) Then s = s & i & ","
   Next i
   Text1.Text = Text1.Text & "Karcrack: " & tim.Elapsed & vbCrLf & s & vbCrLf
End Sub

' Tokes Mod Raul338
Private Function EsCasiCuadrado(ByVal lNumb As Long, ByRef n As Long) As Boolean
   If lNumb < 0 Then Exit Function
   If (lNumb And 1) Then Exit Function
   
   Dim s As Long
   s = CLng(Right$(lNumb, 1))
   If (Not s = 0) Xor (Not s = 2) Xor (Not s = 6) Then
       Exit Function
   End If
   
   Dim fin As Long
   fin = Sqr(lNumb)

   For n = 1 To fin
       If lNumb = n * n + n Then
           EsCasiCuadrado = True
           Exit Function
       End If
   Next
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


A ver quien mas se postula


Ademas Karcrack, poniendo \ me empezo a tirar valores literalmente falsos




Resultados en tiempo de ejecucion!!!

Código [Seleccionar] Expandir


Tokes: 44,9498563796377
2,6,12,20,30,42,56,72,90,110,132,156,182,210,240,272,306,342,380,420,462,506,552,600,650,702,756,812,870,930,992,1056,1122,1190,1260,1332,1406,1482,1560,1640,1722,1806,1892,1980,2070,2162,2256,2352,2450,2550,2652,2756,2862,2970,3080,3192,3306,3422,3540,3660,3782,3906,4032,4160,4290,4422,4556,4692,4830,4970,5112,5256,5402,5550,5700,5852,6006,6162,6320,6480,6642,6806,6972,7140,7310,7482,7656,7832,8010,8190,8372,8556,8742,8930,9120,9312,9506,9702,9900,10100,10302,10506,10712,10920,11130,11342,11556,11772,11990,12210,12432,12656,12882,13110,13340,13572,13806,14042,14280,14520,14762,15006,15252,15500,15750,16002,16256,16512,16770,17030,17292,17556,17822,18090,18360,18632,18906,19182,19460,19740,20022,20306,20592,20880,21170,21462,21756,22052,22350,22650,22952,23256,23562,23870,24180,24492,24806,25122,25440,25760,26082,26406,26732,27060,27390,27722,28056,28392,28730,29070,29412,29756,30102,30450,30800,31152,31506,31862,32220,32580,32942,33306,33672,34040,34410,34782,35156,35532,35910,36290,36672,37056,37442,37830,38220,38612,39006,39402,39800,40200,40602,41006,41412,41820,42230,42642,43056,43472,43890,44310,44732,45156,45582,46010,46440,46872,47306,47742,48180,48620,49062,49506,49952,50400,50850,51302,51756,52212,52670,53130,53592,54056,54522,54990,55460,55932,56406,56882,57360,57840,58322,58806,59292,59780,60270,60762,61256,61752,62250,62750,63252,63756,64262,64770,65280,65792,66306,66822,67340,67860,68382,68906,69432,69960,70490,71022,71556,72092,72630,73170,73712,74256,74802,75350,75900,76452,77006,77562,78120,78680,79242,79806,80372,80940,81510,82082,82656,83232,83810,84390,84972,85556,86142,86730,87320,87912,88506,89102,89700,90300,90902,91506,92112,92720,93330,93942,94556,95172,95790,96410,97032,97656,98282,98910,99540,
Tokes Mod Raul338: 76,2871329372145
2,6,12,20,30,42,56,72,90,110,132,156,182,210,240,272,306,342,380,420,462,506,552,600,650,702,756,812,870,930,992,1056,1122,1190,1260,1332,1406,1482,1560,1640,1722,1806,1892,1980,2070,2162,2256,2352,2450,2550,2652,2756,2862,2970,3080,3192,3306,3422,3540,3660,3782,3906,4032,4160,4290,4422,4556,4692,4830,4970,5112,5256,5402,5550,5700,5852,6006,6162,6320,6480,6642,6806,6972,7140,7310,7482,7656,7832,8010,8190,8372,8556,8742,8930,9120,9312,9506,9702,9900,10100,10302,10506,10712,10920,11130,11342,11556,11772,11990,12210,12432,12656,12882,13110,13340,13572,13806,14042,14280,14520,14762,15006,15252,15500,15750,16002,16256,16512,16770,17030,17292,17556,17822,18090,18360,18632,18906,19182,19460,19740,20022,20306,20592,20880,21170,21462,21756,22052,22350,22650,22952,23256,23562,23870,24180,24492,24806,25122,25440,25760,26082,26406,26732,27060,27390,27722,28056,28392,28730,29070,29412,29756,30102,30450,30800,31152,31506,31862,32220,32580,32942,33306,33672,34040,34410,34782,35156,35532,35910,36290,36672,37056,37442,37830,38220,38612,39006,39402,39800,40200,40602,41006,41412,41820,42230,42642,43056,43472,43890,44310,44732,45156,45582,46010,46440,46872,47306,47742,48180,48620,49062,49506,49952,50400,50850,51302,51756,52212,52670,53130,53592,54056,54522,54990,55460,55932,56406,56882,57360,57840,58322,58806,59292,59780,60270,60762,61256,61752,62250,62750,63252,63756,64262,64770,65280,65792,66306,66822,67340,67860,68382,68906,69432,69960,70490,71022,71556,72092,72630,73170,73712,74256,74802,75350,75900,76452,77006,77562,78120,78680,79242,79806,80372,80940,81510,82082,82656,83232,83810,84390,84972,85556,86142,86730,87320,87912,88506,89102,89700,90300,90902,91506,92112,92720,93330,93942,94556,95172,95790,96410,97032,97656,98282,98910,99540,
Karcrack: 61,5048539640439
2,


[LeandroA]

Hola me matan las matematicas @~#~#

bueno pongo dos funciones una a lo bruto y la otra mejor es en base a la de tokes pero mas rapida.

Código (vb) [Seleccionar] Expandir


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


y esta mucho mas rapida

Código (vb) [Seleccionar] Expandir


Private Function IsOblongoLeo2(ByVal lNumb As Long, ByRef n As Long) As Boolean

    Dim lmax As Long, i As Long

    If (lNumb And 1) Then Exit Function
    If lNumb = 0 Then n = 0: IsOblongoLeo2 = True: Exit Function

    lmax = Sqr(lNumb)

    For i = lmax - 1 To lmax
        If lNumb = i * (i + 1) Then
            IsOblongoLeo2 = True
            n = i
            Exit Function
        End If
    Next
End Function


[cobein]

Algo que vi en algunos algoritmos

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

[LeandroA]

jaja eso me pasa por copiar