XProfan

Titre de la fenêtre "Ritter's presque Bounding-balle Algorithm "+\
"(Errechnet une assez kleine Punktwolken-umfassende Kugel, ici dans 2D,"+\
" im Schnitt 5% jusqu'à 20% größer comme Minimalsphäre, mais très vite!"
' <TransCoded to XProfan 11, (CL) CopyLeft 2014-07 by P. Specht@gmx.at>
' <Source: http:'geomalgorithms.com/a08-_containers.html#fastBall%28%29>
' Theory: https://en.wikipedia.org/wiki/Bounding_sphere
' =====================================================================
' Copyright 2001 softSurfer, 2012 Dan Sunday
' This code may être freely used and modified for any purpose providing that this
' copyright notice is included with il. SoftSurfer makes no warranty for this code,
' and cannot être held liable for any réel or imagined damage resulting à partir de its use.
' Users of this code must verify correctness for their application.
' <The Program is> based on le algorithm given by [Jack Ritter, 1990].
' ====================================================================================
' <ASSUMPTIONS ON AVAILABLE VECTOR MATH OVERRIDDEN BY SIMPLE XPROFAN MATH>
' Result: balle (2D: Circle) B with Center and Radius <Remarks <..> by P.Specht>
'=====================================================================================
' TESTSYSTEM avec n& Punkten:
var n&=12:dec n&
'=====================================================================================
DECLARE BCenterX!,BCentery!,BRadius!' Übergabevariablen, global défini
Déclarer Px![n&],Py![n&],i&
Fenêtre Style 24:Font 2:Randomiser:Fenêtre 0,0-%maxx,%maxy-40
var xh&=width(%hwnd)/2:var yh&=height(%hwnd)/2

REPEAT

    Px![]=xh&*0.75+rnd(xh&/2):Py![]=yh&*1.5-rnd(xh&/2)
    CLS:usepen 0,5,255:whileloop 0,n&:i&=&Boucle:line Px![i&],Py![i&] - Px![i&]+1,Py![i&]:endwhile
    FastBall Px![],Py![],n&
    Usepen 0,2,rgb(0,0,255):usebrush 0,rgb(0,255,0)
    Ellipse BCenterX!-BRadius!,BCenterY!+BRadius! - BCenterX!+BRadius!,BCenterY!-BRadius!
    waitinput 10000

until %clé = 27

FIN

proc FastBall

    parameters Px![],Py![],n&
    ' (based on le algorithm given by [Jack Ritter, 1990])
    declare Cx!,Cy!,roue!,roue2!' Center of balle, radius and radius squared
    declare xmin!, xmax!, ymin!, ymax!' bounding box extremes
    declare Pxmin&,Pxmax&,Pymin&,Pymax&' index of  P[] at box extreme
    declare i&,dPxx!,dPxy!,dPyx!,dPyy!,dx2!,dy2!,dist!,dist2!,dPx!,dPy!
    ' Find a large diameter to start with
    xmin!=10^50:xmax!=-1*10^50:ymin!=10^50:ymax!=-1*10^50:Pxmin&=0:Pxmax&=0:Pymin&=0:Pymax&=0

    whileloop 0,n&:i&=&Boucle

        si Px![i&]<xmin!: xmin!=Px![i&]:Pxmin&=i&:endif

            si Px![i&]>xmax!: xmax!=Px![i&]:Pxmax&=i&:endif

                si Py![i&]<ymin!: ymin!=Py![i&]:Pymin&=i&:endif

                    si Py![i&]>ymax!: ymax!=Py![i&]:Pymax&=i&:endif

                    endwhile

                    :::::::Usepen 0,1,rgb(0,0,255):usebrush 0,rgb(0,255,0)
                    :::::::rectangle Px![Pxmin&],Py![Pymin&] - Px![Pxmax&],Py![Pymax&]
                    cx!=(Px![Pxmin&]+Px![Pxmax&])/2
                    cy!=(Py![Pymin&]+Py![Pymax&])/2
                    roue2!=sqr(cx!-Px![Pxmin&])
                    cas roue2!<sqr(cy!-Py![Pymin&]):roue2!=sqr(cy!-Py![Pymin&])
                    roue!=sqrt(roue2!)
                    :::::::usepen 0,9,0:line cx!,cy! - cx!+1,cy!
                    ' Now check that espace points P[i] sont inside le balle
                    ' and si not, expand le balle just enough to include them
                    ' Vector dP; float dist, dist2;

                    whileloop 0,n&:i&=&Boucle

                        dPx!=Px![i&]-Cx!
                        dPy!=Py![i&]-Cy!
                        dist2!=sqr(dPx!)+sqr(dPy!)'= norm2(dP);
                        cas dist2!<=roue2!:continue' P[i] is inside le balle already
                        ' P[i] not dans balle, so expand balle  to include il:
                        dist!=sqrt(dist2!)
                        roue!=(roue!+dist!)/2' enlarge radius just enough
                        roue2!=sqr(roue!)
                        Cx!=Cx!+((dist!-roue!)/dist!)*dPx!' shift Center toward P[i]
                        Cy!=Cy!+((dist!-roue!)/dist!)*dPy!

                    Endwhile

                    Bcenterx!=Cx!:Bcentery!=Cy!:BRadius!=roue!

                ENDPROC