Foro de elhacker.net

Programación => Programación Visual Basic => Mensaje iniciado por: Karcrack en 17 Agosto 2010, 01:23 am


Título: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Karcrack en 17 Agosto 2010, 01:23 am
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 :D

Mas informacion:
Código:
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:
numero_oblongo = n*(n+1)
Ejemplo:
Código:
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
  1. 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 :-[ :P

Se el mas rapido del oeste, vaquero! (http://r.i.elhacker.net/cache?url=http://foro.elhacker.net/Smileys/cowboy/laugh.gif)(http://r.i.elhacker.net/cache?url=http://foro.elhacker.net/Smileys/cowboy/laugh.gif)

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Karcrack en 17 Agosto 2010, 01:32 am
Esta seria la forma habitual y logica de realizar el algoritmo:
Código
  1. Private Function IsOblongo(ByVal lNumb As Long, ByRef n As Long) As Boolean
  2.     Dim i   As Long
  3.  
  4.     For i = 0 To lNumb
  5.         If lNumb = i * (i + 1) Then
  6.             IsOblongo = True
  7.             n = i
  8.             Exit For
  9.         End If
  10.     Next i
  11. End Function

Por cierto, la velocidad se medira llamando a la funcion con un rango de 10000 numeros, tal que asi:
Código:
    Dim i   As Long
    Dim n   As Long

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

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Karcrack en 17 Agosto 2010, 01:49 am
Aqui esta mi codigo :D
Código
  1. ' Karcrack
  2. Private Function IsOblongo01(ByVal lNumb As Long, ByRef n As Long) As Boolean
  3.     If (lNumb = 0) Then n = 0: IsOblongo01 = True: Exit Function
  4.  
  5.     If (lNumb And 1) = 0 Then
  6.         For n = 1 To Sqr(lNumb + 1)
  7.             If lNumb = n * (n + 1) Then
  8.                 IsOblongo01 = True
  9.                 Exit For
  10.             End If
  11.         Next n
  12.     End If
  13. End Function

Si simplemente se quiere comprobar si es oblongo sin calcular n, se puede hacer asi:
Código:
' 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 ;)

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: raul338 en 17 Agosto 2010, 02:03 am
Propongo esta pero no es tan rapida :P

Código
  1. Private Function EsCasiCuadrado(ByVal lNumb As Long, ByRef n As Long) As Boolean
  2.     If lNumb < 0 Or (lNumb And 1) = 1 Then Exit Function
  3.     If lNumb = 2 Then
  4.         n = 1
  5.         EsCasiCuadrado = True
  6.     End If
  7.  
  8.     Dim i As Long
  9.     Dim fin As Long
  10.     fin = Sqr(lNumb)
  11.     For i = 2 To fin
  12.         If lNumb / i = i + 1 Then
  13.             n = i
  14.             EsCasiCuadrado = True
  15.             Exit Function
  16.         End If
  17.     Next
  18. End Function
  19.  

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

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Karcrack en 17 Agosto 2010, 02:24 am
@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:
        If lNumb / i = i + 1 Then
Hagas la division entera (\) que es mas rapida ;)

Saludos :D

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Tokes en 17 Agosto 2010, 03:24 am
Aquí dejo mi código.

Código:
'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

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: raul338 en 17 Agosto 2010, 04:40 am
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 :P)
@Karcrack Tu codigo no devuelve nada :( o al menos yo pruebo asi:

Código
  1. Option Explicit
  2. Dim i As Integer
  3. Dim tim As New CTiming
  4.  
  5. Private Sub Form_Load()
  6.     Dim i   As Long
  7.     Dim j As Long
  8.     Dim s As String
  9.  
  10.     s = ""
  11.     tim.Reset
  12.     For i = 1 To 100000
  13.         If EsOblongo(i, j) Then s = s & i & ","
  14.     Next i
  15.     Text1.Text = Text1.Text & "Tokes: " & tim.Elapsed & vbCrLf & s & vbCrLf
  16.  
  17.     s = ""
  18.     tim.Reset
  19.     For i = 1 To 100000
  20.         If EsCasiCuadrado(i, j) Then s = s & i & ","
  21.     Next i
  22.     Text1.Text = Text1.Text & "Tokes Mod Raul338: " & tim.Elapsed & vbCrLf & s & vbCrLf
  23.  
  24.     s = ""
  25.     tim.Reset
  26.     For i = 1 To 100000
  27.         If IsOblongo01(i, j) Then s = s & i & ","
  28.     Next i
  29.     Text1.Text = Text1.Text & "Karcrack: " & tim.Elapsed & vbCrLf & s & vbCrLf
  30. End Sub
  31.  
  32. ' Tokes Mod Raul338
  33. Private Function EsCasiCuadrado(ByVal lNumb As Long, ByRef n As Long) As Boolean
  34.     If lNumb < 0 Then Exit Function
  35.     If (lNumb And 1) Then Exit Function
  36.  
  37.     Dim s As Long
  38.     s = CLng(Right$(lNumb, 1))
  39.     If (Not s = 0) Xor (Not s = 2) Xor (Not s = 6) Then
  40.         Exit Function
  41.     End If
  42.  
  43.     Dim fin As Long
  44.     fin = Sqr(lNumb)
  45.  
  46.     For n = 1 To fin
  47.         If lNumb = n * n + n Then
  48.             EsCasiCuadrado = True
  49.             Exit Function
  50.         End If
  51.     Next
  52. End Function
  53.  
  54. ' Karcrack
  55. Private Function IsOblongo01(ByVal lNumb As Long, ByRef n As Long) As Boolean
  56.     If (lNumb = 0) Or (lNumb = 2) Then n = lNumb \ 2: IsOblongo01 = True: Exit Function
  57.  
  58.     If (lNumb And 1) Then
  59.         For n = 3 To Sqr(lNumb + 1) Step 2
  60.             If lNumb = n * (n + 1) Then
  61.                 IsOblongo01 = True
  62.                 Exit For
  63.             End If
  64.         Next n
  65.     End If
  66. End Function
  67.  
  68. 'Tokes
  69. Private Function EsOblongo(ByVal num As Long, ByRef n As Long) As Boolean
  70. Dim max As Long, i As Long
  71.     If (num And 1) Then Exit Function
  72.  
  73.     max = Sqr(num)
  74.     For i = 0 To max
  75.         If num = i * i + i Then 'i * (i + 1) Then
  76.             EsOblongo = True
  77.             n = i
  78.             Exit Function
  79.         End If
  80.     Next
  81. End Function
  82.  

A ver quien mas se postula :P


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



Resultados en tiempo de ejecucion!!!

Código:
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,

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: LeandroA en 17 Agosto 2010, 05:24 am
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
  1. Private Function IsOblongoLeo(ByVal lNumb As Long, ByRef n As Long) As Boolean
  2.     Dim R As Long
  3.     Dim lSum As Long
  4.  
  5.     If (lNumb And 1) Then Exit Function
  6.  
  7.     lSum = lNumb + 1
  8.  
  9.     R = lSum ^ 0.48
  10.     If lNumb = R * (R + 1) Then
  11.         IsOblongoLeo = True
  12.         n = R
  13.     Else
  14.         R = lSum ^ 0.49
  15.         If lNumb = R * (R + 1) Then
  16.             IsOblongoLeo = True
  17.             n = R
  18.         Else
  19.             R = lSum ^ 0.495
  20.             If lNumb = R * (R + 1) Then
  21.                 IsOblongoLeo = True
  22.                 n = R
  23.             Else
  24.                 R = lSum ^ 0.498
  25.                 If lNumb = R * (R + 1) Then
  26.                     IsOblongoLeo = True
  27.                     n = R
  28.                 Else
  29.                     R = lSum ^ 0.499
  30.                     If lNumb = R * (R + 1) Then
  31.                         IsOblongoLeo = True
  32.                         n = R
  33.                     Else
  34.                         If (lNumb = 0) Or (lNumb = 2) Then n = lNumb \ 2: IsOblongoLeo = True: Exit Function
  35.                         If (lNumb = 6) Then n = 2: IsOblongoLeo = True
  36.                     End If
  37.                 End If
  38.             End If
  39.         End If
  40.     End If
  41. End Function
  42.  

y esta mucho mas rapida

Código
  1. Private Function IsOblongoLeo2(ByVal lNumb As Long, ByRef n As Long) As Boolean
  2.  
  3.     Dim lmax As Long, i As Long
  4.  
  5.     If (lNumb And 1) Then Exit Function
  6.     If lNumb = 0 Then n = 0: IsOblongoLeo2 = True: Exit Function
  7.  
  8.     lmax = Sqr(lNumb)
  9.  
  10.     For i = lmax - 1 To lmax
  11.         If lNumb = i * (i + 1) Then
  12.             IsOblongoLeo2 = True
  13.             n = i
  14.             Exit Function
  15.         End If
  16.     Next
  17. End Function
  18.  


Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: 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

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: LeandroA en 17 Agosto 2010, 06:11 am
jaja eso me pasa por copiar  ;D

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: BlackZeroX en 17 Agosto 2010, 08:27 am
no participe en el anterior reto pero dejo lña mia

Código
  1.  
  2. Private Function IsOblongo(ByVal lNumb As Long, ByRef n As Long) As Boolean
  3. Dim a   As Long
  4.     If lNumb < 0 Then n = -1: Exit Function
  5.     If (lNumb And 1) = 0 Then
  6.         If lNumb = 0 Then
  7.             IsOblongo = True
  8.         ElseIf lNumb = 2 Then
  9.             n = 1
  10.             IsOblongo = True
  11.         ElseIf lNumb = 6 Then
  12.             n = 2
  13.             IsOblongo = True
  14.         ElseIf lNumb = 12 Then
  15.             n = 3
  16.             IsOblongo = True
  17.         Else
  18.             For n = lNumb \ 4 To lNumb ^ (0.5) Step -1
  19.                 If n * (n - 1) = lNumb Then
  20.                     IsOblongo = True
  21.                     Exit Function
  22.                 End If
  23.             Next
  24.         End If
  25.     Else
  26.         IsOblongo = False
  27.         n = -1
  28.     End If
  29. End Function
  30.  
  31.  

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

Dulces Lunas!¡.

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: BlackZeroX en 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!¡.

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: BlackZeroX en 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:

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
  1.  
  2. Option Explicit
  3. Private Declare Function GetTickCount Lib "Kernel32" () As Long
  4.  
  5. Private Sub Form_Load()
  6. Dim i           As Long
  7. Dim t(1)        As Long
  8.  
  9.     t(0) = GetTickCount
  10.     For i = 0 To 92681
  11.         If IsOblongo01(i, 0) <> IsOblongo02(i) Then
  12.             Debug.Print "Karcrack", i
  13.         End If
  14.     Next i
  15.     t(1) = GetTickCount
  16.     text1.text = text1.text & vbNewLine & "Karcrack --> " & t(1) - t(0)
  17.  
  18.     t(0) = GetTickCount
  19.     For i = 0 To 92681
  20.         If EsOblongo(i, 0) <> IsOblongo02(i) Then
  21.             Debug.Print "Tokes", i
  22.         End If
  23.     Next i
  24.     t(1) = GetTickCount
  25.     text1.text = text1.text & vbNewLine & "Tokes --> " & t(1) - t(0)
  26.  
  27.     t(0) = GetTickCount
  28.     For i = 0 To 92681
  29.         If IsOblongo(i, 0) <> IsOblongo02(i) Then
  30.             Debug.Print "BlackZeroX", i
  31.         End If
  32.     Next i
  33.     t(1) = GetTickCount
  34.     text1.text = text1.text & vbNewLine & "BlackZeroX --> " & t(1) - t(0)
  35.  
  36.     t(0) = GetTickCount
  37.     For i = 0 To 92681
  38.         If IsOblongoLeo(i, 0) <> IsOblongo02(i) Then
  39.             Debug.Print "LeandroA", i
  40.         End If
  41.     Next i
  42.     t(1) = GetTickCount
  43.     text1.text = text1.text & vbNewLine & "LeandroA --> " & t(1) - t(0)
  44.  
  45.  
  46. End Sub
  47.  
  48. 'BlackZeroX
  49. Private Function IsOblongo(ByVal lNumb As Long, ByRef n As Long) As Boolean
  50. Dim a   As Long
  51.     If lNumb < 0 Then n = -1: Exit Function
  52.     If (lNumb And 1) = 0 Then
  53.         If lNumb = 0 Then
  54.             IsOblongo = True
  55.         ElseIf lNumb = 2 Then
  56.             n = 1
  57.             IsOblongo = True
  58.         ElseIf lNumb = 6 Then
  59.             n = 2
  60.             IsOblongo = True
  61.         ElseIf lNumb = 12 Then
  62.             n = 3
  63.             IsOblongo = True
  64.         Else
  65.             For n = lNumb \ 4 To lNumb ^ (0.5) Step -1
  66.                 If n * (n - 1) = lNumb Then
  67.                     IsOblongo = True
  68.                     Exit Function
  69.                 End If
  70.             Next
  71.         End If
  72.     Else
  73.         IsOblongo = False
  74.         n = -1
  75.     End If
  76. End Function
  77.  
  78. ' Karcrack
  79. Private Function IsOblongo01(ByVal lNumb As Long, ByRef n As Long) As Boolean
  80.     If (lNumb = 0) Or (lNumb = 2) Then n = lNumb \ 2: IsOblongo01 = True: Exit Function
  81.  
  82.     If (lNumb And 1) Then
  83.         For n = 3 To Sqr(lNumb + 1) Step 2
  84.             If lNumb = n * (n + 1) Then
  85.                 IsOblongo01 = True
  86.                 Exit For
  87.             End If
  88.         Next n
  89.     End If
  90. End Function
  91.  
  92. 'Tokes
  93. Private Function EsOblongo(ByVal num As Long, ByRef n As Long) As Boolean
  94. Dim max As Long, i As Long
  95.     If (num And 1) Then Exit Function
  96.  
  97.     max = Sqr(num)
  98.     For i = 0 To max
  99.         If num = i * i + i Then 'i * (i + 1) Then
  100.             EsOblongo = True
  101.             n = i
  102.             Exit Function
  103.         End If
  104.     Next
  105. End Function
  106.  
  107. 'raul338
  108. Private Function EsCasiCuadrado(ByVal lNumb As Long, ByRef n As Long) As Boolean
  109.     If lNumb < 0 Or (lNumb And 1) = 1 Then Exit Function
  110.     If lNumb = 2 Then
  111.         n = 1
  112.         EsCasiCuadrado = True
  113.     End If
  114.  
  115.     Dim i As Long
  116.     Dim fin As Long
  117.     fin = Sqr(lNumb)
  118.     For i = 2 To fin
  119.         If lNumb / i = i + 1 Then
  120.             n = i
  121.             EsCasiCuadrado = True
  122.             Exit Function
  123.         End If
  124.     Next
  125. End Function
  126.  
  127. 'LeandroA
  128. Private Function IsOblongoLeo(ByVal lNumb As Long, ByRef n As Long) As Boolean
  129.     Dim R As Long
  130.     Dim lSum As Long
  131.  
  132.     If (lNumb And 1) Then Exit Function
  133.  
  134.     lSum = lNumb + 1
  135.  
  136.     R = lSum ^ 0.48
  137.     If lNumb = R * (R + 1) Then
  138.         IsOblongoLeo = True
  139.         n = R
  140.     Else
  141.         R = lSum ^ 0.49
  142.         If lNumb = R * (R + 1) Then
  143.             IsOblongoLeo = True
  144.             n = R
  145.         Else
  146.             R = lSum ^ 0.495
  147.             If lNumb = R * (R + 1) Then
  148.                 IsOblongoLeo = True
  149.                 n = R
  150.             Else
  151.                 R = lSum ^ 0.498
  152.                 If lNumb = R * (R + 1) Then
  153.                     IsOblongoLeo = True
  154.                     n = R
  155.                 Else
  156.                     R = lSum ^ 0.499
  157.                     If lNumb = R * (R + 1) Then
  158.                         IsOblongoLeo = True
  159.                         n = R
  160.                     Else
  161.                         If (lNumb = 0) Or (lNumb = 2) Then n = lNumb \ 2: IsOblongoLeo = True: Exit Function
  162.                         If (lNumb = 6) Then n = 2: IsOblongoLeo = True
  163.                     End If
  164.                 End If
  165.             End If
  166.         End If
  167.     End If
  168. End Function
  169.  
  170. ' Karcrack, no cumple el requisito de devolver n
  171. Private Function IsOblongo02(ByVal lNumb As Long) As Boolean
  172.     IsOblongo02 = (Round(Sqr(lNumb + 1)) - Round(Sqr(lNumb)) = 1)
  173. End Function
  174.  
  175.  

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

Ducles Lunas!¡.

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Karcrack en 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:
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 :laugh:
Código:
' 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

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: 79137913 en 17 Agosto 2010, 14:55 pm
HOLA!!!

QUISIERA SABER QUE ES MAS RAPIDO:


Código
  1. If Not (lNumb And 1) = 0 Then Exit Function
  2.  
  3. ' O
  4.  
  5. If Not (lNumb Mod 2) = 0 Then Exit Function
  6.  


Gracias!!!

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: raul338 en 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 :P

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

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Tokes en 17 Agosto 2010, 17:51 pm
raul338 tiene toda la razón del universo.

                   Saludos...

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: raul338 en 17 Agosto 2010, 18:08 pm
Ufff.... para mi LeandroA ha ganado el reto!, es rapidisima su funcion!!!!

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Karcrack en 17 Agosto 2010, 19:01 pm
@79137913: Es mucho mas rapido el primero, siempre trabajar con Bits es mas rapido.

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Tokes en 17 Agosto 2010, 19:07 pm
Hola a todos. No proclamen un ganador sin primero ver esto.

Código:
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.

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: raul338 en 17 Agosto 2010, 19:09 pm
Tokes, no estas usando la ultima version de LeandroA :P

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Karcrack en 17 Agosto 2010, 19:15 pm
No se como estais calculando los tiempos... en mis calculos mi funcion es la mas rapida :-\

MOD: No useis GetTickCount(), para mas precision usad la Clase CTiming.cls que he puesto en otros retos ;)

MOD2: Acabo de ver que Tokes ha hecho una nueva funcion que no utiliza bucles :o, como has llegado a la conclusion de que num = (max * max) + max? Donde lo has leeeido!! :¬¬ :laugh: :laugh:

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: raul338 en 17 Agosto 2010, 19:22 pm
Cita de: *PsYkE1* en 12 Agosto 2010, 17:02 pm
Me he tomado la libertad de ir testeando, aunque habria que probarlo en más PCs...
Utilizando:
cTiming.cls (http://www.xbeat.net/vbspeed/download/CTiming.zip)

Código
  1. Option Explicit
  2. Dim i As Integer
  3. Dim tim As New CTiming
  4.  
  5. Private Sub Form_Load()
  6.     Dim i   As Long
  7.     Dim j As Long
  8.     Dim s As String
  9.  
  10.     s = ""
  11.     tim.Reset
  12.     For i = 0 To 100000
  13.         If EsOblongo2(i, j) Then s = s & "(" & i & "," & j & ")"
  14.     Next i
  15.     Text1.Text = Text1.Text & "Tokes: " & tim.Elapsed & vbCrLf & s & vbCrLf & vbCrLf
  16.  
  17.     s = ""
  18.     tim.Reset
  19.     For i = 0 To 100000
  20.         If IsOblongoLeo2(i, j) Then s = s & "(" & i & "," & j & ")"
  21.     Next i
  22.     Text1.Text = Text1.Text & "LeandroA: " & tim.Elapsed & vbCrLf & s & vbCrLf & vbCrLf
  23.  
  24.     s = ""
  25.     tim.Reset
  26.     For i = 0 To 100000
  27.         If IsOblongo01(i, j) Then s = s & "(" & i & "," & j & ")"
  28.     Next i
  29.     Text1.Text = Text1.Text & "Karcrack: " & tim.Elapsed & vbCrLf & s & vbCrLf & vbCrLf
  30. End Sub
  31.  
  32. ' Karcrack
  33. Private Function IsOblongo01(ByVal lNumb As Long, ByRef n As Long) As Boolean
  34.     If (lNumb = 0) Then n = 0: IsOblongo01 = True: Exit Function
  35.  
  36.     If (lNumb And 1) = 0 Then
  37.         For n = 1 To Sqr(lNumb + 1)
  38.             If lNumb = n * (n + 1) Then
  39.                 IsOblongo01 = True
  40.                 Exit For
  41.             End If
  42.         Next n
  43.     End If
  44. End Function
  45.  
  46. 'Tokes 2
  47. Private Function EsOblongo2(ByVal num As Long, ByRef n As Long) As Boolean
  48. Dim max As Long
  49.     If (num And 1) Or (num And &H80000000) Then Exit Function
  50.  
  51.     max = Sqr(num)
  52.     If num = max * max + max Then
  53.         EsOblongo2 = True
  54.         n = max
  55.         Exit Function
  56.     End If
  57. End Function
  58.  
  59. ' LeandroA
  60. Private Function IsOblongoLeo2(ByVal lNumb As Long, ByRef n As Long) As Boolean
  61.     Dim lmax As Long, i As Long
  62.  
  63.     If (lNumb And 1) Then Exit Function
  64.     If lNumb = 0 Then n = 0: IsOblongoLeo2 = True: Exit Function
  65.  
  66.     lmax = Sqr(lNumb)
  67.  
  68.     For i = lmax - 1 To lmax
  69.         If lNumb = i * (i + 1) Then
  70.             IsOblongoLeo2 = True
  71.             n = i
  72.             Exit Function
  73.         End If
  74.     Next
  75. End Function
  76.  

Tokes v2: 9,31712800337221
LeandroA: 7,62460838830173
Karcrack: 95,5182170415809

Blackzerox y yo perdimos por goleada :xD

Agregado la v2 de Tokes

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Karcrack en 17 Agosto 2010, 19:32 pm
No habia visto la nueva version de Leandro :o :o :o, buen trabajo :)
Código:
Option Explicit

Dim cT      As New CTiming

Private Sub Form_Load()
Dim i   As Long
Dim n   As Long

    Open "resultados.txt" For Binary As #1
    
    cT.Reset
    For i = 0 To 10000
        Call IsOblongo01(i, n)
    Next i

    Put #1, , "Karcrack -> " & cT.sElapsed & vbCrLf

    cT.Reset
    For i = 0 To 10000
        Call EsOblongo(i, n)
    Next i
    Put #1, , "Tokes -> " & cT.sElapsed & vbCrLf
    
    cT.Reset
    For i = 0 To 10000
        Call IsOblongoLeo2(i, n)
    Next i
    Put #1, , "LeandroA -> " & cT.sElapsed
    
    Close #1
    End
End Sub
 
' 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
 
' LeandroA
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
Código:
Karcrack -> 5,514 msec
Tokes -> 5,603 msec
LeandroA -> 1,576 msec

Tokes y yo estamos practicamente empatados.... es tan poco diferencia que a veces adelanto yo a veces el...

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: 79137913 en 17 Agosto 2010, 19:38 pm
Disculpen que moleste, se que en otro post dicenq ue programas son, pero no los logro encontrar ¿como sabes la velocidad de proceso?

GRACIAS

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: BlackZeroX en 17 Agosto 2010, 19:38 pm
Cita de: Karcrack en 17 Agosto 2010, 19:15 pm
No se como estais calculando los tiempos... en mis calculos mi funcion es la mas rapida :-\

MOD: No useis GetTickCount(), para mas precision usad la Clase CTiming.cls que he puesto en otros retos ;)

MOD2: Acabo de ver que Tokes ha hecho una nueva funcion que no utiliza bucles :o, como has llegado a la conclusion de que num = (max * max) + max? Donde lo has leeeido!! :¬¬ :laugh: :laugh:

x = n (n + 1),

es lo mismo que...

x = n *n + n   ---> [  n (n + 1) ]

esta en la Wikipedia ¬¬", ya ven para que no leen (  :-(  malditas matebruticas )

Código:

Pronic numbers can also be expressed as n² + n. The n-th pronic number is the sum of the first n even integers, as well as the difference between (2n − 1)² and the n-th centered hexagonal number.

All pronic numbers are even, therefore 2 is the only prime pronic number. It is also the only pronic number in the Fibonacci sequence.

The number of off-diagonal entries in a square matrix is always a pronic number.

The value of the Möbius function μ(x) for any pronic number x = n (n + 1), in addition to being computable in the usual way, can also be calculated as

    μ(x) = μ(n) μ(n + 1).

The fact that consecutive integers are coprime and that a pronic number is the product of two consecutive integers leads to a number of properties. Each distinct prime factor of a pronic number is present in only one of its factors. Thus a pronic number is squarefree if and only if n and n + 1 are. The number of distinct prime factors of a pronic number is the sum of the number of distinct prime factors of n and n + 1.


P.D.: La funcion (Original que no esta en base a dla de Tokes como el dice) de LeandroA solo funciona hasta 11771 ver aqui (http://foro.elhacker.net/programacion_visual_basic/reto_comprobar_si_un_numero_es_oblongopronico-t302373.0.html;msg1499805#msg1499805)

Dulces Lunas!¡.

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Tokes en 17 Agosto 2010, 19:44 pm
Bueno, aquí dejo nuevamente una recopilación de códigos, aunque sólo comparo la segunda versión de LeandroA con la segunda versión mía.

Las funciones que comparo son: IsOblongoLeo2 y EsOblongo2.

Cabe hacer notar que la función de LeandroA no tiene filtro para números negativos.

En Private Sub Command1_Click hice un bucle
    
          For i = -100 to Text1.text
              .....
          Next

Y la función de LeandroA se confunde, es decir, si toma en cuenta los negativos.

Código:
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 = ""
    
    'Tokes 2
    c = 0
    t1 = GetTickCount
    For i = -100 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)
    
    'LeandroA 2
    c = 0
    t1 = GetTickCount
    For i = -100 To Val(Text1)
        If IsOblongoLeo2(i, n) Then
            c = c + 1
        End If
    Next
    t2 = GetTickCount
    Label1.Caption = Label1.Caption & "LeandroA 2 --> " & t2 - t1 & Chr(13) _
    & c & " números oblongos encontrados" & Chr(13) & Chr(13)
End Sub
 
'-----------------
'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 + 1) Then
        EsOblongo2 = True
        n = max
        Exit Function
    End If
End Function

'LeandroA 2
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

Eso es todo por el momento. Gracias.

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: raul338 en 17 Agosto 2010, 19:50 pm
Desde -100 hasta 200000:
Agregando "IF lNumb < 0 Then Exit Function" a Karcrack y LeandroA queda....

Tokes: 19,422201520188
LeandroA: 13,5933384789009
Karcrack: 147,218339521488

En tiempo de ejecucion, usando CTiming

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: BlackZeroX en 17 Agosto 2010, 20:01 pm
una modificacion rapida (solo es 2 msec mas rapida ¬¬") a la funcion de Tokes (Ojala hubieramos despenajo n(n+1) ¬¬" )!¡.

Código
  1.  
  2. '  Tokes 03
  3. Private Function IsOblongoTokes03(ByVal nval As Long, ByRef n As Long) As Boolean
  4.     If (nval And 1) Or (nval And &H80000000) Then Exit Function
  5.     n = Sqr(nval)
  6.     IsOblongoTokes03 = n * n + n = nval
  7. End Function
  8.  
  9.  

Código:

Karcrack -> 3,740 msec
LeandroA -> 0,673 msec
raul338 -> 33,761 msec
Tokes -> 4,587 msec
Tokes 2 -> 0,576 msec
Tokes03-> 0,574 msec
BlackZeroX -> 85,029 msec


Temibles Matematicas Lunares!¡.

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Tokes en 17 Agosto 2010, 20:28 pm
BlackZerox:

A mí no me dan los mismos resultados. Yo estoy probando con las funciones GetTickCount y TimeGetTime. ¿Hay alguna otra manera de medir el tiempo?

Y gracias por la optimización de la función. Estuvo muy buena.

          Hasta pronto.

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: BlackZeroX en 17 Agosto 2010, 20:30 pm
Para extremistas!¡.

QueryPerformanceCounter (http://msdn.microsoft.com/en-us/library/ms644904%28VS.85%29.aspx)

Edito:

Proyecto gral!¡.   (http://infrangelux.sytes.net/FileX/index.php?file=/BlackZeroX/Comprovaciones/Oblongo%20Pronico/Text%20Gral%20V1.zip&dir=/BlackZeroX/Comprovaciones/Oblongo%20Pronico&)

Dulces Lunas!¡.

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: cobein en 17 Agosto 2010, 20:35 pm
No me dejen afuera!!!!! no tengo mucho tiempo ahora pero quiero darle una probada.

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Tokes en 17 Agosto 2010, 20:45 pm
Oye BlackZerox:

Gracias por el proyecto general. Te voy a molestar con una pregunta:

El módulo que contiene las funciones del timer, si yo no lo tuviera, ¿Tengo que crearlo, o ya hay una librería o algo así?

       Por tu atención, gracias.

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: LeandroA en 17 Agosto 2010, 20:48 pm
lmax = Sqr(lNumb) = al numero

carajo cuando lo probe no me daba poreso restaba uno y ahora veo que si funciona.  :-\

me gusto esta (nval And &H80000000) para los negativos.


Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: BlackZeroX en 17 Agosto 2010, 21:10 pm
Para quien le interese la funcion Sqr en ASM (es el punto critico ahora)

http://www.azillionmonkeys.com/qed/sqroot.html

@Tokes

en el mismo .Zip esta el archivo CTiming.cls, ya esta el proyecto completo!¡.

Dulces Lunas!¡.

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Novlucker en 17 Agosto 2010, 21:13 pm
No jodas, yo hice ese mismo código que ha colgado Tokes (salvo que omití el valor OR) y no lo puse porque el de Karcrack era bastante más rápido, supongo que eso me pasa por no tener el VB6 y probarlo en VBA :¬¬

Que alguien busque otro "reto" de estos, que a la próxima no me quedo quieto >:D

Saludos

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: LeandroA en 17 Agosto 2010, 21:56 pm
[OffTopic]
estuve queriendo probar las diferencias de velocidades entre el IF, SELECT CASE, IF inline etc.
la cuestion es que vi que las funciones que se llaman primero tiene cierta ventaja con respecto a las otras, esto mismo pasa cuando queremos comparar las funciones que estamos haciendo. Es correcto esto que digo?¿?¿

esto es lo que hice
si alteran el orden de las llamadas hay ciertos cambios.

Código
  1. Option Explicit
  2.  
  3. Private CTiming As CTiming
  4.  
  5.  
  6. Private Sub Form_Load()
  7.     Dim i As Long, j As Long
  8.     Dim ValTest As Long
  9.  
  10.     Set CTiming = New CTiming
  11.  
  12.     Me.AutoRedraw = True
  13.  
  14.     Me.Print "Test de velocidad" & vbCrLf
  15.  
  16.     ValTest = 5000000
  17.  
  18.     CTiming.Reset
  19.  
  20.     For i = 0 To ValTest
  21.         For j = 1 To 4
  22.             Prueba1 j
  23.         Next
  24.     Next
  25.  
  26.     Me.Print "Prueba1 " & CTiming.sElapsed
  27.  
  28.     CTiming.Reset
  29.  
  30.     For i = 0 To ValTest
  31.         For j = 1 To 4
  32.             Prueba2 j
  33.         Next
  34.     Next
  35.  
  36.     Me.Print "Prueba2 " & CTiming.sElapsed
  37.  
  38.     CTiming.Reset
  39.  
  40.     For i = 0 To ValTest
  41.         For j = 1 To 4
  42.             Prueba3 j
  43.         Next
  44.     Next
  45.  
  46.     Me.Print "Prueba3 " & CTiming.sElapsed
  47.  
  48.     CTiming.Reset
  49.  
  50.     For i = 0 To ValTest
  51.         For j = 1 To 4
  52.             Prueba4 j
  53.         Next
  54.     Next
  55.  
  56.     Me.Print "Prueba4 " & CTiming.sElapsed
  57.  
  58.     CTiming.Reset
  59.  
  60.     For i = 0 To ValTest
  61.         For j = 1 To 4
  62.             Prueba5 j
  63.         Next
  64.     Next
  65.  
  66.     Me.Print "Prueba5 " & CTiming.sElapsed
  67.  
  68.     CTiming.Reset
  69.  
  70.     For i = 0 To ValTest
  71.         For j = 1 To 4
  72.             Prueba6 j
  73.         Next
  74.     Next
  75.  
  76.     Me.Print "Prueba6 " & CTiming.sElapsed
  77.  
  78.     CTiming.Reset
  79.  
  80.     For i = 0 To ValTest
  81.         For j = 1 To 4
  82.             Prueba7 j
  83.         Next
  84.     Next
  85.  
  86.     Me.Print "Prueba7 " & CTiming.sElapsed
  87.  
  88. End Sub
  89.  
  90.  
  91.  
  92. Private Function Prueba1(ByVal num As Long) As Long
  93.     Select Case num
  94.         Case 1
  95.             Prueba1 = 1
  96.         Case 2
  97.             Prueba1 = 2
  98.         Case 3
  99.             Prueba1 = 3
  100.         Case Else
  101.             Prueba1 = -1
  102.     End Select
  103. End Function
  104.  
  105.  
  106. Private Function Prueba2(ByVal num As Long) As Long
  107.     If num = 1 Then Prueba2 = 1 Else If num = 2 Then Prueba2 = 2 Else If num = 3 Then Prueba2 = 3 Else Prueba2 = -1
  108. End Function
  109.  
  110.  
  111. Private Function Prueba3(ByVal num As Long) As Long
  112.  
  113.     If num = 1 Then
  114.         Prueba3 = 1
  115.         Exit Function
  116.     End If
  117.  
  118.     If num = 2 Then
  119.         Prueba3 = 2
  120.         Exit Function
  121.     End If
  122.  
  123.     If num = 3 Then
  124.         Prueba3 = 3
  125.         Exit Function
  126.     End If
  127.  
  128.     Prueba3 = -1
  129.  
  130. End Function
  131.  
  132. Private Function Prueba4(ByVal num As Long) As Long
  133.  
  134.     If num = 1 Then
  135.         Prueba4 = 1
  136.     Else
  137.         If num = 2 Then
  138.             Prueba4 = 2
  139.         Else
  140.             If num = 3 Then
  141.                 Prueba4 = 3
  142.             Else
  143.                 Prueba4 = -1
  144.             End If
  145.         End If
  146.     End If
  147.  
  148. End Function
  149.  
  150. Private Function Prueba5(ByVal num As Long) As Long
  151.  
  152.     If num = 1 Then
  153.             Prueba5 = 1
  154.         ElseIf num = 2 Then
  155.                 Prueba5 = 2
  156.             ElseIf num = 3 Then
  157.                     Prueba5 = 3
  158.                 Else
  159.                     Prueba5 = -1
  160.                 End If
  161.  
  162.  
  163. End Function
  164.  
  165.  
  166. Private Function Prueba6(ByVal num As Long) As Long
  167.     Prueba6 = IIf(num = 1, 1, IIf(num = 2, 2, IIf(num = 3, 3, -1)))
  168. End Function
  169.  
  170. Private Function Prueba7(ByVal num As Long) As Long
  171.     If num = 1 Then Prueba7 = 1: Exit Function
  172.     If num = 2 Then Prueba7 = 2: Exit Function
  173.     If num = 3 Then Prueba7 = 3: Exit Function
  174.     Prueba7 = -1
  175. End Function
  176.  

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Karcrack en 17 Agosto 2010, 21:57 pm
Veaaamos:

Código:
n*(n+1) = numero_oblongo
numero_oblongo = n² + n
n² + n - numero_oblongo = 0
n = (-1 +- Raiz(1+4*numero_oblongo))/(2)


Esta no seria la forma mas rapida, pero es la unica que comprendo...
Código:
Private Function IsOblongoAlgebra(ByVal nVal As Long, ByRef n As Long) As Boolean
    If (nVal And 1) Or (nVal And &H80000000) Then Exit Function

    n = (Sqr(1 + nVal * 4) - 1) / 2
    
    IsOblongoAlgebra = (n * n + n = nVal)
End Function

No veo en que punto n = sqr(nVal) a partir de la ecuacion...

Si quereis saber mas sobre VB6 rapido visitar esta pagina :)
Código:
http://www.xbeat.net/vbspeed/

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: raul338 en 17 Agosto 2010, 22:03 pm
Cita de: LeandroA en 17 Agosto 2010, 21:56 pm
[OffTopic]
estuve queriendo probar las diferencias de velocidades entre el IF, SELECT CASE, IF inline etc.
la cuestion es que vi que las funciones que se llaman primero tiene cierta ventaja con respecto a las otras, esto mismo pasa cuando queremos comparar las funciones que estamos haciendo. Es correcto esto que digo?¿?¿

Sabes que yo estaba sospechando lo mismo? :P Cambio el orden de las llamadas, espero un buen rato (2 min :xD) sin ejecutar nada y vuelvo a hacer las pruebas y ...... cambian los resultados (aunque se mantiene una "pequeña" proporcion) :P

Aun asi, no es "para tanto". Lo que me parece raro, es que yo copie la funcion de tokes, le cambie de nombre a las variables.... y? .... 2ms mas lento :¬¬ no se si sera mi cpu o que...

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Karcrack en 17 Agosto 2010, 23:23 pm
He aqui mi obra maestra: (ACTUALIZADO) :P
Código:
'---------------------------------------------------------------------------------------
' Module    : cIsOblongo
' Author    : Karcrack
' Now       : 17/08/2010 22:59
' Purpose   : Fastest way to know if a number is Pronic
' History   : 17/08/2010 First cut .....................................................
'             18/08/2010 Fixed and skip odd numbers ....................................
' + Info    : http://foro.elhacker.net/programacion_visual_basic/reto_comprobar_si_un_numero_es_oblongopronico-t302373.0.html
'---------------------------------------------------------------------------------------

Option Explicit
Option Base 0

'NTDLL
Private Declare Sub RtlMoveMemory Lib "NTDLL" (Destination As Any, Source As Any, ByVal Length As Long)

Private c_Code(9)       As Currency

Public Function IsOblongo(ByVal lNumb As Long, ByRef n As Long) As Boolean
    ' Will be filled with ASM code later
End Function

Private Sub Class_Initialize()
    Dim i               As Long
    Dim p               As Long

    For i = 0 To 8
        c_Code(i) = CCur(Choose(i + 1, _
                        501112136803166.0373@, 341985116955243.3932@, _
                        -95471687302877.8613@, -837664576038867.3265@, _
                        -452778894006412.4835@, -402254135688842.0366@, _
                        -857247319500392.0127@, 353164454255135.2835@, _
                        -441078304330420.0512@, -802975918502654.77@))
    Next i

    Call RtlMoveMemory(p, ByVal ObjPtr(Me), 4)
    Call RtlMoveMemory(ByVal p + &H1C, VarPtr(c_Code(0)), 4)
End Sub
Codigo ASM utilizado:
Código:
http://karcrack.pastebin.com/MUkSE1qs

Resultados de velocidad (i = 0 to 10000):
Código:
~2msec


Saludos ::)

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: BlackZeroX en 17 Agosto 2010, 23:30 pm
lastima que te salgas del hilo de vb6... las operaciones las realizas en ASM asi que para mi solo el vb6 es tu plataforma de arranque.

P.D.: tardo  Karcrack -> 1,267 msec, aun es lenta!¡.

Ducles Lunas!¡.

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Karcrack en 17 Agosto 2010, 23:38 pm
Todo el codigo de VB6 se ensambla, porque no puedo añadir yo un par de instrucciones? :rolleyes: :xD

Bueno, si no quereis que no valga usar ASM... pero a ver quien hace mas rapido el codigo entonces :silbar: :xD

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: BlackZeroX en 17 Agosto 2010, 23:49 pm
a por cierto lo de

n = Sqr(nval)

es solo que nosotros tomamos el valor entero de la raiz, aun que lo "Algebra" esta bien, pero si sabemos que long no va a aceptar los decimales pero si el entero... pues mejor no matamos unas neuronas xP.

al fin y al cabo no hay errores

Código
  1. Option Explicit
  2.  
  3. Dim cT      As New CTiming
  4.  
  5.  
  6.  
  7. Private Sub Form_Load()
  8. Dim i   As Long
  9. Dim n(1)   As Long
  10. Const lim& = 20000
  11. Dim aaa As New Class1
  12.  
  13.  
  14.         cT.Reset
  15.         For i = 0 To lim&
  16.             Call IsOblongoAlgebra(i, 0)
  17.         Next i
  18.         InputBox "", "", "Karcrack -> " & cT.sElapsed & vbCrLf
  19.         MsgBox "Comprovando Coherencias!¡."
  20.         For i = 0 To lim&
  21.             If IsOblongoAlgebra(i, n(0)) And IsOblongoTokes03(i, n(1)) And True Then
  22.                 If n(0) <> n(1) Then MsgBox "Error n=" & n(1) & " el real era n=" & n(0) & " del numero " & i & vbCrLf
  23.             End If
  24.         Next i
  25.  
  26.     MsgBox "Fin"
  27.     End
  28. End Sub
  29.  
  30. Private Function IsOblongoAlgebra(ByVal nval As Long, ByRef n As Long) As Boolean
  31.     If (nval And 1) Or (nval And &H80000000) Then Exit Function
  32.  
  33.     n = (Sqr(1 + nval * 4) - 1) / 2
  34.  
  35.     IsOblongoAlgebra = (n * n + n = nval)
  36. End Function
  37.  
  38. '  Tokes 03
  39. Private Function IsOblongoTokes03(ByVal nval As Long, ByRef n As Long) As Boolean
  40.     If (nval And 1) Or (nval And &H80000000) Then Exit Function
  41.     n = Sqr(nval)
  42.     IsOblongoTokes03 = n * n + n = nval
  43. End Function
  44.  

Dulces Lunas!¡.

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Karcrack en 17 Agosto 2010, 23:55 pm
Cita de: BlackZeroX en 17 Agosto 2010, 23:49 pm
a por cierto lo de

n = Sqr(nval)

es solo que nosotros tomamos el valor entero de la raiz, aun que lo "Algebra" esta bien, pero si sabemos que long no va a aceptar los decimales pero si el entero... pues mejor simplificamos xP
Si, bueno, esa parte la habia entendido... pero no se donde se deduce/"saca" eso... a mi jamas se me hubiese ocurrido... tal vez Tokes sepa decirme :-\

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: BlackZeroX en 17 Agosto 2010, 23:59 pm
la respuesta esta en esto, por lo menos YO lo entiendo en estas secciones...

Código:

**  ***  ****  *****  ******  *******
    ***  ****  *****  ******  *******
         ****  *****  ******  *******
               *****  ******  *******
                      ******  *******
                              *******

The value of the Möbius function μ(x) for any pronic number x = n (n + 1), in addition to being computable in the usual way, can also be calculated as

    μ(x) = μ(n) μ(n + 1).


Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: cobein en 18 Agosto 2010, 00:35 am
Bien, ya ni me molesto Karcrack, la unica idea que se me habia ocurrido despues de leer un poco era utilizar el mmx para calcular la aproximacion de la raiz cuadrada....cosa que ya hiciste :(

mmmmm no es justo ;(

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: LeandroA en 18 Agosto 2010, 01:21 am
che funciona?, no me muestra nada
Código:
Option Explicit
Dim clsIsOblongo As cIsOblongo


Private Sub Form_Load()
    Dim i   As Long
    Dim n   As Long

    Set clsIsOblongo = New cIsOblongo

    For i = 0 To 100
        If clsIsOblongo.IsOblongo(i, n) Then
            Debug.Print n, i
        End If
        
    Next i

End Sub

Título: Re: [RETO] Comprobar si un numero es Oblongo/Pronico
Publicado por: Karcrack en 18 Agosto 2010, 01:27 am
Dejame comprobar Leandro, algo esta fallando :-\... alguna modificacion que habre hecho antes de subirlo... dame un segundo...
MOD: Es un problema con el stack, por lo visto las funciones en las clases trabajan de otra manera, ya mismo lo reparo ;)
Arreglado el codigo en ASM, ahora debe ser mas rapida, se salta los numeros impares ;)
Código:
http://karcrack.pastebin.com/MUkSE1qs


Powered by SMF 1.1.21 | SMF © 2006-2008, Simple Machines