XProfan

WindowTitle "Ellipsenbögen in beliebiger Lage"
'  Hinweis: Bitte Achsendimensionen anpassen an Bildschirmauflösung!
'  (T) Trashware 2012 by P. Specht. Zu meine Gunsten ist an nachfolgender Stelle ein
'  maximal rechtswirksamer Haftungsausschließungtext vom Programmanwender einzufügen:
'
'  <This lines intentionally left blank>
'  Bildausgabe geändert by Volkmar Göritz
WindowStyle 16 | 64
Window 0,0 - %maxx,%maxy
Font 2:randomize
var col&=rgb(200,200,200)+rgb(rnd(56),rnd(56),rnd(56))
var f!=pi()/180:var xm!=%maxx/2:var ym!=%maxy/2
declare end&,ctr&
Declare Bitmap%
Begin:
inc ctr&

WHILELOOP 360,0,-10

    'Locate 1,1:Print " Ende: ESC halten! "
    'MCLS %maxx,%maxy,col&:StartPaint -1
    Case Bitmap% : DeleteObject Bitmap%
    Bitmap% = create("hNewPic", %maxx,%maxy,col&)
    StartPaint Bitmap%
    TextColor 20200,-1'col&
    DrawText 1,1,"Ende ESC"
    Achsen xm!,ym!
    Ellipsenbogen 400,170,f!*0; \'Halbachsen a,b, gewünschte Drehung (f!*grd=rad)
    f!*&Loop+pi(),f!*(&Loop+30); \'Start- und Endwinkel aus Sicht der Ellipse_
    rgb(220,0,0),6;0' Farbe,Stärke,Segmentierschalter 0/1
    Ellipsenbogen 400,170,-f!*50; \'Halbachsen a,b, gewünschte Drehung (f!*grd=rad)
    -f!*&Loop,-f!*(&Loop+40); \'Start- und Endwinkel aus Sicht der Ellipse_
    rgb(0,0,220),9;1' Farbe,Stärke,Segmentierschalter 0/1
    Ellipsenbogen 400,170,-f!*80; \'Halbachsen a,b, gewünschte Drehung (f!*grd=rad)
    f!*&Loop,f!*(&Loop+60); \'Start- und Endwinkel aus Sicht der Ellipse_
    rgb(0,220,0),5;0' Farbe,Stärke,Segmentierschalter 0/1
    'EndPaint:MCopyBMP 0,0 - %maxx,%maxy >0,0;0
    Endpaint
    DrawPic Bitmap%, 0, 0; 0
    waitinput 5:if %key=27:end&=1:break :endif

ENDWHILE

if end&:Sound 2200,40: DeleteObject Bitmap% :END :Endif

    Goto "Begin"
    END

    proc Ellipsenbogen

        parameters a!,b!,alpha!,beta!,gamma!,col&,thk&,sw&
        declare x!,y!,g!,tmp!,nenr!,wrz!,inkr!

        if beta!>gamma!:tmp!=gamma!:gamma!=beta!:beta!=tmp!:endif

            var von!=beta!:var bis!=gamma!:g!=von!
            Repeat :x!=a!*cos(-g!):y!=b!*sin(-g!)
            inkr!=1/(13.2+sqrt(abs(x!*y!/(a!*b!))))
            tmp!=x!*cos(alpha!)+y!*sin(alpha!)
            y!=x!*sin(alpha!)-y!*cos(alpha!):x!=tmp!
            case g!=von! : moveto xm!+x!,ym!-y!
            usepen 0,thk&,col&:lineto xm!+x!,ym!-y!:usepen 0,1,0
            case sw&:line  xm!,ym! - (xm!+x!),ym!-y!
            g!=g!+inkr!:until g!>=bis!

        endproc

        proc Achsen :parameters x!,y!

            line xm!,0 - xm!,2*ym!
            line 0,ym! - 2*xm!,ym!

        endproc