excel - examples - VBA: prueba de cubos perfectos

public function vba excel

Question

Intento escribir una función simple en VBA que pruebe un valor real y genere un resultado de cadena si es un cubo perfecto. Aquí está mi código:

Function PerfectCubeTest(x as Double)
If (x) ^ (1 / 3) = Int(x) Then
PerfectCubeTest = "Perfect"
Else
PerfectCubeTest = "Flawed"
End If
End Function

Como puede ver, estoy usando una instrucción if simple para probar si la raíz cúbica de un valor es igual a su parte entera (es decir, no hay residuo). Intenté probar la función con algunos cubos perfectos (1, 8, 27, 64, 125), pero solo funciona para el número 1. Cualquier otro valor escupe el caso "defectuoso". ¿Alguna idea de lo que está mal aquí?

Answer 1

@ScottCraner explica correctamente por qué obtuviste resultados incorrectos, pero hay algunas otras cosas que señalar aquí. Primero, supongo que está recibiendo un Double como entrada porque el rango de números aceptables es más alto. Sin embargo, según su definición implícita de un cubo perfecto, solo se deben evaluar los números con una raíz cúbica entera (es decir, excluiría 3.375). Solo probaría esto por adelantado para permitir una salida anticipada.

El siguiente problema con el que te encuentras es que 1/3 no se puede representar exactamente con un Double . Como estás elevando a la potencia inversa para obtener tu raíz cúbica, también estás agravando el error de coma flotante. Hay una manera realmente fácil de evitar esto: tomar la raíz del cubo, hacer un cubo y ver si coincide con la entrada. Obtienes el resto de los errores de coma flotante volviendo a tu definición de cubo perfecto como un valor entero; simplemente redondea la raíz del cubo al entero siguiente más alto y al siguiente entero más bajo antes de volver a formar el cubo:

Public Function IsPerfectCube(test As Double) As Boolean
''By your definition, no non-integer can be a perfect cube.
Dim rounded As Double
rounded = Fix(test)
If rounded <> test Then Exit Function
Dim cubeRoot As Double
cubeRoot = rounded ^ (1 / 3)
''Round both ways, then test the cube for equity.
If Fix(cubeRoot) ^ 3 = rounded Then
IsPerfectCube = True
ElseIf (Fix(cubeRoot) + 1) ^ 3 = rounded Then
IsPerfectCube = True
End If
End Function

Esto arrojó el resultado correcto hasta 1E + 27 (mil millones de cubos) cuando lo probé. Dejé de ir más alto en ese momento porque la prueba tardaba tanto en ejecutarse y, en ese momento, probablemente estés fuera del rango que razonablemente necesitarías para ser exacto.

Answer 2

Está probando si el cubo es igual al doble suministrado.

Entonces para 8 estarías probando si 2 = 8.

EDITAR: También encontró un problema de coma flotante. Para resolver, redondearemos los decimales un poco para tratar de superar el problema.

Cambie a lo siguiente:

Function PerfectCubeTest(x As Double)
If Round((x) ^ (1 / 3), 10) = Round((x) ^ (1 / 3), 0) Then
PerfectCubeTest = "Perfect"
Else
PerfectCubeTest = "Flawed"
End If
End Function

O (gracias a Ron)

Function PerfectCubeTest(x As Double)
If CDec(x ^ (1 / 3)) = Int(CDec(x ^ (1 / 3))) Then
PerfectCubeTest = "Perfect"
Else
PerfectCubeTest = "Flawed"
End If
End Function

Answer 3

Para divertirse, aquí hay una implementación de un método basado en la teoría de números que se describe aquí . Define una función de valor booleano (en lugar de valor de cadena) llamada PerfectCube() que prueba si una entrada entera (representada como Long) es un cubo perfecto. Primero ejecuta una prueba rápida que arroja muchos números. Si la prueba rápida no puede clasificarlo, invoca un método basado en factoraje. Factoriza el número y comprueba si la multiplicidad de cada factor primo es un múltiplo de 3. Probablemente podría optimizar esta etapa sin molestarme en encontrar la factorización completa cuando se encuentra un factor malo, pero ya tenía un algoritmo de factorización VBA:

Function DigitalRoot(n As Long) As Long
''assumes that n >= 0
Dim sum As Long, digits As String, i As Long
If n < 10 Then
DigitalRoot = n
Exit Function
Else
digits = Trim(Str(n))
For i = 1 To Len(digits)
sum = sum + Mid(digits, i, 1)
Next i
DigitalRoot = DigitalRoot(sum)
End If
End Function
Sub HelperFactor(ByVal n As Long, ByVal p As Long, factors As Collection)
''Takes a passed collection and adds to it an array of the form
''(q,k) where q >= p is the smallest prime divisor of n
''p is assumed to be odd
''The function is called in such a way that
''the first divisor found is automatically prime
Dim q As Long, k As Long
q = p
Do While q <= Sqr(n)
If n Mod q = 0 Then
k = 1
Do While n Mod q ^ k = 0
k = k + 1
Loop
k = k - 1 ''went 1 step too far
factors.Add Array(q, k)
n = n / q ^ k
If n > 1 Then HelperFactor n, q + 2, factors
Exit Sub
End If
q = q + 2
Loop
''if we get here then n is prime - add it as a factor
factors.Add Array(n, 1)
End Sub
Function factor(ByVal n As Long) As Collection
Dim factors As New Collection
Dim k As Long
Do While n Mod 2 ^ k = 0
k = k + 1
Loop
k = k - 1
If k > 0 Then
n = n / 2 ^ k
factors.Add Array(2, k)
End If
If n > 1 Then HelperFactor n, 3, factors
Set factor = factors
End Function
Function PerfectCubeByFactors(n As Long) As Boolean
Dim factors As Collection
Dim f As Variant
Set factors = factor(n)
For Each f In factors
If f(1) Mod 3 > 0 Then
PerfectCubeByFactors = False
Exit Function
End If
Next f
''if we get here:
PerfectCubeByFactors = True
End Function
Function PerfectCube(n As Long) As Boolean
Dim d As Long
d = DigitalRoot(n)
If d = 0 Or d = 1 Or d = 8 Or d = 9 Then
PerfectCube = PerfectCubeByFactors(n)
Else
PerfectCube = False
End If
End Function

Answer 4

Se corrigió el error de división de enteros gracias a @Comintern. Parece ser correcto hasta 208064 ^ 3 - 2

Function isPerfectCube(n As Double) As Boolean
n = Abs(n)
isPerfectCube = n = Int(n ^ (1 / 3) - (n > 27)) ^ 3
End Function