+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Programs (https://qb64phoenix.com/forum/forumdisplay.php?fid=7)
+---- Thread: It might be useful for something (/showthread.php?tid=2134)
It might be useful for something - MasterGy - 11-01-2023
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 SubRE: It might be useful for something - bplus - 11-01-2023
Good stuff! let me know if you want exact point (coordinates) of intersect, though my code is a little longer
RE: It might be useful for something - NakedApe - 11-18-2024
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...
RE: It might be useful for something - madscijr - 11-19-2024
(11-01-2023, 10:14 AM)MasterGy Wrote: ...This will most definitely come in handy for a few things! Thanks for sharing!
The program checks whether two segments intersect.
...
PS Along those lines, how might we check whether a segment intersects a circle with a certain x,y and radius?