XProfan

Windowstyle 16 | 64
Window 0,0 - %maxx,%maxy
' Ellipsennocke with Auflagestange (zB as Screen saver)
' (D)emoware 2012-05 by P. woodpecker, without each Gewähr!
var xm!=%maxx\2
var ym!=2*%maxy\3'Mittelpunkt
var a!=%maxx\6
var b!=%maxy\12'Halbachsen
var f!=pi()/180'strain2wheel
var qaa!=1/(a!*a!)
var qbb!=1/(b!*b!)'inside/Outer-Hilfsvariablen
declare w&,w!,ww!' Winkel
declare x!,y!, xp!,yp!' Berührpunkt, Ext.point
declare nenn!,wrz!,c1!,c2!' Divi/0 and Minuswurzel-Abfang
declare tmp!,xe!,ye!,k!
var laen!=%maxx\2' Auflagestange
var rm!=b!/3
usebrush 7,rgb(120,120,120)
Begin:

WHILELOOP 0,360,4

    MCLS %maxx, %maxy, $FFFFFF
    StartPaint -1
    w&=&loop:w!=w&*f!
    xp!=1.2*a!:yp!=b!+a!/3
    waitinput 37
    case %key=27:end
    '''cls
    '''locate 3,3:print "Abbruch with Esc"
    DrawText 4, 4, "Abbruch with ESC"
    usepen 0,6,rgb(0,0,200)
    ellipsis xm!+rm!,(ym!+rm!) - (xm!-rm!),ym!-rm!
    Elips a!,b!,w&,xm!,ym!
    'point xp!,yp!
    tmp!=xp!*cos(-w!)+yp!*sin(-w!)
    yp!=xp!*sin(-w!)-yp!*cos(-w!)
    xp!=tmp!
    nenn!=a!*a!*yp!*yp!+b!*b!*xp!*xp!

    if nenn!<>0

        c1!=a!*a!*b!*b!
        wrz!=a!*a!*yp!*yp!+b!*b!*xp!*xp!-c1!

        if wrz!>0

            x!=(a!*a!*yp!*sqrt(wrz!)+c1!*xp!)/nenn!

        endif

    endif

    y!=0

    if a!<>0

        c2!=a!*a!-x!*x!

        if c2!>0'              !>

            if ((xp!>-a!) and (yp!<0)) or (xp!>a!)

                y!=-(b!*sqrt(c2!))/a!

            else

                y!= (b!*sqrt(c2!))/a!

            endif

        endif

    endif

    tmp!=xp!*cos(-w!)+yp!*sin(-w!)
    yp!=xp!*sin(-w!)-yp!*cos(-w!)
    xp!=tmp!
    tmp!=x!*cos(-w!)+y!*sin(-w!)
    y!=x!*sin(-w!)-y!*cos(-w!)
    x!=tmp!

    if (xp!*xp!*qaa!+yp!*yp!*qbb!)>=1

        usepen 0,9,rgb(255,0,0)
        point x!,y!
        line (xm!+xp!),(ym!-yp!) - (xm!+x!),ym!-y!

        if xp!<>x!

            k!=arctan((yp!-y!)/(xp!-x!))
            xe!=xp!-laen!*cos(k!)
            ye!=yp!-laen!*sin(k!)
            line (xm!+xp!),(ym!-yp!) - (xm!+xe!),ym!-ye!

        endif

    endif

    a!=0.999*a!
    EndPaint
    MCopyBMP 0, 0 - %maxx,%maxy > 0, 0; 0

ENDWHILE

Goto "Begin"

proc Elips : parameters a!,b!,g!,xm!,ym!

    declare w!,x!,y!,xe!,ye!
    var f!=-pi()/180:g!=g!*f!
    xe!=a!*cos(g!):ye!=a!*sin(g!)
    Moveto xm!+xe!,ym!-ye!

    WhileLoop 0,360,6

        w!=&Loop*f!
        x!=a!*cos(w!)
        y!=b!*sin(w!)
        xe!=x!*cos(g!)+y!*sin(g!)
        ye!=x!*sin(g!)-y!*cos(g!)
        lineto xm!+xe!,ym!-ye!

    EndWhile

ENDPROC

proc point : parameters xp!,yp!

    rectangle xm!+xp!+3,(ym!-yp!+3) - (xm!+xp!-3),ym!-yp!-3

ENDPROC