+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Programs (https://staging.qb64phoenix.com/forumdisplay.php?fid=7)
+---- Thread: 3D Ferris Wheel (/showthread.php?tid=1460)
3D Ferris Wheel - james2464 - 02-10-2023
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
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 SubCode: (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 SubRE: 3D Ferris Wheel - RokCoder - 02-10-2023
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
RE: 3D Ferris Wheel - bplus - 02-10-2023
Wow! nice 3D work James!
RE: 3D Ferris Wheel - OldMoses - 02-11-2023
Made my giblets draw up just like being on the real thing. Excellent job. A real work of art.
RE: 3D Ferris Wheel - james2464 - 02-11-2023
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