Code : Tout sélectionner
;Comtois 16/02/05
;Construction d'un polygone convexe
;Les points peuvent être déplacés à la souris
;-Include
Declare Erreur(Message$)
Declare TracePolygone()
Declare AffPoints(*P.point,mem)
Declare TestPoint(x1,Y1,X2,Y2,d)
Declare PolygoneConvexe()
Global ScreenHeight.l,ScreenWidth.l
If ExamineDesktops()
ScreenWidth = DesktopWidth(0)
ScreenHeight = DesktopHeight(0)
Else
Erreur("Euh ?")
EndIf
#Nbpoints=15
NewList ListPoint.point()
NewList Polygone.point()
Point.point
DiametreSelection=6
For i=1 To #Nbpoints
AddElement(ListPoint())
ListPoint()\x=Random(ScreenWidth-1)
ListPoint()\y=Random(ScreenHeight-1)
Next
;-Initialisation
If InitSprite() = 0 Or InitMouse() = 0 Or InitKeyboard()=0
Erreur("Impossible d'initialiser DirectX 7 Ou plus")
ElseIf OpenWindow(0,0,0,ScreenWidth,ScreenHeight,#PB_Window_BorderLess,"Collision") = 0
Erreur("Impossible de créer la fenêtre")
EndIf
;{/ouvre un écran
If OpenWindowedScreen( WindowID(0), 0, 0, ScreenWidth , ScreenHeight, 0, 0, 0 ) = 0
Erreur("Impossible d'ouvrir l'écran ")
EndIf
;-Boucle
Repeat
While WindowEvent():Wend
ClearScreen(0, 0, 0)
ExamineKeyboard()
ExamineMouse()
;Les points peuvent être déplacés
If MouseButton(1)
If MemPoint>=0
SelectElement(ListPoint(),MemPoint)
ListPoint()\x = MouseX()
ListPoint()\y = MouseY()
EndIf
Else
MemPoint=-1
EndIf
ForEach ListPoint()
If TestPoint(MouseX(),MouseY(),ListPoint()\x,ListPoint()\y,DiametreSelection)
MemPoint=ListIndex(ListPoint())
Break
EndIf
Next
;Place le point à tester sous la souris
Point\x=MouseX()
Point\y=MouseY()
;Affiche le tout
PolygoneConvexe()
AffPoints(@Point,MemPoint)
TracePolygone()
FlipBuffers()
Delay(1)
Until KeyboardPushed(#PB_Key_Escape)
End
;-Procedures
Procedure Erreur(Message$)
MessageRequester( "Erreur" , Message$ , 0 )
End
EndProcedure
Procedure PolygoneConvexe()
If CountList(ListPoint())<2
ProcedureReturn #False
EndIf
;Trouve le point le plus bas dans la liste des points
FirstElement(ListPoint())
*Min.point=ListPoint()
*bas.point=*Min
ForEach ListPoint()
*p0.point=ListPoint()
;Mémorise le point le plus bas , ou le plus à gauche s'il y a égalité
If (*p0\y<*Min\y) Or ((*p0\y=*Min\y) And (*p0\x<*Min\x))
*Min=*p0
*bas=ListPoint()
EndIf
Next
;Initialise la liste pour le contour convexe
ClearList(Polygone())
;Effectue la progression de Jarvis pour calculer le contour
*p0=*bas
Repeat
;Insertion du nouveau p0 dans le contour convexe
If AddElement(Polygone())=0
Erreur("plus de mémoire pour ajouter un élément dans polygone")
Else
Polygone()\x=*p0\x
Polygone()\y=*p0\y
EndIf
;Trouve le point pc dans le sens des aiguilles d'une montre
cpt=0
ForEach ListPoint()
*pi.point=ListPoint()
;Saute p0
If *pi=*p0
Continue
EndIf
;Compte les points explorés
cpt+1
;On suppose que le premier point à explorer est dans le sens des aiguilles d'une montre
If cpt=1
*pc.point=ListPoint()
Continue
EndIf
;Teste si pi est dans le sens des aiguilles d'une montre par rapport à pc
z=(((*pi\x - *p0\x) * (*pc\y - *p0\y)) - ((*pi\y - *p0\y) * (*pc\x - *p0\x)))
If z > 0
;pi est dans le sens des aiguilles d'une montre par rapport à pc
*pc=*pi
ElseIf z=0
;Si pi et pc sont colinéaires , on choisit le plus éloigné de p0
longueurpi = Pow(*pi\x - *p0\x, 2.0) + Pow(*pi\y - *p0\y, 2.0)
longueurpc = Pow(*pc\x - *p0\x, 2.0) + Pow(*pc\y - *p0\y, 2.0)
If longueurpi > longueurpc
*pc=*pi
EndIf
EndIf
Next
;Cherche le point suivant
*p0=*pc
Until *p0=*bas
EndProcedure
Procedure TracePolygone()
CouleurPolygone=RGB(0,255,0)
StartDrawing(ScreenOutput())
SelectElement(Polygone(),0)
*mem0.point=Polygone()
*mem.point=Polygone()
While NextElement(Polygone())
LineXY(*mem\x,*mem\y,Polygone()\x,Polygone()\y,CouleurPolygone)
*mem=Polygone()
Wend
LineXY(*mem0\x,*mem0\y,*mem\x,*mem\y,CouleurPolygone)
StopDrawing()
EndProcedure
Procedure AffPoints(*P.point,mem)
CouleurCurseur=RGB(255,255,255)
CouleurPoint=RGB(255,0,0)
StartDrawing(ScreenOutput())
ForEach ListPoint()
Circle(ListPoint()\x,ListPoint()\y,4,CouleurPoint)
Next
;/Affiche le point
If mem>=0
DrawingMode(4)
Circle(*P\x,*P\y,6,CouleurCurseur)
Else
DrawingMode(0)
Circle(*P\x,*P\y,4,CouleurCurseur)
EndIf
;/Affiche une croix pour mieux suivre le déplacement du point
LineXY(*P\x,0,*P\x,ScreenHeight-1,CouleurCurseur)
LineXY(0,*P\y,ScreenWidth-1,*P\y,CouleurCurseur)
StopDrawing()
EndProcedure
Procedure TestPoint(x1,Y1,X2,Y2,d)
If x1>X2-d And x1<X2+d And Y1>Y2-d And Y1<Y2+d
ProcedureReturn #True
Else
ProcedureReturn #False
EndIf
EndProcedure
