Posts: 135
Threads: 25
Joined: Apr 2022
Reputation:
39
11-01-2023, 10:14 AM
(This post was last modified: 11-01-2023, 10:18 AM by MasterGy.)
Hello !
A 3D game is being made. For this, it was necessary to write some subprograms.
It can be useful if you want to use it for something.
The program checks whether two segments intersect.
Code: (Select All)
Screen _NewImage(800, 600, 32)
Do
Cls
x1 = 800 * Rnd
y1 = 600 * Rnd
x2 = 800 * Rnd
y2 = 600 * Rnd
x3 = 800 * Rnd
y3 = 600 * Rnd
x4 = 800 * Rnd
y4 = 600 * Rnd
Color _RGB32(255, 255, 255)
Locate 1, 1: Print "SPACE to next"
If IsIntersection(x1, y1, x2, y2, x3, y3, x4, y4) Then
Color _RGB32(255, 50, 50)
Locate 3, 10: Print "Intersect !"
End If
Line (x1, y1)-(x2, y2)
Line (x3, y3)-(x4, y4)
Do: Loop Until InKey$ = " "
Loop
Function IsIntersection (X1, Y1, X2, Y2, X3, Y3, X4, Y4)
Denominator = (Y4 - Y3) * (X2 - X1) - (X4 - X3) * (Y2 - Y1)
If Denominator = 0 Then
IsIntersection = 0
Else
Ua = ((X4 - X3) * (Y1 - Y3) - (Y4 - Y3) * (X1 - X3)) / Denominator
Ub = ((X2 - X1) * (Y1 - Y3) - (Y2 - Y1) * (X1 - X3)) / Denominator
If Ua >= 0 And Ua <= 1 And Ub >= 0 And Ub <= 1 Then IsIntersection = 1 Else IsIntersection = 0
End If
End Function
Creates a surface from arbitrary points arranged in a plane. First it forms sections, and then triangles from the sections.
In this code there is a function 'PointInTriangle' which returns TRUE if a point XY is inside a triangle bounded by points X1Y1X2Y2X3Y3.
Code: (Select All)
Randomize Timer
mon = _NewImage(1000, 400, 32)
Screen mon
marg = 50
pontok = 10 'how many points
Dim p(pontok - 1, 2)
For t = 0 To pontok - 1
p(t, 0) = marg + (_Width - marg * 2) * Rnd
p(t, 1) = marg + (_Height - marg * 2) * Rnd
Circle (p(t, 0), p(t, 1)), 7
Next t
Locate 1, 1: Print "points:"; pontok, "Press SPACE to next"
Do: Loop Until InKey$ = " "
Cls
Dim sz(99999, 3)
Do: changing = 0
For t1 = 0 To pontok - 1
For t = 0 To pontok - 1: p(t, 2) = 1: Next t
qq = 0: cdis = 1800 ^ 2
Do: kovi = 0
find = -1: mindis = 9999999
For t = 0 To pontok - 1: If t = t1 Or p(t, 2) = 0 Then _Continue
disx = p(t, 0) - p(t1, 0): If disx > cdis Then _Continue
disy = p(t, 1) - p(t1, 1): If disy > cdis Then _Continue
dis = (disx * disx + disy * disy): If dis > cdis Then _Continue
If dis < mindis Then mindis = dis: find = t
Next t
If find <> -1 Then
p(find, 2) = 0
If szc > 0 Then
For asz = 0 To szc - 1
If (sz(asz, 0) = find And sz(asz, 1) = t1) Or (sz(asz, 0) = t1 And sz(asz, 1) = find) Then kovi = 1: Exit For
Next asz
If kovi = 0 Then
For asz = 0 To szc - 1
If (t1 = sz(asz, 0) Or t1 = sz(asz, 1)) = 0 And (find = sz(asz, 0) Or find = sz(asz, 1)) = 0 Then
If IsIntersection(p(t1, 0), p(t1, 1), p(find, 0), p(find, 1), p(sz(asz, 0), 0), p(sz(asz, 0), 1), p(sz(asz, 1), 0), p(sz(asz, 1), 1)) Then kovi = 1: Exit For
End If
Next asz
End If
End If
If kovi = 0 Then
sz(szc, 0) = t1: sz(szc, 1) = find: changing = 1
Line (p(sz(szc, 0), 0), p(sz(szc, 0), 1))-(p(sz(szc, 1), 0), p(sz(szc, 1), 1))
szc = szc + 1
Locate 1, 1: Print "szakaszok:"; szc
End If
Else kovi = 0
End If
Loop While kovi
Next t1
Loop While changing
Locate 2, 1: Print "Press SPACE to next"
Do: Loop Until InKey$ = " "
'make triangles
Dim tri(9999, 3)
For s1 = 0 To szc - 1: v(0) = sz(s1, 0): v(1) = sz(s1, 1)
For s2 = 0 To szc - 1: v(2) = sz(s2, 0): v(3) = sz(s2, 1)
For s3 = 0 To szc - 1: v(4) = sz(s3, 0): v(5) = sz(s3, 1)
For t = 0 To 5: ind(t, 1) = -1: Next t: ic = 0: For t1 = 0 To 5: n = 0: For t2 = 0 To 5
If ind(t2, 0) = v(t1) And ind(t2, 1) <> -1 Then ind(t2, 1) = ind(t2, 1) + 1: n = 1
Next t2: If n = 0 Then ind(ic, 0) = v(t1): ind(ic, 1) = 1: ic = ic + 1
Next t1
If ic = 3 And ind(0, 1) = 2 And ind(1, 1) = 2 And ind(2, 1) = 2 Then
sort ind(0, 0), ind(1, 0), ind(2, 0)
ok = 1
For t = 0 To tr_c - 1
If ind(0, 0) = tri(t, 0) And ind(1, 0) = tri(t, 1) And ind(2, 0) = tri(t, 2) Then ok = 0
Next t
If ok Then
For t = 0 To pontok - 1
If t = ind(0, 0) Or t = ind(1, 0) Or t = ind(2, 0) Then _Continue
' If Abs(p(t, 0) - p(ind(0, 0), 0)) > n Then _Continue
' If Abs(p(t, 0) - p(ind(0, 0), 0)) > n Then _Continue
If PointInTriangle(p(t, 0), p(t, 1), p(ind(0, 0), 0), p(ind(0, 0), 1), p(ind(1, 0), 0), p(ind(1, 0), 1), p(ind(2, 0), 0), p(ind(2, 0), 1)) Then ok = 0: Exit For
Next t
End If
If ok Then tri(tr_c, 0) = ind(0, 0): tri(tr_c, 1) = ind(1, 0): tri(tr_c, 2) = ind(2, 0): tr_c = tr_c + 1
End If
Next s3, s2, s1
Cls
Print "triangles:"; tr_c
' If InKey$ = " " Then q = (q + 1) Mod tr_c
For t = 0 To tr_c - 1
Color _RGB32(255, 255, 255)
' If q = t Then Color _RGB32(255 * Rnd, 255 * Rnd, 255 * Rnd)
'Print tri(t, 0), tri(t, 1), tri(t, 2)
Line (p(tri(t, 0), 0), p(tri(t, 0), 1))-(p(tri(t, 1), 0), p(tri(t, 1), 1))
Line (p(tri(t, 0), 0), p(tri(t, 0), 1))-(p(tri(t, 2), 0), p(tri(t, 2), 1))
Line (p(tri(t, 2), 0), p(tri(t, 2), 1))-(p(tri(t, 1), 0), p(tri(t, 1), 1))
x = (p(tri(t, 0), 0) + p(tri(t, 1), 0) + p(tri(t, 2), 0)) / 3
y = (p(tri(t, 0), 1) + p(tri(t, 1), 1) + p(tri(t, 2), 1)) / 3
Color _RGB32(255 * Rnd, 255 * Rnd, 255 * Rnd)
Paint (x, y), , _RGB32(255, 255, 255)
'Circle (x, y), 20 ', _RGB32(255, 255, 255)
Next t
Function IsIntersection (X1, Y1, X2, Y2, X3, Y3, X4, Y4)
Denominator = (Y4 - Y3) * (X2 - X1) - (X4 - X3) * (Y2 - Y1)
If Denominator = 0 Then
IsIntersection = 0
Else
Ua = ((X4 - X3) * (Y1 - Y3) - (Y4 - Y3) * (X1 - X3)) / Denominator
Ub = ((X2 - X1) * (Y1 - Y3) - (Y2 - Y1) * (X1 - X3)) / Denominator
IsIntersection = Ua >= 0 And Ua <= 1 And Ub >= 0 And Ub <= 1
End If
End Function
Function PointInTriangle (X, Y, X1, Y1, X2, Y2, X3, Y3)
D1 = (X - X2) * (Y1 - Y2) - (X1 - X2) * (Y - Y2)
D2 = (X - X3) * (Y2 - Y3) - (X2 - X3) * (Y - Y3)
D3 = (X - X1) * (Y3 - Y1) - (X3 - X1) * (Y - Y1)
PointInTriangle = (D1 > 0 And D2 > 0 And D3 > 0) Or (D1 < 0 And D2 < 0 And D3 < 0)
End Function
Sub sort (a, b, c)
If a > c Then Swap a, c
If b > c Then Swap b, c
If a > b Then Swap a, b
End Sub
Posts: 3,982
Threads: 178
Joined: Apr 2022
Reputation:
220
11-01-2023, 01:20 PM
Good stuff! let me know if you want exact point (coordinates) of intersect, though my code is a little longer 
b = b + ...
Posts: 189
Threads: 22
Joined: Mar 2023
Reputation:
12
Thanks, @MasterGy, for this PointInTriangle function. It's just what I was looking for! I'm adding another challenge to level 2 of my arcade game, Rock Jockey, which will could be ready soon. I've spent many weeks fine tuning, enhancing and debugging the game...
Posts: 733
Threads: 103
Joined: Apr 2022
Reputation:
14
(11-01-2023, 10:14 AM)MasterGy Wrote: ...
The program checks whether two segments intersect.
... This will most definitely come in handy for a few things! Thanks for sharing!
PS Along those lines, how might we check whether a segment intersects a circle with a certain x,y and radius?
Posts: 733
Threads: 103
Joined: Apr 2022
Reputation:
14
(11-01-2023, 01:20 PM)bplus Wrote: Good stuff! let me know if you want exact point (coordinates) of intersect, though my code is a little longer I could use that...
Posts: 3,982
Threads: 178
Joined: Apr 2022
Reputation:
220
(11-21-2024, 06:52 PM)madscijr Wrote: (11-01-2023, 01:20 PM)bplus Wrote: Good stuff! let me know if you want exact point (coordinates) of intersect, though my code is a little longer I could use that...
WTH? I lost all the reply I was working on.
Here's the code, forget the intro:
Code: (Select All) _Title "Segments Intersect revised 2020-03-16: White Circles are Intersects White Lines are Overlaps" 'b+ 2020-03-16
' Just worked Rosetta Code for Line Intersect Line
' but what if we want to know if two line segments intersect?
'2020-03-14 "Two Line Segments Intersect" 'b+ 2020-03-14 start
'2020-03-15 rework this code so we identify points all on same line and
' if there is overlap of line segments say the two x endpoints of the segments
' otherwise, if there is an intersect of 2 line segments say the point x, y.
' Return 0 no intersect or overlap
' Return 1 if intersect and ix, iy point of intersect
' Return -1 if segments are on same and there is overlap: ix = overlap start x, iy overlap end x
'2020-03-16 "Segments Intersect mod tester" >>> just post testing code
'mod tester for 2 segments of vertical line and found I need to add more parameters to
' FUNCTION twoLineSegmentsIntersect% (ax1, ay1, ax2, ay2, bx1, by1, bx2, by2, ix, iy)
' mod that name and parameters to:
' FUNCTION twoSegmentsIntersect% (ax1, ay1, ax2, ay2, bx1, by1, bx2, by2, ix1, iy1, ix2, iy2)
'2020-03-16 Segments Intersect revised 2020-03-16
' OK now get the new FUNCTION working
' ah! I had to tighten down D from >.2 to >.05 but loosen y-axis intersect
Const xmax = 1200, ymax = 700
Screen _NewImage(xmax, ymax, 32)
_Delay .25
_ScreenMove _Middle
Dim ax1 As Integer, ax2 As Integer, ay1 As Integer, ay2 As Integer
Dim bx1 As Integer, bx2 As Integer, by1 As Integer, by2 As Integer
Do
restartA:
Cls
If Rnd < .3 Then 'throw in some vertical lines
Locate 3, 80: Print "Red Points are vertical."
ax1 = (xmax - 20) * Rnd + 10: ay1 = (ymax - 60) * Rnd + 50
ax2 = ax1: ay2 = (ymax - 60) * Rnd + 50
Else
Locate 3, 80: Print "Red Points are Random."
ax1 = (xmax - 20) * Rnd + 10: ay1 = (ymax - 60) * Rnd + 50
ax2 = (xmax - 20) * Rnd + 10: ay2 = (ymax - 60) * Rnd + 50
End If
If _Hypot(ax1 - ax2, ay1 - ay2) < 50 Then GoTo restartA
If Rnd < .6 Then 'get some points on same line
Locate 3, 80: Print "Blue Points are on same line as Red."
slopeYintersect ax1, ay1, ax2, ay2, slope1, Yintercept1
bx1 = (xmax - 20) * Rnd + 10: by1 = bx1 * slope1 + Yintercept1
bx2 = (xmax - 20) * Rnd + 10: by2 = bx2 * slope1 + Yintercept1
Else
If Rnd < .4 Then 'throw in some verticals, we already have a doing verticals
Locate 3, 80: Print Space$(50)
Locate 3, 80: Print "All points vertical."
ax1 = (xmax - 20) * Rnd + 10: ax2 = ax1: bx1 = ax1: bx2 = ax1
ay1 = 50 + Rnd * 50: ay2 = ay1 + 50 + Rnd * 50
by1 = ay1 + 25 + Rnd * 50: by2 = by1 + 50 + (Rnd * ymax - 60 - by1)
by1 = (ymax - 60) * Rnd + 50: bx2 = bx1: by2 = (ymax - 60) * Rnd + 50
Else
Locate 4, 80: Print "Blue Points are Random."
bx1 = (xmax - 20) * Rnd + 10: by1 = (ymax - 60) * Rnd + 50
bx2 = (xmax - 20) * Rnd + 10: by2 = (ymax - 60) * Rnd + 50
End If
End If
If bx1 < 10 Or bx1 > xmax - 10 Then GoTo restartA
If bx2 < 10 Or bx2 > xmax - 10 Then GoTo restartA
If by1 < 50 Or by1 > ymax - 10 Then GoTo restartA
If by2 < 50 Or by2 > ymax - 10 Then GoTo restartA
If _Hypot(bx1 - bx2, by1 - by2) < 30 Then GoTo restartA
Line (ax1, ay1)-(ax2, ay2), &HFFFF0000
Circle (ax1, ay1), 4, &HFFFF0000
Circle (ax2, ay2), 4, &HFFFF0000
Line (bx1, by1)-(bx2, by2), &HFF0000FF
Circle (bx1, by1), 4, &HFF0000FF
Circle (bx2, by2), 4, &HFF0000FF
Locate 1, 1
PRINT "Segments ("; ts$(ax1); ", "; ts$(ay1); ") ("; ts$(ax2); ", ";_
ts$(ay2); ") and ("; ts$(bx1); ", "; ts$(by1); ") ("; ts$(bx2); ", "; ts$(by2); ")"
' Plug in your 2 Segment Intersect SUB or FUNCTION Here
' and interpret reults: yellow circle around intersect point
' and an alpha shaded box where two co-linear segments overlap
'=====================================================================================================
intersect = twoSegmentsIntersect%(ax1, ay1, ax2, ay2, bx1, by1, bx2, by2, ix1, iy1, ix2, iy2)
If intersect = -1 Then 'segments overlap on same line
Print " Segments overlap between: ("; ts$(ix1); ", "; ts$(iy1); ") and ("; ts$(ix2); ", "; ts$(iy2); ")"
Line (ix1, iy1)-(ix2, iy2), &HFFFFFFFF
ElseIf intersect = 1 Then 'segments intersect at one point
Print " Segments intersect: ("; ts$(ix1); ", "; ts$(iy1); ")"
Circle (ix1, iy1), 3, &HFFFFFFFF
ElseIf intersect = 0 Then 'segments do not intersect nor overlap
Print " Segments do not Intersect or Overlap."
End If
'=====================================================================================================
Input "Press enter for another demo, any + enter to quit...", again$
Cls
Loop Until Len(again$)
'Slope and Y-intersect for non vertical lines,
' if x1 = x2 the line is vertical don't call this sub
' because slope calculation would cause division by 0 error.
Sub slopeYintersect (X1, Y1, X2, Y2, slope, Yintercept) 'check x1 <> x2 first!
slope = (Y2 - Y1) / (X2 - X1): Yintercept = slope * (0 - X1) + Y1
End Sub
Function ts$ (n)
ts$ = _Trim$(Str$(Int(100 * n) / 100))
End Function
' ======================================== end tester code functions ======================================
'This function needs: FUNCTION lineIntersectLine% (ax1, ay1, ax2, ay2, bx1, by1, bx2, by2, ix, iy)
' which in turn needs: SUB slopeYintersect (X1, Y1, X2, Y2, slope, Yintercept) 'check x1 <> x2 first!
Function twoSegmentsIntersect% (ax1, ay1, ax2, ay2, bx1, by1, bx2, by2, ix1, iy1, ix2, iy2)
intersect = lineIntersectLine%(ax1, ay1, ax2, ay2, bx1, by1, bx2, by2, ix, iy)
If ax1 < ax2 Then aMinX = ax1: aMaxX = ax2 Else aMinX = ax2: aMaxX = ax1
If ay1 < ay2 Then aMinY = ay1: aMaxY = ay2 Else aMinY = ay2: aMaxY = ay1
If bx1 < bx2 Then bMinX = bx1: bMaxX = bx2 Else bMinX = bx2: bMaxX = bx1
If by1 < by2 Then bMinY = by1: bMaxY = by2 Else bMinY = by2: bMaxY = by1
If intersect = 0 Then 'no intersect
twoSegmentsIntersect% = 0
ElseIf intersect = 1 Then 'segments intersect at one point
If ax1 = ax2 Then 'is iy between
If iy < aMinY Or iy > aMaxY Or ix < bMinX Or ix > bMaxX Then
twoSegmentsIntersect% = 0
Else
ix1 = ix: iy1 = iy: twoSegmentsIntersect% = 1
End If
ElseIf bx1 = bx2 Then
If iy < bMinY Or iy > bMaxY Or ix < aMinX Or ix > aMaxX Then
twoSegmentsIntersect% = 0
Else
ix1 = ix: iy1 = iy: twoSegmentsIntersect% = 1
End If
Else
If (aMinX <= ix And ix <= aMaxX) And (bMinX <= ix And ix <= bMaxX) Then
ix1 = ix: iy1 = iy: twoSegmentsIntersect% = 1
Else
twoSegmentsIntersect% = 0
End If
End If
ElseIf intersect = -1 Then 'segments are on same line get over lap section
'first check if both are on vertical line
If ax1 = ax2 Then 'and we know both are same line we have two vertical segemnts, do they over lap?
ix1 = ax1: ix2 = ax1
If aMinY < bMinY Then
If aMaxY < bMinY Then
twoSegmentsIntersect% = 0
Else
twoSegmentsIntersect% = -1: iy1 = bMinY
If aMaxY > bMaxY Then
iy2 = bMaxY
Else
iy2 = aMaxY
End If
End If
Else 'bMinY <= aMinY
If bMaxY < aMinY Then
twoSegmentsIntersect% = 0
Else
twoSegmentsIntersect% = -1: iy1 = aMinY
If bMaxY > aMaxY Then
iy2 = aMaxY
Else
iy2 = bMaxY
End If
End If
End If
Else 'the same line is not vertical
If aMinX < bMinX Then
If aMaxX < bMinX Then
twoSegmentsIntersect% = 0
Else
twoSegmentsIntersect% = -1: ix1 = bMinX
If bx1 = bMinX Then iy1 = by1 Else iy1 = by2
If aMaxX > bMaxX Then
ix2 = bMaxX
If bx1 = bMaxX Then iy2 = by1 Else iy2 = by2
Else
ix2 = aMaxX
If ax1 = aMaxX Then iy2 = ay1 Else iy2 = ay2
End If
End If
Else 'aMinX >= bMinX
If aMinX > bMaxX Then
twoSegmentsIntersect% = 0
Else
twoSegmentsIntersect% = -1: ix1 = aMinX
If ax1 = aMinX Then iy1 = ay1 Else iy1 = ay2
If bMaxX > aMaxX Then
ix2 = aMaxX
If ax1 = aMaxX Then iy2 = ay1 Else iy2 = ay2
Else
ix2 = bMaxX
If bx1 = bMaxX Then iy2 = by1 Else iy2 = by2
End If
End If
End If
End If
End If
End Function
' this function needs: SUB slopeYintersect (X1, Y1, X2, Y2, slope, Yintercept)
Function lineIntersectLine% (ax1, ay1, ax2, ay2, bx1, by1, bx2, by2, ix, iy)
If ax1 = ax2 Then 'line a is vertical
If bx1 = bx2 Then ' b is vertical
If ax1 = bx1 Then lineIntersectLine% = -1 ' if x's are same it is same vertical line
Exit Function '
Else
ix = ax1
slopeYintersect bx1, by1, bx2, by2, m2, y02
iy = m2 * ix + y02
lineIntersectLine% = 1 'signal a point was found
Exit Function
End If
Else
slopeYintersect ax1, ay1, ax2, ay2, m1, y01 ' -m = a, 1 = b, y0 = c std form
End If
If bx1 = bx2 Then 'b is vertical
ix = bx1: iy = m1 * ix + y01: lineIntersectLine% = 1 'signal a point was found
Exit Function
Else
slopeYintersect bx1, by1, bx2, by2, m2, y02 ' -m = a, 1 = b, y0 = c std form
End If
d = -m1 - -m2 ' if = 0 then parallel or equal because slopes are same
If Abs(d) > .05 Then 'otherwise about 0 <<< tighten down from .2 to .05
ix = (y01 - y02) / d: iy = (-m1 * y02 - -m2 * y01) / d
lineIntersectLine% = 1 'signal one intersect point was found
Else 'same line or parallel? if y0 (y-axis interssect) are same they are the same
If Abs(y01 - y02) < 15 Then lineIntersectLine% = -1 'signal same line! <<< loosen more! 5 to 15
End If
End Function
b = b + ...
Posts: 733
Threads: 103
Joined: Apr 2022
Reputation:
14
(11-21-2024, 10:13 PM)bplus Wrote: ...
WTH? I lost all the reply I was working on.
...
I've been there! Damn web editors crap out every time!
I think it was Pete who said use CTRL+A CTRL+C obsessively, LoL.
Anyway, I'll give that code a look when I'm back at the PC - Thanks!!
|
