XProfan

'dans XProfan 11.2a free geschrieben trop Lernzwecken
Windowstyle 31
Windowtitle "Bresenham-Circles"
Fenêtre %maxx*.81,%maxy*.81
Cls @Rgb(231,231,221)
'  Kreise dans la distance ab%
var r%= sqrt((@width(%hWnd)/2)^2 + (@height(%hWnd)/2)^2 )
var ab%=14

tandis que r%>0

    brCircle( @width(%hWnd)/2, @height(%hWnd)/2 , r% , \
    @rgb(rnd(100)+155,rnd(155)+100,r% and 255) )
    r% = r% - ab%
    cas %MousePressed : pause

endwhile

WaitInput
Fin

proc brCircle

    ' Bresenham-Algorithmus pour une (Achtel-)Kreis
    parameters xmittel%,ymittel%,r%,c%
    var x% = r%
    var y% = 0
    var faute% = r%
    declare dy%,dx%
    Gosub "DrawPixels"' JAWOLL, EIN GOSUB! DA STAUNSTE, WAS?

    WHILE y% < x%

        dy% = y%*2+1 : REM chez Assembler-Implementierung *2 per Shift
        inc y%
        faute% = faute% - dy%

        IF faute%<0

            dx% = 1 - x%*2
            x% = x% - 1
            faute% = faute% - dx%

        ENDIF

        ' là es um den Bildschirm et pas ums Plotten allez,
        ' peux on qui anderen Oktanten ici avec abdecken:
        Gosub "DrawPixels"

    ENDWHILE

    RETOUR
    DrawPixels:
    SETPIXEL xmittel%+x%, ymittel%+y%,c%
    SETPIXEL xmittel%-x%, ymittel%+y%,c%
    SETPIXEL xmittel%-x%, ymittel%-y%,c%
    SETPIXEL xmittel%+x%, ymittel%-y%,c%
    SETPIXEL xmittel%+y%, ymittel%+x%,c%
    SETPIXEL xmittel%-y%, ymittel%+x%,c%
    SETPIXEL xmittel%-y%, ymittel%-x%,c%
    SETPIXEL xmittel%+y%, ymittel%-x%,c%
    Retour

ENDPROC