Welcome, Guest
You have to register before you can post on our site.

Username/Email:
  

Password
  





Search Forums

(Advanced Search)

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

Print this item

  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

Print this item

  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

Print this item

  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!

Print this item

  inspiration for new game programmers, the making of Crisis Mountain on the Apple II
Posted by: madscijr - 07-03-2022, 03:22 PM - Forum: General Discussion - No Replies

I just came across this story, any fans of old games
or aspiring programmers might find it inspiring!

https://venturebeat.com/2016/01/04/crisi...om-number/

Print this item

  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

Print this item

  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.

Print this item

  Prime pattern 6 +/- 1
Posted by: SMcNeill - 06-30-2022, 10:49 AM - Forum: bplus - Replies (12)

Here's something I noticed the other day, which I thought might interest you, since you've written a ton of programs regarding prime numbers -- most primes tend to be multiples of 6, +/- 1!

5 is 6 -1
7 is 6 + 1
11 is 6 * 2 -1
13 is 6 * 2 +1
17 is 6 * 3 -1
19 is 6 x 3 +1
... and so on.

I don't know how far the pattern continues (past 100, I think), but you might want to play with it some and see how it holds up in general.  It may be a quicker way to generate a list of primes than using the Sieve which I've seen you implement often in the past.  My ass is still kicked from my last doctor's visit and all, and I'm not up to coding on it at the moment, but I figured I'd share the observation in case it interested you. Wink

Print this item

  Tech Invaders 4 Warp Edition
Posted by: SierraKen - 06-29-2022, 06:01 PM - Forum: Programs - Replies (6)

Hi all,

Below are the additions to this version of Tech Invaders. I'm really happy with this version. Here's a photo too. Tell me what you think, thanks. As with version 3, this is also controlled with the mouse.

-SierraKen

Additions: A Warp Starfield Backdrop, 5 different Boss Robots total, small change to the enemy explosion sounds, a fix to the enemy shot which will now be deleted as soon as the enemy is destroyed.

And various other small fixes.
There is no ending to this game, after the 5th Boss Robot, it will go back to the first but your points and levels will remain increasing.



[Image: Tech-Invaders-4-Warp-Edition-by-Sierra-Ken.jpg]

Code Deleted, a better version is below that doesn't have high pitched explosions. A YouTube video of the newer one is also below.

Print this item

  VB5 - Decimal places are missing
Posted by: Kernelpanic - 06-29-2022, 04:25 PM - Forum: Help Me! - Replies (5)

A VB5 program, almost like QBasic. - The decimal places are not calculated, but why not? I just can't find the error. Everything is the same as the 2nd screenshot, everything is correct there.

Does anyone know where the error is? Thanks.

[Image: Angebot-VB5-Nachkomma-Fehlt.jpg]

Print this item