Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
3D Terrain
#11
but it's good that I remember! I hope I'm not too late. 1 square is made up of 2 triangles, right? It really doesn't matter how we divide it into two! "exact_deep" works correctly if you draw the triangles this
[Image: qb64-forum2.jpg]

way.
Reply
#12
(01-09-2023, 06:53 PM)OldMoses Wrote:
(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.

Excellent advice.   I didn't realize I was this close to something useful - it was just an experiment to see if I could establish some random uneven terrain and to use a single image for this terrain map.  I'll update the code - Thank you!
Reply
#13
(01-09-2023, 06:56 PM)MasterGy Wrote: but it's good that I remember! I hope I'm not too late. 1 square is made up of 2 triangles, right? It really doesn't matter how we divide it into two! "exact_deep" works correctly if you draw the triangles this
[Image: qb64-forum2.jpg]

way.
Thanks for letting me know.   I have two versions of this terrain.  I think one is exactly like this.   I tried the hex arrangement as well, which won't work because it's all triangles.  But I can use the square version.
Reply
#14
Working towards implementing the 'exact deep' function.   Not quite there yet, but I thought I'd share this update.  

Hopefully I'll have more time to get through this today but probably not - kind of busy today.

Anyway this is the square version which matches the pattern needed for that function to work.   I also added positioning info.   So the next thing to do is set up the deep(x,x) array and start using that function.   

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, xm, ym
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(4, 4)










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

'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) = 600 '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 = 1.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

    _PutImage (0, 0)-(150, 150), ground1



    'find current terrain location
    xm = sp(0) / 50
    ym = sp(1) / 50


    If sp(0) > 3 And sp(0) < 498 Then
        If sp(1) > 3 And sp(1) < 498 Then
            Locate 11, 1
            Print "                "
            Locate 11, 1
            Print "X: "; xm
            Locate 12, 1
            Print "                "
            Locate 12, 1
            Print "Y: "; ym
            Circle (sp(0) / 3.33, sp(1) / 3.33), 1, c(1)
        End If
    End If


    '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)



    '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)



'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================


Function exact_deep (x, y)
    Dim x1, y1, x2, y2, p0, p1, p2, p3, aposx, aposy, q
    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





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 = 485 '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 = 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
    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
    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
                If y > 0 And y < y1 Then
                    trz(t) = 0 - Int(Rnd * 15)
                    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


    '_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(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
Reply
#15
Getting closer, but not quite accurate yet.   I think I can figure this out to make it precise.   At times it seems to follow in the opposite direction, so this is probably just a map error.   

Once I get it fully sorted out I'll start over with better coding.  It's a mess right now  Big Grin

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(xm2, ym2)
            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
Reply
#16
Still missing Minerva. ;-))

I think I like the island better, the latest looks like the Phantom Zone.
b = b + ...
Reply
#17
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.


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
Reply
#18
Here is a cleaned up version where you are walking on the surface.    You can try to follow the moving object.

Controls:  Mouse and WASD keys

Code: (Select All)
'3d Terrain - 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,-19,3,-3,-19,100,100,7: 'block
Data 3,0,0,0,-.1,.1,0,.1,.1,0,-3,3,-19,3,3,-19,100,100,7: 'block
Data 3,0,0,0,-.1,-.1,0,-.1,.1,0,-3,-3,-19,-3,3,-19,100,100,5: 'block
Data 3,0,0,0,.1,-.1,0,.1,.1,0,3,-3,-19,3,3,-19,100,100,4: 'block
Data 3,0,0,0,3,-3,-19,3,3,-19,-3,-3,-19,-3,3,-19,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) = 250 'Y
sp(2) = 490 '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 = 425: 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 = .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

    '_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
            sp(2) = 490 + exact_deep(ym, xm)
        End If
    Else
        sp(2) = 490
    End If


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

    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 = 499 + 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
Reply
#19
+1 really nice! still no Minerva but might be lonely anyway without QB64pe Forum.
b = b + ...
Reply
#20
(01-11-2023, 10:34 PM)bplus Wrote: +1 really nice! still no Minerva but might be lonely anyway without QB64pe Forum.

I was trying to figure out what Minerva was  Big Grin

I'll see if I can add it.
Reply




Users browsing this thread: 3 Guest(s)