XProfan

WindowTitle "Erweiterter Euklidischer Algorithmus, non-rekursiv programmiert"
' (CL) Copyleft 2013-05 by P.Specht, Wien
' Q: https://de.wikipedia.org/wiki/Erweiterter_euklidischer_Algorithmus
' Keine Gewähr! Use solely on your own risk!
'{ Initialisierung, Ein- und Ausgabe-Hauptschleife
Window %maxx,%maxy
font 2:randomize
set("decimals",1)
declare tab%,px%,verbose%
Declare a!,b!,ggt!,s!,t!
tab%=14' Spaltentabulator
verbose%=0' Lösungsweg anzeigen
a!=99:b!=78' Test case
cls rnd(8^8):print

while 1

    Print " A= ";:input a!
    Print " B= ";:input b!
    ggt!=Extended_Euklid(a!,b!;s!,t!)
    print "\n Ergebnis    GGT           S           T               S*A+T*B         "
    print "";tab(tab%);ggt!,tab(tab%*2);s!,tab(tab%*3);t!,tab(tab%*4);s!*a!+t!*b!;"\n\n"

    if %csrlin>27:waitinput :px%=getpixel(1,1):cls px%:endif

    endwhile

    '}
    '{Math Pack I (0.1_beta): Number Theory - Base Functions
    ' Intf(a!), Frac(a!), Floor(a!), Ceil(a!), Sgn(a!), IsNeg(a!),
    ' Modf(a!,b!), Remn(a!,b!), SymModf(a!,b!), ggT(a!,b!), kgV(a!,b!)
    ' Printf(a!),Printfln(a!)

    proc sgn :parameters x!

        ' Signum-Funktion: -1,0,+1
        return (x!>0)-(x!<0)

    endproc

    proc floor :parameters x!

        ' Gaussklammer-Funktion
        case abs(x!)<(10^-35):return 0
        case x!>0:return intf(x!)
        return (abs(x!-intf(x!)) < 10^-35)-intf(abs(x!-1))

    endproc

    proc ceil :parameters x!

        ' Ceiling-Funktion
        return -1*floor(-1*x!)

    endproc

    proc modf :parameters x!,y!

        ' Q: https://de.wikipedia.org/wiki/Modulo
        case abs(x!)<10^-35:return 0
        case abs(y!)<10^-35:return x!
        return sgn(y!)*abs(x!-y!*floor(x!/y!))

    endproc

    proc remn :parameters x!,y!

        ' Q: https://de.wikipedia.org/wiki/Modulo , wie in ADA
        case abs(x!)<(10^-35):return 0
        case abs(y!)<(10^-35):return x!
        return sgn(x!)*abs(x!-y!*floor(x!/y!))

    endproc

    proc IsNeg :parameters x!

        return byte(Addr(x!),7)&%10000000>>7

    endproc

    proc frac :parameters x!

        var s!=sgn(x!)
        x!=abs(x!)
        x!=x!-round(x!,0)
        case x!<0:x!=1+x!
        return s!*x!

    endproc

    proc intf :parameters x!

        var s!=sgn(x!)
        x!=abs(x!)
        x!=x!-frac(x!)
        return s!*x!

    endproc

    proc symmodf :parameters x!,y!

        declare v!
        case abs(x!)<10^-322:return 0
        case abs(y!)<10^-304:return x!
        v!=x!-y!*floor(x!/y!)
        case (2*v!)>y!:v!=v!-y!'symmetric modf()
        return v!

    endproc

    proc ggT :parameters a!,b!

        declare h!

        whilenot nearly(b!,0,11)

            h!=a!-b!*floor(a!/b!)'orig: int() ???
            a!=b!
            b!=h!

        endwhile

        return a!

    endproc

    proc kgV :parameters a!,b!

        return a!*b!/ggt(a!,b!)

    endproc

    proc printf :parameters x!

        print format$("+#.#################E+000;"+\
        "-#.#################E+000;" + " 0.0###############0e0000" ,c!);

    endproc

    proc printfln :parameters x!

        prt(x!):print

    endproc

    '}
    '{ Math Pack II (0.1_alpha): Number Theory - Higher Functions
    ' ggt!=Extended_Euklid(a!,b!)' +> s!,t!

    proc Extended_Euklid :parameters a!,b!

        'liefert ggT! sowie an die extern definierten Variablen s!,t!
        declare a0!,b0!,q0!,r0!,u0!,s0!,v0!,t0!
        declare a1!,b1!,q1!,r1!,u1!,s1!,v1!,t1!
        init:
        a0!=0:b0!=a!:q0!=0:r0!=b!
        u0!=0:s0!=1:v0!=1:t0!=0'Hilfsvariablen
        casenot verbose%:goto "rept"
        print
        print "A",tab(tab%);"B",tab(tab%*2);"Q",tab(tab%*3);"R",tab(tab%*4);
        print "U",tab(tab%*5);"S",tab(tab%*6);"V",tab(tab%*7);"T"
        print
        print a0!,tab(tab%);b0!,tab(tab%*2);q0!,tab(tab%*3);r0!,tab(tab%*4);
        print u0!,tab(tab%*5);s0!,tab(tab%*6);v0!,tab(tab%*7);t0!
        rept:
        a1!=b0!:u1!=s0!:v1!=t0!:b1!=r0!
        s1!=u0!-q0!*s0!:t1!=v0!-q0!*t0!

        if nearly(b1!,0,11)

            s!=s0!:t!=t0!:return a1!

        endif

        q1!=int(a1!/b1!)
        r1!=a1!-b1!*q1!
        casenot verbose%:goto "zeilenschritt"
        print a1!,tab(tab%);b1!,tab(tab%*2);q1!,tab(tab%*3);r1!,tab(tab%*4);
        print u1!,tab(tab%*5);s1!,tab(tab%*6);v1!,tab(tab%*7);t1!
        zeilenschritt:
        a0!=a1!:b0!=b1!:q0!=q1!:r0!=r1!
        u0!=u1!:s0!=s1!:v0!=v1!:t0!=t1!
        goto "rept"

    endproc

    '}