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

Username/Email:
  

Password
  





Search Forums

(Advanced Search)

Forum Statistics
» Members: 308
» Latest member: Donaldvem
» Forum threads: 1,741
» Forum posts: 17,901

Full Statistics

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

Print this item

  REVERSI XXI century qb64
Posted by: DANILIN - 07-04-2022, 04:52 PM - Forum: Programs - Replies (5)

REVERSI XXI century qb64

Chance to make new Reversi of 21 century

Reversi and black hole randomly or with mouse

Reversi and etudes: a random set of chips in center
absorbs 16/64 = 1/4 = quarter moves

Reversi and etudes: a random set of 32 chips
in center and 4*4 more on sides: half of chips


Based on Reversi with mouse

https://qb64forum.alephc.xyz/index.php?topic=677

and or xor Reversi from MicroSoft

https://qb64forum.alephc.xyz/index.php?topic=741

Print this item

  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