01-11-2023, 08:46 PM
Got it! Line 372 was blz = 500 + exact_deep(xm2, ym2) but needed to be (ym2, xm2)
Thank you @MasterGy! The 'exact deep' function works perfectly.
Thank you @MasterGy! The 'exact deep' function works perfectly.
Code: (Select All)
'3d Terrain with grid lines - 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
Dim Shared trx(5000), try(5000), trz(5000) 'terrain points
Dim Shared fr1(5000), fr2(5000), fr3(5000) 'terrain point groups
Dim Shared maxterrain
Dim Shared deep(1000, 1000), ed(4)
Dim Shared xm, ym, xm2, ym2
Dim Shared blx, bly, blz, bla, fx, or1(5)
Cls
colour1
Dim Shared floor1, wall1, wall2, ground1, ground2, sky1, cbx(20)
maketerrain
wall1 = _NewImage(500, 100, 32): makewall
wall2 = _NewImage(500, 100, 32): makewall2
ground1 = _NewImage(500, 500, 32)
ground2 = _NewImage(500, 500, 32): makeground
sky1 = _NewImage(750, 750, 32): makesky
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
Dim Shared moo(900) As mapobject
'create texture point data array
Dim Shared tx(500, 19), txtot, rawtxtot, mootxtot
'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
Data 3,0,0,0,-.1,-.1,0,.1,-.1,0,-3,-3,-9,3,-3,-9,100,100,7: 'block
Data 3,0,0,0,-.1,.1,0,.1,.1,0,-3,3,-9,3,3,-9,100,100,7: 'block
Data 3,0,0,0,-.1,-.1,0,-.1,.1,0,-3,-3,-9,-3,3,-9,100,100,5: 'block
Data 3,0,0,0,.1,-.1,0,.1,.1,0,3,-3,-9,3,3,-9,100,100,4: 'block
Data 3,0,0,0,3,-3,-9,3,3,-9,-3,-3,-9,-3,3,-9,100,100,3: 'block top
rawtxtot = 7: 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
'moveable object copies
nc = 3: xc = 250: yc = 250: zc = 450: ac = 0: moocopy nc, xc, yc, zc, ac 'block
'create spectator
Dim Shared sp(6)
sp(0) = 250 'X position
sp(1) = 400 'Y
sp(2) = 430 '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
blx = 325: bly = 250: blz = 490
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
Do
_Limit 40
moveblock
'or1(1) = 3: or1(2) = blx: or1(3) = bly: or1(4) = blz: or1(5) = .45: moorotate 'block
processterrain
processtextures
processmootextures
'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 = .25 '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
_PutImage (0, 0)-(150, 150), ground1
'find current terrain location
xm = sp(0) / 50
ym = sp(1) / 50
xm2 = blx / 50
ym2 = bly / 50
If sp(0) > 3 And sp(0) < 498 Then
If sp(1) > 3 And sp(1) < 498 Then
Locate 11, 1
Print "Spectator"
Locate 12, 1
Print " "
Locate 12, 1
Print "X: "; xm
Locate 13, 1
Print " "
Locate 13, 1
Print "Y: "; ym
Print " "
Locate 14, 1
Print "SP Z: "; sp(2)
'Print " "
'Locate 14, 1
'Print "TR Z: "; exact_deep(xm, ym)
'Print " "
'Locate 15, 1
'Print "ALT: "; 500 - sp(2) + exact_deep(xm, ym)
Circle (sp(0) / 3.33, sp(1) / 3.33), 1, c(1)
End If
End If
'block
Locate 20, 1
Print "Indicator"
Locate 21, 1
Print " "
Locate 21, 1
Print "X: "; xm2
Locate 22, 1
Print " "
Locate 22, 1
Print "Y: "; ym2
Print " "
Locate 23, 1
Print "Z: "; blz
'Print " "
'Locate 24, 1
'Print "ED: "; exact_deep(xm2, ym2)
'Print " "
'Locate 25, 1
'Print "ALT: "; 500 - blz + exact_deep(xm2, ym2)
Circle (blx / 3.33, bly / 3.33), 1, c(32)
'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)
Loop Until _KeyDown(27)
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
Function exact_deep (x, y)
Dim x1, y1, x2, y2, p0, p1, p2, p3, aposx, aposy, q
x1 = Int(x) + 1: x2 = x1 + 1: aposx = x - (x1 - 1)
y1 = Int(y) + 1: y2 = y1 + 1: aposy = y - (y1 - 1)
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
Sub moveblock
Dim nc, ac
Dim t, t2, zt
bla = .012
Dim xt, yt, h, h1, h2, xt2, yt2
xt = blx - 250: yt = bly - 250
h = _Hypot(yt, xt)
h1 = _Atan2(xt, yt)
h2 = h1 - bla
xt2 = Sin(h2) * h
yt2 = Cos(h2) * h
blx = xt2 + 250
bly = yt2 + 250
For t = 1 To mootxtot
If moo(t).n = 3 Then
moo(t).x = blx
moo(t).y = bly
xm2 = blx / 50: ym2 = bly / 50
blz = 500 + exact_deep(ym2, xm2)
moo(t).z = blz
End If
Next t
End Sub
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, shx, shy, shz, txm
flag = 0
ct = 0
scale1 = 1.
shx = 0 'shift x position
shy = 0 'shift y position
shz = 498 '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
x4 = x4 * scale1: y4 = y4 * scale1: 'z4 = z4 * 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
x4 = x4 + shx: y4 = y4 + shy: z4 = z4 + 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 >= maxterrain 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 = nc: 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 moocopy (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 = mootxtot + ct
moo(t2).n = nc: moo(t2).x = xc: moo(t2).y = yc: moo(t2).z = zc
xt = raw(t).x1: yt = raw(t).y1: xyrotation xt, yt, ac: moo(t2).x1 = xt: moo(t2).y1 = yt: moo(t2).z1 = raw(t).z1
xt = raw(t).x2: yt = raw(t).y2: xyrotation xt, yt, ac: moo(t2).x2 = xt: moo(t2).y2 = yt: moo(t2).z2 = raw(t).z2
xt = raw(t).x3: yt = raw(t).y3: xyrotation xt, yt, ac: moo(t2).x3 = xt: moo(t2).y3 = yt: moo(t2).z3 = raw(t).z3
xt = raw(t).x4: yt = raw(t).y4: xyrotation xt, yt, ac: moo(t2).x4 = xt: moo(t2).y4 = yt: moo(t2).z4 = raw(t).z4
moo(t2).ix = raw(t).ix: moo(t2).iy = raw(t).iy: moo(t2).in = raw(t).in
End If
Next t
mootxtot = mootxtot + ct
End Sub
Sub moorotate
Dim t, x1, y1, x2, y2, x3, y3, x4, y4
For t = 1 To mootxtot
If moo(t).n = or1(1) Then
x1 = moo(t).x1: y1 = moo(t).y1
xyrotation x1, y1, or1(5)
x2 = moo(t).x2: y2 = moo(t).y2
xyrotation x2, y2, or1(5)
x3 = moo(t).x3: y3 = moo(t).y3
xyrotation x3, y3, or1(5)
x4 = moo(t).x4: y4 = moo(t).y4
xyrotation x4, y4, or1(5)
moo(t).x1 = x1: moo(t).y1 = y1
moo(t).x2 = x2: moo(t).y2 = y2
moo(t).x3 = x3: moo(t).y3 = y3
moo(t).x4 = x4: moo(t).y4 = y4
End If
Next t
End Sub
Sub processmootextures
Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
For t = 1 To mootxtot
x1 = moo(t).x1 + moo(t).x: y1 = moo(t).y1 + moo(t).y: z1 = moo(t).z1 + moo(t).z
x2 = moo(t).x2 + moo(t).x: y2 = moo(t).y2 + moo(t).y: z2 = moo(t).z2 + moo(t).z
x3 = moo(t).x3 + moo(t).x: y3 = moo(t).y3 + moo(t).y: z3 = moo(t).z3 + moo(t).z
x4 = moo(t).x4 + moo(t).x: y4 = moo(t).y4 + moo(t).y: z4 = moo(t).z4 + moo(t).z
x = moo(t).ix: y = moo(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(moo(t).in) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
_MapTriangle (x, y)-(0, y)-(x, 0), tximage(moo(t).in) To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
Next t
End Sub
Sub objrotate
Dim t, x1, y1, x2, y2, x3, y3, x4, y4
For t = 1 To txtot
If oo(t).n = or1(1) Then
x1 = oo(t).x1 - or1(2): y1 = oo(t).y1 - or1(3)
xyrotation x1, y1, or1(5)
x2 = oo(t).x2 - or1(2): y2 = oo(t).y2 - or1(3)
xyrotation x2, y2, or1(5)
x3 = oo(t).x3 - or1(2): y3 = oo(t).y3 - or1(3)
xyrotation x3, y3, or1(5)
x4 = oo(t).x4 - or1(2): y4 = oo(t).y4 - or1(3)
xyrotation x4, y4, or1(5)
oo(t).x1 = x1 + or1(2): oo(t).y1 = y1 + or1(3)
oo(t).x2 = x2 + or1(2): oo(t).y2 = y2 + or1(3)
oo(t).x3 = x3 + or1(2): oo(t).y3 = y3 + or1(3)
oo(t).x4 = x4 + or1(2): oo(t).y4 = y4 + or1(3)
End If
Next t
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
Cls
Line (0, 0)-(500, 500), c(40), BF 'ground background
For t = 1 To 55
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500)
Line (x1 - 30, y1 - 30)-(x1 + 30, y1 + 30), c(41), BF
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500)
Line (x1 - 50, y1 - 50)-(x1 + 50, y1 + 50), c(42), BF
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500)
Line (x1 - 20, y1 - 20)-(x1 + 20, y1 + 20), c(43), BF
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500)
Line (x1 - 20, y1 - 20)-(x1 + 20, y1 + 20), c(44), BF
Next t
For t = 1 To 7500
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500)
PSet (x1, y1), c(41)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500)
PSet (x1, y1), c(42)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500)
PSet (x1, y1), c(43)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500)
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
_PutImage (0, 0)-(500, 500), 0, ground2, (0, 0)-(500, 500)
For t = 1 To maxterrain
Line (trx(fr1(t)) - 1, try(fr1(t)))-(trx(fr2(t)) - 1, try(fr2(t))), c(34)
Line (trx(fr1(t)), try(fr1(t)))-(trx(fr2(t)), try(fr2(t))), c(34)
Line (trx(fr2(t)) - 1, try(fr2(t)) - 1)-(trx(fr3(t)) - 1, try(fr3(t)) - 1), c(34)
Line (trx(fr2(t)), try(fr2(t)))-(trx(fr3(t)), try(fr3(t))), c(34)
Line (trx(fr3(t)), try(fr3(t)) - 1)-(trx(fr1(t)), try(fr1(t)) - 1), c(34)
Line (trx(fr3(t)), try(fr3(t)))-(trx(fr1(t)), try(fr1(t))), c(34)
Next t
'_Display
_PutImage (0, 0)-(500, 500), 0, ground1, (0, 0)-(500, 500)
'Sleep
End Sub
Sub makeground2
Dim t, x1, y1
Cls
Line (0, 0)-(500, 500), c(20), BF 'ground background
For t = 1 To 50
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500)
Line (x1 - 30, y1 - 30)-(x1 + 30, y1 + 30), c(42), BF
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500)
Line (x1 - 50, y1 - 50)-(x1 + 50, y1 + 50), c(41), BF
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500)
Line (x1 - 20, y1 - 20)-(x1 + 20, y1 + 20), c(40), BF
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500)
Line (x1 - 20, y1 - 20)-(x1 + 20, y1 + 20), c(41), BF
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, dx, dy, pt(4)
Cls
'Line (0, 0)-(500, 500), c(20), BF 'background
t = 0
x1 = 500: y1 = 500
s = 50
'create points (trx,try,trz)
For x = 0 To x1 Step s
For y = 0 To y1 Step s
t = t + 1
xt = Abs(x): yt = Abs(y)
'trx(t) = x - s: try(t) = y - s
trx(t) = x: try(t) = y
If x > 0 And x < x1 Then
'trz(t) = -2
If y > 0 And y < y1 Then
trz(t) = 0 - Int(Rnd * 20)
'trz(t) = 0
xh = Abs(trx(t) - x1 / 2)
yh = Abs(try(t) - y1 / 2)
vc = _Hypot(xh, yh)
vc = 250 - vc
'If vc < 200 Then trz(t) = trz(t) - (Int(Rnd * vc)) / 3
'trz(t) = trz(t) - (Int(Rnd * vc / 4))
End If
End If
Next y
Next x
'_Display
'Sleep
'create point groups (fr1,fr2,fr3)
p = Int(x1 / s) + 1
q = Int(y1 / s) - 1
p2 = p * q
t = -1
flag = 0
ct = 0
x = 0
Do
For x = 1 To p - 1
t = t + 2
fr1(t) = x + ct
fr2(t) = x + ct + 1
fr3(t) = x + ct + p
fr1(t + 1) = x + ct + 1
fr2(t + 1) = x + ct + p
fr3(t + 1) = x + ct + p + 1
Next x
ct = ct + p
If ct > p2 Then flag = 1
Loop Until flag = 1
maxterrain = t + 1
'Cls
't = t + 1
'For ct = 1 To t
'Print fr1(ct), fr2(ct), fr3(ct)
'Next ct
Cls
For t = 1 To maxterrain
Line (trx(fr1(t)), try(fr1(t)))-(trx(fr2(t)), try(fr2(t))), c(1)
Line (trx(fr2(t)), try(fr2(t)))-(trx(fr3(t)), try(fr3(t))), c(1)
Line (trx(fr3(t)), try(fr3(t)))-(trx(fr1(t)), try(fr1(t))), c(1)
Next t
Cls
'create DEEP array
t = 0
For y = 1 To 11
For x = 1 To 11
t = t + 1
deep(x, y) = trz(t)
Locate y * 3, x * 6
Print deep(x, y)
Next x
Next y
'_Display
'Sleep
'For t = 1 To 10
'test DEEP array
dx = Rnd * 10
dy = Rnd * 10
Locate 40, 1
Print dx, dy
pt(1) = deep(Int(dx) + 1, Int(dy) + 1)
pt(2) = deep(Int(dx) + 2, Int(dy) + 1)
pt(3) = deep(Int(dx) + 1, Int(dy) + 2)
pt(4) = deep(Int(dx) + 2, Int(dy) + 2)
Print pt(1), pt(2)
Print pt(3), pt(4)
'_Display
'Sleep
'Next t
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(40, 50, 10)
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, 255, 255)
c(34) = _RGB(155, 155, 0)
c(40) = _RGBA(45, 20, 25, 45)
c(41) = _RGBA(50, 50, 30, 50)
c(42) = _RGBA(20, 30, 15, 50)
c(43) = _RGBA(75, 45, 15, 50)
c(44) = _RGBA(40, 60, 30, 50)
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 Sub