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