| |
|
|
p.specht
| qui "Fast Bounding Sphere Algorithm" de Ritter[1990]: comment grand sollte chez un certain Punktwolke qui Erfassungsradius eines Umkreises/ einer Umkugel son, et òu serait on ungefähr viser, um alle Punkte trop erfassen?
P.S.: Mittlerweile c'est moi aussi bien sûr, woher qui Fragestellung venez: ici veux on pas Fliegen avec einem grand Schmetterlingsnetz attraper, mais schnelle Feuerlösungen pour qui Artillerie liefern! belle Sch....!!!
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
|
|
|
| Computer: Gerät, daß es in Mikrosekunden erlaubt, 50.000 Fehler zu machen, zB 'daß' statt 'das'... | 11.05.2021 ▲ |
|
|
|