XProfan

Windowtitle "Kubische Gleichung mittels el Formel "+\
"von Doctoris med. Gerolimo CARDANO lösen, con Probe!"
' (CL) Copyleft 2013-05 by P.Pájaro carpintero, Wien. Alpha-Versión - KEINE GEWÄHR!
' Anm.: Das Newton-Verfahren es genauer y universell einsetzbar a ca. x^12
font 2:randomize:set("decimals",15)
declarar x!,x1!,x2!,x3!,y1!,y2!,y3!,a!,b!,c!,d!,p!,q!,dis!,u!,v!
declarar y2r!,y2i!,y3r!,y3i!,x1r!,x1i!,x2r!,x2i!,x3r!,x3i!,phi!,flg&

proc kubrt :parámetros w!

    caso w!=0:volver 0.0
    caso w!>0:volver w!^(1/3)
    volver -1*((-1*w!)^(1/3))

ENDPROC

Proc ArkCos :Parámetros w!

    var res!=0

    if w!=1:res!=0

    elseif w!=-1:res!=Pi()

        más :res!= Pi()/2 - ArcTan(w!/Sqrt(1-w!*w!))
        endif :volver res!

    ENDPROC

    Start:
    cls rgb(200+rnd(56),200+rnd(56),200+rnd(56))
    Loop:
    imprimir "\n a * x³ + b * x² + c * x + d = 0. "
    Imprimir " Bitte a, b, c y d eingeben: \n"
    imprimir " a = ";:input a!
    imprimir " b = ";:input b!
    imprimir " c = ";:input c!
    imprimir " d = ";:input d!

    if a!=0:sound 2000,200

        Imprimir "\n Es no kubische Gleichung! \n"
        goto "Quadr"

    endif

    p!=3*a!*c!-b!*b!
    q!=2*b!*b!*b!-9*a!*b!*c!+27*a!*a!*d!
    dis!=q!*q!+4*p!*p!*p!

    IF dis!>0' 1 real, 2 konjug. komplexe Lösungen

        u!=1/2*kubrt(-4*q!+4*sqrt(dis!))
        v!=1/2*kubrt(-4*q!-4*sqrt(dis!))
        y1!=u!+v!
        x1!=(y1!-b!)/(3*a!)
        y2r!= -1/2*(u!+v!)
        x2r!=(y2r!-b!)/(3*a!)
        y2i!=sqrt(3)*(u!-v!)/2' * j
        x2i!=y2i!/(3*a!)' * j
        y3r!= -1/2*(u!+v!)
        x3r!=(y3r!-b!)/(3*a!)
        y3i!= -1*sqrt(3)*(u!-v!)/2' * j
        x3i!= y3i!/(3*a!)' * j
        flg&= -2

    ELSEIF dis!=0' 3 real Lösungen

        u!=1/2*kubrt(-4*q!)
        v!=1/2*kubrt(-4*q!)
        y1!=2*u!
        x1!=(y1!-b!)/(3*a!)
        y2r!= -1*u!
        x2r!=(y2r!-b!)/(3*a!)
        y2i!=0
        x2i!=0
        x2!=x2r!
        y3r!= -1*u!
        x3r!=(y3r!-b!)/(3*a!)
        y3i!=0
        x3i!=0
        x3!=x3r!
        flg&=2

    ELSEIF dis!<0' 3 verschiedene real Lösungen

        phi!=ArkCos( -1*q!/(2*sqrt(-1*p!*p!*p!)))
        y1!=sqrt(-p!)*2*cos(phi!/3)
        x1!=(y1!-b!)/(3*a!)
        y2!=sqrt(-p!)*2*cos(phi!/3+2*pi()/3)
        x2!=(y2!-b!)/(3*a!)
        y3!=sqrt(-p!)*2*cos(phi!/3+4*pi()/3)
        x3!=(y3!-b!)/(3*a!)
        flg&=3

    ENDIF

    Imprimir "\n L Ö S U N G : \n"
    Imprimir " El kubische Gleichung  "+\
    if(a!<0," -"," ")+if(abs(a!)=1,"",format$("%g",abs(a!)))+" x³"+\
    if(b!=0,"",if(b!<0," - "," + ")+format$("%g",abs(b!))+" x²") +\
    if(c!=0,"",if(c!<0," - "," + ")+format$("%g",abs(c!))+" x") +\
    if(d!=0,"",if(d!<0," - "," + ")+format$("%g",abs(d!)))+" = 0 \n hat";

    if flg&= -2

        Imprimir " una real y zwei konjugiert komplexe Lösungen: "
        imprimir
        imprimir " x1 = ";x1!
        imprimir
        imprimir " x2 = ";x2r!;" + j * ";x2i!
        imprimir " x3 = ";x3r!;" + j * ";x3i!
        imprimir

    elseif flg&= 2

        imprimir " drei real Lösungen (Diese puede auch igual ser): "
        imprimir
        imprimir " x1 = ";x1!
        imprimir " x2 = ";x2!
        imprimir " x3 = ";x3!
        caso (x1!=0) and (x2!=0) and (x3!=0): imprimir " Trivialer Fall!"
        imprimir

    elseif flg&= 3

        Imprimir " drei verschiedene real Lösungen ('Casus irreducibilis'): "
        imprimir
        imprimir " x1 = ";x1!
        imprimir " x2 = ";x2!
        imprimir " x3 = ";x3!
        imprimir

    más

        imprimir " Unknown flag status! "
        sound 2000,200
        waitinput
        end

    endif

    imprimir " P R O B E  por Einsetzen. El Ergebnisse debería stets nahe Null ser: "
    imprimir "\n  f(x1) = ";a!*x1!*x1!*x1!+b!*x1!*x1!+c!*x1!+d!
    caso (flg&=2) or (flg&=3):imprimir "  f(x2) = ";a!*x2!*x2!*x2!+b!*x2!*x2!+c!*x2!+d!

    if flg&= -2

        imprimir " f(x2r) = ";a!*(x2r!*x2r!*x2r!-3*x2r!*x2i!*x2i!)+b!*(x2r!*x2r!-x2i!*x2i!)+c!*x2r!+d!
        imprimir " f(x2i) = ";a!*(3*x2r!*x2r!*x2i!-x2i!*x2i!*x2i!)+b!*    2*x2r!*x2i!  + c!*x2i!

    endif

    caso (flg&=2) or (flg&=3):imprimir "  f(x3) = ";a!*x3!*x3!*x3!+b!*x3!*x3!+c!*x3!+d!

    if flg&= -2

        imprimir " f(x3r) = ";a!*(x3r!*x3r!*x3r!-3*x3r!*x3i!*x3i!)+b!*(x3r!*x3r!-x3i!*x3i!)+c!*x3r!+d!
        imprimir " f(x3i) = ";a!*(3*x3r!*x3r!*x3i!-x3i!*x3i!*x3i!)+b!*    2*x3r!*x3i!  + c!*x3i!

    endif

    waitinput
    caso %csrlin<=20:goto "loop"
    goto "Start"
    Quadr:
    caso b!=0:goto "Linr"
    imprimir "\n Quadratische Gleichung, gelöst gemäß Mitternachtsformel: \n"
    dis!=sqr(c!/(2*b!))-d!/b!

    if dis!=0

        x1!= -1/2*c!/b!
        x2!=x1!
        imprimir " x1 = x2 = "; x1!
        Imprimir " Nullprobe ergibt: ";b!*x1!*x1!+c!*x!+d!

    elseif dis!>0

        x1!= -1/2*c!/b! + sqrt(dis!)
        x2!= -1/2*c!/b! - sqrt(dis!)
        imprimir " x1 = ";x1!
        imprimir " x2 = ";x2!
        Imprimir "\n Nullprobe: "
        Imprimir "  f(x1) = ";b!*x1!*x1!+c!*x1!+d!
        Imprimir "  f(x2) = ";b!*x1!*x1!+c!*x1!+d!

    elseif dis!<0

        Imprimir " Keine reellen Lösungen, sólo en el Komplexen: "
        x1r!= -1/2*c!/b!
        x1i!= sqrt(-1*dis!)
        x2r!= -1/2*c!/b!
        x2i!= -1*sqrt(-1*dis!)
        imprimir " Solución: "
        imprimir " x1 = ";x1r!;" + %j * ";x1i!
        imprimir " x2 = ";x2r!;" + %j * ";x2i!
        imprimir "\n Nullprobe ergibt: "
        imprimir " f(x1r) = "; b!*(x1r!*x1r!-x1i!*x1i!)+c!*x1r!+d!
        imprimir " f(x1i) = "; 2*b!*x1r!*x1i!+c!*x1i!
        imprimir " f(x2r) = "; b!*(x2r!*x2r!-x2i!*x2i!)+c!*x2r!+d!
        imprimir " f(x2i) = "; 2*b!*x2r!*x2i!+c!*x2i!

    endif

    waitinput :goto "Start"
    Linr:
    caso c!=0: goto "Const"
    imprimir "\n Lineare Gleichung con el Solución: \n"
    imprimir " x = ";-1*d!/c!
    imprimir " Nullprobe ergibt: ";c!*(-1*d!/c!)-d!
    waitinput
    goto "Start"
    Const:
    Imprimir "\n Konstantenvergleich: \n"

    if d!=0:Imprimir " x = 0 ... Triviale Solución! \n"

        más :Imprimir " Lo son no Solución. \n"

    endif

    waitinput
    goto "Start"