Welcome, Guest |
You have to register before you can post on our site.
|
Forum Statistics |
» Members: 499
» Latest member: Blayk
» Forum threads: 2,852
» Forum posts: 26,723
Full Statistics
|
Latest Threads |
Glow Bug
Forum: Programs
Last Post: PhilOfPerth
2 hours ago
» Replies: 6
» Views: 72
|
Who wants to PLAY?
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
5 hours ago
» Replies: 14
» Views: 194
|
BAM Sample Programs
Forum: QBJS, BAM, and Other BASICs
Last Post: CharlieJV
9 hours ago
» Replies: 36
» Views: 1,968
|
Audio storage, stereo swi...
Forum: Programs
Last Post: Petr
Yesterday, 09:03 PM
» Replies: 8
» Views: 351
|
_CONSOLEINPUT is blocking
Forum: General Discussion
Last Post: mdijkens
Yesterday, 12:24 PM
» Replies: 7
» Views: 127
|
Most efficient way to bui...
Forum: General Discussion
Last Post: ahenry3068
01-17-2025, 11:36 PM
» Replies: 9
» Views: 136
|
QBJS - ANSI Draw
Forum: QBJS, BAM, and Other BASICs
Last Post: madscijr
01-17-2025, 11:24 PM
» Replies: 4
» Views: 134
|
Fun with Ray Casting
Forum: a740g
Last Post: a740g
01-17-2025, 05:50 AM
» Replies: 10
» Views: 264
|
Very basic key mapping de...
Forum: SMcNeill
Last Post: a740g
01-17-2025, 02:33 AM
» Replies: 1
» Views: 56
|
Methods in types
Forum: General Discussion
Last Post: bobalooie
01-17-2025, 01:02 AM
» Replies: 0
» Views: 65
|
|
|
Happy 4th of July! |
Posted by: SierraKen - 07-04-2022, 03:32 PM - Forum: Programs
- Replies (2)
|
|
Here is a waving U.S. flag with changing hills in the background and moving clouds in the sky. This is from 2 years ago originally and last February for the clouds.
Thank you to B+, Vince and someone named rattrapmax6 for the clouds!
Code: (Select All) 'Made to honor the U.S. Flag.
'By Sierraken
'Feel free to use any or all of this code in your own applications or games.
'Updated with better flag waving and a hills fix on June 16, 2020.
'Thank you to B+ for help on the hills!
'Update again on Feb. 8, 2022 from B+, Vince and someone named rattrapmax6 for the clouds, thank you!
_Title "U.S. Flag"
Screen _NewImage(800, 600, 32)
Cls
x = 150
y = 100
Dim cf&(113000)
Const nn = 1
Const twidth = 640, theight = 480, zoom = 128
Dim Shared noise(nn * twidth * theight) '//the noise array
Dim Shared texture(nn * twidth * theight) '//texture array
Dim Shared pal(256) As _Unsigned Long '//color palette
Screen _NewImage(640, 480, 32)
MakePalette 255, 155, 255, 10, 100, 180
GenerateNoise
buildtexture
Dim vs As Long
vs = _NewImage(twidth, theight, 32)
_Dest vs
drawtexture 0
_Dest 0
ii = 0
jj = -1
kk = 0
GoSub hills:
'Stars
Line (x, y)-(x + 185, y + 130), _RGB32(0, 0, 255), BF
For xx = 155 To 345 Step 32
For yy = 105 To 220 Step 28
Line (xx + 2, yy + 12)-(xx + 7, yy), _RGB32(255, 255, 255)
Line (xx + 7, yy)-(xx + 13, yy + 12), _RGB32(255, 255, 255)
Line (xx + 13, yy + 12)-(xx, yy + 5), _RGB32(255, 255, 255)
Line (xx, yy + 5)-(xx + 15, yy + 5), _RGB32(255, 255, 255)
Line (xx + 15, yy + 5)-(xx + 2, yy + 12), _RGB32(255, 255, 255)
Paint (xx + 7, yy + 2), _RGB32(255, 255, 255)
Paint (xx + 7, yy + 6), _RGB32(255, 255, 255)
Paint (xx + 11, yy + 10), _RGB32(255, 255, 255)
Paint (xx + 4, yy + 10), _RGB32(255, 255, 255)
Paint (xx + 3, yy + 6), _RGB32(255, 255, 255)
Paint (xx + 12, yy + 6), _RGB32(255, 255, 255)
Next yy
Next xx
For xx = 172 To 329 Step 32
For yy = 118.9 To 213.05 Step 28
Line (xx + 2, yy + 12)-(xx + 7, yy), _RGB32(255, 255, 255)
Line (xx + 7, yy)-(xx + 13, yy + 12), _RGB32(255, 255, 255)
Line (xx + 13, yy + 12)-(xx, yy + 5), _RGB32(255, 255, 255)
Line (xx, yy + 5)-(xx + 15, yy + 5), _RGB32(255, 255, 255)
Line (xx + 15, yy + 5)-(xx + 2, yy + 12), _RGB32(255, 255, 255)
Paint (xx + 7, yy + 2), _RGB32(255, 255, 255)
Paint (xx + 7, yy + 6), _RGB32(255, 255, 255)
Paint (xx + 11, yy + 10), _RGB32(255, 255, 255)
Paint (xx + 4, yy + 10), _RGB32(255, 255, 255)
Paint (xx + 3, yy + 6), _RGB32(255, 255, 255)
Paint (xx + 12, yy + 6), _RGB32(255, 255, 255)
Next yy
Next xx
'Stripes
For rs = 100 To 230 Step 37.2
w = w + 1
Line (335, rs)-(612.5, rs + 18.6), _RGB32(255, 0, 0), BF
If w > 3 Then GoTo nex:
Line (335, rs + 18.6)-(612.5, rs + 37.2), _RGB32(255, 255, 255), BF
Next rs
nex:
w = 0
For rs = 230 To 341.6 Step 37.2
r = r + 1
Line (150, rs)-(612.5, rs + 18.6), _RGB32(255, 255, 255), BF
If r > 3 Then GoTo nex2:
Line (150, rs + 18.6)-(612.5, rs + 37.2), _RGB32(255, 0, 0), BF
Next rs
nex2:
r = 0
For fy = 100 To 341.6
For fx = 150 To 612.5
t5 = t5 + 1
cf&(t5) = Point(fx, fy)
Next fx
Next fy
t = 20
On Timer(3) GoSub hills:
Timer On
Do
_Limit 10
kk = kk + 1
ii = ii + 1
If ii >= 640 Then
ii = 0
jj = Not jj
End If
If jj Then
_PutImage (ii, 0)-Step(640, 480), vs
_PutImage (ii, 0)-Step(-640, 480), vs
Else
_PutImage (ii + 640, 0)-Step(-640, 480), vs
_PutImage (ii - 640, 0)-Step(640, 480), vs
End If
'Sky
_PutImage , hills&, 0
'Flag Pole
For sz = .25 To 10 Step .25
Circle (145, 80), sz, _RGB32(122, 128, 166)
Next sz
Line (142, 80)-(147, 600), _RGB32(122, 128, 166), BF
fx2 = fx2 + 1.2
If fx2 > 5 Then fx2 = 1.2
For fy = 100 To 341.6
For fx = 150 To 612.5
t6 = t6 + 1
PSet ((Sin(fy * 0.017453 / fx2) * t) + fx, (Sin(fx * 0.017453 / fx2) * t) + fy), cf&(t6)
Next fx
Next fy
t6 = 0
If tt = 0 Then t = t + 1
If t > 10 Then tt = 1
If tt = 1 Then t = t - 1
If t < -10 Then tt = 0
a$ = InKey$
If a$ = Chr$(27) Then End
If a$ = " " Then GoSub hills:
_Display
Cls
Loop
hills:
'Random Hills
If hills& <> 0 Then _FreeImage hills&
hills& = _NewImage(_Width, _Height, 32)
_Dest hills&
Randomize Timer
hills = Int(Rnd * 40) + 3
For h = 1 To hills
Randomize Timer
hx = Int(Rnd * 800) + 1
size = Int(Rnd * 450) + 75
cl = Int(Rnd * 55)
shape = Rnd
For sz = .25 To size Step .25
cl = cl + .05
Circle (hx, 599), sz, _RGB32(10, cl, 20), , , shape
Next sz
Next h
_Dest 0
Return
'//interpolation code by rattrapmax6
Sub MakePalette (sr, sg, sb, er, eg, eb) ' (b+) start and end RGB's ? yes
Dim i, istart(3), iend(3), ishow(3), rend(3), interpol(3)
interpol(0) = 255
istart(1) = sr
istart(2) = sg
istart(3) = sb
iend(1) = er
iend(2) = eg
iend(3) = eb
interpol(1) = (istart(1) - iend(1)) / interpol(0)
interpol(2) = (istart(2) - iend(2)) / interpol(0)
interpol(3) = (istart(3) - iend(3)) / interpol(0)
rend(1) = istart(1)
rend(2) = istart(2)
rend(3) = istart(3)
For i = 0 To 255
ishow(1) = rend(1)
ishow(2) = rend(2)
ishow(3) = rend(3)
pal(i) = _RGB32(ishow(1), ishow(2), ishow(3))
rend(1) = rend(1) - interpol(1)
rend(2) = rend(2) - interpol(2)
rend(3) = rend(3) - interpol(3)
Next i
End Sub
'//generates random noise.
Sub GenerateNoise ()
Dim As Long x, y
For x = 0 To nn * twidth - 1
For y = 0 To theight - 1
zz = Rnd
noise(x + y * twidth) = zz
Next y
Next x
End Sub
Function SmoothNoise (x, y)
'//get fractional part of x and y
Dim fractx, fracty, x1, y1, x2, y2, value
fractx = x - Int(x)
fracty = y - Int(y)
'//wrap around
x1 = (Int(x) + nn * twidth) Mod twidth
y1 = (Int(y) + theight) Mod theight
'//neighbor values
x2 = (x1 + nn * twidth - 1) Mod twidth
y2 = (y1 + theight - 1) Mod theight
'//smooth the noise with bilinear interpolation
value = 0.0
value = value + fractx * fracty * noise(x1 + y1 * twidth)
value = value + fractx * (1 - fracty) * noise(x1 + y2 * twidth)
value = value + (1 - fractx) * fracty * noise(x2 + y1 * twidth)
value = value + (1 - fractx) * (1 - fracty) * noise(x2 + y2 * twidth)
SmoothNoise = value
End Function
Function Turbulence (x, y, size)
Dim value, initialsize
initialsize = size
While (size >= 1)
value = value + SmoothNoise(x / size, y / size) * size
size = size / 2.0
Wend
Turbulence = (128.0 * value / initialsize)
End Function
'//builds the texture.
Sub buildtexture
Dim x, y
For x = 0 To nn * twidth - 1
For y = 0 To theight - 1
texture(x + y * nn * twidth) = Turbulence(x, y, zoom)
Next y
Next x
End Sub
'//draws texture to screen.
Sub drawtexture (dx)
Dim x, y
Dim As Long c, r, g, b
For x = 0 To twidth - 1
For y = 0 To theight - 1
c = pal(texture(((x + dx) + y * nn * twidth)))
r = _Red(c)
g = _Green(c)
b = _Blue(c)
c = _RGB(r - 0.2 * y, g - 0.2 * y, b - 0.2 * b)
PSet (x, y), c 'pal(texture(((x + dx) + y * nn*twidth)))
Next y
Next x
End Sub
|
|
|
Lazyoval |
Posted by: James D Jarvis - 07-04-2022, 01:58 PM - Forum: Programs
- Replies (3)
|
|
Ovals, well... lazy ovals.
Code: (Select All) 'LazyOval
'this could be better... probably have rotozoom built in too
'demo
Screen _NewImage(800, 500, 32)
k& = _RGB32(200, 100, 50)
lazyoval 200, 200, 50, 30, k&
For h = 1 To 60
_Limit 60
Cls
lazyoval 100, 100, h, 60, k&
Circle (100, 100), 60, _RGB32(250, 250, 250)
_Display
Next h
For h = 60 To 1 Step -1
_Limit 30
Cls
lazyoval 100, 100, 60, h, k&
Circle (100, 100), 60, _RGB32(250, 250, 250)
_Display
Next h
For h = 1 To 60
_Limit 60
Cls
lazyoval 100, 100, h, 60, k&
_Display
Next h
For h = 60 To 1 Step -1
_Limit 30
Cls
lazyoval 100, 100, 60, h, k&
_Display
Next h
Cls
lazyoval 100, 100, 24, 80, k&
_PrintMode _KeepBackground
_PrintString (70, 92), "Lazyoval"
_Display
'the actual routine
Sub lazyoval (xx, yy, hh, ww, K As _Unsigned Long)
'create a lazyoval by changing the ratio of a circle with the putimage command
rr = hh
If ww > rr Then rr = ww
oo& = _NewImage(rr * 2 + 2, rr * 2 + 2, 32)
_Dest oo&
cx = rr
cy = cx
Circle (cx, cy), rr, K
Paint (cx, cy), K, K
x1 = xx - ww: x2 = xx + ww
y1 = yy - hh: y2 = yy + hh
_Dest 0
_PutImage (x1, y1)-(x2, y2), oo&, 0, (0, 0)-(rr * 2, rr * 2)
_FreeImage oo& 'don't delete this
End Sub
|
|
|
Overlapping Circles |
Posted by: SierraKen - 07-04-2022, 12:27 AM - Forum: Programs
- Replies (20)
|
|
I've never made something like this before so I figured I would try it out using the fillcircle sub as pitch black and a colored circle around each of the 2 circles. It might be useful on something someday. I should point out that the 3D rotation orbit isn't a circle, it's more like a 3D square. I couldn't figure out the equation for a 3D orbit on the Z axis, so I just winged it.
Edit: There's a full-circle 3D one on a post below on this thread that I figured out. But I am keeping this one in case anyone wants to use this type.
Code: (Select All) Screen _NewImage(800, 600, 32)
Dim c As Long, c2 As Long
cx = 600: cy = 300: r = 98: c = _RGB32(0, 0, 0)
dir = 1
cx2 = 200: cy2 = 300: r2 = 98: c2 = _RGB32(0, 0, 0)
dir2 = 2
r = 100
r2 = 100
firstoverlap:
Do
a$ = InKey$
If a$ = Chr$(27) Then End
If dir = 1 And dir2 = 2 Then GoTo secondoverlap:
For t = 0 To 360
x = (Sin(t) * (r + 2)) + cx
y = (Cos(t) * (r + 2)) + cy
Circle (x, y), 2, _RGB32(0, 255, 0)
fillCircle cx, cy, r, c
Next t
If dir = 1 And cx < 400 Then r = r - 1
If dir = 1 And cx > 399 Then r = r + 1
If dir = 2 And cx < 400 Then r = r + 1
If dir = 2 And cx > 399 Then r = r - 1
If r < 50 Then r = 50
If r > 150 Then r = 150
If dir = 1 Then cx = cx + 10
If dir = 2 Then cx = cx - 10
If cx > 600 Then dir = 2
If cx < 200 Then dir = 1
For t = 0 To 360
x = (Sin(t) * (r2 + 2)) + cx2
y = (Cos(t) * (r2 + 2)) + cy2
Circle (x, y), 2, _RGB32(255, 0, 0)
fillCircle cx2, cy2, r2, c2
Next t
If dir2 = 1 And cx2 < 400 Then r2 = r2 + 1
If dir2 = 1 And cx2 > 399 Then r2 = r2 - 1
If dir2 = 2 And cx2 < 400 Then r2 = r2 - 1
If dir2 = 2 And cx2 > 399 Then r2 = r2 + 1
If r2 < 50 Then r2 = 50
If r2 > 150 Then r2 = 150
If dir2 = 1 Then cx2 = cx2 + 10
If dir2 = 2 Then cx2 = cx2 - 10
If cx2 > 600 Then dir2 = 2
If cx2 < 200 Then dir2 = 1
Line (0, 0)-(800, 600), _RGB32(0, 0, 0, 50), BF
_Display
Loop
secondoverlap:
Do
a$ = InKey$
If a$ = Chr$(27) Then End
If dir = 2 And dir2 = 1 Then GoTo firstoverlap:
For t = 0 To 360
x = (Sin(t) * (r2 + 2)) + cx2
y = (Cos(t) * (r2 + 2)) + cy2
Circle (x, y), 2, _RGB32(255, 0, 0)
fillCircle cx2, cy2, r2, c2
Next t
If dir2 = 1 And cx2 < 400 Then r2 = r2 - 1
If dir2 = 1 And cx2 > 399 Then r2 = r2 + 1
If dir2 = 2 And cx2 < 400 Then r2 = r2 + 1
If dir2 = 2 And cx2 > 399 Then r2 = r2 - 1
If r2 < 50 Then r2 = 50
If r2 > 150 Then r2 = 150
If dir2 = 1 Then cx2 = cx2 + 10
If dir2 = 2 Then cx2 = cx2 - 10
If cx2 > 600 Then dir2 = 2
If cx2 < 200 Then dir2 = 1
For t = 0 To 360
x = (Sin(t) * (r + 2)) + cx
y = (Cos(t) * (r + 2)) + cy
Circle (x, y), 2, _RGB32(0, 255, 0)
fillCircle cx, cy, r, c
Next t
If dir = 1 And cx < 400 Then r = r + 1
If dir = 1 And cx > 399 Then r = r - 1
If dir = 2 And cx < 400 Then r = r - 1
If dir = 2 And cx > 399 Then r = r + 1
If r < 50 Then r = 50
If r > 150 Then r = 150
If dir = 1 Then cx = cx + 10
If dir = 2 Then cx = cx - 10
If cx > 600 Then dir = 2
If cx < 200 Then dir = 1
Line (0, 0)-(800, 600), _RGB32(0, 0, 0, 50), BF
_Display
Loop
'from Steve Gold standard
Sub fillCircle (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
|
|
|
MasterGy's Return |
Posted by: bplus - 07-03-2022, 08:51 PM - Forum: bplus
- Replies (3)
|
|
Hi all, I am starting a thread for MasterGy who has just PM'd me today asking about a spot of his own in Prolific Programmers. Until Steve can get him setup, I offer a place here like with vince to show off his talents in QB64.
To kick off this thread I found an interesting start of a game possibly, anyway it's interesting and fun to play:
Code: (Select All) ' ref 2021-03-29 https://www.qb64.org/forum/index.php?topic=3714.msg131236#msg131236
' checkout how he reorientates the whole screen when the mouse is moved, no tan, atan nor atan2 used but it is way smoother than my mouse action
Randomize Timer
Const pip180 = 3.141592654 / 180
global_speed = 1.5
space_grav = 15
space = 1000 'space size x-y
planets = 600
planetsize_min = 1
planetsize_max = 12
planet_dif = .05
cr_c_max = 199
zoom = 10
me_buffer_size = 5000
'creating 2d planet
Dim cr(planets - 1, cr_c_max - 1, 1), cr_dat(planets - 1, 3), me_buffer(me_buffer_size - 1, 1)
'cd_dat 0-x,1-y,2-size,3-polars
For aplanet = 0 To planets - 1
cr_dat(aplanet, 2) = planetsize_min + (planetsize_max - planetsize_min) * Rnd(1) 'planet size
cr_l1 = (1 - planet_dif) * cr_dat(aplanet, 2)
cr_l2 = (1 + planet_dif) * cr_dat(aplanet, 2)
cr_dat(aplanet, 0) = space * Rnd(1) - space / 2 'X position
cr_dat(aplanet, 1) = space * Rnd(1) - space / 2 'Y position
cr_dat(aplanet, 3) = Int(cr_dat(aplanet, 2) * 6) 'polars
For t = 0 To cr_dat(aplanet, 3) - 1
cr_r = cr_l1 + (cr_l2 - cr_l1) * Rnd(1)
cr(aplanet, t, 0) = Sin(360 / cr_dat(aplanet, 3) * t * pip180) * cr_r
cr(aplanet, t, 1) = Cos(360 / cr_dat(aplanet, 3) * t * pip180) * cr_r
Next t, aplanet
me_x = 0 'my Xpos
me_y = 0 'my Ypos
me_a = 30 'my angle
me_size = 2 'arrow size
me_size_a = .4
mon = _NewImage(800, 600, 32): Screen mon: _FullScreen: _MouseHide
centx = _Width(mon) / 2: centy = _Height(mon) / 2
Do
'draw me
y1 = centy - me_size / 2 * zoom
y2 = y1 + me_size * zoom
Line (centx, y1)-(centx, y2)
y2 = y1 + me_size_a * zoom
Line (centx, y1)-(centx - me_size_a * zoom, y2)
Line (centx, y1)-(centx + me_size_a * zoom, y2)
'my position center, but where any object ?
grav_x = 0: grav_y = 0: grav_active = 0
For aplanet = 0 To planets - 1
angle1 = degree(me_x - cr_dat(aplanet, 0), me_y - cr_dat(aplanet, 1)) 'how many degree
angle2 = angle1 + angle_me '+arrow
distance = Sqr((me_x - cr_dat(aplanet, 0)) ^ 2 + (me_y - cr_dat(aplanet, 1)) ^ 2)
cr_cx = (Sin(angle2 * pip180)) * distance 'planet origo position on monitor
cr_cy = (Cos(angle2 * pip180)) * distance
For t = 0 To cr_dat(aplanet, 3)
If t = cr_dat(aplanet, 3) Then t2 = 0 Else t2 = t
px = cr(aplanet, t2, 0)
py = cr(aplanet, t2, 1)
angle_r = angle_me * pip180
px2 = (px * Cos(angle_r)) + (py * Sin(angle_r))
py2 = (py * Cos(angle_r)) - (px * Sin(angle_r))
px = (px2 + cr_cx) * zoom + centx
py = (py2 + cr_cy) * zoom + centy
If t Then Line (px, py)-(px_l, py_l)
px_l = px: py_l = py
Next t
'gravity planet
If distance < space / 100 * space_grav Then
grav_active = grav_active + 1
gravity = cr_dat(aplanet, 2) ^ 2 / distance ^ 2
'IF gravity > .01 THEN gravity = .01
grav_x = grav_x + Sin(angle1 * pip180) * gravity
grav_y = grav_y + Cos(angle1 * pip180) * gravity
End If
Next aplanet
'draw my way
For a_buff = 0 To me_buffer_size - 1: If me_buffer(a_buff, 0) = 0 Then _Continue
angle1 = degree(me_x - me_buffer(a_buff, 0), me_y - me_buffer(a_buff, 1)) 'how many degree
angle2 = angle1 + angle_me '+arrow
distance = Sqr((me_x - me_buffer(a_buff, 0)) ^ 2 + (me_y - me_buffer(a_buff, 1)) ^ 2)
cr_cx = (Sin(angle2 * pip180)) * distance 'planet origo position on monitor
cr_cy = (Cos(angle2 * pip180)) * distance
PSet (centx + cr_cx * zoom, centy + cr_cy * zoom)
Next a_buff
'control
mw = 0: mousex = 0: While _MouseInput: mousex = mousex + _MouseMovementX: mw = mw + _MouseWheel: Wend: angle_me = angle_me + mousex
If _MouseButton(1) Then speed = speed + .05
If _MouseButton(2) Then speed = speed - .05
'inertia vector
speed = speed - .01 * Sgn(speed)
If Abs(speed) > .5 Then speed = .5 * Sgn(speed)
vector_x_my = -Sin(pip180 * angle_me) * speed * global_speed
vector_y_my = -Cos(pip180 * angle_me) * speed * global_speed
'gravity vector
angle_g = degree(grav_x, grav_y)
strong = Sqr((grav_x - me_x) ^ 2 + (grav_y - me_y) ^ 2): If strong > 2 Then strong = 2
If Abs(strong) > 1 Then strong = 1 * Sgn(strong)
vector_x_grav = -Sin(pip180 * angle_g) * strong / 5 * global_speed
vector_y_grav = -Cos(pip180 * angle_g) * strong / 5 * global_speed
'resulting vector
me_x = me_x + vector_x_my + vector_x_grav
me_y = me_y - vector_y_my + vector_y_grav
If me_x > space / 2 Then me_x = me_x - space
If me_x < -space / 2 Then me_x = me_x + space
If me_y > space / 2 Then me_y = me_y - space
If me_y < -space / 2 Then me_y = me_y + space
me_buffer(me_buffer_a, 0) = me_x
me_buffer(me_buffer_a, 1) = me_y
me_buffer_a = me_buffer_a + 1: If me_buffer_a = me_buffer_size Then me_buffer_a = 0
zoom = zoom + mw / 2
If zoom > 50 Then zoom = 50
If zoom < .5 Then zoom = .5
'view
_Display
_Limit 30
Cls
'LOCATE 1, 1
'PRINT speed, SQR(grav_x ^ 2 + grav_y ^ 2)
' PRINT "grav_active:"; grav_active
Loop Until _KeyDown(27)
Function degree (a, b)
qarany = (a + .00001) / (b + .00001): d = honnan + Atn(qarany) / pip180
If 0 > b Then d = d - 180
If d < 0 Then d = d + 360
degree = d
End Function
That opening comment might be mine. I fixed up the degree function for version 2.0+ and added an escape from Do Loop since we are in Full Screen.
MasterGy, you are most welcome to add to this thread as you see fit. Thankyou for sharing all your interesting creations!
|
|
|
Microsoft QuickBASIC Programmer's Toolbox |
Posted by: MWheatley - 07-02-2022, 01:53 PM - Forum: General Discussion
- Replies (9)
|
|
This was a book by someone called John Clark Craig, with a Companion Disk that contained the code for the various routines.
Does anyone know if the disk (or code) is still available? I've tried eBay, but no joy.
Good to see many of the old familiar faces here.
Malcolm
|
|
|
Is this an issue? |
Posted by: bobkreid - 07-01-2022, 07:56 PM - Forum: General Discussion
- Replies (11)
|
|
Hi all,
I was looking at creating C/C++ Dll's to add functionality to QB64PE, and I was doing timings to see what would be best done in a dll vs native to QB64PE and I got some results that confused me.
I have a simple c function I created which adds 2 numbers:
int Add(int a, int b)
{
return (a + b);
}
I have a QB64PE function that does the same as the c function:
Function addit% (a%, b%)
addit% = a% + b%
End Function
and as a baseline/control I do inline addition, each is done in a loop (500000000 times).
The results gave me pause:
Dll - 7.25 seconds
inline - 5.38 seconds
internal function - 41.16 seconds
I expected that the internal function would be between the dll and inline in timing. Why would calling external to a dll to a function to add 2 numbers be quicker than calling internal to a function to add 2 numbers?
My code:
' dll test
Declare Dynamic Library "c:\users\bob\qb64\mydll"
Function Add% (ByVal a As Integer, Byval b As Integer) 'SDL procedure name
End Declare
f% = 6
e% = 23
Locate 2, 1
Print "external dll call";
Locate 4, 1
Print "QB64PE inline addition";
Locate 6, 1
Print "QB64PE internal function";
a = Timer
For x& = 1 To 500000000
k% = Add%(f%, e%)
Next
b = Timer
Locate 1, 1
Print Using "##.##########"; (b - a);
c = Timer
For x& = 1 To 500000000
k% = f% + e%
Next
d = Timer
Locate 3, 1
Print Using "##.##########"; (d - c);
g = Timer
For x& = 1 To 500000000
k% = addit%(f%, e%)
Next
h = Timer
Locate 5, 1
Print Using "##.##########"; (h - g);
End
Function addit% (a%, b%)
addit% = a% + b%
End Function
If you want the c code for the dll let me know.
|
|
|
|