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 Terrain |
Posted by: james2464 - 01-08-2023, 09:24 PM - Forum: Help Me!
- Replies (25)
|
|
I've managed to figure out how to produce random terrain using a grid of triangles, and then assigning a slightly random z value to the points. It's very primitive but could be useful to build on.
But for now I'm stuck on how to detect or collide with this terrain. It might be very complicated, or perhaps not. Right now the spectator viewing is just like ghost mode, as in you can fly around and go through everything. I'd like to make it so you can't pass through the textures at all. Then if I can choose some textures as OK to pass throught (such as water surface) and others NOT OK to pass through, such as land, that would be ideal. And later on, I'd like to be able to put a character on the surface and control it. For now though, I'd like to understand how to detect these surfaces. A square/rectangle room is not a problem, because you can just set limits on X,Y,Z movement. Any flat surface is easy this way. But the random terrain seems to need a different approach.
Code: (Select All) '3d terrain on water - james2464 - Jan 2023
'Credit to 3D program and tutorial by MasterGy
Option _Explicit
Randomize Timer
Screen _NewImage(1000, 1000, 32)
Const pip180 = 3.141592 / 180
Dim Shared c(100) As Long
Dim scr, da, db, da2, dega, db2, degb, ss, ap, sqa
Dim sky_points, sky_image, actual_point, asq
Dim wx0, wy0, wz0, wx1, wy1, wz1, wx2, wy2, wz2, wx3, wy3, wz3, sx0, sy0, sx1, sy1, sx2, sy2, sx3, sy3
Dim mousex, mousey, mw, mouse_sens, vec_x, vec_y, vec_z, speed, moving
Dim sp3
Dim t, x, y, h, b, tz
Dim Shared trx(5000), try(5000), trz(5000) 'terrain points
Dim Shared fr1(5000), fr2(5000), fr3(5000), fr4(5000), fr5(5000), fr6(5000) 'terrain point groups (hex)
Dim Shared maxterrain, maxp, shx, shy, shz
Cls
colour1
Dim Shared floor1, wall1, wall2, ground1, sky1, cbx(20)
wall1 = _NewImage(500, 100, 32): makewall
wall2 = _NewImage(500, 100, 32): makewall2
ground1 = _NewImage(500, 500, 32): makeground
'ground1 = _LoadImage("painting.jpg", 32)
sky1 = _NewImage(750, 750, 32): makesky
maketerrain
For t = 0 To 10: cbx(t) = _NewImage(400, 400, 32): Next t: makepallette
Dim Shared tximage(200)
For t = 0 To 10: tximage(t) = _CopyImage(cbx(t), 33): Next t
tximage(11) = _CopyImage(ground1, 33)
tximage(12) = _CopyImage(wall1, 33) 'office wall solid
tximage(13) = _CopyImage(wall2, 33) 'office wall with 3 windows
Type mapobject
n As Integer 'object number
x As Single 'x origin
y As Single 'y origin
z As Single 'z origin
x1 As Single
y1 As Single
z1 As Single
x2 As Single
y2 As Single
z2 As Single
x3 As Single
y3 As Single
z3 As Single
x4 As Single
y4 As Single
z4 As Single
ix As Single 'image x
iy As Single 'image y
in As Integer 'image number - tximage()
End Type
Dim Shared raw(100) As mapobject, oo(900) As mapobject
'create texture point data array
Dim Shared tx(500, 19), txtot, rawtxtot
'objects and data points
Data 1,0,0,0,-1000,0,200,-1000,0,-200,1000,0,200,1000,0,-200,500,100,12: 'wall
Data 2,0,0,0,-4000,-4000,0,-4000,4000,0,4000,-4000,0,4000,4000,0,500,100,3: 'water
rawtxtot = 2: txtot = rawtxtot
'read data into array tx()
Dim t2
For t = 1 To txtot
For t2 = 1 To 19
Read tx(t, t2)
Next t2
'create 'raw' objects
raw(t).n = tx(t, 1): raw(t).x = tx(t, 2): raw(t).y = tx(t, 3): raw(t).z = tx(t, 4)
raw(t).x1 = tx(t, 5): raw(t).y1 = tx(t, 6): raw(t).z1 = tx(t, 7)
raw(t).x2 = tx(t, 8): raw(t).y2 = tx(t, 9): raw(t).z2 = tx(t, 10)
raw(t).x3 = tx(t, 11): raw(t).y3 = tx(t, 12): raw(t).z3 = tx(t, 13)
raw(t).x4 = tx(t, 14): raw(t).y4 = tx(t, 15): raw(t).z4 = tx(t, 16)
raw(t).ix = tx(t, 17): raw(t).iy = tx(t, 18): raw(t).in = tx(t, 19)
Next t
'object copies
Dim nn, nc, xc, yc, zc, ac
'nn = 1: nc = 1: xc = 0: yc = 0: zc = 400: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 2: xc = 0: yc = 0: zc = 500: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'water
'create spectator
Dim Shared sp(6)
sp(0) = 0 'X position
sp(1) = 1500 'Y
sp(2) = 400 'Z
sp(3) = 0 'looking in the direction of the observer XZ
sp(4) = 0 'looking in the direction of the observer YZ
sp(5) = 1 'multiplier X-Y see
sp(6) = 1 'multiplier Z see
'create screen
scr = _NewImage(1000, 1000 / _DesktopWidth * _DesktopHeight, 32)
Screen scr
_MouseHide
_FullScreen
_Dest scr
_DisplayOrder _Hardware , _Software
'sky install
da = 11 'resolution sphere X
db = 7 'resolution sphere Y
sky_points = da * db
Dim sky_points(sky_points - 1, 9), sq(sky_points - 1, 7)
'sky_image = _LoadImage("sky.jpg", 33)
sky_image = _CopyImage(sky1, 33)
For da2 = 0 To da - 1
dega = 360 / (da - 1) * da2 * pip180
For db2 = 0 To db - 1
degb = 180 / (db - 1) * db2 * pip180
ss = 4000
ap = da2 * db + db2
sky_points(ap, 0) = Sin(degb) * Cos(dega) * ss
sky_points(ap, 1) = Sin(degb) * Sin(dega) * ss
sky_points(ap, 2) = Cos(degb) * ss
Next db2
Next da2
For da2 = 0 To da - 2
For db2 = 0 To db - 2
sqa = da2 * db + db2
sq(sqa, 0) = sqa
sq(sqa, 1) = sq(sqa, 0) + 1
sq(sqa, 2) = sq(sqa, 0) + db
sq(sqa, 3) = sq(sqa, 2) + 1
sq(sqa, 4) = _Width(sky_image) - (_Width(sky_image) / (da - 1) * da2) - 1
sq(sqa, 5) = _Width(sky_image) - (_Width(sky_image) / (da - 1) * (da2 + 1)) - 1
sq(sqa, 6) = Int(_Height(sky_image) / (db - 1) * db2)
sq(sqa, 7) = Int(_Height(sky_image) / (db - 1) * (db2 + 1))
Next db2
Next da2
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
Do
_Limit 40
processterrain
processtextures
'draw sky *********************************************************************************
't = 1 'use for checkered sky
'rotating
For actual_point = 0 To sky_points - 1
sky_points(actual_point, 4) = sky_points(actual_point, 0)
sky_points(actual_point, 5) = sky_points(actual_point, 1)
sky_points(actual_point, 6) = sky_points(actual_point, 2)
r2m sky_points(actual_point, 4), sky_points(actual_point, 5), sky_points(actual_point, 6)
Next actual_point
For asq = 0 To sky_points - 1
wx0 = sky_points(sq(asq, 0), 4) + 0: wy0 = sky_points(sq(asq, 0), 5) + 0: wz0 = sky_points(sq(asq, 0), 6)
wx1 = sky_points(sq(asq, 1), 4) + 0: wy1 = sky_points(sq(asq, 1), 5) + 0: wz1 = sky_points(sq(asq, 1), 6)
wx2 = sky_points(sq(asq, 2), 4) + 0: wy2 = sky_points(sq(asq, 2), 5) + 0: wz2 = sky_points(sq(asq, 2), 6)
wx3 = sky_points(sq(asq, 3), 4) + 0: wy3 = sky_points(sq(asq, 3), 5) + 0: wz3 = sky_points(sq(asq, 3), 6)
sy0 = sq(asq, 6): sx0 = sq(asq, 4): sy1 = sq(asq, 7): sx1 = sq(asq, 4): sy2 = sq(asq, 6): sx2 = sq(asq, 5): sy3 = sq(asq, 7): sx3 = sq(asq, 5)
't = t * -1 'use for checkered sky
'If t > 0 Then 'use for checkered sky
_MapTriangle (sx0, sy0)-(sx1, sy1)-(sx2, sy2), sky_image To(wx0, wy0, wz0)-(wx1, wy1, wz1)-(wx2, wy2, wz2), , _Smooth
_MapTriangle (sx3, sy3)-(sx1, sy1)-(sx2, sy2), sky_image To(wx3, wy3, wz3)-(wx1, wy1, wz1)-(wx2, wy2, wz2), , _Smooth
'End If 'use for checkered sky
Next asq
' ****************************************************************************************************
_Display
'-------------------------------------------------------------
'mouse input axis movement and mousewheel
'-------------------------------------------------------------
mousex = mousex * .6
mousey = mousey * .6
mw = 0
While _MouseInput: mousex = mousex + _MouseMovementX: mousey = mousey + _MouseMovementY: mw = mw + _MouseWheel: Wend 'movement data read
'control spectator
mouse_sens = .0007 'mouse rotating sensitive
sp(3) = sp(3) - mousex * mouse_sens
sp(4) = sp(4) + mousey * mouse_sens
If Abs(sp(4)) > _Pi / 2 Then sp(4) = _Pi / 2 * Sgn(sp(4))
sp3 = sp(3) + (_KeyDown(Asc("d")) - _KeyDown(Asc("a"))) * 90 * pip180
vec_x = (Sin(sp3) * (Cos(sp(4) + _Pi)))
vec_y = (Cos(sp3) * (Cos(sp(4) + _Pi)))
vec_z = -Sin(sp(4) + _Pi)
If _KeyDown(Asc("a")) Or _KeyDown(Asc("d")) Then vec_z = 0
speed = 2.5 'moving speed
moving = Abs(_MouseButton(1) Or _KeyDown(Asc("w")) Or _KeyDown(Asc("a")) Or _KeyDown(Asc("d"))) * speed - Abs(_MouseButton(2) Or _KeyDown(Asc("s"))) * speed
sp(0) = sp(0) + vec_x * moving
sp(1) = sp(1) + vec_y * moving
sp(2) = sp(2) + vec_z * moving
'If sp(0) > 465 Then sp(0) = 465
'If sp(1) > 465 Then sp(1) = 465
'If sp(0) < -465 Then sp(0) = -465
'If sp(1) < -465 Then sp(1) = -465
Loop Until _KeyDown(27)
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
Sub r2m (x, y, z)
Dim x2, y2, z2
x2 = x - sp(0)
y2 = y - sp(1)
z2 = z - sp(2)
rotate_2d x2, y2, sp(3)
rotate_2d y2, z2, sp(4) + _Pi / 2
x = x2 * sp(5)
y = y2 * sp(5)
z = z2 * sp(6)
End Sub
Sub rotate_2d (x, y, ang)
Dim x1, y1
x1 = x * Cos(ang) - y * Sin(ang)
y1 = x * Sin(ang) + y * Cos(ang)
x = x1: y = y1
End Sub
Sub processtextures
Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
For t = 1 To txtot
x1 = oo(t).x1: y1 = oo(t).y1: z1 = oo(t).z1
x2 = oo(t).x2: y2 = oo(t).y2: z2 = oo(t).z2
x3 = oo(t).x3: y3 = oo(t).y3: z3 = oo(t).z3
x4 = oo(t).x4: y4 = oo(t).y4: z4 = oo(t).z4
x = oo(t).ix: y = oo(t).iy
r2m x1, y1, z1
r2m x2, y2, z2
r2m x3, y3, z3
r2m x4, y4, z4
_MapTriangle (0, 0)-(0, y)-(x, 0), tximage(oo(t).in) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
_MapTriangle (x, y)-(0, y)-(x, 0), tximage(oo(t).in) To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
Next t
End Sub
Sub processterrain
Dim t, t2, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
Dim xx1, yy1, zz1, xx2, yy2, zz2, xx3, yy3, zz3, xx4, yy4, zz4
Dim flag, ct, scale1, txm
flag = 0
ct = 0
scale1 = 2.
shx = -500 'shift x position
shy = -500 '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
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
r2m x1, y1, z1
r2m x2, y2, z2
r2m x3, y3, z3
txm = 11
_MapTriangle (xx1, yy1)-(xx2, yy2)-(xx3, yy3), tximage(txm) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
If ct >= maxp Then flag = 1
Loop Until flag = 1
End Sub
Sub objectcopy (nn, nc, xc, yc, zc, ac)
Dim ct, t, t2, xt, yt
ct = 0
For t = 1 To rawtxtot
If raw(t).n = nc Then
ct = ct + 1
t2 = txtot + ct
oo(t2).n = nn: oo(t2).x = xc: oo(t2).y = yc: oo(t2).z = zc
xt = raw(t).x1: yt = raw(t).y1: xyrotation xt, yt, ac: oo(t2).x1 = xt + xc: oo(t2).y1 = yt + yc: oo(t2).z1 = raw(t).z1 + zc
xt = raw(t).x2: yt = raw(t).y2: xyrotation xt, yt, ac: oo(t2).x2 = xt + xc: oo(t2).y2 = yt + yc: oo(t2).z2 = raw(t).z2 + zc
xt = raw(t).x3: yt = raw(t).y3: xyrotation xt, yt, ac: oo(t2).x3 = xt + xc: oo(t2).y3 = yt + yc: oo(t2).z3 = raw(t).z3 + zc
xt = raw(t).x4: yt = raw(t).y4: xyrotation xt, yt, ac: oo(t2).x4 = xt + xc: oo(t2).y4 = yt + yc: oo(t2).z4 = raw(t).z4 + zc
oo(t2).ix = raw(t).ix: oo(t2).iy = raw(t).iy: oo(t2).in = raw(t).in
End If
Next t
txtot = txtot + ct
End Sub
Sub xyrotation (x, y, a)
Dim xt, yt, h, h1, h2, xt2, yt2
xt = x: yt = y
h = _Hypot(yt, xt)
h1 = _Atan2(xt, yt)
h2 = h1 - a
xt2 = Sin(h2) * h
yt2 = Cos(h2) * h
x = xt2
y = yt2
End Sub
Sub makefloor
Dim t, x1, y1
Cls
Line (0, 0)-(500, 500), c(18), BF 'floor background
For t = 1 To 6000
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(0)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(2)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(3)
Next t
'_Display
_PutImage (0, 0)-(500, 500), 0, floor1, (0, 0)-(500, 500)
'Sleep
End Sub
Sub makewall
Dim t, x1, y1
Cls
Line (0, 0)-(500, 100), c(7), BF 'wall background
For t = 1 To 6000
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(8)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(9)
Next t
'_Display
_PutImage (0, 0)-(500, 100), 0, wall1, (0, 0)-(500, 100)
_ClearColor c(0), wall1
'Sleep
End Sub
Sub makewall2
Dim t, x1, y1
Cls
Line (0, 0)-(500, 100), c(7), BF 'wall2 background
For t = 1 To 6000
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(8)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(9)
Next t
Line (70, 25)-(150, 75), c(0), BF
Line (210, 25)-(290, 75), c(0), BF
Line (350, 25)-(430, 75), c(0), BF
'_Display
_PutImage (0, 0)-(500, 100), 0, wall2, (0, 0)-(500, 100)
_ClearColor c(0), wall2
'Sleep
End Sub
Sub makeground
Dim t, x1, y1, s, s2
s = 220
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 t = 1 To 155
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
Line (x1 - 30, y1 - 30)-(x1 + 30, y1 + 30), c(41), BF
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
Line (x1 - 50, y1 - 50)-(x1 + 50, y1 + 50), c(42), BF
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
Line (x1 - 20, y1 - 20)-(x1 + 20, y1 + 20), c(43), BF
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
Line (x1 - 20, y1 - 20)-(x1 + 20, y1 + 20), c(44), BF
Next t
s = 790
s2 = (500 - s) / 2
For t = 1 To 7500
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
PSet (x1, y1), c(41)
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
PSet (x1, y1), c(42)
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
PSet (x1, y1), c(43)
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
PSet (x1, y1), c(44)
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
PSet (x1, y1), c(41)
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
PSet (x1, y1), c(42)
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
PSet (x1, y1), c(43)
x1 = Int(Rnd * s) + s2: y1 = Int(Rnd * s) + s2
PSet (x1, y1), c(44)
Next t
'Line (5, 5)-(495, 10), c(31), BF
'Line (5, 495)-(495, 490), c(32), BF
'Line (490, 5)-(495, 495), c(33), BF
'Line (5, 5)-(10, 495), c(34), BF
'_Display
_PutImage (0, 0)-(500, 500), 0, ground1, (0, 0)-(500, 500)
'Sleep
End Sub
Sub maketerrain
Dim t, s, x, y, x1, y1, p, q, p2, ct, ct2, flag
Dim xt, yt, xh, yh, vc, fx, fx1, fx2, mx, oldct
Cls
Line (0, 0)-(500, 500), c(1), B
t = 0
x1 = 500: y1 = 500
s = 25
fx = 1
maxterrain = 0
'create points (trx,try,trz)
For y = 0 To y1 Step s
fx = Int(fx * -1)
If fx > 0 Then
fx1 = 0
Else fx1 = s / 2
End If
For x = fx1 To x1 Step s
t = t + 1
trx(t) = x: try(t) = y
Circle (x, y), 3, c(1)
If x > s And x < x1 - s Then
If y > s And y < y1 - s Then
'trz(t) = 0
trz(t) = 0 - Int(Rnd * 17) - 5
xh = Abs(trx(t) - x1 / 2)
yh = Abs(try(t) - y1 / 2)
vc = _Hypot(xh, yh)
vc = 170 - vc
trz(t) = trz(t) - vc / 4
'trz(t) = trz(t) - (Int(Rnd * vc))
End If
End If
Next x
Next y
'_Display
'Sleep
maxterrain = t
'display points
p = Int(x1 / s) + 1
q = Int(y1 / s) - 1
fx = 1
t = 0
oldct = 0
For y = 0 To y1 Step s
fx = Int(fx * -1)
If fx > 0 Then
fx1 = 0
Else fx1 = s / 2
End If
For x = fx1 To x1 Step s
t = t + 1
If y > s Then
If x > s Then
If x < x1 - s Then
If y < y1 - s Then
Circle (trx(t), try(t)), 2, c(1)
Circle (trx(t), try(t)), 1, c(1)
Circle (trx(oldct), try(oldct)), 2, c(0)
Circle (trx(oldct), try(oldct)), 1, c(0)
'Line (trx(t), try(t))-(trx(t - p), try(t - p)), c(1)
'Line (trx(t), try(t))-(trx(t - p + 1), try(t - p + 1)), c(1)
'Line (trx(t), try(t))-(trx(t + p - 1), try(t + p - 1)), c(1)
'Line (trx(t), try(t))-(trx(t + p), try(t + p)), c(1)
'Line (trx(t), try(t))-(trx(t - 1), try(t - 1)), c(1)
'Line (trx(t), try(t))-(trx(t + 1), try(t + 1)), c(1)
oldct = t
'_Display
'Sleep
'Line (trx(t), try(t))-(trx(t - p), try(t - p)), c(0)
'Line (trx(t), try(t))-(trx(t - p + 1), try(t - p + 1)), c(0)
'Line (trx(t), try(t))-(trx(t + p - 1), try(t + p - 1)), c(0)
'Line (trx(t), try(t))-(trx(t + p), try(t + p)), c(0)
'Line (trx(t), try(t))-(trx(t - 1), try(t - 1)), c(0)
'Line (trx(t), try(t))-(trx(t + 1), try(t + 1)), c(0)
End If
End If
End If
End If
Next x
Next y
'_Display
'Sleep
'create point groups (fr1,fr2,fr3)
p = Int(x1 / s) + 1
q = Int(y1 / s) - 1
fx = 1
t = 0
ct = 0
oldct = 0
For y = 0 To y1 - 1 Step s
fx = Int(fx * -1)
If fx > 0 Then
fx1 = 0
Else fx1 = s / 2
End If
For x = fx1 To x1 Step s
t = t + 1
If fx > 0 Then
ct = ct + 1
fr1(ct) = t
fr2(ct) = t - p
fr3(ct) = t - p + 1
Line (trx(t), try(t))-(trx(t - p), try(t - p)), c(32)
Line (trx(t), try(t))-(trx(t - p + 1), try(t - p + 1)), c(32)
Line (trx(t - p), try(t - p))-(trx(t - p + 1), try(t - p + 1)), c(32)
'_Display
'Sleep
ct = ct + 1
fr1(ct) = t
fr2(ct) = t + p
fr3(ct) = t + p - 1
Line (trx(t), try(t))-(trx(t + p), try(t + p)), c(1)
Line (trx(t), try(t))-(trx(t + p - 1), try(t + p - 1)), c(1)
Line (trx(t + p), try(t + p))-(trx(t + p - 1), try(t + p - 1)), c(1)
'_Display
'Sleep
Else
ct = ct + 1
fr1(ct) = t
fr2(ct) = t + p
fr3(ct) = t + p - 1
Line (trx(t), try(t))-(trx(t + p), try(t + p)), c(33)
Line (trx(t), try(t))-(trx(t + p - 1), try(t + p - 1)), c(33)
Line (trx(t + p), try(t + p))-(trx(t + p - 1), try(t + p - 1)), c(33)
'_Display
'Sleep
ct = ct + 1
fr1(ct) = t + p + p - 1
fr2(ct) = t + p
fr3(ct) = t + p - 1
Line (trx(t + p + p - 1), try(t + p + p - 1))-(trx(t + p), try(t + p)), c(34)
Line (trx(t + p + p - 1), try(t + p + p - 1))-(trx(t + p - 1), try(t + p - 1)), c(34)
Line (trx(t + p), try(t + p))-(trx(t + p - 1), try(t + p - 1)), c(34)
'_Display
'Sleep
End If
oldct = t
Locate 35, 1
Print t, ct
'_Display
'Sleep
Next x
Next y
maxp = ct
'fr1(t) = t - p
'fr2(t) = t - p + 1
'fr3(t) = t + p - 1
'Cls
't = t + 1
'For ct = 1 To t
'Print fr1(ct), fr2(ct), fr3(ct)
'Next ct
'_Display
'Sleep
End Sub
Sub makesky
Dim t, y, m
Cls
y = 750
For t = 1 To y
m = 255 * ((750 - t * .65) / 750)
c(99) = _RGBA(200, 200, 255, m)
Line (0, t)-(750, t), c(99)
Next t
'For t = 0 To 750 Step 25 'longituge lines
'Line (t, 0)-(t, 750), c(1)
'Next t
'For t = 0 To 750 Step 25 'latitude lines
'Line (0, t)-(750, t), c(1)
'Next t
'_Display
_PutImage (0, 0)-(750, 750), 0, sky1, (0, 0)-(750, 750)
'Sleep
End Sub
Sub makepallette
Dim t
For t = 0 To 10
Cls
Line (0, 0)-(400, 400), c(t), BF
_PutImage (0, 0)-(400, 400), 0, cbx(t), (0, 0)-(400, 400)
'_Display
'Sleep
Next t
End Sub
Sub colour1
c(0) = _RGB(0, 0, 0)
c(1) = _RGB(255, 255, 255)
c(2) = _RGB(35, 25, 10)
c(3) = _RGB(10, 45, 65)
c(4) = _RGB(40, 50, 10)
c(5) = _RGB(0, 25, 75)
c(6) = _RGB(45, 35, 20)
c(7) = _RGB(150, 150, 150)
c(8) = _RGB(125, 125, 125)
c(9) = _RGB(100, 100, 100)
c(10) = _RGBA(75, 75, 75, 151)
c(11) = _RGB(0, 0, 0)
c(12) = _RGB(35, 25, 10)
c(13) = _RGB(0, 45, 85)
c(14) = _RGB(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)
End Sub
|
|
|
SAC -- Steve's Anorexic Code |
Posted by: SMcNeill - 01-08-2023, 03:21 AM - Forum: SMcNeill
- Replies (2)
|
|
Ahhh... The smell of the past! Many thanks to @keybone who dug up this old gem from the long lost days of the original qb64 forums over at .net, when Galleon was still around and in charge of things.
Code: (Select All) 'Steve's Anorexic Code
'This code has a very unique value to us.
'1) This allows us to append files to the end of our exe's very easily, and then extract them and clean them up afterwards.
'2) This works at a command line level, and lets us shell out from inside a program itself.
'To use this, first try it a few times with some BACKED UP copy of test files!!
'BACK EM UP!! BACK EM UP!! BACK EM UP!!
'Got that? Good.
'Then run this as a standard program.
'Enter the name of the file you'd like to feed stuff to.
'And at first, -SET THE TABLE Do this only once, as this sets us a counter for number of files "eatten"
'Then feed it something. -GOBBLE filename$ <-- this is the file we tack to the end of our exe
'Feed it more files if you want. Watch the exe grow in size as it absorbs the other files...
'Is it fat? Did you feed it enough?
'If so, then -PUKE or -BARF Throw them files back up!
'Phew! Didn't that make a mess?
'Then -CLEAN UP
'See all them files go POOF and disappear again? We clean up our mess afterwards.
'But this is MAGIC Anorexic Code! The exe still has all those files in it that it barfed up.
'Tell it to -PUKE again.
'All those files are back once more!!
'Use this as a quick, easy way to tack needed files onto your exe to make certain that an user will always have them.
'I use this to tack sound files, fonts, even images to my exe, and I extract them as needed.
'NOTE however, that this isn't just limited to EXE files. You can use this to assemble 100 map files into 1 map compendium,
' and then extract them when needed. At the moment, we don't puke single files up -- we puke every file up -- but
' someone could modify this easily enough to extract single files from a larger collection.
'To use as a shell command, use it like the following:
' Shell _hide "SAC.exe g.exe -gobble z:\test.txt" <--- this would add the test.txt file to the end of the g.exe file'
' syntax is: SAC.exe file1$ -command file2$
' file1$ would be the file we want to write to -- or feed.
' -command is the -command which we want to execute. -SET THE TABLE, -GOBBLE, -BARF, -CLEAN UP
'Simple, and useful as heck! :D
Dim Shared SAC_FileName As String
parameter$ = LTrim$(RTrim$(Command$))
If parameter$ <> "" Then
dash = InStr(parameter$, "-")
SAC_FileName = LTrim$(RTrim$(Left$(parameter$, dash - 1)))
parameter$ = RTrim$(LTrim$(Right$(parameter$, Len(parameter$) - dash + 1)))
Print SAC_FileName, parameter$
End
DoSAC parameter$
System
End If
Print "Give me the name of your file to stuff =>";
Input SAC_FileName
Do
Cls
Print SAC_FileName
Print
Print "1) Initialize"
Print "2) Gobble Something"
Print "3) Puke"
Print "4) Clean Up"
Print "5) End"
a$ = Input$(1)
a = Val(a$)
Select Case a
Case 1: DoSAC "-INIT": Print "Initialized"
Case 2:
Print "Name of file to eat:";
Input NAME$
NAME$ = "-GOBBLE " + NAME$
DoSAC NAME$
Case 3: DoSAC "-BARF"
Case 4: DoSAC "-CLEAN UP"
Case 5: System
End Select
Sleep
Loop
Sub DoSAC (t$)
Dim b As _Unsigned _Byte
Dim text As String * 1
Dim l(10) As _Unsigned _Integer64, l As _Unsigned _Integer64
Dim SACfile As String * 255
f = FreeFile
Select Case UCase$(t$)
Case "-SET THE TABLE", "-SET", "-INIT"
'initialize
Open SAC_FileName For Binary As #f
Seek #f, LOF(f) + 1
b = 0
Put #f, , b
Case "-BARF", "-PUKE"
'puke it all up
Open SAC_FileName For Binary As #f
Seek #f, LOF(f)
Get #f, , b
If b < 1 Then Print "No files have been gorged on by this program. FEED ME SOME!!": Beep: Beep: End
Print b; "files to puke up!"
CurrentPos = LOF(f) + 1
AmountAte = b
For i&& = 1 To AmountAte
CurrentPos = CurrentPos - 256
Get #f, CurrentPos, SACfile
file$ = LTrim$(RTrim$(SACfile))
Print file$; " barfed up!"
CurrentPos = CurrentPos - 8
Get #f, CurrentPos, l
CurrentPos = CurrentPos - l
g = FreeFile
Seek #f, CurrentPos
Open file$ For Binary As #g
For j&& = 1 To l
Get #f, , b
Put #g, , b
Next
b = 0
Put #g, , b
Close #g
Next
Case "-CLEAN UP"
'clean up the drive of all the puke
Open SAC_FileName For Binary As #f
Seek #f, LOF(f)
Get #f, , b
If b < 1 Then Print "No files have been gorged on by this program. FEED ME SOME!!": Beep: Beep: End
Print b; "puked up files to clean up!"
CurrentPos = LOF(f) + 1
AmountAte = b
For i&& = 1 To AmountAte
CurrentPos = CurrentPos - 256
Get #f, CurrentPos, SACfile
file$ = LTrim$(RTrim$(SACfile))
Print file$; " cleaned up off the dinner table!"
CurrentPos = CurrentPos - 8
Get #f, CurrentPos, l
CurrentPos = CurrentPos - l
Kill file$
Next
Case Else
If Left$(t$, 8) = "-GOBBLE " Then
file$ = Right$(t$, Len(t$) - 8)
If _FileExists(file$) Then
Print "Eatting "; file$
'eat stuff
Open SAC_FileName For Binary As #f
l(0) = LOF(f)
Seek #f, l(0)
Get #f, , b
AmountEat = b
g = FreeFile
Open file$ For Binary As #g
l(1) = LOF(g)
For i&& = 1 To l(1)
Get #g, , b
Put #f, , b
Next
Close #g
Put #f, , l(1)
SACfile = file$
Put #f, , SACfile
b = AmountEat + 1
Put #f, , b
Print file$, " was tasty!"
Else
'Do nothing as the file doesn't exist.
Print "WARNING: "; file$; " does not exist!"
Beep: Beep
End If
End If
End Select
Close #f
End Sub
Steve's Anorexic Code is an utility which eats resource files, stuffs them onto your existing EXE, and then barfs them back up on call. Want to pack a dozen files into one and ship them all together? This can do that! Compile your EXE, and then feed SAC that EXE and resource files, and get one nice and fat file all packaged up together. When you need those resources, just -barf them back up on demand!
What's not to love about it? Just read the comments for ease of usage.
|
|
|
Changing Compile Options |
Posted by: bplus - 01-07-2023, 04:09 PM - Forum: Repo Discussion
- Replies (9)
|
|
When I changed compile options in QB64 pe 3.4.1 I lost all my recent files!
Was this fixed?
It looks like I have latest release according to this site bottom link for QB64pe
|
|
|
Keypad Entry |
Posted by: eoredson - 01-07-2023, 05:33 AM - Forum: Help Me!
- Replies (17)
|
|
I am working on a project that requires keypad entry.
The problem is that QB64 does not trap them!?
Here is my code:
Code: (Select All) Rem Keypad-5 = 76
Rem Shift-Keypad-5 = 53
Rem Ctrl-Keypad-5 = 143
Do
X$ = InKey$
If Len(X$) Then
If X$ = Chr$(27) Then End
If Len(X$) = 2 Then
X = Asc(Right$(X$, 1))
Select Case X
Case 76
Print "keypad-5"
Case 53
Print "shift-keypad-5"
Case 143
Print "ctrl-keypad-5"
End Select
End If
End If
Loop
End
|
|
|
better error trapping? |
Posted by: madscijr - 01-06-2023, 06:57 PM - Forum: General Discussion
- Replies (15)
|
|
With http/s capability coming, QB64PE is getting a major feature set.
With that out of the way, I was thinking that another big feature for an upcoming release would be try/catch functionality. Even basic "on error resume next", like in classic VB/VBA, would be an improvement, or full try/catch like every other modern language.
Thoughts?
|
|
|
People in SCREEN 0 |
Posted by: mnrvovrfc - 01-06-2023, 02:29 PM - Forum: Programs
- No Replies
|
|
This is a silly program that could make a good screensaver LOL. I wrote something like this for one of my Tandy1000's many years back with QuickBASIC. Technology has gone such that it's amazing this program could run many times as fast on 64-bit, while being more bloated than a 16-bit program, and with single-core CPU barely capable of multimedia.
Code: (Select All) ''by mnrvovrfc 06-Jan-2023
OPTION _EXPLICIT
CONST NUMPEOPLE = 80
'fields:
'x, y = position of "person"
'xd, yd = direction is changed when the "person" reaches an edge of the screen
'c = color
'h = open or filled face
'k = count
'l = length of fixed path taken by the "person"
TYPE peoplette
AS INTEGER x, y, xd, yd, c, k, l, h
END TYPE
DIM p(1 TO NUMPEOPLE) AS peoplette
DIM AS INTEGER i, j, k, kl, u, v, x, y, ox, oy, wd, ht, kc
DIM a$, found AS _BYTE
RANDOMIZE TIMER
'no two "persons" may have the same path but could look alike LOL
'kc = to repeat one direction a "person" takes up to four times
'kl = the number of times the "person" could change direction
DIM check$(1 TO NUMPEOPLE)
FOR i = 1 TO NUMPEOPLE
kl = INT(RND * 10 + 5)
kc = INT(RND * 4 + 1)
k = kl
a$ = ""
DO WHILE k > 0
DO
x = INT(RND * 3) - 1
y = INT(RND * 3) - 1
LOOP WHILE x = 0 AND y = 0
a$ = a$ + repeat$(STR$(x) + STR$(y), kc)
k = k - 1
LOOP
IF i > 1 THEN
found = 0
FOR j = 1 TO i - 1
IF a$ = check$(j) THEN found = 1: EXIT FOR
NEXT
IF found THEN _CONTINUE
END IF
check$(i) = a$
p(i).l = kl
p(i).k = 0
p(i).c = INT(RND * 14 + 1)
p(i).h = INT(RND * 2 + 1)
p(i).xd = 1
p(i).yd = 1
NEXT
'spread the people all over the screen
wd = _WIDTH
ht = _HEIGHT
u = wd * ht
u = u \ NUMPEOPLE
v = u \ 2
FOR i = 1 TO NUMPEOPLE
p(i).x = (v MOD 80) + 1
p(i).y = (v \ 80) + 1
v = v + u
NEXT
'main loop
DO
'change the following line to taste, to make it run faster
_LIMIT 10
FOR i = 1 TO NUMPEOPLE
p(i).k = p(i).k + 1
IF p(i).k > p(i).l THEN p(i).k = 1
ox = p(i).x
oy = p(i).y
p(i).x = p(i).x + VAL(MID$(check$(i), p(i).k * 4 - 3, 2)) * p(i).xd
p(i).y = p(i).y + VAL(MID$(check$(i), p(i).k * 4 - 1, 2)) * p(i).yd
'"persons" aren't allowed to go off the screen nor run into each other
IF p(i).x < 1 OR p(i).x > wd OR p(i).y < 1 OR p(i).y > ht THEN
IF p(i).x < 1 OR p(i).x > wd THEN
p(i).xd = p(i).xd * (-1)
ELSE
p(i).yd = p(i).yd * (-1)
END IF
p(i).x = ox: p(i).y = oy
ELSEIF SCREEN(p(i).y, p(i).x) <> 32 THEN
p(i).x = ox: p(i).y = oy
END IF
NEXT
CLS
FOR i = 1 TO NUMPEOPLE
LOCATE p(i).y, p(i).x
COLOR p(i).c
PRINT CHR$(p(i).h);
NEXT
_DISPLAY
'press [ESC] to leave program
LOOP UNTIL _KEYDOWN(27)
SYSTEM
FUNCTION repeat$ (astr AS STRING, numtimes AS INTEGER)
DIM sret AS STRING, i AS INTEGER
IF numtimes < 2 THEN repeat$ = astr: EXIT FUNCTION
FOR i = 1 TO numtimes
sret = sret + astr
NEXT
repeat$ = sret
END FUNCTION
|
|
|
The L-BASIC compiler |
Posted by: luke - 01-06-2023, 01:16 PM - Forum: Works in Progress
- Replies (20)
|
|
For some time now I have been working on a BASIC compiler which I've called L-BASIC. In many ways it's still rather primitive and in early stages, but it's reached the point where it can compile simple programs to executable format so I thought I'd make a thread for it.
Although all the source is available here on github and it's mostly written in QB64, it's rather complicated to build. If you'd like to try it, there's a prebuilt download-and-run version for 64 bit windows here: https://github.com/flukiluke/L-BASIC/rel...-x86_64.7z
You'll need to run it from a command prompt: "lbasic.exe test.bas" to compile test.bas, then run "test.exe" assuming you got no errors.
Some notes and warnings:
- Very poor support for most commands. All programs are console programs, you have a primitive PRINT but no input.
- DO, WHILE, IF, ELSE, FOR should work. ELSEIF, SELECT and EXIT don't.
- No GOTO or GOSUB, but SUB and FUNCTION can create subs/functions, and you can call them. Recursion works.
- Data types are INTEGER, LONG, INTEGER64 (no underscore), SINGLE, DOUBLE, QUAD, STRING. No _UNSIGNED. The usual suffixes %, & etc. are available.
- Basic string support: concatenation (a$ + b$), LEFT$, RIGHT$, MID$, CHR$
- All numeric operators are available and should work with proper precedence. This includes bitwise (AND, OR, XOR, NOT, IMP, EQV), relational (<, >, <=, >=, =, <>), arithmetic (+, -, *, /, \, MOD, ^).
Some programs that work:
Code: (Select All) 'Recursive factorial
'Functions can come before the main program
function fact(n)
if n = 1 then fact = 1 else fact = n * fact(n-1)
end function
for i = 1 to 10 step 2
print "fact("; i; ") = "; fact(i)
next i
Code: (Select All) text$ = "hello" + " " + "world"
for i = 1 to len(text) 'Notice you can leave off the $ on text
print left(text, i) 'And the $ is optional on left too
next i
|
|
|
Compare Images |
Posted by: SMcNeill - 01-04-2023, 09:42 PM - Forum: SMcNeill
- No Replies
|
|
Code: (Select All) 'int memcmp(const void *str1, const void *str2, size_t n)
Declare CustomType Library
Function memcmp% (ByVal s1%&, Byval s2%&, Byval n As _Offset)
End Declare
Randomize Timer
Screen _NewImage(1280, 720, 32)
'let's make this an unique and pretty image!
For i = 1 To 100
Line (Rnd * _Width, Rnd * _Height)-(Rnd * width, Rnd * _Height), &HFF000000 + Rnd * &HFFFFFF, BF
Next
image2 = _CopyImage(0) 'identical copies for testing
image3 = _CopyImage(0) 'identical copy... BUT
_Dest image3
PSet (Rnd * _Width, Rnd * _Height), &HFF000000 + Rnd * &HFFFFFF 'We've just tweaked it so that there's no way in hell it's the same as the other two now!
_Dest 0 'image3 is EXACTLY one pixel different from the other two. Can we detect that?
image4 = _CopyImage(0) 'an identical copy once again, because 0 will change once we print the resul
result1 = CompareImages(0, image2)
result2 = CompareImages(0, image3)
result3 = CompareImages(image2, image3)
Print "Current Screen and Image 1 Compare: "; result1
Print "Current Screen and Image 2 Compare: "; result2
Print "Image1 and Image 2 Compare : "; result3
Print
Print "Press <ANY KEY> for a speed test!"
Sleep
t# = Timer
Limit = 1000
For i = 1 To Limit
result = CompareImages(image2, image3)
result = CompareImages(image2, image4)
Next
Print
Print Using "####.####### seconds to do"; Timer - t#;
Print Limit * 2; "comparisons."
Function CompareImages (handle1 As Long, handle2 As Long)
Static m(1) As _MEM
m(0) = _MemImage(handle1): m(1) = _MemImage(handle2)
If m(0).SIZE <> m(1).SIZE Then Exit Function 'not identical
If m(0).ELEMENTSIZE <> m(1).ELEMENTSIZE Then Exit Function 'not identical
If memcmp(m(0).OFFSET, m(1).OFFSET, m(0).SIZE) = 0 Then x = -1 Else x = 0
CompareImages = x
End Function
Copied from deep inside another topic and shared here for ease of search and reference.
|
|
|
|