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
|
|
|
Calculating with complex numbers |
Posted by: Kernelpanic - 07-05-2022, 02:05 PM - Forum: General Discussion
- Replies (5)
|
|
This is from the QBasic Tech Reference book, and is intended to demonstrate math with complex numbers. I myself can't see through it anymore, but anyone who deals with mathematics can perhaps use it.
Code: (Select All) 'Loesung quadratischer Gleichungen S. 231, QBasic Referenz - 5. Juli 2022
Option _Explicit
Dim a, b, c, det As Double
Dim j As String
Do
Cls
Print "Geben Sie die Parameter a, b, c der Gleichung ax^2 + bx + c = 0 ein: "
Input "a = "; a: Input "b = "; b: Input "c = "; c
Print "Loesung: ";
If a = 0 Then
If b = 0 Then Print "alle Zahlen" Else Print "x = "; -c / b
Else det = b * b - 4 * a * c
If det >= 0 Then
Print "x1 = "; (-b + Sqr(det)) / 2 / a; "x2 = "; (-b - Sqr(det)) / 2 / a
Else
Print "x1 = "; b / 2 / a; "+"; Sqr(det) / 2 / a; "* i;";
Print " x2 = "; b / 2 / a; "-"; Sqr(det) / 2 / a; "* i"
End If
End If
Print
Input "Nochmal (J/N)", j
Loop Until UCase$(j) = "N"
End
|
|
|
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.
|
|
|
|