; http://herved25.free.fr/pureindex.htm
; Author: Comtois (updated for PB 4.00 by Andre)
; Date: 16. February 2005
; OS: Windows
; Demo: Yes


; Problem: collission don't work, it always show "OUT"...



;Comtois 16/02/05
;Détection collision d'un segment avec un autre segment

;-Include
Structure Segment
  P1.point
  P2.point
EndStructure

Global Box1.Segment,Box2.Segment
Global ScreenHeight.l,ScreenWidth.l

Segment1.Segment
Segment2.Segment
Point.point
;Segment1
Segment1\P1\x=50
Segment1\P1\y=50
Segment1\P2\x=110
Segment1\P2\y=250
;Segment2
Segment2\P1\x=210
Segment2\P1\y=250
Segment2\P2\x=410
Segment2\P2\y=350
;Point à tester
Point\x=340
Point\y=100
DiametreSelection=6

Declare Erreur(Message$)
Declare.l Signe(a.l)
Declare.l Min(a.l,b.l)
Declare.l Max(a.l,b.l)
Declare Encadrement(*S1.Segment,*S2.Segment)
Declare CollisionSegmentSegment(*S1.Segment,*S2.Segment)
Declare AffPoints(*S1.Segment,*S2.Segment,*P.point,mem)
Declare TestPoint(X1,Y1,X2,Y2,d)

;-Initialisation
If ExamineDesktops()
  ScreenWidth = DesktopWidth(0)
  ScreenHeight = DesktopHeight(0)
Else
  Erreur("Euh ?")
EndIf 
If InitSprite() = 0 Or InitMouse() = 0 Or InitKeyboard()=0
  Erreur("Impossible d'initialiser DirectX 7 Ou plus") 
ElseIf OpenWindow(0,0,0,ScreenWidth,ScreenHeight,"Collision",#PB_Window_BorderLess) = 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(RGB(0, 0, 0))
  ExamineKeyboard()
  ExamineMouse()
  ;Le triangle est modifiable à la souris en cliquant sur un point
  If MouseButton(1)
    If MemPoint=1
      Segment1\P1\x=MouseX()
      Segment1\P1\y=MouseY()
    ElseIf MemPoint=2
      Segment1\P2\x=MouseX()
      Segment1\P2\y=MouseY()
    ElseIf MemPoint=3
      Segment2\P1\x=MouseX()
      Segment2\P1\y=MouseY()
    ElseIf MemPoint=4
      Segment2\P2\x=MouseX()
      Segment2\P2\y=MouseY()  
    EndIf
  Else
    MemPoint=0
  EndIf
  If TestPoint(MouseX(),MouseY(),Segment1\P1\x,Segment1\P1\y,DiametreSelection)
    MemPoint=1
  ElseIf TestPoint(MouseX(),MouseY(),Segment1\P2\x,Segment1\P2\y,DiametreSelection)
    MemPoint=2
  ElseIf TestPoint(MouseX(),MouseY(),Segment2\P1\x,Segment2\P1\y,DiametreSelection)
    MemPoint=3
  ElseIf TestPoint(MouseX(),MouseY(),Segment2\P2\x,Segment2\P2\y,DiametreSelection)
    MemPoint=4  
  EndIf
  ;Place le point à tester sous la souris
  Point\x=MouseX()
  Point\y=MouseY()
  ;Affiche le tout
  Encadrement(@Segment1,@Segment2)
  AffPoints(@Segment1,@Segment2,@Point,MemPoint)
  FlipBuffers()
  Delay(1)
Until KeyboardPushed(#PB_Key_Escape) 
End

;-Procedures
Procedure Erreur(Message$)
  MessageRequester( "Erreur" , Message$ , 0 ) 
  End 
EndProcedure
Procedure.l Signe(a.l)
  If a>0
    ProcedureReturn 1
  ElseIf a=0
    ProcedureReturn 0
  Else
    ProcedureReturn -1
  EndIf
EndProcedure
Procedure.l Min(a.l,b.l)
  If a<b
    ProcedureReturn a
  Else
    ProcedureReturn b
  EndIf
EndProcedure
Procedure.l Max(a.l,b.l)
  If a>b
    ProcedureReturn a
  Else
    ProcedureReturn b
  EndIf
EndProcedure
Procedure Encadrement(*S1.Segment,*S2.Segment)
  ;Box Segment1
  Box1\P1\x=Min(*S1\P1\x,*S1\P2\x)
  Box1\P1\y=Min(*S1\P1\y,*S1\P2\y)
  Box1\P2\x=Max(*S1\P1\x,*S1\P2\x)
  Box1\P2\y=Max(*S1\P1\y,*S1\P2\y)  
  ;Box Segment2
  Box2\P1\x=Min(*S2\P1\x,*S2\P2\x)
  Box2\P1\y=Min(*S2\P1\y,*S2\P2\y)
  Box2\P2\x=Max(*S2\P1\x,*S2\P2\x)
  Box2\P2\y=Max(*S2\P1\y,*S2\P2\y) 
EndProcedure
Procedure CollisionSegmentSegment(*S1.Segment,*S2.Segment)
  ;Test Collision encadrement
  If Box1\P2\x >= Box2\P1\x And Box1\P1\x <= Box2\P2\x And Box1\P2\y >= Box2\P1\y And Box1\P1\y <= Box2\P2\y
    ;Test chevauchement segments
    R1=((*S2\P1\x-*S1\P1\x)*(*S1\P2\y-*S1\P1\y))-((*S2\P1\y-*S1\P1\y)*(*S1\P2\x-*S1\P1\x))
    R2=((*S2\P2\x-*S1\P1\x)*(*S1\P2\y-*S1\P1\y))-((*S2\P2\y-*S1\P1\y)*(*S1\P2\x-*S1\P1\x))
    R3=((*S1\P1\x-*S2\P1\x)*(*S2\P2\y-*S2\P1\y))-((*S1\P1\y-*S2\P1\y)*(*S2\P2\x-*S2\P1\x))
    R4=((*S1\P2\x-*S2\P1\x)*(*S2\P2\y-*S2\P1\y))-((*S1\P2\y-*S2\P1\y)*(*S2\P2\x-*S2\P1\x))
    If (Signe(R1)*Signe(R2)<=0) And (Signe(R3)*Signe(R4)<=0)
      Resultat = #True
    EndIf
  EndIf  
  ProcedureReturn Resultat
EndProcedure
Procedure AffPoints(*S1.Segment,*S2.Segment,*P.point,mem)
  CouleurBox=RGB(70,70,70)
  CouleurSegment1=RGB(255,0,0)
  CouleurSegment2=RGB(0,255,0)
  CouleurCurseur=RGB(255,255,255)
  StartDrawing(ScreenOutput())
  ;/Affiche les encadrements des segments en premier pour ne pas effacer le tracé d'un segment
  ;Segment1
  LineXY(Box1\P1\x,Box1\P1\y,Box1\P1\x,Box1\P2\y,CouleurBox)
  LineXY(Box1\P1\x,Box1\P1\y,Box1\P2\x,Box1\P1\y,CouleurBox)
  LineXY(Box1\P2\x,Box1\P1\y,Box1\P2\x,Box1\P2\y,CouleurBox)
  LineXY(Box1\P1\x,Box1\P2\y,Box1\P2\x,Box1\P2\y,CouleurBox) 
  ;Segment2
  LineXY(Box2\P1\x,Box2\P1\y,Box2\P1\x,Box2\P2\y,CouleurBox)
  LineXY(Box2\P1\x,Box2\P1\y,Box2\P2\x,Box2\P1\y,CouleurBox)
  LineXY(Box2\P2\x,Box2\P1\y,Box2\P2\x,Box2\P2\y,CouleurBox)
  LineXY(Box2\P1\x,Box2\P2\y,Box2\P2\x,Box2\P2\y,CouleurBox) 
  ;/Affiche le Segment1
  Circle(*S1\P1\x,*S1\P1\y,4,CouleurSegment1)
  Circle(*S1\P2\x,*S1\P2\y,4,CouleurSegment1)
  LineXY(*S1\P1\x,*S1\P1\y,*S1\P2\x,*S1\P2\y,CouleurSegment1)
  ;/Affiche le Segment2
  Circle(*S2\P1\x,*S2\P1\y,4,CouleurSegment2)
  Circle(*S2\P2\x,*S2\P2\y,4,CouleurSegment2)
  LineXY(*S2\P1\x,*S2\P1\y,*S2\P2\x,*S2\P2\y,CouleurSegment2)
  ;/Affiche le point
  If mem
    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)
  If CollisionSegmentSegment(*S1,*S2)
    FrontColor(RGB(255,255,0))
    BackColor(RGB(255,0,0))
    texte$="  IN "
  Else
    FrontColor(RGB(255,255,255))
    BackColor(RGB(0,255,0))
    texte$=" OUT "
  EndIf
  DrawText(0,0,texte$)
  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
; IDE Options = PureBasic v4.02 (Windows - x86)
; Folding = --