I have done this code... i was wondering is someobody has a better way
to do this, and if someone can help me in detecting line crossing and
add a separation point if a line crosses another...
A bit messy, help?
%MIA_USED = &H000000001
%MIA_NORMALSTREET = &H000000002
%MIA_SEMAPHORE = &H000000004
%MIA_AVENUE = &H000000008
%MIA_GROUND = &H000000010
%LAYER_VISIBLE = 1
%LAYER_MIXED = 2
%LAYER_MIXER = 3
%LAYER_SHADOWS = 4
%LAYER_BUFFER = 5
TYPE GLayer
HmemDC AS DWORD
HMemBM AS DWORD
HHolBM AS DWORD
END TYPE
TYPE PuntosType
X AS LONG
Y AS LONG
END TYPE
TYPE LineasType
Col AS LONG ' Color
F AS LONG ' Flags
P1 AS LONG ' Point 1 (Start)
P2 AS LONG ' Point 2 (End)
PA AS LONG ' Point 3 (Angle)
END TYPE
GLOBAL Ly() AS Glayer
GLOBAL Punto() AS PuntosType
GLOBAL Linea() AS LineasType
GLOBAL Dragging AS LONG
GLOBAL x1 AS LONG
GLOBAL y1 AS LONG
GLOBAL x2 AS LONG
GLOBAL y2 AS LONG
'--------------------------------------------------------------------------------
FUNCTION FORM1_WM_PAINT ( _
hWndForm AS DWORD _ ' handle of Form
) AS LONG
IF ISTRUE(Dragging) THEN
CALL Copy_Layer(%LAYER_BUFFER, %LAYER_MIXER)
Draw_Line(%LAYER_MIXER, X1, Y1, X2, Y2, 1, %RED)
Copy_Layer(%LAYER_MIXER, %LAYER_VISIBLE)
Make_visible(%LAYER_VISIBLE, hWndForm)
ELSE
Clear_Layer(%LAYER_VISIBLE)
CALL Draw_Whole(%LAYER_VISIBLE)
Make_visible(%LAYER_VISIBLE, hWndForm)
END IF
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION FORM1_WM_DESTROY ( _
hWndForm AS DWORD _ ' handle of Form
) AS LONG
CALL Delete_Layers()
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION FORM1_CUSTOM ( _
hWndForm AS DWORD, _ ' handle of Form
wMsg AS LONG, _ ' type of message
wParam AS DWORD, _ ' first message parameter
lParam AS LONG _ ' second message parameter
) AS LONG
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION FORM1_WM_LBUTTONDOWN ( _
hWndForm AS DWORD, _ ' handle of Form
MouseFlags AS LONG, _ ' virtual keys that are pressed
xPos AS LONG, _ ' x-coordinate of cursor
yPos AS LONG _ ' y-coordinate of cursor
) AS LONG
SETCAPTURE(hWndForm)
CALL GETASYNCKEYSTATE(%VK_CONTROL)
IF GETASYNCKEYSTATE(%VK_CONTROL) THEN Dragging=1 ELSE Dragging=2
x1 = Xpos
y1 = Ypos
CALL Copy_Layer(%LAYER_VISIBLE, %LAYER_BUFFER)
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION FORM1_WM_LBUTTONUP ( _
hWndForm AS DWORD, _ ' handle of Form
MouseFlags AS LONG, _ ' virtual keys that are pressed
xPos AS LONG, _ ' x-coordinate of cursor
yPos AS LONG _ ' y-coordinate of cursor
) AS LONG
RELEASECAPTURE()
X2 = Xpos
Y2 = Ypos
FUNCTION = AddNewUnion(X1, Y1, X2, Y2)
Dragging = %false
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION FORM1_WM_MOUSEMOVE ( _
hWndForm AS DWORD, _ ' handle of Form
MouseFlags AS LONG, _ ' virtual keys that are pressed
xPos AS LONG, _ ' x-coordinate of cursor
yPos AS LONG _ ' y-coordinate of cursor
) AS LONG
X2 = Xpos
Y2 = Ypos
IF ISFALSE(Dragging) THEN
CALL GETASYNCKEYSTATE(%VK_CONTROL)
SELECT CASE Start_point(Xpos, Ypos)
CASE %WHITE : MOUSEPTR 1
CASE 1 TO 2000000 : MOUSEPTR 10
CASE ELSE : IF GETASYNCKEYSTATE(%VK_CONTROL) THEN MOUSEPTR 5 ELSE MOUSEPTR 1
END SELECT
END IF
CALL INVALIDATERECT(hWndForm, BYVAL %NULL, %FALSE)
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION UpdateLine(LineID AS LONG, Point1 AS LONG, Point2 AS LONG, Point3 AS LONG) AS LONG
Linea(LineID).P1 = Point1
Linea(LineID).P2 = Point2
Linea(LineID).PA = Point3
FUNCTION = %TRUE
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION AddNewLine(Point1 AS LONG, Point2 AS LONG) AS LONG
ERRCLEAR
REDIM PRESERVE Linea(UBOUND(Linea())+1) AS LineasType
IF ERR THEN EXIT FUNCTION
Linea(UBOUND(Linea())).P1 = Point1
Linea(UBOUND(Linea())).P2 = Point2
Linea(UBOUND(Linea())).PA = 0
FUNCTION = UBOUND(Linea())
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION AddNewPoint(X1 AS LONG, Y1 AS LONG) AS LONG
ERRCLEAR
REDIM PRESERVE Punto(UBOUND(Punto())+1) AS PuntosType
IF ERR THEN EXIT FUNCTION
Punto(UBOUND(Punto())).X = X1
Punto(UBOUND(Punto())).Y = Y1
FUNCTION = UBOUND(Punto())
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION AddNewUnion(X1 AS LONG, Y1 AS LONG, X2 AS LONG, Y2 AS LONG) AS LONG
LOCAL HitLine AS LONG
LOCAL OnPoint AS LONG
LOCAL Pp1 AS LONG
LOCAL Pp2 AS LONG
LOCAL NLP1 AS LONG
LOCAL NLP2 AS LONG
'------------------------------------------------
HitLIne = Start_point(X1, Y1)
OnPoint = (Hitline>2000000)
IF (HitLIne>2000000) THEN HitLIne=(HitLIne-2000000)
IF ISFALSE(HitLine) THEN ' Starts in white area.
NLP1 = AddNewPoint(X1, Y1)
ELSE
IF OnPoint THEN 'Starts in a point
NLP1 = HitLine
ELSE 'Starts in a line
Pp1 = Linea(Hitline).P1
Pp2 = Linea(Hitline).P2
NLP1 = AddNewPoint(X1, Y1)
Linea(Hitline).P2 = NLP1
AddNewLine(NLP1, Pp2)
END IF
END IF
'------------------------------------------------
'------------------------------------------------
HitLIne = Start_point(X2, Y2)
OnPoint = (Hitline>2000000)
IF (HitLIne>2000000) THEN HitLIne=(HitLIne-2000000)
IF ISFALSE(HitLine) THEN 'Ends in white area.
NLP2 = AddNewPoint(X2, Y2)
ELSE
IF OnPoint THEN 'Ends in a point
NLP2 = HitLine
ELSE 'Ends in a line
Pp1 = Linea(Hitline).P1
Pp2 = Linea(Hitline).P2
NLP2 = AddNewPoint(X2, Y2)
Linea(Hitline).P1 = NLP2
AddNewLine(Pp1, NLP2)
END IF
END IF
'------------------------------------------------
FUNCTION = AddNewLine(NLP1, NLP2)
END FUNCTION
FUNCTION Clear_Layer(LayerNum AS LONG, OPT ClearColor AS LONG) AS LONG
LOCAL RC AS RECT
LOCAL OBMP AS BITMAP
GETOBJECT(Ly(LayerNum).HmemBm, LEN(OBMP), OBMP)
RC.NLEFT = 0
RC.NTOP = 0
RC.NRIGHT = OBMP.bmWidth
RC.NBOTTOM = OBMP.bmHeight
IF VARPTR(ClearColor) THEN
LOCAL Hbrush AS LONG
Hbrush = CREATESOLIDBRUSH(ClearColor)
FUNCTION = FILLRECT(Ly(LayerNum).HmemDc, RC, Hbrush)
DELETEOBJECT Hbrush
ELSE
FUNCTION = FILLRECT(Ly(LayerNum).HmemDc, RC, GETSTOCKOBJECT(%WHITE_BRUSH))
END IF
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION Create_Layers(NumLayers AS LONG, Wid AS LONG, Hei AS LONG) AS LONG
ERRCLEAR
IF UBOUND(LY()) > -1 THEN EXIT FUNCTION
REDIM PRESERVE Ly(NumLayers) AS GLayer
LOCAL Index AS LONG
LOCAL Hdc AS LONG
HDC = GETDC(%HWND_DESKTOP)
FOR Index = 1 TO NumLayers
Ly(Index).HmemDc = CREATECOMPATIBLEDC(HDC)
Ly(Index).HmemBm = CREATECOMPATIBLEBITMAP(HDC, Wid, Hei)
Ly(Index).HHolBm = SELECTOBJECT(Ly(Index).HmemDc, Ly(Index).HmemBm)
CALL Clear_Layer(Index)
NEXT Index
RELEASEDC %HWND_DESKTOP, HDC
FUNCTION = (ERR=0)
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION Resize_Layers(Wid AS LONG, Hei AS LONG) AS LONG
ERRCLEAR
IF UBOUND(LY()) < 0 THEN EXIT FUNCTION
LOCAL Index AS LONG
LOCAL Hdc AS LONG
HDC = GETDC(%HWND_DESKTOP)
FOR Index = 1 TO UBOUND(Ly())
DELETEOBJECT SELECTOBJECT(Ly(Index).HmemDc, Ly(Index).HHolBm)
Ly(Index).HmemBm = CREATECOMPATIBLEBITMAP(HDC, Wid, Hei)
Ly(Index).HHolBm = SELECTOBJECT(Ly(Index).HmemDc, Ly(Index).HmemBm)
NEXT Index
RELEASEDC %HWND_DESKTOP, HDC
FUNCTION = (ERR=0)
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION Delete_Layers() AS LONG
ERRCLEAR
IF UBOUND(LY()) < 0 THEN EXIT FUNCTION
LOCAL Index AS LONG
FOR Index = 1 TO UBOUND(Ly())
DELETEOBJECT SELECTOBJECT(Ly(Index).HmemDc, Ly(Index).HHolBm)
DELETEDC Ly(Index).HmemDc
NEXT Index
FUNCTION = (ERR=0)
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION Copy_Layer(Orig AS LONG, Dest AS LONG) AS LONG
ERRCLEAR
IF UBOUND(LY()) < 0 THEN EXIT FUNCTION
IF Orig < 1 THEN EXIT FUNCTION
IF Orig > UBOUND(LY()) THEN EXIT FUNCTION
IF Dest < 1 THEN EXIT FUNCTION
IF Dest > UBOUND(LY()) THEN EXIT FUNCTION
LOCAL OBMP AS BITMAP
GETOBJECT(Ly(Orig).HmemBm, LEN(OBMP), OBMP)
BITBLT Ly(Dest).HmemDc, 0, 0, OBMP.bmWidth, OBMP.bmHeight, Ly(Orig).HmemDc, 0, 0, %SRCCOPY
FUNCTION = (ERR=0)
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION FORM1_WM_CREATE ( _
hWndForm AS DWORD, _ ' handle of Form
BYVAL UserData AS LONG _ 'optional user defined Long value
) AS LONG
CALL Create_Layers(5, 800, 800)
DIM Punto(0) AS GLOBAL PuntosType
DIM Linea(0) AS GLOBAL LineasType
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION Start_Point(X AS LONG, y AS LONG) AS LONG
FUNCTION = GETPIXEL(LY(%LAYER_SHADOWS).HmemDC, X, Y)
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION Draw_Line(LayerNum AS LONG, x1 AS LONG, y1 AS LONG, x2 AS LONG, y2 AS LONG, _
LineThickness AS LONG, LineColor AS LONG) AS LONG
LOCAL HPen AS LONG
HPen = SELECTOBJECT(Ly(LayerNum).HmemDc, CREATEPEN(%PS_SOLID, LineThickness, LineColor))
MOVETOEX(Ly(LayerNum).HmemDc, X1, Y1, BYVAL %NULL)
LINETO(Ly(LayerNum).HmemDc, X2, Y2)
DELETEOBJECT SELECTOBJECT(Ly(LayerNum).HmemDc, HPen)
FUNCTION = %true
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION Draw_Square(LayerNum AS LONG, x1 AS LONG, y1 AS LONG, _
BYVAL Bs AS LONG, LineColor AS LONG, FillColor AS LONG) AS LONG
LOCAL RC AS RECT
LOCAL Hpen AS LONG
LOCAL HBrush AS LONG
HPen = SELECTOBJECT(Ly(LayerNum).HmemDc, CREATEPEN(%PS_SOLID, 0, LineColor))
HBrush = SELECTOBJECT(Ly(LayerNum).HmemDc, CREATESOLIDBRUSH(FillColor))
Bs = INT(Bs/2)
MOVETOEX(Ly(LayerNum).HmemDc, X1-Bs, Y1-Bs, BYVAL %NULL)
LINETO(Ly(LayerNum).HmemDc, X1+(Bs*2), Y1-Bs)
LINETO(Ly(LayerNum).HmemDc, X1+(Bs*2), Y1+(Bs*2))
LINETO(Ly(LayerNum).HmemDc, X1-Bs, Y1+(Bs*2))
LINETO(Ly(LayerNum).HmemDc, X1-Bs, Y1-Bs)
CALL SETRECT(RC, X1-Bs, Y1-Bs, (X1+(Bs*2)), (Y1+(Bs*2)))
FILLRECT(Ly(LayerNum).HmemDc, RC, BYVAL %NULL)
DELETEOBJECT SELECTOBJECT(Ly(LayerNum).HmemDc, Hpen)
DELETEOBJECT SELECTOBJECT(Ly(LayerNum).HmemDc, HBrush)
FUNCTION = %true
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION Make_Visible(LayerNum AS LONG, HwndForm AS LONG) AS LONG
LOCAL HDC AS LONG
LOCAL PS AS PAINTSTRUCT
LOCAL OBMP AS BITMAP
GETOBJECT(Ly(LayerNum).HmemBm, LEN(OBMP), OBMP)
HDC = BEGINPAINT(hWndForm, PS)
BITBLT HDC, 0, 0, OBMP.bmWidth, OBMP.bmHeight, Ly(LayerNum).HmemDc, 0, 0, %SRCCOPY
ENDPAINT(hWndForm, PS)
FUNCTION = %true
END FUNCTION
'--------------------------------------------------------------------------------
FUNCTION Draw_Whole(LayerNum AS LONG) AS LONG
LOCAL Index AS LONG
Clear_Layer(%LAYER_SHADOWS, %BLACK)
FOR Index = 1 TO UBOUND(Linea())
Draw_Line(LayerNum, Punto(Linea(Index).P1).X, _
Punto(Linea(Index).P1).Y, _
Punto(Linea(Index).P2).X, _
Punto(Linea(Index).P2).Y, _
1, %BLUE)
Draw_Line(%LAYER_SHADOWS, _
Punto(Linea(Index).P1).X, _
Punto(Linea(Index).P1).Y, _
Punto(Linea(Index).P2).X, _
Punto(Linea(Index).P2).Y, _
4, Index)
NEXT Index
FOR Index = 1 TO UBOUND(Punto())
Draw_Square(LayerNum, Punto(Index).X-2, _
Punto(Index).Y-2, _
5, %BLACK, %RED)
Draw_Square(%LAYER_SHADOWS, _
Punto(Index).X-2, _
Punto(Index).Y-2, _
5, Index+2000000, Index+2000000)
NEXT Index
END FUNCTION
Elias,
This is what I use to detect if two line segments cross and to calculate an intersection point from the two line segments. I use this code for real world calculations dealing with large coordinate values hence the use of double precision. You can convert the input values to a long data type if you wish.
The two line segments cross if the parameters S and T are both in the range of 0 <= S <= 1 and 0 <= T <= 1. This routine will also tell you if the end point of one line segment falls on another line segment, in this case S or T will be equal to 0 or 1. The parameter S applies to the first line segment, T to the second.
If the two line segments are parallel the FUNCTION value will be %FALSE.
'*************************************************************************
' Purpose:
'
' Function to calculate the intersection point of two line segments. Two
' line segments will intersect if the parameters s# and t# are in the
' range of 0 <= s# <= 1 and 0 <= t# <= 1.
'
'*************************************************************************
FUNCTION isect2d_LineLine_XY ALIAS "isect2d_LineLine_XY" _
(BYVAL X1 AS DOUBLE, _
BYVAL Y1 AS DOUBLE, _
BYVAL X2 AS DOUBLE, _
BYVAL Y2 AS DOUBLE, _
BYVAL X3 AS DOUBLE, _
BYVAL Y3 AS DOUBLE, _
BYVAL X4 AS DOUBLE, _
BYVAL Y4 AS DOUBLE, _
dIpX AS DOUBLE, _
dIpY AS DOUBLE, _
S AS DOUBLE, _
T AS DOUBLE) EXPORT AS LONG
LOCAL dSnum AS DOUBLE
LOCAL dTnum AS DOUBLE
LOCAL dDenom AS DOUBLE
'-----------------------------------------------------------------------
FUNCTION = %FALSE
S = 0#
T = 0#
dDenom = (((X2 - X1) * (Y4 - Y3)) - ((Y2 - Y1) * (X4 - X3)))
IF dDenom = 0 THEN 'Line segments parallel?
EXIT FUNCTION
END IF
dSnum = (((Y1 - Y3) * (X4 - X3)) - ((X1 - X3) * (Y4 - Y3)))
dTnum = (((Y1 - Y3) * (X2 - X1)) - ((X1 - X3) * (Y2 - Y1)))
S = dSnum / dDenom
T = dTnum / dDenom
'
' Calculate intersection point from line segment 1 using vector equation
' of a line.
'
dIpX = X1 + ((X2 - X1) * S)
dIpY = Y1 + ((Y2 - Y1) * S)
FUNCTION = %TRUE 'Set return status.
END FUNCTION
HTH
JR
Thanks for your time JR!!, i think i can adapt this to my code...
:)
Elias,
The intersting thing is you can tell a lot about the geometry of both line segments by examining the values of S and T together. One other issue that this routine does not cover adequately is the possibility of having two line segments that fall on top of each other. This routine will report this possibility as a parallel condition which is technically correct, but in this case you would have an infinite number of possible intersection points.
JR
Oh no... I forgot something important... This program works only in 32
Bit screen mode... is any lower... it crashes!! Back to the design table...
:(