XProfan

Windowtitle "Kubische Gleichung mittels der Formel "+\
"von Doctoris med. Gerolimo CARDANO lösen, mit Probe!"
' (CL) Copyleft 2013-05 by P.Specht, Wien. Alpha-Version - KEINE GEWÄHR!
' Anm.: Das Newton-Verfahren ist genauer und universell einsetzbar bis 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!

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

endproc

Proc ArkCos :Parameters w!

    var res!=0

    if w!=1:res!=0

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

        else :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))
    Loop:
    print "\n a * x³ + b * x² + c * x + d = 0. "
    Print " Bitte a, b, c und d eingeben: \n"
    print " a = ";:input a!
    print " b = ";:input b!
    print " c = ";:input c!
    print " d = ";:input d!

    if a!=0:sound 2000,200

        Print "\n Das ist keine 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 reelle, 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 reelle 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 reelle 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

    Print "\n L Ö S U N G : \n"
    Print " Die 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

        Print " eine reelle und zwei konjugiert komplexe Lösungen: "
        print
        print " x1 = ";x1!
        print
        print " x2 = ";x2r!;" + j * ";x2i!
        print " x3 = ";x3r!;" + j * ";x3i!
        print

    elseif flg&= 2

        print " drei reelle Lösungen (Diese können auch gleich sein): "
        print
        print " x1 = ";x1!
        print " x2 = ";x2!
        print " x3 = ";x3!
        case (x1!=0) and (x2!=0) and (x3!=0): print " Trivialer Fall!"
        print

    elseif flg&= 3

        Print " drei verschiedene reelle Lösungen ('Casus irreducibilis'): "
        print
        print " x1 = ";x1!
        print " x2 = ";x2!
        print " x3 = ";x3!
        print

    else

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

    endif

    print " P R O B E  durch Einsetzen. Die Ergebnisse sollten stets nahe Null sein: "
    print "\n  f(x1) = ";a!*x1!*x1!*x1!+b!*x1!*x1!+c!*x1!+d!
    case (flg&=2) or (flg&=3):print "  f(x2) = ";a!*x2!*x2!*x2!+b!*x2!*x2!+c!*x2!+d!

    if flg&= -2

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

    endif

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

    if flg&= -2

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

    endif

    waitinput
    case %csrlin<=20:goto "loop"
    goto "Start"
    Quadr:
    case b!=0:goto "Linr"
    print "\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!
        print " x1 = x2 = "; x1!
        Print " 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!)
        print " x1 = ";x1!
        print " x2 = ";x2!
        Print "\n Nullprobe: "
        Print "  f(x1) = ";b!*x1!*x1!+c!*x1!+d!
        Print "  f(x2) = ";b!*x1!*x1!+c!*x1!+d!

    elseif dis!<0

        Print " Keine reellen Lösungen, nur im Komplexen: "
        x1r!= -1/2*c!/b!
        x1i!= sqrt(-1*dis!)
        x2r!= -1/2*c!/b!
        x2i!= -1*sqrt(-1*dis!)
        print " Lösung: "
        print " x1 = ";x1r!;" + %j * ";x1i!
        print " x2 = ";x2r!;" + %j * ";x2i!
        print "\n Nullprobe ergibt: "
        print " f(x1r) = "; b!*(x1r!*x1r!-x1i!*x1i!)+c!*x1r!+d!
        print " f(x1i) = "; 2*b!*x1r!*x1i!+c!*x1i!
        print " f(x2r) = "; b!*(x2r!*x2r!-x2i!*x2i!)+c!*x2r!+d!
        print " f(x2i) = "; 2*b!*x2r!*x2i!+c!*x2i!

    endif

    waitinput :goto "Start"
    Linr:
    case c!=0: goto "Const"
    print "\n Lineare Gleichung mit der Lösung: \n"
    print " x = ";-1*d!/c!
    print " Nullprobe ergibt: ";c!*(-1*d!/c!)-d!
    waitinput
    goto "Start"
    Const:
    Print "\n Konstantenvergleich: \n"

    if d!=0:Print " x = 0 ... Triviale Lösung! \n"

        else :Print " Es gibt keine Lösung. \n"

    endif

    waitinput
    goto "Start"