XProfan

Windowtitle "Kubische Gleichung mittels qui Formel "+\
"von Doctoris med. Gerolimo CARDANO lösen, avec Probe!"
' (CL) Copyleft 2013-05 by P.Specht, vienne. Alpha-Version - KEINE GEWÄHR!
' Anm.: cela Newton-procéder ist genauer et universell einsetzbar jusqu'à ca. x^12
font 2:randomize:set("decimals",15)
declare x!,x1!,x2!,x3!,y1!,y2!,y3!,a!,b!,c!,d!,p!,q!,dis!,u!,v!
declare y2r!,y2i!,y3r!,y3i!,x1r!,x1i!,x2r!,x2i!,x3r!,x3i!,phi!,flg&

proc kubrt :parameters w!

    cas w!=0:return 0.0
    cas w!>0:return w!^(1/3)
    return -1*((-1*w!)^(1/3))

endproc

Proc ArkCos :Paramètres w!

    var res!=0

    si w!=1:res!=0

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

        d'autre :res!= Pi()/2 - ArcTan(w!/Sqrt(1-w!*w!))
        endif :return res!

    ENDPROC

    Start:
    cls rgb(200+rnd(56),200+rnd(56),200+rnd(56))
    Boucle:
    imprimer "\n a * x³ + b * x² + c * x + d = 0. "
    Imprimer " s'il te plaît a, b, c et d eingeben: \n"
    imprimer " a = ";:input a!
    imprimer " b = ";:input b!
    imprimer " c = ";:input c!
    imprimer " d = ";:input d!

    si a!=0:sound 2000,200

        Imprimer "\n c'est aucun 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 réel, 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 réel 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 réel 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

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

    si flg&= -2

        Imprimer " une réel et deux konjugiert komplexe Lösungen: "
        imprimer
        imprimer " x1 = ";x1!
        imprimer
        imprimer " x2 = ";x2r!;" + j * ";x2i!
        imprimer " x3 = ";x3r!;" + j * ";x3i!
        imprimer

    elseif flg&= 2

        imprimer " trois réel Lösungen (cet peut aussi juste son): "
        imprimer
        imprimer " x1 = ";x1!
        imprimer " x2 = ";x2!
        imprimer " x3 = ";x3!
        cas (x1!=0) and (x2!=0) and (x3!=0): imprimer " Trivialer le cas!"
        imprimer

    elseif flg&= 3

        Imprimer " trois verschiedene réel Lösungen ('Casus irreducibilis'): "
        imprimer
        imprimer " x1 = ";x1!
        imprimer " x2 = ";x2!
        imprimer " x3 = ";x3!
        imprimer

    d'autre

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

    endif

    imprimer " P R O B E  par Einsetzen. qui Ergebnisse devrait stets proche zéro son: "
    imprimer "\n  f(x1) = ";a!*x1!*x1!*x1!+b!*x1!*x1!+c!*x1!+d!
    cas (flg&=2) or (flg&=3):imprimer "  f(x2) = ";a!*x2!*x2!*x2!+b!*x2!*x2!+c!*x2!+d!

    si flg&= -2

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

    endif

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

    si flg&= -2

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

    endif

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

    si dis!=0

        x1!= -1/2*c!/b!
        x2!=x1!
        imprimer " x1 = x2 = "; x1!
        Imprimer " 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!)
        imprimer " x1 = ";x1!
        imprimer " x2 = ";x2!
        Imprimer "\n Nullprobe: "
        Imprimer "  f(x1) = ";b!*x1!*x1!+c!*x1!+d!
        Imprimer "  f(x2) = ";b!*x1!*x1!+c!*x1!+d!

    elseif dis!<0

        Imprimer " aucun reellen Lösungen, seulement im Komplexen: "
        x1r!= -1/2*c!/b!
        x1i!= sqrt(-1*dis!)
        x2r!= -1/2*c!/b!
        x2i!= -1*sqrt(-1*dis!)
        imprimer " Solution: "
        imprimer " x1 = ";x1r!;" + %j * ";x1i!
        imprimer " x2 = ";x2r!;" + %j * ";x2i!
        imprimer "\n Nullprobe ergibt: "
        imprimer " f(x1r) = "; b!*(x1r!*x1r!-x1i!*x1i!)+c!*x1r!+d!
        imprimer " f(x1i) = "; 2*b!*x1r!*x1i!+c!*x1i!
        imprimer " f(x2r) = "; b!*(x2r!*x2r!-x2i!*x2i!)+c!*x2r!+d!
        imprimer " f(x2i) = "; 2*b!*x2r!*x2i!+c!*x2i!

    endif

    waitinput :goto "Start"
    Linr:
    cas c!=0: goto "Const"
    imprimer "\n Lineare Gleichung avec qui Solution: \n"
    imprimer " x = ";-1*d!/c!
    imprimer " Nullprobe ergibt: ";c!*(-1*d!/c!)-d!
    waitinput
    goto "Start"
    Const:
    Imprimer "\n Konstantenvergleich: \n"

    si d!=0:Imprimer " x = 0 ... Triviale Solution! \n"

        d'autre :Imprimer " il y a aucun Solution. \n"

    endif

    waitinput
    goto "Start"