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.
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.
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
