02-11-2023, 04:51 PM
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.
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