Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
3D Ferris Wheel
#1
A while ago I made a Ferris Wheel program and recently I've been tinkering with 3D stuff so I thought I'd give it another try.

I'll post both programs below.   No attachments needed but the 3D version might be a little much for a slower computer.   Thank goodness for speedy hardware images  Big Grin

There are controls in the new version if you're interested.   

Move around using WASD keys and mouse.   The L&R arrow keys control the wheel direction and speed.   The up arrow puts you in one of the seats.   The down arrow puts you back down on the ground.    And the F key allows you to fly around in ghost mode.   

Cheers!




Code: (Select All)
'ferris wheel
'james2464 - Nov 11 2022 - Radian Ferris Wheel

Dim Shared scx, scy As Integer
scx = 800: scy = 600
Screen _NewImage(scx, scy, 32)

Const PI = 3.141592654#
Randomize Timer

Dim Shared bg&
bg& = _NewImage(scx + 1, scy + 1, 32)

Dim Shared c(100) As Long
colour1

background1
_PutImage (1, 1)-(scx - 1, scy - 1), 0, bg&, (1, 1)-(scx - 1, scy - 1) 'take snapshot of screen



'origin
xx = 400
yy = 300
w = 220 'wheel radius
p = 17 'number of positions
'=====================================================
h = _Hypot(w, 0)
h1 = _Atan2(0, w)
'=====================================================
Do
    _Limit 30
    Cls
    _PutImage (0, 0)-(scx, scy), bg&, 0 'draw background
    Circle (xx, yy), w, c(0)
    Line (xx, yy)-(xx - 50, yy + w + 40), c(0)
    Line (xx, yy)-(xx + 50, yy + w + 40), c(0)
    Line (xx - 50, yy + w + 40)-(xx + 50, yy + w + 40), c(0)
    h1 = h1 + .002
    If h1 >= PI * 2 Then h1 = 0
    '-------------------------------------------------
    For t = 1 To p
        h2 = h1 + ((PI * 2) / p) * t
        x = Cos(h2) * h: y = Sin(h2) * h
        Line (xx, yy)-(xx + x, yy + y), c(0)
        Line (xx + x - 7, yy + y - 1)-(xx + x + 7, yy + y + 1), c(12), BF
        Line (xx + x, yy + y)-(xx + x, yy + y + 15), c(0)
        Line (xx + x - 7, yy + y + 15)-(xx + x + 7, yy + y + 25), c(12), BF
    Next t
    _Display
Loop

Sub background1
    Cls
    Line (1, 1)-(scx - 1, scy - 1), c(1), BF

    y = 400
    For t = 1 To y
        m = 255 * ((400 - t) / 400)
        c(99) = _RGBA(150, 150, 255, m)
        Line (1, t)-(scx - 1, t), c(99)
    Next t

    ty = scy - y
    For t = y To scy
        t2 = ((scy - t) * 2)
        m = 255 * ((scy - t2) / scy)
        c(99) = _RGBA(50, 150, 50, m)
        Line (1, t)-(scx - 1, t), c(99)
    Next t
End Sub



Sub colour1
    c(0) = _RGB(0, 0, 0)
    c(1) = _RGB(255, 255, 255)
    c(2) = _RGB(255, 255, 0)
    c(3) = _RGB(255, 0, 0)
    c(4) = _RGB(0, 255, 0)
    c(5) = _RGB(0, 255, 255)
    c(6) = _RGB(255, 0, 255)
    c(7) = _RGB(30, 30, 255)
    c(8) = _RGB(150, 150, 250)
    c(9) = _RGB(250, 150, 150)
    c(10) = _RGB(150, 250, 150)
    c(11) = _RGB(150, 150, 255) 'sky blue
    c(12) = _RGB(125, 75, 125) 'cars
    c(13) = _RGB(255, 0, 0)
    c(14) = _RGB(50, 150, 50) 'ground
    c(15) = _RGB(0, 255, 255)
    c(16) = _RGB(255, 0, 255)
    c(17) = _RGB(30, 30, 255)
    c(18) = _RGB(150, 150, 250)
    c(19) = _RGB(250, 150, 150)
    c(20) = _RGB(150, 250, 150)
    c(21) = _RGB(255, 255, 255)
    c(22) = _RGB(255, 255, 0)
    c(23) = _RGB(255, 0, 0)
    c(24) = _RGB(0, 255, 0)
    c(25) = _RGB(0, 255, 255)
    c(26) = _RGB(255, 0, 255)
    c(27) = _RGB(30, 30, 255)
    c(28) = _RGB(150, 150, 250)
    c(29) = _RGB(250, 150, 150)
    c(30) = _RGBA(0, 0, 0, 5)
End Sub


Code: (Select All)
'3d Ferris Wheel - james2464 - Feb 2023
'Credit to MasterGy for 3D programming help and support

'CONTROLS
'UP ARROW = Ride Ferris Wheel
'DOWN ARROW = Walk on ground
'LEFT ARROW = Rotate wheel CCW (+ speed)
'RIGHT ARROW = Rotate wheel CW (+ speed)
'F KEY = Free float (ghost mode)


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 Shared 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
Dim Shared or1(5), key1, keyct, oc
Dim Shared pmode, rspd





maketerrain


Cls


colour1

Dim Shared ground1, sky1, cbx(200)



ground1 = _NewImage(500, 500, 32): makeground
sky1 = _NewImage(750, 750, 32): makesky

For t = 1 To 20: cbx(t) = _NewImage(400, 400, 32): Next t: makepallette

Dim Shared tximage(200)
For t = 1 To 20: tximage(t) = _CopyImage(cbx(t), 33): Next t

tximage(0) = _CopyImage(ground1, 33)

Type rawobject
    n As Integer 'object drawing number
    n2 As Integer 'drawing detail number
    n3 As Integer 'total number of details
    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(2000) As rawobject

Type xyzgroup
    x As Single
    y As Single
    z As Single
End Type

Type axisgroup
    xy As Single
    yz As Single
    xz As Single
End Type


Type mapobject
    det As rawobject 'details
    pos1 As xyzgroup 'position
    ori As axisgroup 'orientation
    vel1 As xyzgroup 'velocity
    sp As Single 'speed
    sc As Single 'scale
End Type

Dim Shared foo(900) As mapobject 'fixed objects eg water
Dim Shared moo(3900) As mapobject 'moveable objects

'create texture point data array
Dim Shared tx(1500, 19), txtot, rawtxtot, mootxtot

'objects and data points
Data 1,1,1,-1000,0,200,-1000,0,-200,1000,0,200,1000,0,-200,500,100,12: 'wall
Data 2,1,1,-4000,-4000,0,-4000,4000,0,4000,-4000,0,4000,4000,0,500,100,3: 'water
Data 3,1,6,-2,-20,10.01,2,-20,10.01,-2,20,10.01,2,20,10.01,100,100,15: 'axle
Data 3,2,6,2,-20,10.01,-2,-20,10.01,2,-20,0,-2,-20,0,100,100,13: 'end
Data 3,3,6,2,20,10.01,-2,20,10.01,2,20,0,-2,20,0,100,100,13: 'end
Data 4,1,6,-.4,-.4,27,.4,-.4,27,-.4,-.4,-20,.4,-.4,-20,100,100,13: 'main beam
Data 4,2,6,-.4,.4,27,.4,.4,27,-.4,.4,-20,.4,.4,-20,100,100,13
Data 4,3,6,-.4,-.4,27,-.4,.4,27,-.4,-.4,-20,-.4,.4,-20,100,100,15
Data 4,4,6,.4,-.4,27,.4,.4,27,.4,-.4,-20,.4,.4,-20,100,100,15
Data 4,5,6,.4,-.4,-20,.4,.4,-20,-.4,-.4,-20,-.4,.4,-20,100,100,10: 'end
Data 4,6,6,.4,-.4,27,.4,.4,27,-.4,-.4,27,-.4,.4,27,100,100,10: 'end
Data 5,1,6,-.1,-.1,-5,.1,-.1,-5,-.1,-.1,-64.5,.1,-.1,-64.5,100,100,7: 'thin beam
Data 5,2,6,-.1,.1,-5,.1,.1,-5,-.1,.1,-64.5,.1,.1,-64.5,100,100,7
Data 5,3,6,-.1,-.1,-5,-.1,.1,-5,-.1,-.1,-64.5,-.1,.1,-64.5,100,100,8
Data 5,4,6,.1,-.1,-5,.1,.1,-5,.1,-.1,-64.5,.1,.1,-64.5,100,100,8
Data 6,1,6,45.9,45.9,-4.95,46.1,45.9,-4.95,45.9,45.9,4.95,46.1,45.9,4.95,100,100,7: 'thin short beam
Data 6,2,6,45.9,46.1,-4.95,46.1,46.1,-4.95,45.9,46.1,4.95,46.1,46.1,4.95,100,100,7
Data 6,3,6,45.9,45.9,-4.95,45.9,46.1,-4.95,45.9,45.9,4.95,45.9,46.1,4.95,100,100,8
Data 6,4,6,46.1,45.9,-4.95,46.1,46.1,-4.95,46.1,45.9,4.95,46.1,46.1,4.95,100,100,8
Data 7,1,4,-8.42,-4.8,-63.9,8.42,-4.8,-63.9,-8.59,-4.8,-65.2,8.59,-4.8,-65.2,100,100,15: 'outer perimeter beam
Data 7,2,4,-8.42,-5.2,-63.9,8.42,-5.2,-63.9,-8.59,-5.2,-65.2,8.59,-5.2,-65.2,100,100,15
Data 7,3,4,-8.59,-4.8,-65.2,-8.59,-5.2,-65.2,8.59,-4.8,-65.2,8.59,-5.2,-65.2,100,100,13
Data 7,4,4,-8.42,-4.8,-63.9,-8.42,-5.2,-63.9,8.42,-4.8,-63.9,8.42,-5.2,-63.9,100,100,13
Data 8,1,14,-.1,-.1,3,.1,-.1,3,-.1,-.1,0,.1,-.1,0,100,100,7: 'carriage roof center beam
Data 8,2,6,-.1,.1,3,.1,.1,3,-.1,.1,0,.1,.1,0,100,100,7
Data 8,3,6,-.1,-.1,3,-.1,.1,3,-.1,-.1,0,-.1,.1,0,100,100,8
Data 8,4,6,.1,-.1,3,.1,.1,3,.1,-.1,0,.1,.1,0,100,100,8
Data 8,5,6,-2,-2,10,2,-2,10,-2,-2,6,2,-2,6,100,100,7: 'walls
Data 8,6,6,-2,2,10,2,2,10,-2,2,6,2,2,6,100,100,7
Data 8,7,6,-2,-2,10,-2,2,10,-2,-2,6,-2,2,6,100,100,17
Data 8,8,6,2,-2,10,2,2,10,2,-2,6,2,2,6,100,100,17
Data 8,9,6,2,-2,3,2,2,3,-2,-2,3,-2,2,3,100,100,18: 'roof
Data 8,10,6,2,-2,10,2,2,10,-2,-2,10,-2,2,10,100,100,18: 'floor
Data 8,11,6,-2,-2,6,-1.95,-2,6,-2,-2,3,-1.95,-2,3,100,100,7: 'corner beam 1
Data 8,12,6,-2,-2,6,-2,-1.95,6,-2,-2,3,-2,-1.95,3,100,100,8
Data 8,12,6,-2,2,6,-1.95,2,6,-2,2,3,-1.95,2,3,100,100,7: 'corner beam 2
Data 8,14,6,-2,2,6,-2,1.95,6,-2,2,3,-2,1.95,3,100,100,8
Data 8,13,6,2,2,6,1.95,2,6,2,2,3,1.95,2,3,100,100,7: 'corner beam 3
Data 8,14,6,2,2,6,2,1.95,6,2,2,3,2,1.95,3,100,100,8
Data 8,12,6,2,-2,6,1.95,-2,6,2,-2,3,1.95,-2,3,100,100,7: 'corner beam 4
Data 8,14,6,2,-2,6,2,-1.95,6,2,-2,3,2,-1.95,3,100,100,8



rawtxtot = 41: txtot = rawtxtot


'read data into array tx()
Dim t2
For t = 1 To txtot
    For t2 = 1 To 18
        Read tx(t, t2)
    Next t2
    'create 'raw' objects
    raw(t).n = tx(t, 1): raw(t).n2 = tx(t, 2): raw(t).n3 = tx(t, 3)
    raw(t).x1 = tx(t, 4): raw(t).y1 = tx(t, 5): raw(t).z1 = tx(t, 6)
    raw(t).x2 = tx(t, 7): raw(t).y2 = tx(t, 8): raw(t).z2 = tx(t, 9)
    raw(t).x3 = tx(t, 10): raw(t).y3 = tx(t, 11): raw(t).z3 = tx(t, 12)
    raw(t).x4 = tx(t, 13): raw(t).y4 = tx(t, 14): raw(t).z4 = tx(t, 15)
    raw(t).ix = tx(t, 16): raw(t).iy = tx(t, 17): raw(t).in = tx(t, 18)
Next t




Dim n1, n2, n3, n4, n5, n6, n7, n8 'n, x, y, z, sc,ac,ac2,ac3

'water
n1 = 2: n2 = 0: n3 = 0: n4 = 500: n5 = 1: n6 = 0: n7 = 0: n8 = 0: foocopy n1, n2, n3, n4, n5, n6, n7, n8 'water

'main beams
n1 = 4: n2 = 170: n3 = 70: n4 = 447: n5 = 2: n6 = _Pi / 2: n7 = .50: n8 = 0: foocopy n1, n2, n3, n4, n5, n6, n7, n8 'main beam
n1 = 4: n2 = 130: n3 = 70: n4 = 447: n5 = 2: n6 = _Pi / 2: n7 = -.50: n8 = 0: foocopy n1, n2, n3, n4, n5, n6, n7, n8 'main beam
n1 = 4: n2 = 170: n3 = 90: n4 = 447: n5 = 2: n6 = _Pi / 2: n7 = .50: n8 = 0: foocopy n1, n2, n3, n4, n5, n6, n7, n8 'main beam
n1 = 4: n2 = 130: n3 = 90: n4 = 447: n5 = 2: n6 = _Pi / 2: n7 = -.50: n8 = 0: foocopy n1, n2, n3, n4, n5, n6, n7, n8 'main beam

'axle
n1 = 3: n2 = 150: n3 = 80: n4 = 411: n5 = .55: n6 = 0: n7 = 0
For t = 1 To 16
    n8 = _Pi / 16 * (2 * t): foocopy n1, n2, n3, n4, n5, n6, n7, n8 'short beam
Next t

'rotating beam
n1 = 5: n2 = 150: n3 = 75: n4 = 411: n5 = 1: n6 = _Pi / 2: n8 = 0
For t = 1 To 24
    n7 = (_Pi / 6) * (.5 * t) + .131: moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t

n1 = 5: n2 = 150: n3 = 85: n4 = 411: n5 = 1: n6 = _Pi / 2: n8 = 0
For t = 1 To 24
    n7 = (_Pi / 6) * (.5 * t) + .131: moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t

'rotating short end beam  (carriage attached to this)
n1 = 6: n2 = 150: n3 = 80: n4 = 411: n5 = 1: n6 = 0: n7 = _Pi / 2
For t = 1 To 24
    n8 = (_Pi / 6) * (.5 * t) + .131: moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t

'outer perimeter beam
n1 = 7: n2 = 150: n3 = 80: n4 = 411: n5 = 1: n6 = 0: n7 = 0
For t = 1 To 24
    n8 = (_Pi / 6) * (.5 * t): moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t

'outer perimeter beam
n1 = 7: n2 = 150: n3 = 90: n4 = 411: n5 = 1: n6 = 0: n7 = 0
For t = 1 To 24
    n8 = (_Pi / 6) * (.5 * t): moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t


'carriages
n1 = 8: n2 = 50: n3 = 80: n4 = 431: n5 = 1: n6 = 0: n7 = 0
For t = 1 To 24
    n8 = 0: moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t
Dim v, c1

'colours
For t = 1 To mootxtot
    If moo(t).det.n = 8 Then
        If moo(t).det.n2 = 1 Then
            c1 = ((t / 1) Mod 7) + 10

            moo(t + 4).det.in = c1
            moo(t + 5).det.in = c1
            moo(t + 8).det.in = c1

        End If
    End If
Next t


'create spectator
Dim Shared sp(6)
sp(0) = 250 'X position
sp(1) = 150 'Y
sp(2) = 470 '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 = _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

pmode = 3
rspd = 0
Dim rcount

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

Do
    _Limit 40


    'keyboard input
    keyct = keyct + 1
    If keyct > 10 Then 'wait before more input
        key1 = keyboard
        keyct = 0
    Else
        key1 = 0
    End If


    'keyboard actions

    If key1 = 1 Then
        rspd = rspd + .001
        If rspd > .016 Then rspd = .012
    End If

    If key1 = 2 Then
        rspd = rspd - .001
        If rspd < -.016 Then rspd = -.012
    End If



    If key1 = 5 Then
        pmode = 1
    End If

    If key1 = 4 Then
        pmode = 2
    End If

    If key1 = 3 Then
        pmode = 3
    End If





    or1(1) = 5: or1(2) = 0: or1(3) = 0: or1(4) = 0: or1(5) = rspd: objrotate3
    or1(1) = 6: or1(2) = 0: or1(3) = 0: or1(4) = 0: or1(5) = rspd: objrotate3
    or1(1) = 7: or1(2) = 0: or1(3) = 0: or1(4) = 0: or1(5) = rspd: objrotate3

    processcarriages
    processterrain
    processfootextures
    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

    If pmode = 1 Then
        sp(0) = sp(0) + vec_x * moving
        sp(1) = sp(1) + vec_y * moving
        sp(2) = sp(2) + vec_z * moving
    End If
    If pmode = 2 Then
        'take a ride
        sp(0) = moo(907).pos1.x
        sp(1) = moo(907).pos1.y
        sp(2) = moo(907).pos1.z + 4
    End If

    If pmode = 3 Then

        sp(0) = sp(0) + vec_x * moving
        sp(1) = sp(1) + vec_y * moving


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

    End If

    t = Abs(rspd) / (2 * _Pi)
    rcount = rcount + t


    'Locate 1, 1
    'Print rspd
    'Locate 2, 1
    'Print rcount

    'If rcount > 1000 Then rspd = 0


Loop Until _KeyDown(27)



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


Function keyboard
    keyboard = 0

    If _KeyDown(19712) Then 'right arrow key
        keyboard = 1
    End If

    If _KeyDown(19200) Then 'left arrow key
        keyboard = 2
    End If

    If _KeyDown(20480) Then 'down arrow key
        keyboard = 3
    End If

    If _KeyDown(18432) Then 'up arrow key
        keyboard = 4
    End If

    If _KeyDown(102) Then 'f key
        keyboard = 5
    End If


End Function



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 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 processterrain
    Dim x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
    Dim xx1, yy1, xx2, yy2, xx3, yy3
    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 = 502 'shift z position

    Do
        ct = ct + 1

        x1 = trx(fr1(ct)): y1 = try(fr1(ct)): z1 = trz(fr1(ct))
        x2 = trx(fr2(ct)): y2 = try(fr2(ct)): z2 = trz(fr2(ct))
        x3 = trx(fr3(ct)): y3 = try(fr3(ct)): z3 = trz(fr3(ct))

        xx1 = x1: yy1 = y1
        xx2 = x2: yy2 = y2
        xx3 = x3: yy3 = y3


        x1 = x1 * scale1: y1 = y1 * scale1: 'z1 = z1 * scale1
        x2 = x2 * scale1: y2 = y2 * scale1: 'z2 = z2 * scale1
        x3 = x3 * scale1: y3 = y3 * scale1: 'z3 = z3 * scale1
        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 = 0
        _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 foocopy (n, x, y, z, sc, ac, ac2, ac3)
    Dim t, t2, flag, xt, yt, zt
    oc = oc + 1 'object count - used for object id number

    For t = 1 To rawtxtot 'find number of details in this object
        If raw(t).n = n Then
            t2 = 1
            flag = 0
            Do 'search foo() array for availability
                If foo(t2).det.n = 0 Then
                    flag = 1
                Else
                    t2 = t2 + 1
                End If
            Loop Until flag > 0
            't2 is next available array position


            foo(t2).det.n = n: foo(t2).pos1.x = x: foo(t2).pos1.y = y: foo(t2).pos1.z = z: foo(t2).sc = sc

            xt = raw(t).x1: yt = raw(t).y1: zt = raw(t).z1: objrotation xt, yt, zt, ac, ac2, ac3: foo(t2).det.x1 = xt * sc: foo(t2).det.y1 = yt * sc: foo(t2).det.z1 = zt * sc
            xt = raw(t).x2: yt = raw(t).y2: zt = raw(t).z2: objrotation xt, yt, zt, ac, ac2, ac3: foo(t2).det.x2 = xt * sc: foo(t2).det.y2 = yt * sc: foo(t2).det.z2 = zt * sc
            xt = raw(t).x3: yt = raw(t).y3: zt = raw(t).z3: objrotation xt, yt, zt, ac, ac2, ac3: foo(t2).det.x3 = xt * sc: foo(t2).det.y3 = yt * sc: foo(t2).det.z3 = zt * sc
            xt = raw(t).x4: yt = raw(t).y4: zt = raw(t).z4: objrotation xt, yt, zt, ac, ac2, ac3: foo(t2).det.x4 = xt * sc: foo(t2).det.y4 = yt * sc: foo(t2).det.z4 = zt * sc

            foo(t2).det.ix = raw(t).ix: foo(t2).det.iy = raw(t).iy: foo(t2).det.in = raw(t).in
        End If
    Next t
End Sub


Sub objrotation (x, y, z, a, a2, a3)
    Dim xt, yt, zt, h, h1, h2, xt2, yt2, zt2
    Dim y2
    'yz rotation
    yt = y: zt = z
    h = _Hypot(zt, yt)
    h1 = _Atan2(yt, zt)
    h2 = h1 - a2
    yt2 = Sin(h2) * h
    zt2 = Cos(h2) * h
    y2 = yt2
    z = zt2
    'xy rotation
    xt = x: yt = y2
    h = _Hypot(yt, xt)
    h1 = _Atan2(xt, yt)
    h2 = h1 - a
    xt2 = Sin(h2) * h
    yt2 = Cos(h2) * h
    x = xt2
    y = yt2
    'xz rotation
    zt = z: xt = x
    h = _Hypot(zt, xt)
    h1 = _Atan2(xt, zt)
    h2 = h1 - a3
    If h2 < 0 Then h2 = h2 + _Pi * 2
    xt2 = Sin(h2) * h
    zt2 = Cos(h2) * h
    z = zt2
    x = xt2

End Sub


Sub moocopy (n, x, y, z, sc, ac, ac2, ac3)
    Dim t, t2, flag, xt, yt, zt
    oc = oc + 1 'object count - used for object id number

    For t = 1 To rawtxtot 'find number of details in this object
        If raw(t).n = n Then
            t2 = 1
            flag = 0
            Do 'search foo() array for availability
                If moo(t2).det.n = 0 Then
                    flag = 1
                Else
                    t2 = t2 + 1
                End If
            Loop Until flag > 0
            't2 is next available array position
            mootxtot = t2

            moo(t2).det.n = n: moo(t2).pos1.x = x: moo(t2).pos1.y = y: moo(t2).pos1.z = z: moo(t2).sc = sc
            moo(t2).det.n2 = raw(t).n2
            xt = raw(t).x1: yt = raw(t).y1: zt = raw(t).z1: objrotation xt, yt, zt, ac, ac2, ac3: moo(t2).det.x1 = xt * sc: moo(t2).det.y1 = yt * sc: moo(t2).det.z1 = zt * sc
            xt = raw(t).x2: yt = raw(t).y2: zt = raw(t).z2: objrotation xt, yt, zt, ac, ac2, ac3: moo(t2).det.x2 = xt * sc: moo(t2).det.y2 = yt * sc: moo(t2).det.z2 = zt * sc
            xt = raw(t).x3: yt = raw(t).y3: zt = raw(t).z3: objrotation xt, yt, zt, ac, ac2, ac3: moo(t2).det.x3 = xt * sc: moo(t2).det.y3 = yt * sc: moo(t2).det.z3 = zt * sc
            xt = raw(t).x4: yt = raw(t).y4: zt = raw(t).z4: objrotation xt, yt, zt, ac, ac2, ac3: moo(t2).det.x4 = xt * sc: moo(t2).det.y4 = yt * sc: moo(t2).det.z4 = zt * sc

            moo(t2).det.ix = raw(t).ix: moo(t2).det.iy = raw(t).iy: moo(t2).det.in = raw(t).in
            moo(t2).ori.xz = ac3
        End If
    Next t
End Sub





Sub moocopy2 (n, x, y, z, sc)
    Dim t, t2, flag
    oc = oc + 1 'object count - used for object id number

    For t = 1 To rawtxtot 'find number of details in this object
        If raw(t).n = n Then
            t2 = 1
            flag = 0
            Do 'search moo() array for availability
                If moo(t2).det.n = 0 Then
                    flag = 1
                Else
                    t2 = t2 + 1
                End If
            Loop Until flag > 0
            't2 is next available array position

            moo(t2).det.n = n: moo(t2).pos1.x = x: moo(t2).pos1.y = y: moo(t2).pos1.z = z: moo(t2).sc = sc
            moo(t2).det.x1 = raw(t).x1 * sc: moo(t2).det.y1 = raw(t).y1 * sc: moo(t2).det.z1 = raw(t).z1 * sc
            moo(t2).det.x2 = raw(t).x2 * sc: moo(t2).det.y2 = raw(t).y2 * sc: moo(t2).det.z2 = raw(t).z2 * sc
            moo(t2).det.x3 = raw(t).x3 * sc: moo(t2).det.y3 = raw(t).y3 * sc: moo(t2).det.z3 = raw(t).z3 * sc
            moo(t2).det.x4 = raw(t).x4 * sc: moo(t2).det.y4 = raw(t).y4 * sc: moo(t2).det.z4 = raw(t).z4 * sc
            moo(t2).det.ix = raw(t).ix: moo(t2).det.iy = raw(t).iy: moo(t2).det.in = raw(t).in
        End If
    Next t
End Sub




Sub moorotate
    Dim t, x1, y1, x2, y2, x3, y3, x4, y4

    For t = 1 To mootxtot
        If moo(t).det.n = or1(1) Then
            x1 = moo(t).det.x1: y1 = moo(t).det.y1
            xyrotation x1, y1, or1(5)
            x2 = moo(t).det.x2: y2 = moo(t).det.y2
            xyrotation x2, y2, or1(5)
            x3 = moo(t).det.x3: y3 = moo(t).det.y3
            xyrotation x3, y3, or1(5)
            x4 = moo(t).det.x4: y4 = moo(t).det.y4
            xyrotation x4, y4, or1(5)
            moo(t).det.x1 = x1: moo(t).det.y1 = y1
            moo(t).det.x2 = x2: moo(t).det.y2 = y2
            moo(t).det.x3 = x3: moo(t).det.y3 = y3
            moo(t).det.x4 = x4: moo(t).det.y4 = y4
        End If
    Next t
End Sub



Sub processfootextures
    Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
    Dim flag

    flag = 0
    t = 1

    Do
        x1 = foo(t).det.x1 + foo(t).pos1.x: y1 = foo(t).det.y1 + foo(t).pos1.y: z1 = foo(t).det.z1 + foo(t).pos1.z
        x2 = foo(t).det.x2 + foo(t).pos1.x: y2 = foo(t).det.y2 + foo(t).pos1.y: z2 = foo(t).det.z2 + foo(t).pos1.z
        x3 = foo(t).det.x3 + foo(t).pos1.x: y3 = foo(t).det.y3 + foo(t).pos1.y: z3 = foo(t).det.z3 + foo(t).pos1.z
        x4 = foo(t).det.x4 + foo(t).pos1.x: y4 = foo(t).det.y4 + foo(t).pos1.y: z4 = foo(t).det.z4 + foo(t).pos1.z
        x = foo(t).det.ix: y = foo(t).det.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(foo(t).det.in) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
        _MapTriangle (x, y)-(0, y)-(x, 0), tximage(foo(t).det.in) To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth

        t = t + 1
        If foo(t).det.n = 0 Then flag = 1

    Loop Until flag > 0

End Sub




Sub processmootextures
    Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
    Dim flag

    flag = 0
    t = 1

    Do
        x1 = moo(t).det.x1 + moo(t).pos1.x: y1 = moo(t).det.y1 + moo(t).pos1.y: z1 = moo(t).det.z1 + moo(t).pos1.z
        x2 = moo(t).det.x2 + moo(t).pos1.x: y2 = moo(t).det.y2 + moo(t).pos1.y: z2 = moo(t).det.z2 + moo(t).pos1.z
        x3 = moo(t).det.x3 + moo(t).pos1.x: y3 = moo(t).det.y3 + moo(t).pos1.y: z3 = moo(t).det.z3 + moo(t).pos1.z
        x4 = moo(t).det.x4 + moo(t).pos1.x: y4 = moo(t).det.y4 + moo(t).pos1.y: z4 = moo(t).det.z4 + moo(t).pos1.z
        x = moo(t).det.ix: y = moo(t).det.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).det.in) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
        _MapTriangle (x, y)-(0, y)-(x, 0), tximage(moo(t).det.in) To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth

        t = t + 1
        If moo(t).det.n = 0 Then flag = 1

    Loop Until flag > 0

End Sub




Sub processcarriages
    Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
    Dim flag, ct6, ct8, c(50), xc(50), zc(50), k
    Dim xt, zt, h, h2, v, c1

    flag = 0
    ct6 = 0
    ct8 = 0
    For t = 1 To mootxtot

        If moo(t).det.n = 6 Then

            If moo(t).det.n2 = 1 Then
                ct6 = ct6 + 1
                c(ct6) = moo(t).ori.xz
                xc(ct6) = moo(t).pos1.x
                zc(ct6) = moo(t).pos1.z
            End If

        End If


        If moo(t).det.n = 8 Then

            If moo(t).det.n2 = 1 Then
                ct8 = ct8 + 1
                k = c(ct8)
                h2 = k ' + .131
                h = 65.05

                xt = Sin(h2) * h
                zt = Cos(h2) * h

                c1 = Int(Rnd * 6) + 12
                moo(t).pos1.x = xc(ct8) + xt: moo(t).pos1.z = zc(ct8) + zt

                'Locate 1, 1
                'Print t

                For v = 1 To 18
                    moo(t + v).pos1.x = xc(ct8) + xt: moo(t + v).pos1.z = zc(ct8) + zt
                Next v


            End If


        End If

    Next t
    'Locate 1, 1
    'Print ct6, ct8
    'Print c(1); c(2); c(3); c(4)
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 yzrotation (y, z, a)
    Dim zt, yt, h, h1, h2, zt2, yt2
    zt = z: yt = y
    h = _Hypot(zt, yt)
    h1 = _Atan2(yt, zt)
    h2 = h1 - a
    If h2 < 0 Then h2 = h2 + _Pi * 2
    yt2 = Sin(h2) * h
    zt2 = Cos(h2) * h
    z = zt2
    y = yt2
End Sub


Sub xzrotation (x, z, a)
    Dim zt, xt, h, h1, h2, zt2, xt2
    zt = z: xt = x
    h = _Hypot(zt, xt)
    h1 = _Atan2(xt, zt)
    h2 = h1 - a
    If h2 < 0 Then h2 = h2 + _Pi * 2
    xt2 = Sin(h2) * h
    zt2 = Cos(h2) * h
    z = zt2
    x = xt2
End Sub





Sub makeground
    Dim t, x1, y1, s, s2, x, y, c, ed
    s = 320
    s2 = (500 - s) / 2
    Cls
    Line (0, 0)-(500, 500), c(14), BF 'border/beach
    Line (0, 0)-(500, 500), c(40), BF 'ground background
    For y = 1 To 500
        For x = 1 To 500
            x1 = x / 50
            y1 = y / 50
            ed = exact_deep(y1, x1)
            s = 0 - ed
            c(99) = _RGBA(10 - s / 2, 40 - s / 2, 30 - s / 2, s)
            For t = 1 To 60
                If s > t + 5 Then
                    'PSet (x, y), c(99)
                    Circle (x, y), 1, c(99)
                End If
            Next t


            'texture dots
            s2 = Rnd * 15
            c(99) = _RGBA(120, 100, 70, 5)
            If s2 > 2 Then Circle (x, y), 1, c(99)
            c(99) = _RGBA(125, 95, 70, 5)
            If s2 > 3 Then Circle (x, y), 1, c(99)


        Next x
    Next y
    '_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, 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
                    trz(t) = 0 - Int(Rnd * 8) - 2
                    xh = Abs(trx(t) - x1 / 2)
                    yh = Abs(try(t) - y1 / 2)
                    vc = _Hypot(xh, yh)
                    vc = 140 - vc
                    trz(t) = trz(t) - vc / 12
                    'trz(t) = trz(t) - (Int(Rnd * vc))
                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

    'set some terrain z points manually
    trz(13) = -8
    trz(24) = -9
    trz(35) = -10
    trz(46) = -9
    trz(57) = -8

    trz(14) = -8
    trz(25) = -9
    trz(36) = -10
    trz(47) = -9
    trz(58) = -8

    trz(15) = -7

    trz(48) = -14
    trz(59) = -14
    trz(70) = -14

    trz(49) = -14
    trz(60) = -14
    trz(71) = -14



    '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

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 = 1 To 20
        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(35, 70, 100)
    c(4) = _RGB(40, 250, 10)
    c(5) = _RGB(0, 25, 75)
    c(6) = _RGB(45, 35, 20)
    c(7) = _RGB(100, 100, 105)
    c(8) = _RGB(75, 75, 80)
    c(9) = _RGB(50, 50, 55)
    c(10) = _RGB(95, 95, 100)
    c(11) = _RGB(50, 150, 50)
    c(12) = _RGB(150, 50, 50)
    c(13) = _RGB(0, 45, 85)
    c(14) = _RGB(160, 150, 100)
    c(15) = _RGB(0, 25, 75)
    c(16) = _RGB(55, 25, 30)
    c(17) = _RGB(175, 175, 175)
    c(18) = _RGB(100, 100, 100)
    c(20) = _RGB(20, 30, 15)
    c(31) = _RGB(255, 255, 255)
    c(32) = _RGB(255, 0, 0)
    c(33) = _RGB(0, 55, 255)
    c(34) = _RGB(255, 255, 0)
    c(40) = _RGBA(45, 20, 25, 125)
    c(41) = _RGBA(50, 50, 30, 40)
    c(42) = _RGBA(20, 30, 15, 40)
    c(43) = _RGBA(75, 45, 15, 40)
    c(44) = _RGBA(40, 60, 30, 40)
    c(45) = _RGB(50, 50, 30)
    c(46) = _RGB(20, 30, 15)
    c(47) = _RGB(55, 45, 15)
    c(48) = _RGB(40, 50, 10)
    c(51) = _RGBA(10, 40, 30, 160)
    c(52) = _RGBA(10, 43, 30, 140)
    c(53) = _RGBA(10, 46, 30, 120)
    c(54) = _RGBA(10, 49, 30, 100)
    c(55) = _RGBA(10, 52, 30, 80)
    c(56) = _RGBA(10, 55, 30, 60)
    c(57) = _RGBA(10, 58, 30, 40)
    c(58) = _RGBA(10, 61, 30, 20)
    c(59) = _RGBA(10, 64, 30, 10)

End Sub



Sub objrotate
    Dim t, x1, y1, x2, y2, x3, y3, x4, y4

    For t = 1 To txtot
        If moo(t).det.n = or1(1) Then
            x1 = moo(t).det.x1 - or1(2): y1 = moo(t).det.y1 - or1(4)
            xyrotation x1, y1, or1(5)
            x2 = moo(t).det.x2 - or1(2): y2 = moo(t).det.y2 - or1(4)
            xyrotation x2, y2, or1(5)
            x3 = moo(t).det.x3 - or1(2): y3 = moo(t).det.y3 - or1(4)
            xyrotation x3, y3, or1(5)
            x4 = moo(t).det.x4 - or1(2): y4 = moo(t).det.y4 - or1(4)
            xyrotation x4, y4, or1(5)
            moo(t).det.x1 = x1 + or1(2): moo(t).det.y1 = y1 + or1(4)
            moo(t).det.x2 = x2 + or1(2): moo(t).det.y2 = y2 + or1(4)
            moo(t).det.x3 = x3 + or1(2): moo(t).det.y3 = y3 + or1(4)
            moo(t).det.x4 = x4 + or1(2): moo(t).det.y4 = y4 + or1(4)
        End If
    Next t
End Sub


Sub objrotate2
    Dim t, y1, z1, y2, z2, y3, z3, y4, z4

    For t = 1 To txtot
        If moo(t).det.n = or1(1) Then
            y1 = moo(t).det.y1 - or1(2): z1 = moo(t).det.z1 - or1(4)
            yzrotation y1, z1, or1(5)
            y2 = moo(t).det.y2 - or1(2): z2 = moo(t).det.z2 - or1(4)
            yzrotation y2, z2, or1(5)
            y3 = moo(t).det.y3 - or1(2): z3 = moo(t).det.z3 - or1(4)
            yzrotation y3, z3, or1(5)
            y4 = moo(t).det.y4 - or1(2): z4 = moo(t).det.z4 - or1(4)
            yzrotation y4, z4, or1(5)
            moo(t).det.y1 = y1 + or1(2): moo(t).det.z1 = z1 + or1(4)
            moo(t).det.y2 = y2 + or1(2): moo(t).det.z2 = z2 + or1(4)
            moo(t).det.y3 = y3 + or1(2): moo(t).det.z3 = z3 + or1(4)
            moo(t).det.y4 = y4 + or1(2): moo(t).det.z4 = z4 + or1(4)
        End If
    Next t
End Sub


Sub objrotate3
    Dim t, x1, z1, x2, z2, x3, z3, x4, z4

    For t = 1 To mootxtot
        If moo(t).det.n = or1(1) Then
            x1 = moo(t).det.x1 - or1(2): z1 = moo(t).det.z1 - or1(4)
            xzrotation x1, z1, or1(5)
            x2 = moo(t).det.x2 - or1(2): z2 = moo(t).det.z2 - or1(4)
            xzrotation x2, z2, or1(5)
            x3 = moo(t).det.x3 - or1(2): z3 = moo(t).det.z3 - or1(4)
            xzrotation x3, z3, or1(5)
            x4 = moo(t).det.x4 - or1(2): z4 = moo(t).det.z4 - or1(4)
            xzrotation x4, z4, or1(5)
            moo(t).det.x1 = x1 + or1(2): moo(t).det.z1 = z1 + or1(4)
            moo(t).det.x2 = x2 + or1(2): moo(t).det.z2 = z2 + or1(4)
            moo(t).det.x3 = x3 + or1(2): moo(t).det.z3 = z3 + or1(4)
            moo(t).det.x4 = x4 + or1(2): moo(t).det.z4 = z4 + or1(4)
            moo(t).ori.xz = moo(t).ori.xz - or1(5)
            If moo(t).ori.xz > 7 Then
                moo(t).ori.xz = moo(t).ori.xz - (2 * _Pi)
            End If
            If moo(t).ori.xz < -7 Then
                moo(t).ori.xz = moo(t).ori.xz + (2 * _Pi)
            End If

        End If
    Next t

End Sub
Reply
#2
I see what's happened here. An idea to quickly transform a scene to 3D became a labour of love and transformed into something quite wonderful Cool
RokCoder - dabbling in QB64pe for fun
Reply
#3
Thumbs Up 
Wow! nice 3D work James!
b = b + ...
Reply
#4
Made my giblets draw up just like being on the real thing. Excellent job. A real work of art.
DO: LOOP: DO: LOOP
sha_na_na_na_na_na_na_na_na_na:
Reply
#5
Thank you for the kind words!   


The island was the original project, but once that was made I wondered what could be done with it.    Before the Ferris wheel, I was messing around with throwing sticks, which eventually became throwing axes.  

If you want to try it, press the down arrow key to throw an axe.   I set the max at 100.    


Code: (Select All)
'Axe Island - 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 Shared 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
Dim Shared or1(5), key1, keyct, ks, ksct, oc





maketerrain


Cls


colour1

Dim Shared ground1, sky1, panel1, treering(4), cbx(200)



ground1 = _NewImage(500, 500, 32): makeground
sky1 = _NewImage(750, 750, 32): makesky
treering(1) = _NewImage(400, 400, 32)
treering(2) = _NewImage(400, 400, 32)
treering(3) = _NewImage(400, 400, 32)
treering(4) = _NewImage(400, 400, 32): maketreerings
panel1 = _NewImage(500, 500, 32): makepanel

For t = 1 To 20: cbx(t) = _NewImage(400, 400, 32): Next t: makepallette

Dim Shared tximage(200)
For t = 1 To 20: tximage(t) = _CopyImage(cbx(t), 33): Next t

tximage(0) = _CopyImage(ground1, 33)
tximage(195) = _CopyImage(panel1, 33)
tximage(197) = _CopyImage(treering(1), 33)
tximage(198) = _CopyImage(treering(2), 33)
tximage(199) = _CopyImage(treering(3), 33)

Type rawobject
    n As Integer 'object drawing number
    n2 As Integer 'drawing detail number
    n3 As Integer 'total number of details
    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(1000) As rawobject

Type xyzgroup
    x As Single
    y As Single
    z As Single
End Type

Type axisgroup
    xy As Single
    yz As Single
    xz As Single
End Type


Type mapobject
    det As rawobject 'details
    pos1 As xyzgroup 'position
    ori As axisgroup 'orientation
    vel1 As xyzgroup 'velocity
    sp As Single 'speed
    sc As Single 'scale
End Type

Dim Shared foo(900) As mapobject 'fixed objects eg water
Dim Shared moo(900) As mapobject 'moveable objects
Dim Shared post(100, 50) As mapobject 'specific object called 'post' which has 5 surfaces
Dim Shared stk(100, 50) As mapobject 'stick to throw

'create texture point data array
Dim Shared tx(500, 19), txtot, rawtxtot, mootxtot

'objects and data points
Data 1,1,1,-1000,0,200,-1000,0,-200,1000,0,200,1000,0,-200,500,100,12: 'wall
Data 2,1,1,-4000,-4000,0,-4000,4000,0,4000,-4000,0,4000,4000,0,500,100,3: 'water
Data 3,1,5,-.5,-.5,0,.5,-.5,0,-.5,-.5,-20,.5,-.5,-20,100,100,6: 'post
Data 3,2,5,-.5,.5,0,.5,.5,0,-.5,.5,-20,.5,.5,-20,100,100,6: 'post
Data 3,3,5,-.5,-.5,0,-.5,.5,0,-.5,-.5,-20,-.5,.5,-20,100,100,2: 'post
Data 3,4,5,.5,-.5,0,.5,.5,0,.5,-.5,-20,.5,.5,-20,100,100,2: 'post
Data 3,5,5,.5,-.5,-20,.5,.5,-20,-.5,-.5,-20,-.5,.5,-20,100,100,0: 'post top
Data 4,1,5,-.1,-.1,0,.1,-.1,0,-3,-3,-19,3,-3,-19,100,100,6: 'block
Data 4,2,5,-.1,.1,0,.1,.1,0,-3,3,-19,3,3,-19,100,100,6: 'block
Data 4,3,5,-.1,-.1,0,-.1,.1,0,-3,-3,-19,-3,3,-19,100,100,2: 'block
Data 4,4,5,.1,-.1,0,.1,.1,0,3,-3,-19,3,3,-19,100,100,2: 'block
Data 4,5,5,3,-3,-19,3,3,-19,-3,-3,-19,-3,3,-19,100,100,0: 'block top
Data 4,5,5,3,-3,-19,3,3,-19,-3,-3,-22,-3,3,-22,100,100,0: 'block top
Data 5,1,19,-1.5,-1.5,0,1.5,-1.5,0,-2.5,-1.5,20,.5,-1.5,20,100,100,6: 'stick
Data 5,2,1,-1.5,1.5,0,1.5,1.5,0,-2.5,1.5,20,.5,1.5,20,100,100,6: 'stick
Data 5,3,1,-1.5,-1.5,0,-1.5,1.5,0,-2.5,-1.5,20,-2.5,1.5,20,100,100,2: 'stick
Data 5,4,1,1.5,-1.5,0,1.5,1.5,0,.5,-1.5,20,.5,1.5,20,100,100,2: 'stick
Data 5,5,1,.5,-1.5,20,.5,1.5,20,-2.5,-1.5,20,-2.5,1.5,20,100,100,11: 'stick top
Data 5,6,1,-1.5,-1.5,0,1.5,-1.5,0,-2.2,-1.5,-20,.8,-1.5,-20,100,100,6: 'stick
Data 5,7,1,-1.5,1.5,0,1.5,1.5,0,-2.2,1.5,-20,.8,1.5,-20,100,100,6: 'stick
Data 5,8,1,-1.5,-1.5,0,-1.5,1.5,0,-2.2,-1.5,-20,-2.2,1.5,-20,100,100,2: 'stick
Data 5,9,1,1.5,-1.5,0,1.5,1.5,0,.8,-1.5,-20,.8,1.5,-20,100,100,2: 'stick
Data 5,10,1,.8,-1.5,-20,.8,1.5,-20,-2.2,-1.5,-20,-2.2,1.5,-20,100,100,11: 'stick top
Data 5,11,1,-9,0,-20,-9,0,-20,3,3,-17,3,-3,-17,100,100,9: 'axe top cover
Data 5,12,1,-10,0,-17,-9,0,-20,3,3,-16,3,3,-17,100,100,10: 'axe top edge
Data 5,13,1,-10,0,-17,-9,0,-20,3,-3,-16,3,-3,-17,100,100,7: 'axe top edge
Data 5,14,1,-10,0,-14,-10,0,-17,3,3,-15,3,3,-16,100,100,10: 'axe mid edge
Data 5,15,1,-10,0,-14,-10,0,-17,3,-3,-15,3,-3,-16,100,100,7: 'axe mid edge
Data 5,16,1,-10,0,-14,-9,0,-11,3,3,-15,3,3,-14,100,100,10: 'axe bottom edge
Data 5,17,1,-10,0,-14,-9,0,-11,3,-3,-15,3,-3,-14,100,100,7: 'axe bottom edge
Data 5,18,1,-9,0,-11,-9,0,-11,3,3,-14,3,-3,-14,100,100,9: 'axe bottom cover
Data 5,19,1,3,3,-17,3,3,-14,3,-3,-17,3,-3,-14,100,100,8: 'axe back cover
Data 6,1,11,-.3827,-.9239,1,.3827,-.9239,1,-.3827,-.9239,-15,.3827,-.9239,-15,100,100,6: 'trunk
Data 6,1,1,.3827,-.9239,1,.9239,-.3827,1,.3827,-.9239,-15,.9239,-.3827,-15,100,100,2: 'trunk
Data 6,1,1,.9239,-.3827,1,.9239,.3827,1,.9239,-.3827,-15,.9239,.3827,-15,100,100,6: 'trunk
Data 6,1,1,.9239,.3827,1,.3827,.9239,1,.9239,.3827,-15,.3827,.9239,-15,100,100,2: 'trunk
Data 6,1,1,.3827,.9239,1,-.3827,.9239,1,.3827,.9239,-15,-.3827,.9239,-15,100,100,6: 'trunk
Data 6,1,1,-.3827,.9239,1,-.9239,.3827,1,-.3827,.9239,-15,-.9239,.3827,-15,100,100,2: 'trunk
Data 6,1,1,-.9239,.3827,1,-.9239,-.3827,1,-.9239,.3827,-15,-.9239,-.3827,-15,100,100,6: 'trunk
Data 6,1,1,-.9239,-.3827,1,-.3827,-.9239,1,-.9239,-.3827,-15,-.3827,-.9239,-15,100,100,2: 'trunk
Data 6,1,1,-.9239,.9239,-15,.9239,.9239,-15,-.9239,.3827,-15,.9239,.3827,-15,400,133,197: 'trunk top
Data 6,1,1,-.9239,.3827,-15,.9239,.3827,-15,-.9239,-.3827,-15,.9239,-.3827,-15,400,133,198: 'trunk top
Data 6,1,1,-.9239,-.9239,-15,.9239,-.9239,-15,-.9239,-.3827,-15,.9239,-.3827,-15,400,133,199: 'trunk top
Data 7,1,6,-15,-.5,0,15,-.5,0,-15,-.5,-20,15,-.5,-20,300,300,195: 'wall
Data 7,2,1,-15,.5,0,15,.5,0,-15,.5,-20,15,.5,-20,300,300,195: 'wall
Data 7,3,1,-15,-.5,0,-15,.5,0,-15,-.5,-20,-15,.5,-20,100,100,2: 'wall
Data 7,4,1,15,-.5,0,15,.5,0,15,-.5,-20,15,.5,-20,100,100,2: 'wall
Data 7,5,1,15,-.5,-20,15,.5,-20,-15,-.5,-20,-15,.5,-20,100,100,2: 'wall top
Data 7,5,1,15,-.5,0,15,.5,0,-15,-.5,0,-15,.5,0,100,100,2: 'wall top
Data 8,1,5,-10,-.5,0,10,-.5,0,-10,-.5,-20,10,-.5,-20,300,300,195: 'wall
Data 8,2,5,-10,.5,0,10,.5,0,-10,.5,-20,10,.5,-20,300,300,195: 'wall
Data 8,3,5,-10,-.5,0,-10,.5,0,-10,-.5,-20,-10,.5,-20,100,100,2: 'wall
Data 8,4,5,10,-.5,0,10,.5,0,10,-.5,-20,10,.5,-20,100,100,2: 'wall
Data 8,5,5,10,-.5,-20,10,.5,-20,-10,-.5,-20,-10,.5,-20,100,100,5: 'wall top
Data 9,1,5,-15,-.5,0,15,-.5,0,-15,-.5,-20,15,-.5,-20,100,100,195: 'wall
Data 9,2,5,-15,.5,0,15,.5,0,-15,.5,-20,15,.5,-20,100,100,195: 'wall
Data 9,3,5,-15,-.5,0,-15,.5,0,-15,-.5,-20,-15,.5,-20,100,100,195: 'wall
Data 9,4,5,15,-.5,0,15,.5,0,15,-.5,-20,15,.5,-20,100,100,195: 'wall
Data 9,5,5,15,-.5,-20,15,.5,-20,-15,-.5,-20,-15,.5,-20,100,100,195: 'wall end
Data 9,5,5,15,-.5,0,15,.5,0,-15,-.5,0,-15,.5,0,100,100,195: 'wall end



rawtxtot = 60: txtot = rawtxtot


'read data into array tx()
Dim t2
For t = 1 To txtot
    For t2 = 1 To 18
        Read tx(t, t2)
    Next t2
    'create 'raw' objects
    raw(t).n = tx(t, 1): raw(t).n2 = tx(t, 2): raw(t).n3 = tx(t, 3)
    raw(t).x1 = tx(t, 4): raw(t).y1 = tx(t, 5): raw(t).z1 = tx(t, 6)
    raw(t).x2 = tx(t, 7): raw(t).y2 = tx(t, 8): raw(t).z2 = tx(t, 9)
    raw(t).x3 = tx(t, 10): raw(t).y3 = tx(t, 11): raw(t).z3 = tx(t, 12)
    raw(t).x4 = tx(t, 13): raw(t).y4 = tx(t, 14): raw(t).z4 = tx(t, 15)
    raw(t).ix = tx(t, 16): raw(t).iy = tx(t, 17): raw(t).in = tx(t, 18)
Next t




Dim n1, n2, n3, n4, n5, n6, n7 'n, x, y, z, sc,ac,ac2

'water
n1 = 2: n2 = 0: n3 = 0: n4 = 500: n5 = 1: n6 = 0: n7 = 0: foocopy n1, n2, n3, n4, n5, n6, n7 'water

'giant axe
n1 = 5: n2 = 150: n3 = 75: n4 = 485 + exact_deep(n3 / 50, n2 / 50): n5 = 1: n6 = 3.14: n7 = 0: foocopy n1, n2, n3, n4, n5, n6, n7 'giant axe

'tree stumps
Dim xt, yt, zt
For t = 1 To 15
    xt = Rnd * 100 + 200: yt = Rnd * 320 + 70: zt = exact_deep(yt / 50, xt / 50)
    If zt < -12 Then
        n1 = 6: n2 = xt: n3 = yt: n4 = Rnd * 2 + 522 + zt: n5 = 1.6: n6 = 0: n7 = 0
        foocopy n1, n2, n3, n4, n5, n6, n7 'tree stump
    End If
    xt = Rnd * 100 + 200: yt = Rnd * 320 + 70: zt = exact_deep(yt / 50, xt / 50)
    If zt < -12 Then
        n1 = 6: n2 = xt: n3 = yt: n4 = Rnd * 2 + 511 + zt: n5 = .8: n6 = 0: n7 = 0
        foocopy n1, n2, n3, n4, n5, n6, n7 'tree stump
    End If
Next t

'hut
'n1 = 9: n2 = 248.5: n3 = 184: n4 = 502 + exact_deep(n3 / 50, n2 / 50): n5 = .3: n6 = 0: n7 = 0: foocopy n1, n2, n3, n4, n5, n6, n7 'front counter
'n1 = 9: n2 = 248.5: n3 = 181: n4 = 497 + exact_deep(n3 / 50, n2 / 50): n5 = .3: n6 = 0: n7 = 1.572: foocopy n1, n2, n3, n4, n5, n6, n7 'front counter
n1 = 8: n2 = 250: n3 = 166.7: n4 = 502 + exact_deep(n3 / 50, n2 / 50): n5 = .6: n6 = 0: n7 = 0: foocopy n1, n2, n3, n4, n5, n6, n7 'wall
n1 = 7: n2 = 243.65: n3 = 175: n4 = 502 + exact_deep(n3 / 50, n2 / 50): n5 = .6: n6 = 1.57: n7 = 0: foocopy n1, n2, n3, n4, n5, n6, n7 'wall
n1 = 7: n2 = 256.35: n3 = 175: n4 = 502 + exact_deep(n3 / 50, n2 / 50): n5 = .6: n6 = 1.57: n7 = 0: foocopy n1, n2, n3, n4, n5, n6, n7 'wall
n1 = 9: n2 = 260: n3 = 177: n4 = 502 + exact_deep(n3 / 50, n2 / 50): n5 = 1.: n6 = 1.57: n7 = 1.572: foocopy n1, n2, n3, n4, n5, n6, n7 'floor
n1 = 9: n2 = 261: n3 = 175: n4 = 491.5 + exact_deep(n3 / 50, n2 / 50): n5 = .6: n6 = 1.57: n7 = 1.18: foocopy n1, n2, n3, n4, n5, n6, n7 'roof
n1 = 9: n2 = 239: n3 = 175.01: n4 = 491.5 + exact_deep(n3 / 50, n2 / 50): n5 = .6: n6 = 1.57: n7 = -1.18: foocopy n1, n2, n3, n4, n5, n6, n7 'roof


'create spectator
Dim Shared sp(6)
sp(0) = 250 'X position
sp(1) = 250 'Y
sp(2) = 470 '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 = _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


    'keyboard input
    keyct = keyct + 1
    If keyct > 10 Then 'wait before more input
        key1 = keyboard
        keyct = 0
    Else
        key1 = 0
    End If


    'keyboard actions
    If key1 = 1 Then
        ksct = 1
        ks = ks + 1
    End If
    If key1 = 2 Then
        ksct = 1
        ks = ks - 1
        If ks < 1 Then ks = 1
    End If
    ksct = ksct + 1
    If ksct > 200 Then ks = 0


    If key1 = 4 Then
        deletepost
    End If


    If key1 = 3 Then
        If ks < 100 Then throwstick
    End If

    processterrain
    processfootextures
    processmootextures
    processposttextures

    stickrotatexz
    processthrow


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

    Locate 1, 1
    'Print vec_x
    'Print vec_y

Loop Until _KeyDown(27)



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


Function keyboard
    keyboard = 0

    If _KeyDown(19712) Then '                                IF right arrow key was pressed
        keyboard = 1
    End If

    If _KeyDown(19200) Then '                                IF left arrow key was pressed
        keyboard = 2
    End If

    If _KeyDown(20480) Then '                                IF down arrow key was pressed
        keyboard = 3
    End If

    If _KeyDown(18432) Then '                                IF up arrow key was pressed
        keyboard = 4
    End If

End Function



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 throwstick
    Dim n1, n2, n3, n4, n5 'n, x, y, z, sc
    n1 = 5
    n2 = sp(0)
    n3 = sp(1)
    'n4 = 495 + exact_deep(n3 / 50, n2 / 50)
    n4 = sp(2)
    n5 = .09
    newstick n1, n2, n3, n4, n5 'stick

End Sub


Sub deletepost
    post(ks, 1).det.n = 0
End Sub


Sub deletestick
    stk(ks, 1).det.n = 0
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 processterrain
    Dim x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
    Dim xx1, yy1, xx2, yy2, xx3, yy3
    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 = 502 'shift z position

    Do
        ct = ct + 1

        x1 = trx(fr1(ct)): y1 = try(fr1(ct)): z1 = trz(fr1(ct))
        x2 = trx(fr2(ct)): y2 = try(fr2(ct)): z2 = trz(fr2(ct))
        x3 = trx(fr3(ct)): y3 = try(fr3(ct)): z3 = trz(fr3(ct))

        xx1 = x1: yy1 = y1
        xx2 = x2: yy2 = y2
        xx3 = x3: yy3 = y3


        x1 = x1 * scale1: y1 = y1 * scale1: 'z1 = z1 * scale1
        x2 = x2 * scale1: y2 = y2 * scale1: 'z2 = z2 * scale1
        x3 = x3 * scale1: y3 = y3 * scale1: 'z3 = z3 * scale1
        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 = 0
        _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 foocopy (n, x, y, z, sc, ac, ac2)
    Dim t, t2, flag, xt, yt, zt
    oc = oc + 1 'object count - used for object id number

    For t = 1 To rawtxtot 'find number of details in this object
        If raw(t).n = n Then
            t2 = 1
            flag = 0
            Do 'search foo() array for availability
                If foo(t2).det.n = 0 Then
                    flag = 1
                Else
                    t2 = t2 + 1
                End If
            Loop Until flag > 0
            't2 is next available array position


            foo(t2).det.n = n: foo(t2).pos1.x = x: foo(t2).pos1.y = y: foo(t2).pos1.z = z: foo(t2).sc = sc

            xt = raw(t).x1: yt = raw(t).y1: zt = raw(t).z1: objrotation xt, yt, zt, ac, ac2: foo(t2).det.x1 = xt * sc: foo(t2).det.y1 = yt * sc: foo(t2).det.z1 = zt * sc
            xt = raw(t).x2: yt = raw(t).y2: zt = raw(t).z2: objrotation xt, yt, zt, ac, ac2: foo(t2).det.x2 = xt * sc: foo(t2).det.y2 = yt * sc: foo(t2).det.z2 = zt * sc
            xt = raw(t).x3: yt = raw(t).y3: zt = raw(t).z3: objrotation xt, yt, zt, ac, ac2: foo(t2).det.x3 = xt * sc: foo(t2).det.y3 = yt * sc: foo(t2).det.z3 = zt * sc
            xt = raw(t).x4: yt = raw(t).y4: zt = raw(t).z4: objrotation xt, yt, zt, ac, ac2: foo(t2).det.x4 = xt * sc: foo(t2).det.y4 = yt * sc: foo(t2).det.z4 = zt * sc

            'foo(t2).det.x1 = raw(t).x1 * sc: foo(t2).det.y1 = raw(t).y1 * sc: foo(t2).det.z1 = raw(t).z1 * sc
            'foo(t2).det.x2 = raw(t).x2 * sc: foo(t2).det.y2 = raw(t).y2 * sc: foo(t2).det.z2 = raw(t).z2 * sc
            'foo(t2).det.x3 = raw(t).x3 * sc: foo(t2).det.y3 = raw(t).y3 * sc: foo(t2).det.z3 = raw(t).z3 * sc
            'foo(t2).det.x4 = raw(t).x4 * sc: foo(t2).det.y4 = raw(t).y4 * sc: foo(t2).det.z4 = raw(t).z4 * sc

            foo(t2).det.ix = raw(t).ix: foo(t2).det.iy = raw(t).iy: foo(t2).det.in = raw(t).in
        End If
    Next t
End Sub


Sub objrotation (x, y, z, a, a2)
    Dim xt, yt, zt, h, h1, h2, xt2, yt2, zt2
    Dim y2
    'yz rotation
    yt = y: zt = z
    h = _Hypot(zt, yt)
    h1 = _Atan2(yt, zt)
    h2 = h1 - a2
    yt2 = Sin(h2) * h
    zt2 = Cos(h2) * h
    y2 = yt2
    z = zt2
    'xy rotation
    xt = x: yt = y2
    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 moocopy (n, x, y, z, sc)
    Dim t, t2, flag
    oc = oc + 1 'object count - used for object id number

    For t = 1 To rawtxtot 'find number of details in this object
        If raw(t).n = n Then
            t2 = 1
            flag = 0
            Do 'search moo() array for availability
                If moo(t2).det.n = 0 Then
                    flag = 1
                Else
                    t2 = t2 + 1
                End If
            Loop Until flag > 0
            't2 is next available array position

            moo(t2).det.n = n: moo(t2).pos1.x = x: moo(t2).pos1.y = y: moo(t2).pos1.z = z: moo(t2).sc = sc
            moo(t2).det.x1 = raw(t).x1 * sc: moo(t2).det.y1 = raw(t).y1 * sc: moo(t2).det.z1 = raw(t).z1 * sc
            moo(t2).det.x2 = raw(t).x2 * sc: moo(t2).det.y2 = raw(t).y2 * sc: moo(t2).det.z2 = raw(t).z2 * sc
            moo(t2).det.x3 = raw(t).x3 * sc: moo(t2).det.y3 = raw(t).y3 * sc: moo(t2).det.z3 = raw(t).z3 * sc
            moo(t2).det.x4 = raw(t).x4 * sc: moo(t2).det.y4 = raw(t).y4 * sc: moo(t2).det.z4 = raw(t).z4 * sc
            moo(t2).det.ix = raw(t).ix: moo(t2).det.iy = raw(t).iy: moo(t2).det.in = raw(t).in
        End If
    Next t
End Sub



Sub postcopy (n, x, y, z, sc)
    Dim t, t2, t3, flag

    t2 = 1
    Do 'search moo() array for availability
        If post(t2, 1).det.n = 0 Then
            flag = 1
        Else
            t2 = t2 + 1
            If t2 > 99 Then flag = 2
        End If
    Loop Until flag > 0
    't2 is next available array position

    If flag < 2 Then

        t3 = 0
        For t = 1 To rawtxtot
            If raw(t).n = n Then
                t3 = t3 + 1
                post(t2, t3).det.n = n: post(t2, t3).pos1.x = x: post(t2, t3).pos1.y = y: post(t2, t3).pos1.z = z: post(t2, t3).sc = sc
                post(t2, t3).det.x1 = raw(t).x1 * sc: post(t2, t3).det.y1 = raw(t).y1 * sc: post(t2, t3).det.z1 = raw(t).z1 * sc
                post(t2, t3).det.x2 = raw(t).x2 * sc: post(t2, t3).det.y2 = raw(t).y2 * sc: post(t2, t3).det.z2 = raw(t).z2 * sc
                post(t2, t3).det.x3 = raw(t).x3 * sc: post(t2, t3).det.y3 = raw(t).y3 * sc: post(t2, t3).det.z3 = raw(t).z3 * sc
                post(t2, t3).det.x4 = raw(t).x4 * sc: post(t2, t3).det.y4 = raw(t).y4 * sc: post(t2, t3).det.z4 = raw(t).z4 * sc
                post(t2, t3).det.ix = raw(t).ix: post(t2, t3).det.iy = raw(t).iy: post(t2, t3).det.in = raw(t).in
            End If
        Next t
    End If
End Sub



Sub newstick (n, x, y, z, sc)
    Dim t, t2, t3, flag
    Dim vx, vy, vz, spd, ori

    t2 = 1
    Do 'search moo() array for availability
        If stk(t2, 1).det.n = 0 Then
            flag = 1
        Else
            t2 = t2 + 1
            If t2 > 99 Then flag = 2
        End If
    Loop Until flag > 0
    't2 is next available array position

    If flag < 2 Then
        vx = vec_x: vy = vec_y: vz = vec_z
        vx = vx * (Rnd * .2 + .9)
        vy = vy * (Rnd * .2 + .9)
        vz = vz * (Rnd * .2 + .9) - .5
        spd = Rnd * .4 + 1.4
        ori = Rnd * .15 + .1: ori = ori * -1
        t3 = 0
        For t = 1 To rawtxtot
            If raw(t).n = n Then
                t3 = t3 + 1
                stk(t2, t3).det.n = n: stk(t2, t3).pos1.x = x: stk(t2, t3).pos1.y = y: stk(t2, t3).pos1.z = z: stk(t2, t3).sc = sc
                stk(t2, t3).det.x1 = raw(t).x1 * sc: stk(t2, t3).det.y1 = raw(t).y1 * sc: stk(t2, t3).det.z1 = raw(t).z1 * sc
                stk(t2, t3).det.x2 = raw(t).x2 * sc: stk(t2, t3).det.y2 = raw(t).y2 * sc: stk(t2, t3).det.z2 = raw(t).z2 * sc
                stk(t2, t3).det.x3 = raw(t).x3 * sc: stk(t2, t3).det.y3 = raw(t).y3 * sc: stk(t2, t3).det.z3 = raw(t).z3 * sc
                stk(t2, t3).det.x4 = raw(t).x4 * sc: stk(t2, t3).det.y4 = raw(t).y4 * sc: stk(t2, t3).det.z4 = raw(t).z4 * sc
                stk(t2, t3).det.ix = raw(t).ix: stk(t2, t3).det.iy = raw(t).iy: stk(t2, t3).det.in = raw(t).in
                stk(t2, t3).det.n3 = raw(t).n3
                'set velocity and rotation
                stk(t2, t3).vel1.x = vx
                stk(t2, t3).vel1.y = vy
                stk(t2, t3).vel1.z = vz
                stk(t2, t3).sp = spd
                stk(t2, t3).ori.xz = ori

            End If
        Next t
    End If
End Sub






Sub moorotate
    Dim t, x1, y1, x2, y2, x3, y3, x4, y4

    For t = 1 To mootxtot
        If moo(t).det.n = or1(1) Then
            x1 = moo(t).det.x1: y1 = moo(t).det.y1
            xyrotation x1, y1, or1(5)
            x2 = moo(t).det.x2: y2 = moo(t).det.y2
            xyrotation x2, y2, or1(5)
            x3 = moo(t).det.x3: y3 = moo(t).det.y3
            xyrotation x3, y3, or1(5)
            x4 = moo(t).det.x4: y4 = moo(t).det.y4
            xyrotation x4, y4, or1(5)
            moo(t).det.x1 = x1: moo(t).det.y1 = y1
            moo(t).det.x2 = x2: moo(t).det.y2 = y2
            moo(t).det.x3 = x3: moo(t).det.y3 = y3
            moo(t).det.x4 = x4: moo(t).det.y4 = y4
        End If
    Next t
End Sub



Sub processfootextures
    Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
    Dim flag

    flag = 0
    t = 1

    Do
        x1 = foo(t).det.x1 + foo(t).pos1.x: y1 = foo(t).det.y1 + foo(t).pos1.y: z1 = foo(t).det.z1 + foo(t).pos1.z
        x2 = foo(t).det.x2 + foo(t).pos1.x: y2 = foo(t).det.y2 + foo(t).pos1.y: z2 = foo(t).det.z2 + foo(t).pos1.z
        x3 = foo(t).det.x3 + foo(t).pos1.x: y3 = foo(t).det.y3 + foo(t).pos1.y: z3 = foo(t).det.z3 + foo(t).pos1.z
        x4 = foo(t).det.x4 + foo(t).pos1.x: y4 = foo(t).det.y4 + foo(t).pos1.y: z4 = foo(t).det.z4 + foo(t).pos1.z
        x = foo(t).det.ix: y = foo(t).det.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(foo(t).det.in) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
        _MapTriangle (x, y)-(0, y)-(x, 0), tximage(foo(t).det.in) To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth

        t = t + 1
        If foo(t).det.n = 0 Then flag = 1

    Loop Until flag > 0

End Sub




Sub processmootextures
    Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
    Dim flag

    flag = 0
    t = 1

    Do
        x1 = moo(t).det.x1 + moo(t).pos1.x: y1 = moo(t).det.y1 + moo(t).pos1.y: z1 = moo(t).det.z1 + moo(t).pos1.z
        x2 = moo(t).det.x2 + moo(t).pos1.x: y2 = moo(t).det.y2 + moo(t).pos1.y: z2 = moo(t).det.z2 + moo(t).pos1.z
        x3 = moo(t).det.x3 + moo(t).pos1.x: y3 = moo(t).det.y3 + moo(t).pos1.y: z3 = moo(t).det.z3 + moo(t).pos1.z
        x4 = moo(t).det.x4 + moo(t).pos1.x: y4 = moo(t).det.y4 + moo(t).pos1.y: z4 = moo(t).det.z4 + moo(t).pos1.z
        x = moo(t).det.ix: y = moo(t).det.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).det.in) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
        _MapTriangle (x, y)-(0, y)-(x, 0), tximage(moo(t).det.in) To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth

        t = t + 1
        If moo(t).det.n = 0 Then flag = 1

    Loop Until flag > 0

End Sub



Sub processposttextures
    Dim x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
    Dim k, t2, t3

    For t2 = 1 To 100

        If post(t2, 1).det.n > 0 Then
            For t3 = 1 To 6
                x1 = post(t2, t3).det.x1 + post(t2, t3).pos1.x: y1 = post(t2, t3).det.y1 + post(t2, t3).pos1.y: z1 = post(t2, t3).det.z1 + post(t2, t3).pos1.z
                x2 = post(t2, t3).det.x2 + post(t2, t3).pos1.x: y2 = post(t2, t3).det.y2 + post(t2, t3).pos1.y: z2 = post(t2, t3).det.z2 + post(t2, t3).pos1.z
                x3 = post(t2, t3).det.x3 + post(t2, t3).pos1.x: y3 = post(t2, t3).det.y3 + post(t2, t3).pos1.y: z3 = post(t2, t3).det.z3 + post(t2, t3).pos1.z
                x4 = post(t2, t3).det.x4 + post(t2, t3).pos1.x: y4 = post(t2, t3).det.y4 + post(t2, t3).pos1.y: z4 = post(t2, t3).det.z4 + post(t2, t3).pos1.z
                x = post(t2, t3).det.ix: y = post(t2, t3).det.iy

                'if selected
                If t2 = ks Then
                    k = ksct Mod 20
                    k = k / 10
                    z1 = z1 - k: z2 = z2 - k: z3 = z3 - k: z4 = z4 - k
                End If


                r2m x1, y1, z1
                r2m x2, y2, z2
                r2m x3, y3, z3
                r2m x4, y4, z4
                _MapTriangle (0, 0)-(0, y)-(x, 0), tximage(post(t2, t3).det.in) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
                _MapTriangle (x, y)-(0, y)-(x, 0), tximage(post(t2, t3).det.in) To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth

            Next t3
        End If
    Next t2

End Sub



Sub processthrow
    Dim x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
    Dim t2, t3, xt, yt, zt

    For t2 = 1 To 100

        If stk(t2, 1).det.n > 0 Then


            For t3 = 1 To stk(t2, 1).det.n3
                'apply gravity and velocity info
                xt = stk(t2, t3).pos1.x
                yt = stk(t2, t3).pos1.y
                If xt > 0 And xt < 500 Then
                    If yt > 0 And yt < 500 Then

                        xt = stk(t2, t3).pos1.x / 50
                        yt = stk(t2, t3).pos1.y / 50
                        zt = 501 + exact_deep(yt, xt)
                        If stk(t2, t3).pos1.z < zt Then
                            stk(t2, t3).sp = stk(t2, t3).sp * .9995
                            stk(t2, t3).vel1.z = stk(t2, t3).vel1.z + .030
                        Else
                            stk(t2, t3).sp = 0
                            stk(t2, t3).vel1.x = 0
                            stk(t2, t3).vel1.y = 0
                        End If

                    End If
                End If



                stk(t2, t3).pos1.x = stk(t2, t3).pos1.x + stk(t2, t3).vel1.x * stk(t2, t3).sp
                stk(t2, t3).pos1.y = stk(t2, t3).pos1.y + stk(t2, t3).vel1.y * stk(t2, t3).sp
                stk(t2, t3).pos1.z = stk(t2, t3).pos1.z + stk(t2, t3).vel1.z * stk(t2, t3).sp



                If stk(t2, t3).pos1.z > 501 Then
                    stk(t2, 1).det.n = 0
                End If

                x1 = stk(t2, t3).det.x1 + stk(t2, t3).pos1.x: y1 = stk(t2, t3).det.y1 + stk(t2, t3).pos1.y: z1 = stk(t2, t3).det.z1 + stk(t2, t3).pos1.z
                x2 = stk(t2, t3).det.x2 + stk(t2, t3).pos1.x: y2 = stk(t2, t3).det.y2 + stk(t2, t3).pos1.y: z2 = stk(t2, t3).det.z2 + stk(t2, t3).pos1.z
                x3 = stk(t2, t3).det.x3 + stk(t2, t3).pos1.x: y3 = stk(t2, t3).det.y3 + stk(t2, t3).pos1.y: z3 = stk(t2, t3).det.z3 + stk(t2, t3).pos1.z
                x4 = stk(t2, t3).det.x4 + stk(t2, t3).pos1.x: y4 = stk(t2, t3).det.y4 + stk(t2, t3).pos1.y: z4 = stk(t2, t3).det.z4 + stk(t2, t3).pos1.z
                x = stk(t2, t3).det.ix: y = stk(t2, t3).det.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(stk(t2, t3).det.in) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
                _MapTriangle (x, y)-(0, y)-(x, 0), tximage(stk(t2, t3).det.in) To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth



            Next t3
        End If
    Next t2

End Sub



Sub stickrotatexz
    Dim t2, t3, x1, z1, x2, z2, x3, z3, x4, z4
    'or1(5) = -.2
    For t2 = 1 To 100
        If stk(t2, 1).det.n > 0 Then
            If stk(t2, 1).sp > .02 Then
                For t3 = 1 To stk(t2, 1).det.n3
                    or1(5) = stk(t2, t3).ori.xz
                    x1 = stk(t2, t3).det.x1: z1 = stk(t2, t3).det.z1
                    xzrotation x1, z1, or1(5)
                    x2 = stk(t2, t3).det.x2: z2 = stk(t2, t3).det.z2
                    xzrotation x2, z2, or1(5)
                    x3 = stk(t2, t3).det.x3: z3 = stk(t2, t3).det.z3
                    xzrotation x3, z3, or1(5)
                    x4 = stk(t2, t3).det.x4: z4 = stk(t2, t3).det.z4
                    xzrotation x4, z4, or1(5)
                    stk(t2, t3).det.x1 = x1: stk(t2, t3).det.z1 = z1
                    stk(t2, t3).det.x2 = x2: stk(t2, t3).det.z2 = z2
                    stk(t2, t3).det.x3 = x3: stk(t2, t3).det.z3 = z3
                    stk(t2, t3).det.x4 = x4: stk(t2, t3).det.z4 = z4
                Next t3
            End If
        End If
    Next t2
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 yzrotation (y, z, a)
    Dim zt, yt, h, h1, h2, zt2, yt2
    zt = z: yt = y
    h = _Hypot(zt, yt)
    h1 = _Atan2(yt, zt)
    h2 = h1 - a
    If h2 < 0 Then h2 = h2 + _Pi * 2
    yt2 = Sin(h2) * h
    zt2 = Cos(h2) * h
    z = zt2
    y = yt2
End Sub


Sub xzrotation (x, z, a)
    Dim zt, xt, h, h1, h2, zt2, xt2
    zt = z: xt = x
    h = _Hypot(zt, xt)
    h1 = _Atan2(xt, zt)
    h2 = h1 - a
    If h2 < 0 Then h2 = h2 + _Pi * 2
    xt2 = Sin(h2) * h
    zt2 = Cos(h2) * h
    z = zt2
    x = xt2
End Sub





Sub makeground
    Dim t, x1, y1, s, s2, x, y, c, ed
    s = 320
    s2 = (500 - s) / 2
    Cls
    Line (0, 0)-(500, 500), c(14), BF 'border/beach
    Line (0, 0)-(500, 500), c(40), BF 'ground background
    For y = 1 To 500
        For x = 1 To 500
            x1 = x / 50
            y1 = y / 50
            ed = exact_deep(y1, x1)
            s = 0 - ed
            c(99) = _RGBA(10 - s / 2, 40 - s / 2, 30 - s / 2, s)
            For t = 1 To 60
                If s > t + 5 Then
                    'PSet (x, y), c(99)
                    Circle (x, y), 1, c(99)
                End If
            Next t


            'texture dots
            s2 = Rnd * 15
            c(99) = _RGBA(120, 100, 70, 5)
            If s2 > 2 Then Circle (x, y), 1, c(99)
            c(99) = _RGBA(125, 95, 70, 5)
            If s2 > 3 Then Circle (x, y), 1, c(99)


        Next x
    Next y
    '_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, 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
                    trz(t) = 0 - Int(Rnd * 8) - 2
                    xh = Abs(trx(t) - x1 / 2)
                    yh = Abs(try(t) - y1 / 2)
                    vc = _Hypot(xh, yh)
                    vc = 140 - vc
                    trz(t) = trz(t) - vc / 12
                    'trz(t) = trz(t) - (Int(Rnd * vc))
                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

    'set some terrain z points manually
    trz(13) = -8
    trz(24) = -9
    trz(35) = -10
    trz(46) = -9
    trz(57) = -8

    trz(14) = -8
    trz(25) = -9
    trz(36) = -10
    trz(47) = -9
    trz(58) = -8

    trz(15) = -7

    trz(48) = -14
    trz(59) = -14
    trz(70) = -14

    trz(49) = -14
    trz(60) = -14
    trz(71) = -14



    '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

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 maketreerings
    Dim t, y, m, r1, r2, x1, x2, y1, y2
    Cls
    y = 200
    For t = 1 To 212 Step .01
        m = t Mod 40
        If m > 20 Then
            m = 150
        Else
            m = 100
        End If
        c(99) = _RGB(m, m - 20, m - 40)
        r1 = .390: r2 = 1.250
        x1 = Cos(r1) * t: y1 = Sin(r1) * t
        x2 = Cos(r2) * t: y2 = Sin(r2) * t
        Line (y + x1, y - y1)-(y + x1, y + y1), c(99)
        Line (y + x1, y - y1)-(y + x2, y - y2), c(99)
        Line (y - x2, y - y2)-(y + x2, y - y2), c(99)
        Line (y - x1, y - y1)-(y - x2, y - y2), c(99)
        Line (y - x1, y - y1)-(y - x1, y + y1), c(99)
        Line (y + x1, y + y1)-(y + x2, y + y2), c(99)
        Line (y - x2, y + y2)-(y + x2, y + y2), c(99)
        Line (y - x1, y + y1)-(y - x2, y + y2), c(99)


    Next t



    '_Display
    _PutImage (0, 0)-(400, 400), 0, treering(4), (0, 0)-(400, 400)
    _PutImage (0, 0)-(400, 133), 0, treering(1), (1, 1)-(133, 399)
    _PutImage (0, 0)-(400, 133), 0, treering(2), (266, 1)-(134, 399)
    _PutImage (0, 0)-(400, 133), 0, treering(3), (399, 1)-(267, 399)
    _ClearColor c(0), treering(1)
    _ClearColor c(0), treering(2)
    _ClearColor c(0), treering(3)
    'Sleep
End Sub


Sub makepanel
    Dim t, y, m, r1, r2, x1, x2, y1, y2
    Cls
    y = 200
    For t = 1 To 212 Step .01
        m = t Mod 40
        If m > 20 Then
            m = 50
        Else
            m = 40
        End If
        c(99) = _RGB(m, m - 5, m - 15)
        r1 = .390: r2 = 1.250
        x1 = Cos(r1) * t: y1 = Sin(r1) * t
        x2 = Cos(r2) * t: y2 = Sin(r2) * t
        Line (y + x1, y - y1)-(y + x1, y + y1), c(99)
        Line (y + x1, y - y1)-(y + x2, y - y2), c(99)
        Line (y - x2, y - y2)-(y + x2, y - y2), c(99)
        Line (y - x1, y - y1)-(y - x2, y - y2), c(99)
        Line (y - x1, y - y1)-(y - x1, y + y1), c(99)
        Line (y + x1, y + y1)-(y + x2, y + y2), c(99)
        Line (y - x2, y + y2)-(y + x2, y + y2), c(99)
        Line (y - x1, y + y1)-(y - x2, y + y2), c(99)
    Next t

    _PutImage (0, 0)-(400, 133), 0, treering(4), (266, 1)-(134, 399)

    Cls
    _PutImage (0, 0)-(500, 300), treering(4)
    _PutImage (0, 100)-(500, 400), treering(4)
    _PutImage (0, 200)-(500, 500), treering(4)
    _PutImage (0, 300)-(500, 600), treering(4)
    _PutImage (0, 400)-(500, 700), treering(4)
    _PutImage (0, 0)-(500, 500), 0, panel1, (0, 0)-(500, 500)



    '_Display
    'Sleep
End Sub




Sub makepallette
    Dim t
    For t = 1 To 20
        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(35, 70, 100)
    c(4) = _RGB(40, 250, 10)
    c(5) = _RGB(0, 25, 75)
    c(6) = _RGB(45, 35, 20)
    c(7) = _RGB(100, 100, 105)
    c(8) = _RGB(75, 75, 80)
    c(9) = _RGB(50, 50, 55)
    c(10) = _RGB(95, 95, 100)
    c(11) = _RGB(0, 0, 0)
    c(12) = _RGB(35, 25, 10)
    c(13) = _RGB(0, 45, 85)
    c(14) = _RGB(160, 150, 100)
    c(15) = _RGB(0, 25, 75)
    c(16) = _RGB(55, 25, 30)
    c(17) = _RGB(175, 175, 175)
    c(18) = _RGB(100, 100, 100)
    c(20) = _RGB(20, 30, 15)
    c(31) = _RGB(255, 255, 255)
    c(32) = _RGB(255, 0, 0)
    c(33) = _RGB(0, 55, 255)
    c(34) = _RGB(255, 255, 0)
    c(40) = _RGBA(45, 20, 25, 125)
    c(41) = _RGBA(50, 50, 30, 40)
    c(42) = _RGBA(20, 30, 15, 40)
    c(43) = _RGBA(75, 45, 15, 40)
    c(44) = _RGBA(40, 60, 30, 40)
    c(45) = _RGB(50, 50, 30)
    c(46) = _RGB(20, 30, 15)
    c(47) = _RGB(55, 45, 15)
    c(48) = _RGB(40, 50, 10)
    c(51) = _RGBA(10, 40, 30, 160)
    c(52) = _RGBA(10, 43, 30, 140)
    c(53) = _RGBA(10, 46, 30, 120)
    c(54) = _RGBA(10, 49, 30, 100)
    c(55) = _RGBA(10, 52, 30, 80)
    c(56) = _RGBA(10, 55, 30, 60)
    c(57) = _RGBA(10, 58, 30, 40)
    c(58) = _RGBA(10, 61, 30, 20)
    c(59) = _RGBA(10, 64, 30, 10)

End Sub
Reply




Users browsing this thread: 1 Guest(s)