Welcome, Guest |
You have to register before you can post on our site.
|
Latest Threads |
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 762
|
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 31
|
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 32
|
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 2,034
|
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,261
|
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 315
|
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 127
|
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,589
|
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 254
|
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 155
|
|
|
3D Ferris Wheel |
Posted by: james2464 - 02-10-2023, 05:44 AM - Forum: Programs
- Replies (4)
|
|
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 Sub
Code: (Select All) '3d Ferris Wheel - james2464 - Feb 2023
'Credit to MasterGy for 3D programming help and support
'CONTROLS
'UP ARROW = Ride Ferris Wheel
'DOWN ARROW = Walk on ground
'LEFT ARROW = Rotate wheel CCW (+ speed)
'RIGHT ARROW = Rotate wheel CW (+ speed)
'F KEY = Free float (ghost mode)
Option _Explicit
Randomize Timer
Screen _NewImage(1000, 1000, 32)
Const pip180 = 3.141592 / 180
Dim Shared c(100) As Long
Dim scr, da, db, da2, dega, db2, degb, ss, ap, sqa
Dim sky_points, sky_image, actual_point, asq
Dim wx0, wy0, wz0, wx1, wy1, wz1, wx2, wy2, wz2, wx3, wy3, wz3, sx0, sy0, sx1, sy1, sx2, sy2, sx3, sy3
Dim Shared mousex, mousey, mw, mouse_sens, vec_x, vec_y, vec_z, speed, moving
Dim sp3
Dim t
Dim Shared trx(5000), try(5000), trz(5000) 'terrain points
Dim Shared fr1(5000), fr2(5000), fr3(5000) 'terrain point groups
Dim Shared maxterrain
Dim Shared deep(1000, 1000), ed(4)
Dim Shared xm, ym
Dim Shared or1(5), key1, keyct, oc
Dim Shared pmode, rspd
maketerrain
Cls
colour1
Dim Shared ground1, sky1, cbx(200)
ground1 = _NewImage(500, 500, 32): makeground
sky1 = _NewImage(750, 750, 32): makesky
For t = 1 To 20: cbx(t) = _NewImage(400, 400, 32): Next t: makepallette
Dim Shared tximage(200)
For t = 1 To 20: tximage(t) = _CopyImage(cbx(t), 33): Next t
tximage(0) = _CopyImage(ground1, 33)
Type rawobject
n As Integer 'object drawing number
n2 As Integer 'drawing detail number
n3 As Integer 'total number of details
x1 As Single
y1 As Single
z1 As Single
x2 As Single
y2 As Single
z2 As Single
x3 As Single
y3 As Single
z3 As Single
x4 As Single
y4 As Single
z4 As Single
ix As Single 'image x
iy As Single 'image y
in As Integer 'image number - tximage()
End Type
Dim Shared raw(2000) As rawobject
Type xyzgroup
x As Single
y As Single
z As Single
End Type
Type axisgroup
xy As Single
yz As Single
xz As Single
End Type
Type mapobject
det As rawobject 'details
pos1 As xyzgroup 'position
ori As axisgroup 'orientation
vel1 As xyzgroup 'velocity
sp As Single 'speed
sc As Single 'scale
End Type
Dim Shared foo(900) As mapobject 'fixed objects eg water
Dim Shared moo(3900) As mapobject 'moveable objects
'create texture point data array
Dim Shared tx(1500, 19), txtot, rawtxtot, mootxtot
'objects and data points
Data 1,1,1,-1000,0,200,-1000,0,-200,1000,0,200,1000,0,-200,500,100,12: 'wall
Data 2,1,1,-4000,-4000,0,-4000,4000,0,4000,-4000,0,4000,4000,0,500,100,3: 'water
Data 3,1,6,-2,-20,10.01,2,-20,10.01,-2,20,10.01,2,20,10.01,100,100,15: 'axle
Data 3,2,6,2,-20,10.01,-2,-20,10.01,2,-20,0,-2,-20,0,100,100,13: 'end
Data 3,3,6,2,20,10.01,-2,20,10.01,2,20,0,-2,20,0,100,100,13: 'end
Data 4,1,6,-.4,-.4,27,.4,-.4,27,-.4,-.4,-20,.4,-.4,-20,100,100,13: 'main beam
Data 4,2,6,-.4,.4,27,.4,.4,27,-.4,.4,-20,.4,.4,-20,100,100,13
Data 4,3,6,-.4,-.4,27,-.4,.4,27,-.4,-.4,-20,-.4,.4,-20,100,100,15
Data 4,4,6,.4,-.4,27,.4,.4,27,.4,-.4,-20,.4,.4,-20,100,100,15
Data 4,5,6,.4,-.4,-20,.4,.4,-20,-.4,-.4,-20,-.4,.4,-20,100,100,10: 'end
Data 4,6,6,.4,-.4,27,.4,.4,27,-.4,-.4,27,-.4,.4,27,100,100,10: 'end
Data 5,1,6,-.1,-.1,-5,.1,-.1,-5,-.1,-.1,-64.5,.1,-.1,-64.5,100,100,7: 'thin beam
Data 5,2,6,-.1,.1,-5,.1,.1,-5,-.1,.1,-64.5,.1,.1,-64.5,100,100,7
Data 5,3,6,-.1,-.1,-5,-.1,.1,-5,-.1,-.1,-64.5,-.1,.1,-64.5,100,100,8
Data 5,4,6,.1,-.1,-5,.1,.1,-5,.1,-.1,-64.5,.1,.1,-64.5,100,100,8
Data 6,1,6,45.9,45.9,-4.95,46.1,45.9,-4.95,45.9,45.9,4.95,46.1,45.9,4.95,100,100,7: 'thin short beam
Data 6,2,6,45.9,46.1,-4.95,46.1,46.1,-4.95,45.9,46.1,4.95,46.1,46.1,4.95,100,100,7
Data 6,3,6,45.9,45.9,-4.95,45.9,46.1,-4.95,45.9,45.9,4.95,45.9,46.1,4.95,100,100,8
Data 6,4,6,46.1,45.9,-4.95,46.1,46.1,-4.95,46.1,45.9,4.95,46.1,46.1,4.95,100,100,8
Data 7,1,4,-8.42,-4.8,-63.9,8.42,-4.8,-63.9,-8.59,-4.8,-65.2,8.59,-4.8,-65.2,100,100,15: 'outer perimeter beam
Data 7,2,4,-8.42,-5.2,-63.9,8.42,-5.2,-63.9,-8.59,-5.2,-65.2,8.59,-5.2,-65.2,100,100,15
Data 7,3,4,-8.59,-4.8,-65.2,-8.59,-5.2,-65.2,8.59,-4.8,-65.2,8.59,-5.2,-65.2,100,100,13
Data 7,4,4,-8.42,-4.8,-63.9,-8.42,-5.2,-63.9,8.42,-4.8,-63.9,8.42,-5.2,-63.9,100,100,13
Data 8,1,14,-.1,-.1,3,.1,-.1,3,-.1,-.1,0,.1,-.1,0,100,100,7: 'carriage roof center beam
Data 8,2,6,-.1,.1,3,.1,.1,3,-.1,.1,0,.1,.1,0,100,100,7
Data 8,3,6,-.1,-.1,3,-.1,.1,3,-.1,-.1,0,-.1,.1,0,100,100,8
Data 8,4,6,.1,-.1,3,.1,.1,3,.1,-.1,0,.1,.1,0,100,100,8
Data 8,5,6,-2,-2,10,2,-2,10,-2,-2,6,2,-2,6,100,100,7: 'walls
Data 8,6,6,-2,2,10,2,2,10,-2,2,6,2,2,6,100,100,7
Data 8,7,6,-2,-2,10,-2,2,10,-2,-2,6,-2,2,6,100,100,17
Data 8,8,6,2,-2,10,2,2,10,2,-2,6,2,2,6,100,100,17
Data 8,9,6,2,-2,3,2,2,3,-2,-2,3,-2,2,3,100,100,18: 'roof
Data 8,10,6,2,-2,10,2,2,10,-2,-2,10,-2,2,10,100,100,18: 'floor
Data 8,11,6,-2,-2,6,-1.95,-2,6,-2,-2,3,-1.95,-2,3,100,100,7: 'corner beam 1
Data 8,12,6,-2,-2,6,-2,-1.95,6,-2,-2,3,-2,-1.95,3,100,100,8
Data 8,12,6,-2,2,6,-1.95,2,6,-2,2,3,-1.95,2,3,100,100,7: 'corner beam 2
Data 8,14,6,-2,2,6,-2,1.95,6,-2,2,3,-2,1.95,3,100,100,8
Data 8,13,6,2,2,6,1.95,2,6,2,2,3,1.95,2,3,100,100,7: 'corner beam 3
Data 8,14,6,2,2,6,2,1.95,6,2,2,3,2,1.95,3,100,100,8
Data 8,12,6,2,-2,6,1.95,-2,6,2,-2,3,1.95,-2,3,100,100,7: 'corner beam 4
Data 8,14,6,2,-2,6,2,-1.95,6,2,-2,3,2,-1.95,3,100,100,8
rawtxtot = 41: txtot = rawtxtot
'read data into array tx()
Dim t2
For t = 1 To txtot
For t2 = 1 To 18
Read tx(t, t2)
Next t2
'create 'raw' objects
raw(t).n = tx(t, 1): raw(t).n2 = tx(t, 2): raw(t).n3 = tx(t, 3)
raw(t).x1 = tx(t, 4): raw(t).y1 = tx(t, 5): raw(t).z1 = tx(t, 6)
raw(t).x2 = tx(t, 7): raw(t).y2 = tx(t, 8): raw(t).z2 = tx(t, 9)
raw(t).x3 = tx(t, 10): raw(t).y3 = tx(t, 11): raw(t).z3 = tx(t, 12)
raw(t).x4 = tx(t, 13): raw(t).y4 = tx(t, 14): raw(t).z4 = tx(t, 15)
raw(t).ix = tx(t, 16): raw(t).iy = tx(t, 17): raw(t).in = tx(t, 18)
Next t
Dim n1, n2, n3, n4, n5, n6, n7, n8 'n, x, y, z, sc,ac,ac2,ac3
'water
n1 = 2: n2 = 0: n3 = 0: n4 = 500: n5 = 1: n6 = 0: n7 = 0: n8 = 0: foocopy n1, n2, n3, n4, n5, n6, n7, n8 'water
'main beams
n1 = 4: n2 = 170: n3 = 70: n4 = 447: n5 = 2: n6 = _Pi / 2: n7 = .50: n8 = 0: foocopy n1, n2, n3, n4, n5, n6, n7, n8 'main beam
n1 = 4: n2 = 130: n3 = 70: n4 = 447: n5 = 2: n6 = _Pi / 2: n7 = -.50: n8 = 0: foocopy n1, n2, n3, n4, n5, n6, n7, n8 'main beam
n1 = 4: n2 = 170: n3 = 90: n4 = 447: n5 = 2: n6 = _Pi / 2: n7 = .50: n8 = 0: foocopy n1, n2, n3, n4, n5, n6, n7, n8 'main beam
n1 = 4: n2 = 130: n3 = 90: n4 = 447: n5 = 2: n6 = _Pi / 2: n7 = -.50: n8 = 0: foocopy n1, n2, n3, n4, n5, n6, n7, n8 'main beam
'axle
n1 = 3: n2 = 150: n3 = 80: n4 = 411: n5 = .55: n6 = 0: n7 = 0
For t = 1 To 16
n8 = _Pi / 16 * (2 * t): foocopy n1, n2, n3, n4, n5, n6, n7, n8 'short beam
Next t
'rotating beam
n1 = 5: n2 = 150: n3 = 75: n4 = 411: n5 = 1: n6 = _Pi / 2: n8 = 0
For t = 1 To 24
n7 = (_Pi / 6) * (.5 * t) + .131: moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t
n1 = 5: n2 = 150: n3 = 85: n4 = 411: n5 = 1: n6 = _Pi / 2: n8 = 0
For t = 1 To 24
n7 = (_Pi / 6) * (.5 * t) + .131: moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t
'rotating short end beam (carriage attached to this)
n1 = 6: n2 = 150: n3 = 80: n4 = 411: n5 = 1: n6 = 0: n7 = _Pi / 2
For t = 1 To 24
n8 = (_Pi / 6) * (.5 * t) + .131: moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t
'outer perimeter beam
n1 = 7: n2 = 150: n3 = 80: n4 = 411: n5 = 1: n6 = 0: n7 = 0
For t = 1 To 24
n8 = (_Pi / 6) * (.5 * t): moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t
'outer perimeter beam
n1 = 7: n2 = 150: n3 = 90: n4 = 411: n5 = 1: n6 = 0: n7 = 0
For t = 1 To 24
n8 = (_Pi / 6) * (.5 * t): moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t
'carriages
n1 = 8: n2 = 50: n3 = 80: n4 = 431: n5 = 1: n6 = 0: n7 = 0
For t = 1 To 24
n8 = 0: moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t
Dim v, c1
'colours
For t = 1 To mootxtot
If moo(t).det.n = 8 Then
If moo(t).det.n2 = 1 Then
c1 = ((t / 1) Mod 7) + 10
moo(t + 4).det.in = c1
moo(t + 5).det.in = c1
moo(t + 8).det.in = c1
End If
End If
Next t
'create spectator
Dim Shared sp(6)
sp(0) = 250 'X position
sp(1) = 150 'Y
sp(2) = 470 'Z
sp(3) = 0 'looking in the direction of the observer XZ
sp(4) = 0 'looking in the direction of the observer YZ
sp(5) = .1 'multiplier X-Y see
sp(6) = .1 'multiplier Z see
'create screen
scr = _NewImage(1000, 1000 / _DesktopWidth * _DesktopHeight, 32)
Screen scr
_MouseHide
_FullScreen
_Dest scr
_DisplayOrder _Hardware , _Software
'sky install
da = 11 'resolution sphere X
db = 7 'resolution sphere Y
sky_points = da * db
Dim sky_points(sky_points - 1, 9), sq(sky_points - 1, 7)
sky_image = _CopyImage(sky1, 33)
For da2 = 0 To da - 1
dega = 360 / (da - 1) * da2 * pip180
For db2 = 0 To db - 1
degb = 180 / (db - 1) * db2 * pip180
ss = 4000
ap = da2 * db + db2
sky_points(ap, 0) = Sin(degb) * Cos(dega) * ss
sky_points(ap, 1) = Sin(degb) * Sin(dega) * ss
sky_points(ap, 2) = Cos(degb) * ss
Next db2
Next da2
For da2 = 0 To da - 2
For db2 = 0 To db - 2
sqa = da2 * db + db2
sq(sqa, 0) = sqa
sq(sqa, 1) = sq(sqa, 0) + 1
sq(sqa, 2) = sq(sqa, 0) + db
sq(sqa, 3) = sq(sqa, 2) + 1
sq(sqa, 4) = _Width(sky_image) - (_Width(sky_image) / (da - 1) * da2) - 1
sq(sqa, 5) = _Width(sky_image) - (_Width(sky_image) / (da - 1) * (da2 + 1)) - 1
sq(sqa, 6) = Int(_Height(sky_image) / (db - 1) * db2)
sq(sqa, 7) = Int(_Height(sky_image) / (db - 1) * (db2 + 1))
Next db2
Next da2
pmode = 3
rspd = 0
Dim rcount
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
Do
_Limit 40
'keyboard input
keyct = keyct + 1
If keyct > 10 Then 'wait before more input
key1 = keyboard
keyct = 0
Else
key1 = 0
End If
'keyboard actions
If key1 = 1 Then
rspd = rspd + .001
If rspd > .016 Then rspd = .012
End If
If key1 = 2 Then
rspd = rspd - .001
If rspd < -.016 Then rspd = -.012
End If
If key1 = 5 Then
pmode = 1
End If
If key1 = 4 Then
pmode = 2
End If
If key1 = 3 Then
pmode = 3
End If
or1(1) = 5: or1(2) = 0: or1(3) = 0: or1(4) = 0: or1(5) = rspd: objrotate3
or1(1) = 6: or1(2) = 0: or1(3) = 0: or1(4) = 0: or1(5) = rspd: objrotate3
or1(1) = 7: or1(2) = 0: or1(3) = 0: or1(4) = 0: or1(5) = rspd: objrotate3
processcarriages
processterrain
processfootextures
processmootextures
'draw sky *********************************************************************************
't = 1 'use for checkered sky
'rotating
For actual_point = 0 To sky_points - 1
sky_points(actual_point, 4) = sky_points(actual_point, 0)
sky_points(actual_point, 5) = sky_points(actual_point, 1)
sky_points(actual_point, 6) = sky_points(actual_point, 2)
r2m sky_points(actual_point, 4), sky_points(actual_point, 5), sky_points(actual_point, 6)
Next actual_point
For asq = 0 To sky_points - 1
wx0 = sky_points(sq(asq, 0), 4) + 0: wy0 = sky_points(sq(asq, 0), 5) + 0: wz0 = sky_points(sq(asq, 0), 6)
wx1 = sky_points(sq(asq, 1), 4) + 0: wy1 = sky_points(sq(asq, 1), 5) + 0: wz1 = sky_points(sq(asq, 1), 6)
wx2 = sky_points(sq(asq, 2), 4) + 0: wy2 = sky_points(sq(asq, 2), 5) + 0: wz2 = sky_points(sq(asq, 2), 6)
wx3 = sky_points(sq(asq, 3), 4) + 0: wy3 = sky_points(sq(asq, 3), 5) + 0: wz3 = sky_points(sq(asq, 3), 6)
sy0 = sq(asq, 6): sx0 = sq(asq, 4): sy1 = sq(asq, 7): sx1 = sq(asq, 4): sy2 = sq(asq, 6): sx2 = sq(asq, 5): sy3 = sq(asq, 7): sx3 = sq(asq, 5)
't = t * -1 'use for checkered sky
'If t > 0 Then 'use for checkered sky
_MapTriangle (sx0, sy0)-(sx1, sy1)-(sx2, sy2), sky_image To(wx0, wy0, wz0)-(wx1, wy1, wz1)-(wx2, wy2, wz2), , _Smooth
_MapTriangle (sx3, sy3)-(sx1, sy1)-(sx2, sy2), sky_image To(wx3, wy3, wz3)-(wx1, wy1, wz1)-(wx2, wy2, wz2), , _Smooth
'End If 'use for checkered sky
Next asq
' ****************************************************************************************************
_Display
'-------------------------------------------------------------
'mouse input axis movement and mousewheel
'-------------------------------------------------------------
mousex = mousex * .6
mousey = mousey * .6
mw = 0
While _MouseInput: mousex = mousex + _MouseMovementX: mousey = mousey + _MouseMovementY: mw = mw + _MouseWheel: Wend 'movement data read
'control spectator
mouse_sens = .0007 'mouse rotating sensitive
sp(3) = sp(3) - mousex * mouse_sens
sp(4) = sp(4) + mousey * mouse_sens
If Abs(sp(4)) > _Pi / 2 Then sp(4) = _Pi / 2 * Sgn(sp(4))
sp3 = sp(3) + (_KeyDown(Asc("d")) - _KeyDown(Asc("a"))) * 90 * pip180
vec_x = (Sin(sp3) * (Cos(sp(4) + _Pi)))
vec_y = (Cos(sp3) * (Cos(sp(4) + _Pi)))
vec_z = -Sin(sp(4) + _Pi)
If _KeyDown(Asc("a")) Or _KeyDown(Asc("d")) Then vec_z = 0
speed = .5 'moving speed
moving = Abs(_MouseButton(1) Or _KeyDown(Asc("w")) Or _KeyDown(Asc("a")) Or _KeyDown(Asc("d"))) * speed - Abs(_MouseButton(2) Or _KeyDown(Asc("s"))) * speed
If pmode = 1 Then
sp(0) = sp(0) + vec_x * moving
sp(1) = sp(1) + vec_y * moving
sp(2) = sp(2) + vec_z * moving
End If
If pmode = 2 Then
'take a ride
sp(0) = moo(907).pos1.x
sp(1) = moo(907).pos1.y
sp(2) = moo(907).pos1.z + 4
End If
If pmode = 3 Then
sp(0) = sp(0) + vec_x * moving
sp(1) = sp(1) + vec_y * moving
'find current terrain location
xm = sp(0) / 50
ym = sp(1) / 50
If sp(0) > 3 And sp(0) < 498 Then
If sp(1) > 3 And sp(1) < 498 Then
sp(2) = 494 + exact_deep(ym, xm)
End If
Else
sp(2) = 494
End If
End If
t = Abs(rspd) / (2 * _Pi)
rcount = rcount + t
'Locate 1, 1
'Print rspd
'Locate 2, 1
'Print rcount
'If rcount > 1000 Then rspd = 0
Loop Until _KeyDown(27)
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
Function keyboard
keyboard = 0
If _KeyDown(19712) Then 'right arrow key
keyboard = 1
End If
If _KeyDown(19200) Then 'left arrow key
keyboard = 2
End If
If _KeyDown(20480) Then 'down arrow key
keyboard = 3
End If
If _KeyDown(18432) Then 'up arrow key
keyboard = 4
End If
If _KeyDown(102) Then 'f key
keyboard = 5
End If
End Function
Function exact_deep (x, y)
Dim x1, y1, x2, y2, p0, p1, p2, p3, aposx, aposy, q
x1 = Int(x) + 1: x2 = x1 + 1: aposx = x - (x1 - 1)
y1 = Int(y) + 1: y2 = y1 + 1: aposy = y - (y1 - 1)
p1 = deep(x2, y1)
p2 = deep(x1, y2)
If aposx * aposx + aposy * aposy < (1 - aposx) * (1 - aposx) + (1 - aposy) * (1 - aposy) Then
p0 = deep(x1, y1)
q = p0 + aposx * (p1 - p0) + aposy * (p2 - p0)
Else
p3 = deep(x2, y2)
q = p3 + (1 - aposy) * (p1 - p3) + (1 - aposx) * (p2 - p3)
End If
exact_deep = q
End Function
Sub r2m (x, y, z)
Dim x2, y2, z2
x2 = x - sp(0)
y2 = y - sp(1)
z2 = z - sp(2)
rotate_2d x2, y2, sp(3)
rotate_2d y2, z2, sp(4) + _Pi / 2
x = x2 * sp(5)
y = y2 * sp(5)
z = z2 * sp(6)
End Sub
Sub rotate_2d (x, y, ang)
Dim x1, y1
x1 = x * Cos(ang) - y * Sin(ang)
y1 = x * Sin(ang) + y * Cos(ang)
x = x1: y = y1
End Sub
Sub processterrain
Dim x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
Dim xx1, yy1, xx2, yy2, xx3, yy3
Dim flag, ct, scale1, shx, shy, shz, txm
flag = 0
ct = 0
scale1 = 1.
shx = 0 'shift x position
shy = 0 'shift y position
shz = 502 'shift z position
Do
ct = ct + 1
x1 = trx(fr1(ct)): y1 = try(fr1(ct)): z1 = trz(fr1(ct))
x2 = trx(fr2(ct)): y2 = try(fr2(ct)): z2 = trz(fr2(ct))
x3 = trx(fr3(ct)): y3 = try(fr3(ct)): z3 = trz(fr3(ct))
xx1 = x1: yy1 = y1
xx2 = x2: yy2 = y2
xx3 = x3: yy3 = y3
x1 = x1 * scale1: y1 = y1 * scale1: 'z1 = z1 * scale1
x2 = x2 * scale1: y2 = y2 * scale1: 'z2 = z2 * scale1
x3 = x3 * scale1: y3 = y3 * scale1: 'z3 = z3 * scale1
x4 = x4 * scale1: y4 = y4 * scale1: 'z4 = z4 * scale1
x1 = x1 + shx: y1 = y1 + shy: z1 = z1 + shz
x2 = x2 + shx: y2 = y2 + shy: z2 = z2 + shz
x3 = x3 + shx: y3 = y3 + shy: z3 = z3 + shz
x4 = x4 + shx: y4 = y4 + shy: z4 = z4 + shz
r2m x1, y1, z1
r2m x2, y2, z2
r2m x3, y3, z3
txm = 0
_MapTriangle (xx1, yy1)-(xx2, yy2)-(xx3, yy3), tximage(txm) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
If ct >= maxterrain Then flag = 1
Loop Until flag = 1
End Sub
Sub foocopy (n, x, y, z, sc, ac, ac2, ac3)
Dim t, t2, flag, xt, yt, zt
oc = oc + 1 'object count - used for object id number
For t = 1 To rawtxtot 'find number of details in this object
If raw(t).n = n Then
t2 = 1
flag = 0
Do 'search foo() array for availability
If foo(t2).det.n = 0 Then
flag = 1
Else
t2 = t2 + 1
End If
Loop Until flag > 0
't2 is next available array position
foo(t2).det.n = n: foo(t2).pos1.x = x: foo(t2).pos1.y = y: foo(t2).pos1.z = z: foo(t2).sc = sc
xt = raw(t).x1: yt = raw(t).y1: zt = raw(t).z1: objrotation xt, yt, zt, ac, ac2, ac3: foo(t2).det.x1 = xt * sc: foo(t2).det.y1 = yt * sc: foo(t2).det.z1 = zt * sc
xt = raw(t).x2: yt = raw(t).y2: zt = raw(t).z2: objrotation xt, yt, zt, ac, ac2, ac3: foo(t2).det.x2 = xt * sc: foo(t2).det.y2 = yt * sc: foo(t2).det.z2 = zt * sc
xt = raw(t).x3: yt = raw(t).y3: zt = raw(t).z3: objrotation xt, yt, zt, ac, ac2, ac3: foo(t2).det.x3 = xt * sc: foo(t2).det.y3 = yt * sc: foo(t2).det.z3 = zt * sc
xt = raw(t).x4: yt = raw(t).y4: zt = raw(t).z4: objrotation xt, yt, zt, ac, ac2, ac3: foo(t2).det.x4 = xt * sc: foo(t2).det.y4 = yt * sc: foo(t2).det.z4 = zt * sc
foo(t2).det.ix = raw(t).ix: foo(t2).det.iy = raw(t).iy: foo(t2).det.in = raw(t).in
End If
Next t
End Sub
Sub objrotation (x, y, z, a, a2, a3)
Dim xt, yt, zt, h, h1, h2, xt2, yt2, zt2
Dim y2
'yz rotation
yt = y: zt = z
h = _Hypot(zt, yt)
h1 = _Atan2(yt, zt)
h2 = h1 - a2
yt2 = Sin(h2) * h
zt2 = Cos(h2) * h
y2 = yt2
z = zt2
'xy rotation
xt = x: yt = y2
h = _Hypot(yt, xt)
h1 = _Atan2(xt, yt)
h2 = h1 - a
xt2 = Sin(h2) * h
yt2 = Cos(h2) * h
x = xt2
y = yt2
'xz rotation
zt = z: xt = x
h = _Hypot(zt, xt)
h1 = _Atan2(xt, zt)
h2 = h1 - a3
If h2 < 0 Then h2 = h2 + _Pi * 2
xt2 = Sin(h2) * h
zt2 = Cos(h2) * h
z = zt2
x = xt2
End Sub
Sub moocopy (n, x, y, z, sc, ac, ac2, ac3)
Dim t, t2, flag, xt, yt, zt
oc = oc + 1 'object count - used for object id number
For t = 1 To rawtxtot 'find number of details in this object
If raw(t).n = n Then
t2 = 1
flag = 0
Do 'search foo() array for availability
If moo(t2).det.n = 0 Then
flag = 1
Else
t2 = t2 + 1
End If
Loop Until flag > 0
't2 is next available array position
mootxtot = t2
moo(t2).det.n = n: moo(t2).pos1.x = x: moo(t2).pos1.y = y: moo(t2).pos1.z = z: moo(t2).sc = sc
moo(t2).det.n2 = raw(t).n2
xt = raw(t).x1: yt = raw(t).y1: zt = raw(t).z1: objrotation xt, yt, zt, ac, ac2, ac3: moo(t2).det.x1 = xt * sc: moo(t2).det.y1 = yt * sc: moo(t2).det.z1 = zt * sc
xt = raw(t).x2: yt = raw(t).y2: zt = raw(t).z2: objrotation xt, yt, zt, ac, ac2, ac3: moo(t2).det.x2 = xt * sc: moo(t2).det.y2 = yt * sc: moo(t2).det.z2 = zt * sc
xt = raw(t).x3: yt = raw(t).y3: zt = raw(t).z3: objrotation xt, yt, zt, ac, ac2, ac3: moo(t2).det.x3 = xt * sc: moo(t2).det.y3 = yt * sc: moo(t2).det.z3 = zt * sc
xt = raw(t).x4: yt = raw(t).y4: zt = raw(t).z4: objrotation xt, yt, zt, ac, ac2, ac3: moo(t2).det.x4 = xt * sc: moo(t2).det.y4 = yt * sc: moo(t2).det.z4 = zt * sc
moo(t2).det.ix = raw(t).ix: moo(t2).det.iy = raw(t).iy: moo(t2).det.in = raw(t).in
moo(t2).ori.xz = ac3
End If
Next t
End Sub
Sub moocopy2 (n, x, y, z, sc)
Dim t, t2, flag
oc = oc + 1 'object count - used for object id number
For t = 1 To rawtxtot 'find number of details in this object
If raw(t).n = n Then
t2 = 1
flag = 0
Do 'search moo() array for availability
If moo(t2).det.n = 0 Then
flag = 1
Else
t2 = t2 + 1
End If
Loop Until flag > 0
't2 is next available array position
moo(t2).det.n = n: moo(t2).pos1.x = x: moo(t2).pos1.y = y: moo(t2).pos1.z = z: moo(t2).sc = sc
moo(t2).det.x1 = raw(t).x1 * sc: moo(t2).det.y1 = raw(t).y1 * sc: moo(t2).det.z1 = raw(t).z1 * sc
moo(t2).det.x2 = raw(t).x2 * sc: moo(t2).det.y2 = raw(t).y2 * sc: moo(t2).det.z2 = raw(t).z2 * sc
moo(t2).det.x3 = raw(t).x3 * sc: moo(t2).det.y3 = raw(t).y3 * sc: moo(t2).det.z3 = raw(t).z3 * sc
moo(t2).det.x4 = raw(t).x4 * sc: moo(t2).det.y4 = raw(t).y4 * sc: moo(t2).det.z4 = raw(t).z4 * sc
moo(t2).det.ix = raw(t).ix: moo(t2).det.iy = raw(t).iy: moo(t2).det.in = raw(t).in
End If
Next t
End Sub
Sub moorotate
Dim t, x1, y1, x2, y2, x3, y3, x4, y4
For t = 1 To mootxtot
If moo(t).det.n = or1(1) Then
x1 = moo(t).det.x1: y1 = moo(t).det.y1
xyrotation x1, y1, or1(5)
x2 = moo(t).det.x2: y2 = moo(t).det.y2
xyrotation x2, y2, or1(5)
x3 = moo(t).det.x3: y3 = moo(t).det.y3
xyrotation x3, y3, or1(5)
x4 = moo(t).det.x4: y4 = moo(t).det.y4
xyrotation x4, y4, or1(5)
moo(t).det.x1 = x1: moo(t).det.y1 = y1
moo(t).det.x2 = x2: moo(t).det.y2 = y2
moo(t).det.x3 = x3: moo(t).det.y3 = y3
moo(t).det.x4 = x4: moo(t).det.y4 = y4
End If
Next t
End Sub
Sub processfootextures
Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
Dim flag
flag = 0
t = 1
Do
x1 = foo(t).det.x1 + foo(t).pos1.x: y1 = foo(t).det.y1 + foo(t).pos1.y: z1 = foo(t).det.z1 + foo(t).pos1.z
x2 = foo(t).det.x2 + foo(t).pos1.x: y2 = foo(t).det.y2 + foo(t).pos1.y: z2 = foo(t).det.z2 + foo(t).pos1.z
x3 = foo(t).det.x3 + foo(t).pos1.x: y3 = foo(t).det.y3 + foo(t).pos1.y: z3 = foo(t).det.z3 + foo(t).pos1.z
x4 = foo(t).det.x4 + foo(t).pos1.x: y4 = foo(t).det.y4 + foo(t).pos1.y: z4 = foo(t).det.z4 + foo(t).pos1.z
x = foo(t).det.ix: y = foo(t).det.iy
r2m x1, y1, z1
r2m x2, y2, z2
r2m x3, y3, z3
r2m x4, y4, z4
_MapTriangle (0, 0)-(0, y)-(x, 0), tximage(foo(t).det.in) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
_MapTriangle (x, y)-(0, y)-(x, 0), tximage(foo(t).det.in) To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
t = t + 1
If foo(t).det.n = 0 Then flag = 1
Loop Until flag > 0
End Sub
Sub processmootextures
Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
Dim flag
flag = 0
t = 1
Do
x1 = moo(t).det.x1 + moo(t).pos1.x: y1 = moo(t).det.y1 + moo(t).pos1.y: z1 = moo(t).det.z1 + moo(t).pos1.z
x2 = moo(t).det.x2 + moo(t).pos1.x: y2 = moo(t).det.y2 + moo(t).pos1.y: z2 = moo(t).det.z2 + moo(t).pos1.z
x3 = moo(t).det.x3 + moo(t).pos1.x: y3 = moo(t).det.y3 + moo(t).pos1.y: z3 = moo(t).det.z3 + moo(t).pos1.z
x4 = moo(t).det.x4 + moo(t).pos1.x: y4 = moo(t).det.y4 + moo(t).pos1.y: z4 = moo(t).det.z4 + moo(t).pos1.z
x = moo(t).det.ix: y = moo(t).det.iy
r2m x1, y1, z1
r2m x2, y2, z2
r2m x3, y3, z3
r2m x4, y4, z4
_MapTriangle (0, 0)-(0, y)-(x, 0), tximage(moo(t).det.in) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
_MapTriangle (x, y)-(0, y)-(x, 0), tximage(moo(t).det.in) To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
t = t + 1
If moo(t).det.n = 0 Then flag = 1
Loop Until flag > 0
End Sub
Sub processcarriages
Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
Dim flag, ct6, ct8, c(50), xc(50), zc(50), k
Dim xt, zt, h, h2, v, c1
flag = 0
ct6 = 0
ct8 = 0
For t = 1 To mootxtot
If moo(t).det.n = 6 Then
If moo(t).det.n2 = 1 Then
ct6 = ct6 + 1
c(ct6) = moo(t).ori.xz
xc(ct6) = moo(t).pos1.x
zc(ct6) = moo(t).pos1.z
End If
End If
If moo(t).det.n = 8 Then
If moo(t).det.n2 = 1 Then
ct8 = ct8 + 1
k = c(ct8)
h2 = k ' + .131
h = 65.05
xt = Sin(h2) * h
zt = Cos(h2) * h
c1 = Int(Rnd * 6) + 12
moo(t).pos1.x = xc(ct8) + xt: moo(t).pos1.z = zc(ct8) + zt
'Locate 1, 1
'Print t
For v = 1 To 18
moo(t + v).pos1.x = xc(ct8) + xt: moo(t + v).pos1.z = zc(ct8) + zt
Next v
End If
End If
Next t
'Locate 1, 1
'Print ct6, ct8
'Print c(1); c(2); c(3); c(4)
End Sub
Sub xyrotation (x, y, a)
Dim xt, yt, h, h1, h2, xt2, yt2
xt = x: yt = y
h = _Hypot(yt, xt)
h1 = _Atan2(xt, yt)
h2 = h1 - a
xt2 = Sin(h2) * h
yt2 = Cos(h2) * h
x = xt2
y = yt2
End Sub
Sub yzrotation (y, z, a)
Dim zt, yt, h, h1, h2, zt2, yt2
zt = z: yt = y
h = _Hypot(zt, yt)
h1 = _Atan2(yt, zt)
h2 = h1 - a
If h2 < 0 Then h2 = h2 + _Pi * 2
yt2 = Sin(h2) * h
zt2 = Cos(h2) * h
z = zt2
y = yt2
End Sub
Sub xzrotation (x, z, a)
Dim zt, xt, h, h1, h2, zt2, xt2
zt = z: xt = x
h = _Hypot(zt, xt)
h1 = _Atan2(xt, zt)
h2 = h1 - a
If h2 < 0 Then h2 = h2 + _Pi * 2
xt2 = Sin(h2) * h
zt2 = Cos(h2) * h
z = zt2
x = xt2
End Sub
Sub makeground
Dim t, x1, y1, s, s2, x, y, c, ed
s = 320
s2 = (500 - s) / 2
Cls
Line (0, 0)-(500, 500), c(14), BF 'border/beach
Line (0, 0)-(500, 500), c(40), BF 'ground background
For y = 1 To 500
For x = 1 To 500
x1 = x / 50
y1 = y / 50
ed = exact_deep(y1, x1)
s = 0 - ed
c(99) = _RGBA(10 - s / 2, 40 - s / 2, 30 - s / 2, s)
For t = 1 To 60
If s > t + 5 Then
'PSet (x, y), c(99)
Circle (x, y), 1, c(99)
End If
Next t
'texture dots
s2 = Rnd * 15
c(99) = _RGBA(120, 100, 70, 5)
If s2 > 2 Then Circle (x, y), 1, c(99)
c(99) = _RGBA(125, 95, 70, 5)
If s2 > 3 Then Circle (x, y), 1, c(99)
Next x
Next y
'_Display
_PutImage (0, 0)-(500, 500), 0, ground1, (0, 0)-(500, 500)
'Sleep
End Sub
Sub maketerrain
Dim t, s, x, y, x1, y1, p, q, p2, ct, flag
Dim xt, yt, xh, yh, vc, dx, dy, pt(4)
Cls
'Line (0, 0)-(500, 500), c(20), BF 'background
t = 0
x1 = 500: y1 = 500
s = 50
'create points (trx,try,trz)
For x = 0 To x1 Step s
For y = 0 To y1 Step s
t = t + 1
xt = Abs(x): yt = Abs(y)
'trx(t) = x - s: try(t) = y - s
trx(t) = x: try(t) = y
If x > 0 And x < x1 Then
'trz(t) = -2
If y > 0 And y < y1 Then
'trz(t) = 0
trz(t) = 0 - Int(Rnd * 8) - 2
xh = Abs(trx(t) - x1 / 2)
yh = Abs(try(t) - y1 / 2)
vc = _Hypot(xh, yh)
vc = 140 - vc
trz(t) = trz(t) - vc / 12
'trz(t) = trz(t) - (Int(Rnd * vc))
End If
End If
Next y
Next x
'_Display
'Sleep
'create point groups (fr1,fr2,fr3)
p = Int(x1 / s) + 1
q = Int(y1 / s) - 1
p2 = p * q
t = -1
flag = 0
ct = 0
x = 0
Do
For x = 1 To p - 1
t = t + 2
fr1(t) = x + ct
fr2(t) = x + ct + 1
fr3(t) = x + ct + p
fr1(t + 1) = x + ct + 1
fr2(t + 1) = x + ct + p
fr3(t + 1) = x + ct + p + 1
Next x
ct = ct + p
If ct > p2 Then flag = 1
Loop Until flag = 1
maxterrain = t + 1
'Cls
't = t + 1
'For ct = 1 To t
'Print fr1(ct), fr2(ct), fr3(ct)
'Next ct
Cls
For t = 1 To maxterrain
Line (trx(fr1(t)), try(fr1(t)))-(trx(fr2(t)), try(fr2(t))), c(1)
Line (trx(fr2(t)), try(fr2(t)))-(trx(fr3(t)), try(fr3(t))), c(1)
Line (trx(fr3(t)), try(fr3(t)))-(trx(fr1(t)), try(fr1(t))), c(1)
Next t
'set some terrain z points manually
trz(13) = -8
trz(24) = -9
trz(35) = -10
trz(46) = -9
trz(57) = -8
trz(14) = -8
trz(25) = -9
trz(36) = -10
trz(47) = -9
trz(58) = -8
trz(15) = -7
trz(48) = -14
trz(59) = -14
trz(70) = -14
trz(49) = -14
trz(60) = -14
trz(71) = -14
'create DEEP array
t = 0
For y = 1 To 11
For x = 1 To 11
t = t + 1
deep(x, y) = trz(t)
Locate y * 3, x * 6
Print deep(x, y)
Next x
Next y
'_Display
'Sleep
End Sub
Sub makesky
Dim t, y, m
Cls
y = 750
For t = 1 To y
m = 255 * ((750 - t * .65) / 750)
c(99) = _RGBA(200, 200, 255, m)
Line (0, t)-(750, t), c(99)
Next t
'For t = 0 To 750 Step 25 'longituge lines
'Line (t, 0)-(t, 750), c(1)
'Next t
'For t = 0 To 750 Step 25 'latitude lines
'Line (0, t)-(750, t), c(1)
'Next t
'_Display
_PutImage (0, 0)-(750, 750), 0, sky1, (0, 0)-(750, 750)
'Sleep
End Sub
Sub makepallette
Dim t
For t = 1 To 20
Cls
Line (0, 0)-(400, 400), c(t), BF
_PutImage (0, 0)-(400, 400), 0, cbx(t), (0, 0)-(400, 400)
'_Display
'Sleep
Next t
End Sub
Sub colour1
c(0) = _RGB(0, 0, 0)
c(1) = _RGB(255, 255, 255)
c(2) = _RGB(35, 25, 10)
c(3) = _RGB(35, 70, 100)
c(4) = _RGB(40, 250, 10)
c(5) = _RGB(0, 25, 75)
c(6) = _RGB(45, 35, 20)
c(7) = _RGB(100, 100, 105)
c(8) = _RGB(75, 75, 80)
c(9) = _RGB(50, 50, 55)
c(10) = _RGB(95, 95, 100)
c(11) = _RGB(50, 150, 50)
c(12) = _RGB(150, 50, 50)
c(13) = _RGB(0, 45, 85)
c(14) = _RGB(160, 150, 100)
c(15) = _RGB(0, 25, 75)
c(16) = _RGB(55, 25, 30)
c(17) = _RGB(175, 175, 175)
c(18) = _RGB(100, 100, 100)
c(20) = _RGB(20, 30, 15)
c(31) = _RGB(255, 255, 255)
c(32) = _RGB(255, 0, 0)
c(33) = _RGB(0, 55, 255)
c(34) = _RGB(255, 255, 0)
c(40) = _RGBA(45, 20, 25, 125)
c(41) = _RGBA(50, 50, 30, 40)
c(42) = _RGBA(20, 30, 15, 40)
c(43) = _RGBA(75, 45, 15, 40)
c(44) = _RGBA(40, 60, 30, 40)
c(45) = _RGB(50, 50, 30)
c(46) = _RGB(20, 30, 15)
c(47) = _RGB(55, 45, 15)
c(48) = _RGB(40, 50, 10)
c(51) = _RGBA(10, 40, 30, 160)
c(52) = _RGBA(10, 43, 30, 140)
c(53) = _RGBA(10, 46, 30, 120)
c(54) = _RGBA(10, 49, 30, 100)
c(55) = _RGBA(10, 52, 30, 80)
c(56) = _RGBA(10, 55, 30, 60)
c(57) = _RGBA(10, 58, 30, 40)
c(58) = _RGBA(10, 61, 30, 20)
c(59) = _RGBA(10, 64, 30, 10)
End Sub
Sub objrotate
Dim t, x1, y1, x2, y2, x3, y3, x4, y4
For t = 1 To txtot
If moo(t).det.n = or1(1) Then
x1 = moo(t).det.x1 - or1(2): y1 = moo(t).det.y1 - or1(4)
xyrotation x1, y1, or1(5)
x2 = moo(t).det.x2 - or1(2): y2 = moo(t).det.y2 - or1(4)
xyrotation x2, y2, or1(5)
x3 = moo(t).det.x3 - or1(2): y3 = moo(t).det.y3 - or1(4)
xyrotation x3, y3, or1(5)
x4 = moo(t).det.x4 - or1(2): y4 = moo(t).det.y4 - or1(4)
xyrotation x4, y4, or1(5)
moo(t).det.x1 = x1 + or1(2): moo(t).det.y1 = y1 + or1(4)
moo(t).det.x2 = x2 + or1(2): moo(t).det.y2 = y2 + or1(4)
moo(t).det.x3 = x3 + or1(2): moo(t).det.y3 = y3 + or1(4)
moo(t).det.x4 = x4 + or1(2): moo(t).det.y4 = y4 + or1(4)
End If
Next t
End Sub
Sub objrotate2
Dim t, y1, z1, y2, z2, y3, z3, y4, z4
For t = 1 To txtot
If moo(t).det.n = or1(1) Then
y1 = moo(t).det.y1 - or1(2): z1 = moo(t).det.z1 - or1(4)
yzrotation y1, z1, or1(5)
y2 = moo(t).det.y2 - or1(2): z2 = moo(t).det.z2 - or1(4)
yzrotation y2, z2, or1(5)
y3 = moo(t).det.y3 - or1(2): z3 = moo(t).det.z3 - or1(4)
yzrotation y3, z3, or1(5)
y4 = moo(t).det.y4 - or1(2): z4 = moo(t).det.z4 - or1(4)
yzrotation y4, z4, or1(5)
moo(t).det.y1 = y1 + or1(2): moo(t).det.z1 = z1 + or1(4)
moo(t).det.y2 = y2 + or1(2): moo(t).det.z2 = z2 + or1(4)
moo(t).det.y3 = y3 + or1(2): moo(t).det.z3 = z3 + or1(4)
moo(t).det.y4 = y4 + or1(2): moo(t).det.z4 = z4 + or1(4)
End If
Next t
End Sub
Sub objrotate3
Dim t, x1, z1, x2, z2, x3, z3, x4, z4
For t = 1 To mootxtot
If moo(t).det.n = or1(1) Then
x1 = moo(t).det.x1 - or1(2): z1 = moo(t).det.z1 - or1(4)
xzrotation x1, z1, or1(5)
x2 = moo(t).det.x2 - or1(2): z2 = moo(t).det.z2 - or1(4)
xzrotation x2, z2, or1(5)
x3 = moo(t).det.x3 - or1(2): z3 = moo(t).det.z3 - or1(4)
xzrotation x3, z3, or1(5)
x4 = moo(t).det.x4 - or1(2): z4 = moo(t).det.z4 - or1(4)
xzrotation x4, z4, or1(5)
moo(t).det.x1 = x1 + or1(2): moo(t).det.z1 = z1 + or1(4)
moo(t).det.x2 = x2 + or1(2): moo(t).det.z2 = z2 + or1(4)
moo(t).det.x3 = x3 + or1(2): moo(t).det.z3 = z3 + or1(4)
moo(t).det.x4 = x4 + or1(2): moo(t).det.z4 = z4 + or1(4)
moo(t).ori.xz = moo(t).ori.xz - or1(5)
If moo(t).ori.xz > 7 Then
moo(t).ori.xz = moo(t).ori.xz - (2 * _Pi)
End If
If moo(t).ori.xz < -7 Then
moo(t).ori.xz = moo(t).ori.xz + (2 * _Pi)
End If
End If
Next t
End Sub
|
|
|
UniDate |
Posted by: SMcNeill - 02-09-2023, 07:40 PM - Forum: SMcNeill
- Replies (3)
|
|
As we were talking on Discord, it'd be nice if there was some function to easily format a date to the proper localization. (month-day-year vs day-month-year, for example)
Well, now there is!
Code: (Select All) PRINT UniDate$("mm/dd/yyyy", DATE$)
PRINT UniDate$("w, MM dd, YYYY", DATE$)
PRINT UniDate$("W, MM DD, YYYY", DATE$)
PRINT UniDate$("dd/mm/yyyy", DATE$)
PRINT UniDate$("W, E D, YYYY", DATE$)
PRINT UniDate$("mm-dd-yy", DATE$)
FUNCTION UniDate$ (format$, userdate$)
'some basic documentation for formatting:
'dates sent via userdate$ should be in the standardized QB64 DATE$ format -- MM/DD/YYYY
'To customize your return date format, use the following syntax
'w = short weekday names. (Mon, Tue, Wed, Thu, Fri, Sat, Sun)
'W = long weekday names. (Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday)
'E = Extended month names. (January, February, March....)
'M = long month names. (Jan, Feb, Mar...)
'm = short month names. (01, 02, 03...)
'D = long day names. (01st, 02nd, 03rd...)
'd = short day names. (01, 02, 03...)
'Y or y (case insensitive) = year. Number of Yy present determines the number of digits we return.
' YY = 2-digit year
' YYYY = 4 digit year
' Y with any additional number of y's = 4 digit year by default, so a typo of YYYYY is the same as YYYY.
'Any other character is simply considered part of the desired output and faithfully carried over into the proper spot.
' For example, "mm/dd/yyyy" gives us "02/10/2023" for Feb 10th, 2023.
' Second example, "dd.mm.yyyy" gives us "10.02.2023" for the same date.
' Third example, "dd EE YYYY" gives us "02 February 2023" for that same date.
'Note: Extra digits of most of these codes are simply ignored for error proofing purposes, with only the initial code being accepted.
' For example "mM YYYY" is actually processed as a simple "m YYYY". The process won't mix short, long, or extended results.
' Also for example, "m YY" is the *exact* same as "mm YY".
' Feel free to use extra digits as you desire to help you keep track of positional spacing in your format string.
' Even though "M D, yyyy" may process the same as "MMM DDDD, YYYY", the second may work better for you if you're trying to track
' position of formatted objects. (The output would be "Feb 10th, 2023", and those extra characters help hold that
' positioning for us easily.)
'And, I think that's it. Enjoy, guys!
temp$ = userdate$
IF temp$ = "" THEN temp$ = DATE$
m$ = LEFT$(temp$, 2)
d$ = MID$(temp$, 4, 2)
y$ = RIGHT$(temp$, 4)
temp$ = format$
DO
firstchar$ = LEFT$(temp$, 1)
SELECT CASE firstchar$
CASE "E" 'extended month
temp$ = MID$(temp$, 2)
IF NOT MonthSet THEN
MonthSet = -1
SELECT CASE VAL(m$)
CASE 1: out$ = out$ + "January"
CASE 2: out$ = out$ + "February"
CASE 3: out$ = out$ + "March"
CASE 4: out$ = out$ + "April"
CASE 5: out$ = out$ + "May"
CASE 6: out$ = out$ + "June"
CASE 7: out$ = out$ + "July"
CASE 8: out$ = out$ + "August"
CASE 9: out$ = out$ + "September"
CASE 10: out$ = out$ + "October"
CASE 11: out$ = out$ + "November"
CASE 12: out$ = out$ + "December"
END SELECT
END IF
CASE "M" 'long month
temp$ = MID$(temp$, 2)
IF NOT MonthSet THEN
MonthSet = -1
SELECT CASE VAL(m$)
CASE 1: out$ = out$ + "Jan"
CASE 2: out$ = out$ + "Feb"
CASE 3: out$ = out$ + "Mar"
CASE 4: out$ = out$ + "Apr"
CASE 5: out$ = out$ + "May"
CASE 6: out$ = out$ + "Jun"
CASE 7: out$ = out$ + "Jul"
CASE 8: out$ = out$ + "Aug"
CASE 9: out$ = out$ + "Sep"
CASE 10: out$ = out$ + "Oct"
CASE 11: out$ = out$ + "Nov"
CASE 12: out$ = out$ + "Dec"
END SELECT
END IF
CASE "m" 'short month
temp$ = MID$(temp$, 2)
IF NOT MonthSet THEN
MonthSet = -1
SELECT CASE VAL(m$)
CASE 1: out$ = out$ + "01"
CASE 2: out$ = out$ + "02"
CASE 3: out$ = out$ + "03"
CASE 4: out$ = out$ + "04"
CASE 5: out$ = out$ + "05"
CASE 6: out$ = out$ + "06"
CASE 7: out$ = out$ + "07"
CASE 8: out$ = out$ + "08"
CASE 9: out$ = out$ + "09"
CASE 10: out$ = out$ + "10"
CASE 11: out$ = out$ + "11"
CASE 12: out$ = out$ + "12"
END SELECT
END IF
CASE "D" 'long day
temp$ = MID$(temp$, 2)
IF NOT DaySet THEN
DaySet = -1
out$ = out$ + RIGHT$("00" + _TRIM$(d$), 2)
SELECT CASE VAL(d$)
CASE 1, 11, 21, 31: out$ = out$ + "st"
CASE 2, 22: out$ = out$ + "nd"
CASE 3, 23: out$ = out$ + "rd"
CASE ELSE: out$ = out$ + "th"
END SELECT
END IF
CASE "d" 'short day
temp$ = MID$(temp$, 2)
IF NOT DaySet THEN
DaySet = -1
out$ = out$ + RIGHT$("00" + _TRIM$(d$), 2)
END IF
CASE "W" 'long weekday
temp$ = MID$(temp$, 2)
IF NOT WeekdaySet THEN
GOSUB getday
SELECT CASE result
CASE 0: Day$ = "Saturday"
CASE 1: Day$ = "Sunday"
CASE 2: Day$ = "Monday"
CASE 3: Day$ = "Tuesday"
CASE 4: Day$ = "Wednesday"
CASE 5: Day$ = "Thursday"
CASE 6: Day$ = "Friday"
END SELECT
out$ = out$ + Day$
END IF
CASE "w" 'short weekday
temp$ = MID$(temp$, 2)
IF NOT WeekdaySet THEN
GOSUB getday
SELECT CASE result
CASE 0: Day$ = "Sat"
CASE 1: Day$ = "Sun"
CASE 2: Day$ = "Mon"
CASE 3: Day$ = "Tue"
CASE 4: Day$ = "Wed"
CASE 5: Day$ = "Thr"
CASE 6: Day$ = "Fri"
END SELECT
out$ = out$ + Day$
END IF
CASE "Y", "y" 'year
IF NOT YearSet THEN
YearSet = -1
IF LEFT$(UCASE$(temp$), 4) = "YYYY" THEN
temp$ = MID$(temp$, 5)
out$ = out$ + y$
ELSEIF LEFT$(UCASE$(temp$), 2) = "YY" THEN
temp$ = MID$(temp$, 3)
out$ = out$ + RIGHT$(y$, 2)
ELSE
temp$ = MID$(temp$, 2)
out$ = out$ + y$
END IF
ELSE
temp$ = MID$(temp$, 2)
END IF
CASE ELSE 'seperator
temp$ = MID$(temp$, 2)
out$ = out$ + firstchar$
END SELECT
LOOP UNTIL temp$ = ""
UniDate$ = out$
EXIT FUNCTION
getday:
WeekdaySet = -1
'From Zeller's congruence: https://en.wikipedia.org/wiki/Zeller%27s_congruence
mm = VAL(m$): dd = VAL(d$): yyyy = VAL(y$)
IF mm < 3 THEN mm = mm + 12: yyyy = yyyy - 1
century = yyyy MOD 100
zerocentury = yyyy \ 100
result = (dd + INT(13 * (mm + 1) / 5) + century + INT(century / 4) + INT(zerocentury / 4) + 5 * zerocentury) MOD 7
RETURN
END FUNCTION
|
|
|
Using periods in sub and function names? |
Posted by: TerryRitchie - 02-09-2023, 06:36 AM - Forum: Help Me!
- Replies (13)
|
|
I noticed this can be done:
FUNCTION MY.NEW.FUNCTION()
- code here
MY.NEW.FUNCTION = -1
END FUNCTION
I saw the use of periods as word separators in someone else's code. I decided to use this construct on a project I'm working on. However, as the code grows (up to 4000 lines now) the IDE sometime fails to color code the SUBS and FUNCTIONS that use periods in their names. I need to move the cursor by pressing the space bar (or simply typing) and the color coding will come back, but disappear later again.
Is the IDE doing this because it does not like the use of periods in the SUB and FUNCTION names? Should I not be using this construct? I find it to be much cleaner looking than MY_NEW_FUNCTION but can revert to this if need be.
I've not run into a problem with the code compiling or running in any way, just curious behavior from the IDE I've noticed, especially like I said as the code continues to grow and only affecting SUBs and FUNCTIONs with periods in their name.
|
|
|
Exercism |
Posted by: bruce_axtens - 02-09-2023, 06:17 AM - Forum: General Discussion
- Replies (4)
|
|
I'm sure I've mentioned this before. Can't find it in a search. So, here we go again.
Exercism.org is a place where programmers can go to get better. The blurb on the front page includes "Solve coding exercises and get mentored to develop fluency in your chosen programming languages. Exercism is open-source and not-for-profit."
I've recently launched a learning track for 8th, a FORTH dialect. It took me a while but I was working mostly alone. I had a considerably larger team around me for the COBOL track.
There could be a BASIC track. It's not hard, just takes a bit of dogged persistence. The community is helpful and the admin support is outstanding. The requirements are well described.
I am NOT volunteering to lead. I'm still working on a Euphoria track, and if that doesn't kill me, I'll follow with SNOBOL4.
This is a suggestion. Get some folk inspired.
-Bruce
|
|
|
Explosions - Handy Drawing Tool |
Posted by: bplus - 02-09-2023, 04:27 AM - Forum: Utilities
- Replies (1)
|
|
I got tired of reinventing the wheel for explosions so I made a handy drawing tool. Just give it the x, y location, the diameter = spread to cover and red, green, blue colors to use. It will calculate the number of dots, frames and speeds needed for decent explosion and set that up with DrawDots sub.
This is my test code for developing Explode:
Code: (Select All) Option _Explicit
_Title "Explosions test" 'b+ revisit 2023-02-08
Const xmax = 800, ymax = 600
Screen _NewImage(xmax, ymax, 32)
_ScreenMove (1280 - xmax) / 2 + 30, (760 - ymax) / 2
Randomize Timer
Type particle ' ===================================== Explosions Setup
As Long life, death
As Single x, y, dx, dy, r
As _Unsigned Long c
End Type
Dim Shared nDots
nDots = 2000
ReDim Shared dots(nDots) As particle ' ==============================
Dim As Long mx, my, mb
Do
Cls
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
Circle (mx, my), 5
If mb Then
' explode sets up dots and runs them out over several loops
Explode mx, my, 100, 0, 120, 40
Circle (mx, my), 100
_Display
_Delay .2 ' alittle delay for user to release mousebutton
End If
DrawDots
_Display
_Limit 30 ' or 60
Loop
Print "done"
' explode sets up old dead particles for display for a life
' This sub sets up Dots to display with DrawDots
' this sub uses rndCW
Sub Explode (x, y, spread, cr, cg, cb)
' x, y explosion origin
' spread is diameter of area to cover from it number of dots, number of frames and speed are calculated
' setup for explosions in main
'Type particle
' As Long life, death
' As Single x, y, dx, dy, r
' As _Unsigned Long c
'End Type
'Dim Shared nDots
'nDots = 2000
'ReDim Shared dots(nDots) As particle
Dim As Long i, dotCount, newDots
Dim angle, speed, rd, rAve, frames
newDots = spread / 2 ' quota
frames = spread / 5
speed = spread / frames ' 0 to spread in frames
rAve = .5 * spread / Sqr(newDots)
For i = 1 To nDots ' find next available dot
If dots(i).life = 0 Then
dots(i).life = 1 ' turn on display
dots(i).death = frames
angle = _Pi(2 * Rnd)
dots(i).x = x: dots(i).y = y ' origin
rd = Rnd
dots(i).dx = rd * speed * Cos(angle) ' moving
dots(i).dy = rd * speed * Sin(angle)
dots(i).r = RndCW(rAve, rAve) ' radius
dots(i).c = _RGB32(cr + Rnd * 40 - 20, cg + Rnd * 40 - 20, cb + Rnd * 40 - 20) 'color
dotCount = dotCount + 1
If dotCount >= newDots Then Exit Sub
End If
Next
End Sub
Sub DrawDots ' this sub needs fcirc to Fill Circles and Sub Explode sets up the Dots to draw.
' setup in main for explosions
'Type particle
' As Long life, death
' As Single x, y, dx, dy, r
' As _Unsigned Long c
'End Type
'Dim Shared nDots
'nDots = 2000
'ReDim Shared dots(nDots) As particle
Dim As Long i
For i = 1 To nDots ' display of living particles
If dots(i).life Then
FCirc dots(i).x, dots(i).y, dots(i).r, dots(i).c
' update dot
If dots(i).life + 1 >= dots(i).death Then
dots(i).life = 0
Else
dots(i).life = dots(i).life + 1
' might want air resistence or gravity added to dx or dy
dots(i).x = dots(i).x + dots(i).dx
dots(i).y = dots(i).y + dots(i).dy
If dots(i).x < 0 Or dots(i).x > xmax Then dots(i).life = 0
If dots(i).y < 0 Or dots(i).y > ymax Then dots(i).life = 0
dots(i).r = dots(i).r * 1 - (dots(i).life / dots(i).death) ' puff!
If dots(i).r <= 0 Then dots(i).life = 0
End If
End If
Next
End Sub
'from Steve Gold standard
Sub FCirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Function RndCW (C As Single, range As Single) 'center +/-range weights to center
RndCW = C + Rnd * range - Rnd * range
End Function
|
|
|
The Window Closer X |
Posted by: Ron - 02-08-2023, 06:58 PM - Forum: Help Me!
- Replies (7)
|
|
Hello everyone, I am using the QB64 for windows compatibility converted all the QB 4.5 to QB64 it has been working for 6 years now. Anyway one of my users asked me to disable the X on closing the program because they didn't want it to close in the middle of what they were doing so I put in the the command 'ex = _EXIT'. This works like it states you can't close the program with the X on the window. Now to kill the program when it freezes they have to kill the process in windows. Is there a why to use ON KEY to close it? I have tried ON KEY(1) with a subroutine and GOSUB it will not do the code when I press F1 so somehow the ON KEY is not working for me. I am using QB64 Version 1.1 Revision 20170120/51 does it work in more recent versions and where do I find them now. Alt + F4 should be what the Window close X button uses I think but maybe I am wrong.
Is there anyone that may know something to help me or should I leave it the way it is.
|
|
|
Welcome to 2023. |
Posted by: eoredson - 02-08-2023, 03:39 AM - Forum: Help Me!
- Replies (5)
|
|
Hi,
Happy belated 2023! This is a program to display the factors of 2023:
Code: (Select All) Year = 2023
z = Year - 1
Do Until z = Year
z = z + 1
x = z
Print x; "=";
l = 1
q = 0
Do Until x = 1
l = l + 1
Do While x / l = x \ l ' continue to divide number
q = q + 1
If q > 1 Then
Print "*";
End If
Print l;
x = x / l
Loop
If l > Int(z / 2) Then ' test for maximum divisor
Exit Do
End If
If l > Int(Sqr(x)) Then ' test maximum divisor is prime
If q = 0 Then
Exit Do
End If
End If
Loop
If q = 0 Then ' display number is prime
Print " (prime)";
End If
Print
Loop
End
|
|
|
some suggestions / requests for anyone looking to port a classic game to QB64PE |
Posted by: madscijr - 02-07-2023, 10:20 PM - Forum: General Discussion
- Replies (12)
|
|
Hey all!
After Terry's killer version of Pac Man and RokCoder's Galaga, I'm compelled to list a few that may be beyond my current skillset, patience level, and/or free time, but which would make the world a better place if they existed...
- Pinball Construction Set
- Zaxxon / Super Zaxxon - except let the player have full freedom of motion to fly in any direction (i.e. the plane can turn 360 degrees like in Time Pilot or Asteroids) and maybe even land and the player can get out and run around isometrically (like Realm of Impossibility), and maybe pilot other vehicles (like Frontline)! And a level editor!
- Gravitar - the vector game, but maybe with multiplayer (split screen or quad split screen) options and a level editor of course.
- Cliff Hanger - the C64 game which is basically like the old Road Runner cartoon
- Sprint 8 / Super Sprint - top down racing fun
- Jumpman / Jumpman Jr. / Ultimate Wizard - with level editor
- Tempest with level editor
- Defender / Stargate
- Mr. Do! / Dig Dug or maybe a combination of the 2
- Lode Runner (the 8-bit C64 or IBM version) with editor
- Racing Destruction Set
- Spy vs Spy
- Ultima III Construction Set
- a Zork game construction set
- Berzerk / Outlaw / Gunfighter but for 2-4 players with an editor
- Atari Adventure Construction Set (maybe multiplayer option too)
- Pitfall! and/or Pitfall II (with editor)
- Mail Order Monsters
(I would happily program all of the above but I'm still working on Spacewar! and maybe a Lunar Lander / Asteroids mashup, and a Pong Construction Set, maybe eventually one for multiplayer controllable with multiple USB mice plugged into a single PC!)
That's all I got for now -
Cheers
|
|
|
SEEK with INPUT for variable length strings |
Posted by: SMcNeill - 02-07-2023, 07:28 PM - Forum: SMcNeill
- Replies (2)
|
|
Code: (Select All) OPEN "data.txt" FOR OUTPUT AS #1
OPEN "data.ndx" FOR RANDOM AS #2 LEN = 4 'one long variable in size
DIM ndx AS LONG 'that long variable I mentioned above
DIM text AS STRING 'and a random length string
DIM count AS LONG 'and a counter for which element we want
DO
ndx = LOF(1) + 1
PUT #2, , ndx
READ text$
PRINT #1, text$
LOOP UNTIL text$ = "EOD"
CLOSE #1
OPEN "data.txt" FOR INPUT AS #1
'now we have a data file that we can use input with and read any record out of at will
DO
INPUT "Which record would you like to retrieve =>"; count
IF count = 0 THEN SYSTEM
GET #2, count, ndx
SEEK #1, ndx
INPUT #1, text
PRINT "That record was: "; text
LOOP
1
DATA one,two,three,four,five,six,seven,eight,nine,ten,eleven,twelve
DATA thirteen,fourteen,fiveteen,sixteen,seventeen,eighteen,nineteen,tenteen,eleventeen,twelveteen,EOD
|
|
|
|