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:
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:
numero_oblongo = n*(n+1)
Ejemplo:
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:
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)
Esta seria la forma habitual y logica de realizar el algoritmo:
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:
Dim i As Long
Dim n As Long
For i = 0 To 10000
Call IsOblongo(i, n)
Next i
Aqui esta mi codigo :D
' 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:
' 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 ;)
Propongo esta pero no es tan rapida :P
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!!! :xD[/OFFTOPIC]
@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:
If lNumb / i = i + 1 Then
Hagas la division entera (\) que es mas rapida ;)
Saludos :D
Aquí dejo mi 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
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:
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 :P
Ademas Karcrack, poniendo \ me empezo a tirar valores literalmente falsos :xD
Resultados en tiempo de ejecucion!!!
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,
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.
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
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
Algo que vi en algunos algoritmos
6 = 2*(2+1) no es lo mismo que 2 * 2+1
jaja eso me pasa por copiar ;D
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!¡.
@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!¡.
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
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
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!¡.
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 :)):
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:
' 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
HOLA!!!
QUISIERA SABER QUE ES MAS RAPIDO:
If Not (lNumb And 1) = 0 Then Exit Function
' O
If Not (lNumb Mod 2) = 0 Then Exit Function
Gracias!!!
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
raul338 tiene toda la razón del universo.
Saludos...
Ufff.... para mi LeandroA ha ganado el reto!, es rapidisima su funcion!!!!
@79137913: Es mucho mas rapido el primero, siempre trabajar con Bits es mas rapido.
Hola a todos. No proclamen un ganador sin primero ver esto.
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.
Tokes, no estas usando la ultima version de LeandroA :P
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:
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)
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 = 0 To 100000
If EsOblongo2(i, j) Then s = s & "(" & i & "," & j & ")"
Next i
Text1.Text = Text1.Text & "Tokes: " & tim.Elapsed & vbCrLf & s & vbCrLf & vbCrLf
s = ""
tim.Reset
For i = 0 To 100000
If IsOblongoLeo2(i, j) Then s = s & "(" & i & "," & j & ")"
Next i
Text1.Text = Text1.Text & "LeandroA: " & tim.Elapsed & vbCrLf & s & vbCrLf & vbCrLf
s = ""
tim.Reset
For i = 0 To 100000
If IsOblongo01(i, j) Then s = s & "(" & i & "," & j & ")"
Next i
Text1.Text = Text1.Text & "Karcrack: " & tim.Elapsed & vbCrLf & s & vbCrLf & vbCrLf
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 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
' 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
Tokes v2: 9,31712800337221
LeandroA: 7,62460838830173
Karcrack: 95,5182170415809
Blackzerox y yo perdimos por goleada :xD
Agregado la v2 de Tokes
No habia visto la nueva version de Leandro :o :o :o, buen trabajo :)
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
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...
Disculpen que moleste, se que en otro post dicenq ue programas son, pero no los logro encontrar ¿como sabes la velocidad de proceso?
GRACIAS
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 )
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!¡.
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.
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.
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
una modificacion rapida (solo es 2 msec mas rapida ¬¬") a la funcion de Tokes (Ojala hubieramos despenajo n(n+1) ¬¬" )!¡.
' Tokes 03
Private Function IsOblongoTokes03(ByVal nval As Long, ByRef n As Long) As Boolean
If (nval And 1) Or (nval And &H80000000) Then Exit Function
n = Sqr(nval)
IsOblongoTokes03 = n * n + n = nval
End Function
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!¡.
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.
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!¡.
No me dejen afuera!!!!! no tengo mucho tiempo ahora pero quiero darle una probada.
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.
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.
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!¡.
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
[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.
Option Explicit
Private CTiming As CTiming
Private Sub Form_Load()
Dim i As Long, j As Long
Dim ValTest As Long
Set CTiming = New CTiming
Me.AutoRedraw = True
Me.Print "Test de velocidad" & vbCrLf
ValTest = 5000000
CTiming.Reset
For i = 0 To ValTest
For j = 1 To 4
Prueba1 j
Next
Next
Me.Print "Prueba1 " & CTiming.sElapsed
CTiming.Reset
For i = 0 To ValTest
For j = 1 To 4
Prueba2 j
Next
Next
Me.Print "Prueba2 " & CTiming.sElapsed
CTiming.Reset
For i = 0 To ValTest
For j = 1 To 4
Prueba3 j
Next
Next
Me.Print "Prueba3 " & CTiming.sElapsed
CTiming.Reset
For i = 0 To ValTest
For j = 1 To 4
Prueba4 j
Next
Next
Me.Print "Prueba4 " & CTiming.sElapsed
CTiming.Reset
For i = 0 To ValTest
For j = 1 To 4
Prueba5 j
Next
Next
Me.Print "Prueba5 " & CTiming.sElapsed
CTiming.Reset
For i = 0 To ValTest
For j = 1 To 4
Prueba6 j
Next
Next
Me.Print "Prueba6 " & CTiming.sElapsed
CTiming.Reset
For i = 0 To ValTest
For j = 1 To 4
Prueba7 j
Next
Next
Me.Print "Prueba7 " & CTiming.sElapsed
End Sub
Private Function Prueba1(ByVal num As Long) As Long
Select Case num
Case 1
Prueba1 = 1
Case 2
Prueba1 = 2
Case 3
Prueba1 = 3
Case Else
Prueba1 = -1
End Select
End Function
Private Function Prueba2(ByVal num As Long) As Long
If num = 1 Then Prueba2 = 1 Else If num = 2 Then Prueba2 = 2 Else If num = 3 Then Prueba2 = 3 Else Prueba2 = -1
End Function
Private Function Prueba3(ByVal num As Long) As Long
If num = 1 Then
Prueba3 = 1
Exit Function
End If
If num = 2 Then
Prueba3 = 2
Exit Function
End If
If num = 3 Then
Prueba3 = 3
Exit Function
End If
Prueba3 = -1
End Function
Private Function Prueba4(ByVal num As Long) As Long
If num = 1 Then
Prueba4 = 1
Else
If num = 2 Then
Prueba4 = 2
Else
If num = 3 Then
Prueba4 = 3
Else
Prueba4 = -1
End If
End If
End If
End Function
Private Function Prueba5(ByVal num As Long) As Long
If num = 1 Then
Prueba5 = 1
ElseIf num = 2 Then
Prueba5 = 2
ElseIf num = 3 Then
Prueba5 = 3
Else
Prueba5 = -1
End If
End Function
Private Function Prueba6(ByVal num As Long) As Long
Prueba6 = IIf(num = 1, 1, IIf(num = 2, 2, IIf(num = 3, 3, -1)))
End Function
Private Function Prueba7(ByVal num As Long) As Long
If num = 1 Then Prueba7 = 1: Exit Function
If num = 2 Then Prueba7 = 2: Exit Function
If num = 3 Then Prueba7 = 3: Exit Function
Prueba7 = -1
End Function
Veaaamos:
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...
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 :)
http://www.xbeat.net/vbspeed/
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...
He aqui mi obra maestra: (ACTUALIZADO) :P
'---------------------------------------------------------------------------------------
' 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:
http://karcrack.pastebin.com/MUkSE1qs
Resultados de velocidad (i = 0 to 10000):
~2msec
Saludos ::)
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!¡.
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
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
Option Explicit
Dim cT As New CTiming
Private Sub Form_Load()
Dim i As Long
Dim n(1) As Long
Const lim& = 20000
Dim aaa As New Class1
cT.Reset
For i = 0 To lim&
Call IsOblongoAlgebra(i, 0)
Next i
InputBox "", "", "Karcrack -> " & cT.sElapsed & vbCrLf
MsgBox "Comprovando Coherencias!¡."
For i = 0 To lim&
If IsOblongoAlgebra(i, n(0)) And IsOblongoTokes03(i, n(1)) And True Then
If n(0) <> n(1) Then MsgBox "Error n=" & n(1) & " el real era n=" & n(0) & " del numero " & i & vbCrLf
End If
Next i
MsgBox "Fin"
End
End Sub
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
' Tokes 03
Private Function IsOblongoTokes03(ByVal nval As Long, ByRef n As Long) As Boolean
If (nval And 1) Or (nval And &H80000000) Then Exit Function
n = Sqr(nval)
IsOblongoTokes03 = n * n + n = nval
End Function
Dulces Lunas!¡.
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 :-\
la respuesta esta en esto, por lo menos YO lo entiendo en estas secciones...
** *** **** ***** ****** *******
*** **** ***** ****** *******
**** ***** ****** *******
***** ****** *******
****** *******
*******
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).
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 ;(
che funciona?, no me muestra nada
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
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 ;)
http://karcrack.pastebin.com/MUkSE1qs