+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Help Me! (https://staging.qb64phoenix.com/forumdisplay.php?fid=10)
+---- Thread: 3D Terrain (/showthread.php?tid=1376)
3D Terrain - james2464 - 01-08-2023
I've managed to figure out how to produce random terrain using a grid of triangles, and then assigning a slightly random z value to the points. It's very primitive but could be useful to build on.
But for now I'm stuck on how to detect or collide with this terrain. It might be very complicated, or perhaps not. Right now the spectator viewing is just like ghost mode, as in you can fly around and go through everything. I'd like to make it so you can't pass through the textures at all. Then if I can choose some textures as OK to pass throught (such as water surface) and others NOT OK to pass through, such as land, that would be ideal. And later on, I'd like to be able to put a character on the surface and control it. For now though, I'd like to understand how to detect these surfaces. A square/rectangle room is not a problem, because you can just set limits on X,Y,Z movement. Any flat surface is easy this way. But the random terrain seems to need a different approach.
Code: (Select All)
'3d terrain on water - james2464 - Jan 2023
'Credit to 3D program and tutorial by MasterGy
Option _Explicit
Randomize Timer
Screen _NewImage(1000, 1000, 32)
Const pip180 = 3.141592 / 180
Dim Shared c(100) As Long
Dim scr, da, db, da2, dega, db2, degb, ss, ap, sqa
Dim sky_points, sky_image, actual_point, asq
Dim wx0, wy0, wz0, wx1, wy1, wz1, wx2, wy2, wz2, wx3, wy3, wz3, sx0, sy0, sx1, sy1, sx2, sy2, sx3, sy3
Dim mousex, mousey, mw, mouse_sens, vec_x, vec_y, vec_z, speed, moving
Dim sp3
Dim t, x, y, h, b, tz
Dim Shared trx(5000), try(5000), trz(5000) 'terrain points
Dim Shared fr1(5000), fr2(5000), fr3(5000), fr4(5000), fr5(5000), fr6(5000) 'terrain point groups (hex)
Dim Shared maxterrain, maxp, shx, shy, shz
Cls
colour1
Dim Shared floor1, wall1, wall2, ground1, sky1, cbx(20)
wall1 = _NewImage(500, 100, 32): makewall
wall2 = _NewImage(500, 100, 32): makewall2
ground1 = _NewImage(500, 500, 32): makeground
'ground1 = _LoadImage("painting.jpg", 32)
sky1 = _NewImage(750, 750, 32): makesky
maketerrain
For t = 0 To 10: cbx(t) = _NewImage(400, 400, 32): Next t: makepallette
Dim Shared tximage(200)
For t = 0 To 10: tximage(t) = _CopyImage(cbx(t), 33): Next t
tximage(11) = _CopyImage(ground1, 33)
tximage(12) = _CopyImage(wall1, 33) 'office wall solid
tximage(13) = _CopyImage(wall2, 33) 'office wall with 3 windows
Type mapobject
n As Integer 'object number
x As Single 'x origin
y As Single 'y origin
z As Single 'z origin
x1 As Single
y1 As Single
z1 As Single
x2 As Single
y2 As Single
z2 As Single
x3 As Single
y3 As Single
z3 As Single
x4 As Single
y4 As Single
z4 As Single
ix As Single 'image x
iy As Single 'image y
in As Integer 'image number - tximage()
End Type
Dim Shared raw(100) As mapobject, oo(900) As mapobject
'create texture point data array
Dim Shared tx(500, 19), txtot, rawtxtot
'objects and data points
Data 1,0,0,0,-1000,0,200,-1000,0,-200,1000,0,200,1000,0,-200,500,100,12: 'wall
Data 2,0,0,0,-4000,-4000,0,-4000,4000,0,4000,-4000,0,4000,4000,0,500,100,3: 'water
rawtxtot = 2: txtot = rawtxtot
'read data into array tx()
Dim t2
For t = 1 To txtot
For t2 = 1 To 19
Read tx(t, t2)
Next t2
'create 'raw' objects
raw(t).n = tx(t, 1): raw(t).x = tx(t, 2): raw(t).y = tx(t, 3): raw(t).z = tx(t, 4)
raw(t).x1 = tx(t, 5): raw(t).y1 = tx(t, 6): raw(t).z1 = tx(t, 7)
raw(t).x2 = tx(t, 8): raw(t).y2 = tx(t, 9): raw(t).z2 = tx(t, 10)
raw(t).x3 = tx(t, 11): raw(t).y3 = tx(t, 12): raw(t).z3 = tx(t, 13)
raw(t).x4 = tx(t, 14): raw(t).y4 = tx(t, 15): raw(t).z4 = tx(t, 16)
raw(t).ix = tx(t, 17): raw(t).iy = tx(t, 18): raw(t).in = tx(t, 19)
Next t
'object copies
Dim nn, nc, xc, yc, zc, ac
'nn = 1: nc = 1: xc = 0: yc = 0: zc = 400: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 2: xc = 0: yc = 0: zc = 500: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'water
'create spectator
Dim Shared sp(6)
sp(0) = 0 'X position
sp(1) = 1500 'Y
sp(2) = 400 'Z
sp(3) = 0 'looking in the direction of the observer XZ
sp(4) = 0 'looking in the direction of the observer YZ
sp(5) = 1 'multiplier X-Y see
sp(6) = 1 'multiplier Z see
'create screen
scr = _NewImage(1000, 1000 / _DesktopWidth * _DesktopHeight, 32)
Screen scr
_MouseHide
_FullScreen
_Dest scr
_DisplayOrder _Hardware , _Software
'sky install
da = 11 'resolution sphere X
db = 7 'resolution sphere Y
sky_points = da * db
Dim sky_points(sky_points - 1, 9), sq(sky_points - 1, 7)
'sky_image = _LoadImage("sky.jpg", 33)
sky_image = _CopyImage(sky1, 33)
For da2 = 0 To da - 1
dega = 360 / (da - 1) * da2 * pip180
For db2 = 0 To db - 1
degb = 180 / (db - 1) * db2 * pip180
ss = 4000
ap = da2 * db + db2
sky_points(ap, 0) = Sin(degb) * Cos(dega) * ss
sky_points(ap, 1) = Sin(degb) * Sin(dega) * ss
sky_points(ap, 2) = Cos(degb) * ss
Next db2
Next da2
For da2 = 0 To da - 2
For db2 = 0 To db - 2
sqa = da2 * db + db2
sq(sqa, 0) = sqa
sq(sqa, 1) = sq(sqa, 0) + 1
sq(sqa, 2) = sq(sqa, 0) + db
sq(sqa, 3) = sq(sqa, 2) + 1
sq(sqa, 4) = _Width(sky_image) - (_Width(sky_image) / (da - 1) * da2) - 1
sq(sqa, 5) = _Width(sky_image) - (_Width(sky_image) / (da - 1) * (da2 + 1)) - 1
sq(sqa, 6) = Int(_Height(sky_image) / (db - 1) * db2)
sq(sqa, 7) = Int(_Height(sky_image) / (db - 1) * (db2 + 1))
Next db2
Next da2
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
Do
_Limit 40
processterrain
processtextures
'draw sky *********************************************************************************
't = 1 'use for checkered sky
'rotating
For actual_point = 0 To sky_points - 1
sky_points(actual_point, 4) = sky_points(actual_point, 0)
sky_points(actual_point, 5) = sky_points(actual_point, 1)
sky_points(actual_point, 6) = sky_points(actual_point, 2)
r2m sky_points(actual_point, 4), sky_points(actual_point, 5), sky_points(actual_point, 6)
Next actual_point
For asq = 0 To sky_points - 1
wx0 = sky_points(sq(asq, 0), 4) + 0: wy0 = sky_points(sq(asq, 0), 5) + 0: wz0 = sky_points(sq(asq, 0), 6)
wx1 = sky_points(sq(asq, 1), 4) + 0: wy1 = sky_points(sq(asq, 1), 5) + 0: wz1 = sky_points(sq(asq, 1), 6)
wx2 = sky_points(sq(asq, 2), 4) + 0: wy2 = sky_points(sq(asq, 2), 5) + 0: wz2 = sky_points(sq(asq, 2), 6)
wx3 = sky_points(sq(asq, 3), 4) + 0: wy3 = sky_points(sq(asq, 3), 5) + 0: wz3 = sky_points(sq(asq, 3), 6)
sy0 = sq(asq, 6): sx0 = sq(asq, 4): sy1 = sq(asq, 7): sx1 = sq(asq, 4): sy2 = sq(asq, 6): sx2 = sq(asq, 5): sy3 = sq(asq, 7): sx3 = sq(asq, 5)
't = t * -1 'use for checkered sky
'If t > 0 Then 'use for checkered sky
_MapTriangle (sx0, sy0)-(sx1, sy1)-(sx2, sy2), sky_image To(wx0, wy0, wz0)-(wx1, wy1, wz1)-(wx2, wy2, wz2), , _Smooth
_MapTriangle (sx3, sy3)-(sx1, sy1)-(sx2, sy2), sky_image To(wx3, wy3, wz3)-(wx1, wy1, wz1)-(wx2, wy2, wz2), , _Smooth
'End If 'use for checkered sky
Next asq
' ****************************************************************************************************
_Display
'-------------------------------------------------------------
'mouse input axis movement and mousewheel
'-------------------------------------------------------------
mousex = mousex * .6
mousey = mousey * .6
mw = 0
While _MouseInput: mousex = mousex + _MouseMovementX: mousey = mousey + _MouseMovementY: mw = mw + _MouseWheel: Wend 'movement data read
'control spectator
mouse_sens = .0007 'mouse rotating sensitive
sp(3) = sp(3) - mousex * mouse_sens
sp(4) = sp(4) + mousey * mouse_sens
If Abs(sp(4)) > _Pi / 2 Then sp(4) = _Pi / 2 * Sgn(sp(4))
sp3 = sp(3) + (_KeyDown(Asc("d")) - _KeyDown(Asc("a"))) * 90 * pip180
vec_x = (Sin(sp3) * (Cos(sp(4) + _Pi)))
vec_y = (Cos(sp3) * (Cos(sp(4) + _Pi)))
vec_z = -Sin(sp(4) + _Pi)
If _KeyDown(Asc("a")) Or _KeyDown(Asc("d")) Then vec_z = 0
speed = 2.5 'moving speed
moving = Abs(_MouseButton(1) Or _KeyDown(Asc("w")) Or _KeyDown(Asc("a")) Or _KeyDown(Asc("d"))) * speed - Abs(_MouseButton(2) Or _KeyDown(Asc("s"))) * speed
sp(0) = sp(0) + vec_x * moving
sp(1) = sp(1) + vec_y * moving
sp(2) = sp(2) + vec_z * moving
'If sp(0) > 465 Then sp(0) = 465
'If sp(1) > 465 Then sp(1) = 465
'If sp(0) < -465 Then sp(0) = -465
'If sp(1) < -465 Then sp(1) = -465
Loop Until _KeyDown(27)
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
Sub r2m (x, y, z)
Dim x2, y2, z2
x2 = x - sp(0)
y2 = y - sp(1)
z2 = z - sp(2)
rotate_2d x2, y2, sp(3)
rotate_2d y2, z2, sp(4) + _Pi / 2
x = x2 * sp(5)
y = y2 * sp(5)
z = z2 * sp(6)
End Sub
Sub rotate_2d (x, y, ang)
Dim x1, y1
x1 = x * Cos(ang) - y * Sin(ang)
y1 = x * Sin(ang) + y * Cos(ang)
x = x1: y = y1
End Sub
Sub processtextures
Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
For t = 1 To txtot
x1 = oo(t).x1: y1 = oo(t).y1: z1 = oo(t).z1
x2 = oo(t).x2: y2 = oo(t).y2: z2 = oo(t).z2
x3 = oo(t).x3: y3 = oo(t).y3: z3 = oo(t).z3
x4 = oo(t).x4: y4 = oo(t).y4: z4 = oo(t).z4
x = oo(t).ix: y = oo(t).iy
r2m x1, y1, z1
r2m x2, y2, z2
r2m x3, y3, z3
r2m x4, y4, z4
_MapTriangle (0, 0)-(0, y)-(x, 0), tximage(oo(t).in) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
_MapTriangle (x, y)-(0, y)-(x, 0), tximage(oo(t).in) To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
Next t
End Sub
Sub processterrain
Dim t, t2, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
Dim xx1, yy1, zz1, xx2, yy2, zz2, xx3, yy3, zz3, xx4, yy4, zz4
Dim flag, ct, scale1, txm
flag = 0
ct = 0
scale1 = 2.
shx = -500 'shift x position
shy = -500 'shift y position
shz = 502 'shift z position
Do
ct = ct + 1
x1 = trx(fr1(ct)): y1 = try(fr1(ct)): z1 = trz(fr1(ct))
x2 = trx(fr2(ct)): y2 = try(fr2(ct)): z2 = trz(fr2(ct))
x3 = trx(fr3(ct)): y3 = try(fr3(ct)): z3 = trz(fr3(ct))
xx1 = x1: yy1 = y1
xx2 = x2: yy2 = y2
xx3 = x3: yy3 = y3
x1 = x1 * scale1: y1 = y1 * scale1: 'z1 = z1 * scale1
x2 = x2 * scale1: y2 = y2 * scale1: 'z2 = z2 * scale1
x3 = x3 * scale1: y3 = y3 * scale1: 'z3 = z3 * scale1
x1 = x1 + shx: y1 = y1 + shy: z1 = z1 + shz
x2 = x2 + shx: y2 = y2 + shy: z2 = z2 + shz
x3 = x3 + shx: y3 = y3 + shy: z3 = z3 + shz
r2m x1, y1, z1
r2m x2, y2, z2
r2m x3, y3, z3
txm = 11
_MapTriangle (xx1, yy1)-(xx2, yy2)-(xx3, yy3), tximage(txm) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
If ct >= maxp Then flag = 1
Loop Until flag = 1
End Sub
Sub objectcopy (nn, nc, xc, yc, zc, ac)
Dim ct, t, t2, xt, yt
ct = 0
For t = 1 To rawtxtot
If raw(t).n = nc Then
ct = ct + 1
t2 = txtot + ct
oo(t2).n = nn: oo(t2).x = xc: oo(t2).y = yc: oo(t2).z = zc
xt = raw(t).x1: yt = raw(t).y1: xyrotation xt, yt, ac: oo(t2).x1 = xt + xc: oo(t2).y1 = yt + yc: oo(t2).z1 = raw(t).z1 + zc
xt = raw(t).x2: yt = raw(t).y2: xyrotation xt, yt, ac: oo(t2).x2 = xt + xc: oo(t2).y2 = yt + yc: oo(t2).z2 = raw(t).z2 + zc
xt = raw(t).x3: yt = raw(t).y3: xyrotation xt, yt, ac: oo(t2).x3 = xt + xc: oo(t2).y3 = yt + yc: oo(t2).z3 = raw(t).z3 + zc
xt = raw(t).x4: yt = raw(t).y4: xyrotation xt, yt, ac: oo(t2).x4 = xt + xc: oo(t2).y4 = yt + yc: oo(t2).z4 = raw(t).z4 + zc
oo(t2).ix = raw(t).ix: oo(t2).iy = raw(t).iy: oo(t2).in = raw(t).in
End If
Next t
txtot = txtot + ct
End Sub
Sub xyrotation (x, y, a)
Dim xt, yt, h, h1, h2, xt2, yt2
xt = x: yt = y
h = _Hypot(yt, xt)
h1 = _Atan2(xt, yt)
h2 = h1 - a
xt2 = Sin(h2) * h
yt2 = Cos(h2) * h
x = xt2
y = yt2
End Sub
Sub makefloor
Dim t, x1, y1
Cls
Line (0, 0)-(500, 500), c(18), BF 'floor background
For t = 1 To 6000
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(0)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(2)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(3)
Next t
'_Display
_PutImage (0, 0)-(500, 500), 0, floor1, (0, 0)-(500, 500)
'Sleep
End Sub
Sub makewall
Dim t, x1, y1
Cls
Line (0, 0)-(500, 100), c(7), BF 'wall background
For t = 1 To 6000
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(8)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(9)
Next t
'_Display
_PutImage (0, 0)-(500, 100), 0, wall1, (0, 0)-(500, 100)
_ClearColor c(0), wall1
'Sleep
End Sub
Sub makewall2
Dim t, x1, y1
Cls
Line (0, 0)-(500, 100), c(7), BF 'wall2 background
For t = 1 To 6000
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(8)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(9)
Next t
Line (70, 25)-(150, 75), c(0), BF
Line (210, 25)-(290, 75), c(0), BF
Line (350, 25)-(430, 75), c(0), BF
'_Display
_PutImage (0, 0)-(500, 100), 0, wall2, (0, 0)-(500, 100)
_ClearColor c(0), wall2
'Sleep
End Sub
Sub makeground
Dim t, x1, y1, s, s2
s = 220
s2 = (500 - s) / 2
Cls
Line (0, 0)-(500, 500), c(14), BF 'border/beach
Line (0, 0)-(500, 500), c(40), BF 'ground background
For t = 1 To 155
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
Line (x1 - 30, y1 - 30)-(x1 + 30, y1 + 30), c(41), BF
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
Line (x1 - 50, y1 - 50)-(x1 + 50, y1 + 50), c(42), BF
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
Line (x1 - 20, y1 - 20)-(x1 + 20, y1 + 20), c(43), BF
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
Line (x1 - 20, y1 - 20)-(x1 + 20, y1 + 20), c(44), BF
Next t
s = 790
s2 = (500 - s) / 2
For t = 1 To 7500
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
PSet (x1, y1), c(41)
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
PSet (x1, y1), c(42)
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
PSet (x1, y1), c(43)
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
PSet (x1, y1), c(44)
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
PSet (x1, y1), c(41)
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
PSet (x1, y1), c(42)
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
PSet (x1, y1), c(43)
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
PSet (x1, y1), c(44)
Next t
'Line (5, 5)-(495, 10), c(31), BF
'Line (5, 495)-(495, 490), c(32), BF
'Line (490, 5)-(495, 495), c(33), BF
'Line (5, 5)-(10, 495), c(34), BF
'_Display
_PutImage (0, 0)-(500, 500), 0, ground1, (0, 0)-(500, 500)
'Sleep
End Sub
Sub maketerrain
Dim t, s, x, y, x1, y1, p, q, p2, ct, ct2, flag
Dim xt, yt, xh, yh, vc, fx, fx1, fx2, mx, oldct
Cls
Line (0, 0)-(500, 500), c(1), B
t = 0
x1 = 500: y1 = 500
s = 25
fx = 1
maxterrain = 0
'create points (trx,try,trz)
For y = 0 To y1 Step s
fx = Int(fx * -1)
If fx > 0 Then
fx1 = 0
Else fx1 = s / 2
End If
For x = fx1 To x1 Step s
t = t + 1
trx(t) = x: try(t) = y
Circle (x, y), 3, c(1)
If x > s And x < x1 - s Then
If y > s And y < y1 - s Then
'trz(t) = 0
trz(t) = 0 - Int(Rnd * 17) - 5
xh = Abs(trx(t) - x1 / 2)
yh = Abs(try(t) - y1 / 2)
vc = _Hypot(xh, yh)
vc = 170 - vc
trz(t) = trz(t) - vc / 4
'trz(t) = trz(t) - (Int(Rnd * vc))
End If
End If
Next x
Next y
'_Display
'Sleep
maxterrain = t
'display points
p = Int(x1 / s) + 1
q = Int(y1 / s) - 1
fx = 1
t = 0
oldct = 0
For y = 0 To y1 Step s
fx = Int(fx * -1)
If fx > 0 Then
fx1 = 0
Else fx1 = s / 2
End If
For x = fx1 To x1 Step s
t = t + 1
If y > s Then
If x > s Then
If x < x1 - s Then
If y < y1 - s Then
Circle (trx(t), try(t)), 2, c(1)
Circle (trx(t), try(t)), 1, c(1)
Circle (trx(oldct), try(oldct)), 2, c(0)
Circle (trx(oldct), try(oldct)), 1, c(0)
'Line (trx(t), try(t))-(trx(t - p), try(t - p)), c(1)
'Line (trx(t), try(t))-(trx(t - p + 1), try(t - p + 1)), c(1)
'Line (trx(t), try(t))-(trx(t + p - 1), try(t + p - 1)), c(1)
'Line (trx(t), try(t))-(trx(t + p), try(t + p)), c(1)
'Line (trx(t), try(t))-(trx(t - 1), try(t - 1)), c(1)
'Line (trx(t), try(t))-(trx(t + 1), try(t + 1)), c(1)
oldct = t
'_Display
'Sleep
'Line (trx(t), try(t))-(trx(t - p), try(t - p)), c(0)
'Line (trx(t), try(t))-(trx(t - p + 1), try(t - p + 1)), c(0)
'Line (trx(t), try(t))-(trx(t + p - 1), try(t + p - 1)), c(0)
'Line (trx(t), try(t))-(trx(t + p), try(t + p)), c(0)
'Line (trx(t), try(t))-(trx(t - 1), try(t - 1)), c(0)
'Line (trx(t), try(t))-(trx(t + 1), try(t + 1)), c(0)
End If
End If
End If
End If
Next x
Next y
'_Display
'Sleep
'create point groups (fr1,fr2,fr3)
p = Int(x1 / s) + 1
q = Int(y1 / s) - 1
fx = 1
t = 0
ct = 0
oldct = 0
For y = 0 To y1 - 1 Step s
fx = Int(fx * -1)
If fx > 0 Then
fx1 = 0
Else fx1 = s / 2
End If
For x = fx1 To x1 Step s
t = t + 1
If fx > 0 Then
ct = ct + 1
fr1(ct) = t
fr2(ct) = t - p
fr3(ct) = t - p + 1
Line (trx(t), try(t))-(trx(t - p), try(t - p)), c(32)
Line (trx(t), try(t))-(trx(t - p + 1), try(t - p + 1)), c(32)
Line (trx(t - p), try(t - p))-(trx(t - p + 1), try(t - p + 1)), c(32)
'_Display
'Sleep
ct = ct + 1
fr1(ct) = t
fr2(ct) = t + p
fr3(ct) = t + p - 1
Line (trx(t), try(t))-(trx(t + p), try(t + p)), c(1)
Line (trx(t), try(t))-(trx(t + p - 1), try(t + p - 1)), c(1)
Line (trx(t + p), try(t + p))-(trx(t + p - 1), try(t + p - 1)), c(1)
'_Display
'Sleep
Else
ct = ct + 1
fr1(ct) = t
fr2(ct) = t + p
fr3(ct) = t + p - 1
Line (trx(t), try(t))-(trx(t + p), try(t + p)), c(33)
Line (trx(t), try(t))-(trx(t + p - 1), try(t + p - 1)), c(33)
Line (trx(t + p), try(t + p))-(trx(t + p - 1), try(t + p - 1)), c(33)
'_Display
'Sleep
ct = ct + 1
fr1(ct) = t + p + p - 1
fr2(ct) = t + p
fr3(ct) = t + p - 1
Line (trx(t + p + p - 1), try(t + p + p - 1))-(trx(t + p), try(t + p)), c(34)
Line (trx(t + p + p - 1), try(t + p + p - 1))-(trx(t + p - 1), try(t + p - 1)), c(34)
Line (trx(t + p), try(t + p))-(trx(t + p - 1), try(t + p - 1)), c(34)
'_Display
'Sleep
End If
oldct = t
Locate 35, 1
Print t, ct
'_Display
'Sleep
Next x
Next y
maxp = ct
'fr1(t) = t - p
'fr2(t) = t - p + 1
'fr3(t) = t + p - 1
'Cls
't = t + 1
'For ct = 1 To t
'Print fr1(ct), fr2(ct), fr3(ct)
'Next ct
'_Display
'Sleep
End Sub
Sub makesky
Dim t, y, m
Cls
y = 750
For t = 1 To y
m = 255 * ((750 - t * .65) / 750)
c(99) = _RGBA(200, 200, 255, m)
Line (0, t)-(750, t), c(99)
Next t
'For t = 0 To 750 Step 25 'longituge lines
'Line (t, 0)-(t, 750), c(1)
'Next t
'For t = 0 To 750 Step 25 'latitude lines
'Line (0, t)-(750, t), c(1)
'Next t
'_Display
_PutImage (0, 0)-(750, 750), 0, sky1, (0, 0)-(750, 750)
'Sleep
End Sub
Sub makepallette
Dim t
For t = 0 To 10
Cls
Line (0, 0)-(400, 400), c(t), BF
_PutImage (0, 0)-(400, 400), 0, cbx(t), (0, 0)-(400, 400)
'_Display
'Sleep
Next t
End Sub
Sub colour1
c(0) = _RGB(0, 0, 0)
c(1) = _RGB(255, 255, 255)
c(2) = _RGB(35, 25, 10)
c(3) = _RGB(10, 45, 65)
c(4) = _RGB(40, 50, 10)
c(5) = _RGB(0, 25, 75)
c(6) = _RGB(45, 35, 20)
c(7) = _RGB(150, 150, 150)
c(8) = _RGB(125, 125, 125)
c(9) = _RGB(100, 100, 100)
c(10) = _RGBA(75, 75, 75, 151)
c(11) = _RGB(0, 0, 0)
c(12) = _RGB(35, 25, 10)
c(13) = _RGB(0, 45, 85)
c(14) = _RGB(160, 150, 100)
c(15) = _RGB(0, 25, 75)
c(16) = _RGB(55, 25, 30)
c(17) = _RGB(175, 175, 175)
c(18) = _RGB(100, 100, 100)
c(20) = _RGB(20, 30, 15)
c(31) = _RGB(255, 255, 255)
c(32) = _RGB(255, 0, 0)
c(33) = _RGB(0, 55, 255)
c(34) = _RGB(255, 255, 0)
c(40) = _RGBA(45, 20, 25, 125)
c(41) = _RGBA(50, 50, 30, 40)
c(42) = _RGBA(20, 30, 15, 40)
c(43) = _RGBA(75, 45, 15, 40)
c(44) = _RGBA(40, 60, 30, 40)
c(45) = _RGB(50, 50, 30)
c(46) = _RGB(20, 30, 15)
c(47) = _RGB(55, 45, 15)
c(48) = _RGB(40, 50, 10)
End SubRE: 3D Terrain - mnrvovrfc - 01-09-2023
I wanted to be on that lonely island. Nice job!
RE: 3D Terrain - OldMoses - 01-09-2023
A couple of thoughts:
If there's a simple solution, I don't know it.
I think it would probably involve some sort of parametric algorithm after determining which triangle grid element was being approached. I've not done anything like that myself, having mostly worked with line/sphere intersections. Most line/plane intersection stuff I've looked at presumes an infinite plane, so you would need to narrow your inputs to the correct grid element with some Pythagorean checking.
https://courseware.cemc.uwaterloo.ca/web/Gr12CaAn000/Public_Html/slides/V4/TheIntersectionOfALineAndAPlane.pdf
There's lots of other stuff on parametric equations available.
The other possibility, is that you can take the plane 'normal' {i.e. perpendicular} of a target terrain grid element, and dot it with the position vector relative to that normal, updating it as you go along the path (easier to do than to describe). When the sign of the dot product result changes, you've intersected the plane, and likely gone through it. If the dot product result went to zero and stayed there, you would be moving along the plane. It would be a 3D version of what we were discussing at https://staging.qb64phoenix.com/showthread.php?tid=972 Generally, the same concepts apply for 3D as for 2D
The former would have the advantage of being able to calculate exact points of intersection, the later would be computationally simpler for a crash scenario.
RE: 3D Terrain - MasterGy - 01-09-2023
I rewrote it to universal. in this example, the DEEP array records the height values. The height value can be easily read.
1 square grid = 2 triangles. He counts with the one that falls into a triangle.
Code: (Select All)
Function exact_deep (x, y)
x1 = Int(x): x2 = x1 + 1: aposx = (x - x1)
y1 = Int(y): y2 = y1 + 1: aposy = (y - y1)
p1 = deep(x2, y1)
p2 = deep(x1, y2)
If aposx * aposx + aposy * aposy < (1 - aposx) * (1 - aposx) + (1 - aposy) * (1 - aposy) Then
p0 = deep(x1, y1)
q = p0 + aposx * (p1 - p0) + aposy * (p2 - p0)
Else
p3 = deep(x2, y2)
q = p3 + (1 - aposy) * (p1 - p3) + (1 - aposx) * (p2 - p3)
End If
exact_deep = q
End FunctionRE: 3D Terrain - james2464 - 01-09-2023
(01-09-2023, 08:29 AM)mnrvovrfc Wrote: I wanted to be on that lonely island. Nice job!
Thanks! Just need a house on there, and maybe a boat too.
RE: 3D Terrain - james2464 - 01-09-2023
(01-09-2023, 12:12 PM)OldMoses Wrote: A couple of thoughts:
If there's a simple solution, I don't know it.
I think it would probably involve some sort of parametric algorithm after determining which triangle grid element was being approached. I've not done anything like that myself, having mostly worked with line/sphere intersections. Most line/plane intersection stuff I've looked at presumes an infinite plane, so you would need to narrow your inputs to the correct grid element with some Pythagorean checking.
https://courseware.cemc.uwaterloo.ca/web/Gr12CaAn000/Public_Html/slides/V4/TheIntersectionOfALineAndAPlane.pdf
There's lots of other stuff on parametric equations available.
The other possibility, is that you can take the plane 'normal' {i.e. perpendicular} of a target terrain grid element, and dot it with the position vector relative to that normal, updating it as you go along the path (easier to do than to describe). When the sign of the dot product result changes, you've intersected the plane, and likely gone through it. If the dot product result went to zero and stayed there, you would be moving along the plane. It would be a 3D version of what we were discussing at https://staging.qb64phoenix.com/showthread.php?tid=972 Generally, the same concepts apply for 3D as for 2D
The former would have the advantage of being able to calculate exact points of intersection, the later would be computationally simpler for a crash scenario.
Thanks for the PDF...that should help make sense of this. Some interesting math there too...quadradic equations? Been a long time since I've done that.
Using vector math would really open up some possibilities. Definitely over my head but this seems like the way to go for a good 3d physics engine.
RE: 3D Terrain - james2464 - 01-09-2023
(01-09-2023, 03:24 PM)MasterGy Wrote: I rewrote it to universal. in this example, the DEEP array records the height values. The height value can be easily read.
1 square grid = 2 triangles. He counts with the one that falls into a triangle.
Code: (Select All)Function exact_deep (x, y)
x1 = Int(x): x2 = x1 + 1: aposx = (x - x1)
y1 = Int(y): y2 = y1 + 1: aposy = (y - y1)
p1 = deep(x2, y1)
p2 = deep(x1, y2)
If aposx * aposx + aposy * aposy < (1 - aposx) * (1 - aposx) + (1 - aposy) * (1 - aposy) Then
p0 = deep(x1, y1)
q = p0 + aposx * (p1 - p0) + aposy * (p2 - p0)
Else
p3 = deep(x2, y2)
q = p3 + (1 - aposy) * (p1 - p3) + (1 - aposx) * (p2 - p3)
End If
exact_deep = q
End Function
Thank you! I'll try to make this work. Cheers!
RE: 3D Terrain - MasterGy - 01-09-2023
I checked. it will work. You should record the depth data in the following way and it will be compatible with this.
I hope everything is understandable in the example! good luck !
Code: (Select All)
Dim Shared deep(4, 4)
deep(0, 0) = 10
deep(1, 0) = 20
deep(0, 1) = 30
deep(1, 1) = 40
'deep-array now
' 10 20 0 0 0
' 30 40 0 0 0
' 0 0 0 0 0
' 0 0 0 0 0
' 0 0 0 0 0
Print exact_deep(0, 0) '10
Print exact_deep(0.5, 0) 'between 10 and 20
Print exact_deep(.5, .5) 'between central 10,20,30,40 (central 25)
Function exact_deep (x, y)
x1 = Int(x): x2 = x1 + 1: aposx = x - x1
y1 = Int(y): y2 = y1 + 1: aposy = y - y1
p1 = deep(x2, y1)
p2 = deep(x1, y2)
If aposx * aposx + aposy * aposy < (1 - aposx) * (1 - aposx) + (1 - aposy) * (1 - aposy) Then
p0 = deep(x1, y1)
q = p0 + aposx * (p1 - p0) + aposy * (p2 - p0)
Else
p3 = deep(x2, y2)
q = p3 + (1 - aposy) * (p1 - p3) + (1 - aposx) * (p2 - p3)
End If
exact_deep = q
End FunctionRE: 3D Terrain - james2464 - 01-09-2023
Perfect. I was working on creating the DEEP array (incorrectly) but now with this information I can set it up properly.
Thank you!
RE: 3D Terrain - OldMoses - 01-09-2023
(01-09-2023, 05:26 PM)james246 Wrote: Using vector math would really open up some possibilities. Definitely over my head but this seems like the way to go for a good 3d physics engine.
You already are, truth be told. The only difference is your code handles the vectors as individual x/y/z components.
The main possibility is less overall typing and more succinct code. It's just a matter of thinking of those individual components as whole objects and writing some subroutines to handle the individual components of those objects.
I notice your SUB processterrain is doing just that. In the DO...LOOP, it's mostly scalar multiplications of, and additions to vectors, which could be SUB'ed out to something that would handle the grunt work. All that would be needed is a vector TYPE, say...
TYPE Vector
x AS SINGLE
y AS SINGLE
z AS SINGLE
END TYPE
A subroutine to do the multiplications
SUB MultVec (v as Vector, m AS SINGLE)
v.x = v.x * m
v.y = v.y * m
v.z = v.z * m
END SUB
Then just DIM AS Vector vec1, vec2, vec3 ' in the SUB
Suddenly:
x1 = x1 * scale1: y1 = y1 * scale1: 'z1 = z1 * scale1
x2 = x2 * scale1: y2 = y2 * scale1: 'z2 = z2 * scale1
x3 = x3 * scale1: y3 = y3 * scale1: 'z3 = z3 * scale1
becomes:
MultiVec vec1, scale1
MultiVec vec2, scale1
MultiVec vec3, scale1
Then you can do the same to the vector additions. Change shx, shy & shz to a single vector type: sh.x, sh.y & sh.z. Write a sub to add two vectors together:
SUB AddVec (v1 as Vector, v2 AS Vector)
v1.x = v1.x + v2.x
v1.y = v1.y + v2.y
v1.z = v1.z + v2.z
END SUB
Now:
x1 = x1 + shx: y1 = y1 + shy: z1 = z1 + shz
x2 = x2 + shx: y2 = y2 + shy: z2 = z2 + shz
x3 = x3 + shx: y3 = y3 + shy: z3 = z3 + shz
becomes:
AddVec vec1, sh
AddVec vec2, sh
AddVec vec3, sh
A little more upfront work for a big payoff in short code, more descriptive variable naming, etc.