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: 758
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: 1,981
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,250
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 313
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 124
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,445
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 247
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 151

 
  Vim in Linux
Posted by: Kernelpanic - 07-26-2023, 12:28 AM - Forum: General Discussion - Replies (3)

There are some here who work with Linux. My favorite editor on the command line has always been Vim (on KDE it was jedit). Today I only have WSL2 under Windows, as a hobby.

You can customize Vim for each programming language if you want. In case anyone is interested, my source code in Vim looks the same under WSL2 as it used to under SuSE, namely like this (GCC):

[Image: GCC-in-Vim-Konfiguration.jpg]

The settings in the .exrc and .vimrc look like this. They have to be filed separately in each sub-forum - that is, for each programming language.

[Image: Vim-exrc2023-07-26.jpg]

[Image: Vim-vimrc-Einstellung.jpg]

Forget! Result:

[Image: nte-wurzel-Linux-2022-09-22.jpg]

Print this item

  BAM: New Font-Weight setting for IDE
Posted by: CharlieJV - 07-25-2023, 03:18 AM - Forum: QBJS, BAM, and Other BASICs - Replies (8)

https://basicanywheremachine-news.blogsp...r-ide.html

Print this item

  Images getting cut on right side
Posted by: bplus - 07-24-2023, 10:53 PM - Forum: Site Suggestions - No Replies

Forum is currently cutting off images on the right side.

Print this item

  Laser Blades
Posted by: bplus - 07-24-2023, 10:49 PM - Forum: Programs - Replies (6)

An alternate way to draw Laser Bolts:

Code: (Select All)
Option _Explicit
_Title "Laser Blades" 'b+ 2023-07-24 another way to do laser beams

Const NBolts = 50 ' max number of Bolt slots available, just like bullet science
Const PulseLength = 150 ' length of light pulses as they travel down BoltLine

Type BoltType 'see NewBolt for description of these variables
    As Single x1, y1, r1, dx, dy, dr, d, ang, frames, frame, active, speedX, speedY, x, y, r
    As _Unsigned Long k
End Type
Dim Shared Bolts(1 To NBolts) As BoltType

Dim Shared bk
Dim As Long mx, my, i, lpc, blastedShip, r

Randomize Timer
Screen _NewImage(1200, 700, 32)
_ScreenMove 50, 20

makeBackground
Do
    Cls
    _PutImage , bk, 0
    If blastedShip Then
        DrawShip 600, 350, &HFF00CC66
        For r = blastedShip To 1 Step -2
            FCirc 600, 350, r, _RGB32(5 * (50 - r), 5 * (50 - r), 0, 20)
        Next
        blastedShip = blastedShip + 2
        If blastedShip > 50 Then blastedShip = 0
    Else
        DrawShip 600, 350, &HFF00CC66 ' bplus signature space ship, for rent :)
    End If
    ' fire off some more bolts at the ship from the screen corners!
    If lpc = 0 Then
        If Rnd < .7 Then NewBolt 0, 0, 1, 600, 350, 20, 3, &HCCFF0000
    ElseIf lpc = 30 Then
        If Rnd < .7 Then NewBolt _Width - 1, 0, 1, 600, 350, 25, 2, &HCC007700
    ElseIf lpc = 60 Then
        If Rnd < .7 Then NewBolt _Width - 1, _Height - 1, 1, 600, 350, 30, 3, &HCCFF00FF
    ElseIf lpc = 90 Then
        If Rnd < .7 Then NewBolt 0, _Height - 1, 1, 600, 350, 35, 2, &HCC008888
    End If
    lpc = (lpc + 1) Mod 120 ' loopscounter every 30 shoot from a corner
    For i = 1 To NBolts
        If Bolts(i).active Then DrawBolt (i) ' draws the bolts still active
    Next '                                     according to what frame they are on
    ' collision detection  blow up when ship is hit
    For i = 1 To NBolts
        If Bolts(i).active Then
            If _Hypot(Bolts(i).x - 600, Bolts(i).y - 350) < 20 + Bolts(i).r Then
                If Bolts(i).x1 <> 600 And Bolts(i).y1 <> 350 Then ' oops watch out for friendly fire!!!
                    If blastedShip = 0 Then blastedShip = 1
                    Bolts(i).active = 0
                End If
            End If
        End If
    Next
    While _MouseInput: Wend
    mx = _MouseX: my = _MouseY
    If _MouseButton(1) Then
        NewBolt 600, 340, 1, mx, my, 25, 10, _RGB32(255, 255, 0, 180)
        _Delay .25
    End If
    _Display
    _Limit 60
Loop Until _KeyDown(27)


Sub NewBolt (x1, y1, r1, x2, y2, r2, ppfSpeed, k~&) ' sets up for the DrawBolt Sub
    'x1, y1, r1 = location and radius at start of beam
    'x2, y2, r2 = target location and radius at beam end
    'ppfSpeed = how many pixels per frame in main loop  to transverse
    Dim i
    For i = 1 To NBolts
        If Bolts(i).active = 0 Then
            Bolts(i).x1 = x1 ' start x, y, radius
            Bolts(i).y1 = y1
            Bolts(i).r1 = r1
            Bolts(i).active = 1 ' bolt is activated
            Bolts(i).dx = x2 - x1 ' drawing the bolt line and thickness
            Bolts(i).dy = y2 - y1 ' as it changes from x1, y1, r1 to x2, y2, r2
            Bolts(i).dr = r2 - r1
            Bolts(i).d = _Hypot(Bolts(i).dx, Bolts(i).dy) ' distance of the bolt line
            Bolts(i).frames = Int(Bolts(i).d / ppfSpeed) + 1 ' divide that distance by pulse = PulseLength
            Bolts(i).frame = 1 ' set the frame you are on to locate the pulse in drawing
            Bolts(i).ang = _Atan2(y2 - y1, x2 - x1)
            Bolts(i).speedX = ppfSpeed * Cos(Bolts(i).ang)
            Bolts(i).speedY = ppfSpeed * Sin(Bolts(i).ang)
            Bolts(i).x = x1 ' track leading x, y, r of current bolt for collision detection
            Bolts(i).y = y1
            Bolts(i).r = r1
            Bolts(i).k = k~&
            Exit Sub
        End If
    Next
End Sub

Sub DrawBolt (idx) ' needs FCirc (Fill Circle) routine
    ' This sub draw a pulse of light on the BoltLine from .x1, .y1 on the way to .x2, .y2
    ' The start radius is .r1 and the end radius is .r2 and the pulse is thinned or thickened
    ' as it proceeds down the boltLine.

    'All this is setup in the NewBolt Sub and uses DIM Shared Bolts() as BoltType and Constants
    ' NBolts = max amount of activated Bolt "slots" available and PulseLength the length of
    ' BoltLine sections to draw in each frame.

    Dim d, d2, stepper, oldX, oldY, r2
    ' new lead position for tracking location for collision detection
    Bolts(idx).x = Bolts(idx).x1 + Bolts(idx).speedX * Bolts(idx).frame
    Bolts(idx).y = Bolts(idx).y1 + Bolts(idx).speedY * Bolts(idx).frame
    d = _Hypot(Bolts(idx).x1 - Bolts(idx).x, Bolts(idx).y1 - Bolts(idx).y)
    If Abs(Bolts(idx).dr / PulseLength) < .2 Then stepper = .5 Else stepper = 2
    Bolts(idx).r = Bolts(idx).r1 + d * Bolts(idx).dr / Bolts(idx).d
    If d < PulseLength Then
        Blade Bolts(idx).x1, Bolts(idx).y1, Bolts(idx).r1 + d2 * Bolts(idx).dr / Bolts(idx).d, Bolts(idx).x, Bolts(idx).y, Bolts(idx).r, Bolts(idx).k
        Blade Bolts(idx).x1, Bolts(idx).y1, .4 * Bolts(idx).r1 + d2 * Bolts(idx).dr / Bolts(idx).d, Bolts(idx).x, Bolts(idx).y, .4 * Bolts(idx).r, &H80FFFFFF
    Else
        oldX = Bolts(idx).x + PulseLength * Cos(Bolts(idx).ang - _Pi)
        oldY = Bolts(idx).y + PulseLength * Sin(Bolts(idx).ang - _Pi)
        d2 = _Hypot(Bolts(idx).x1 - oldX, Bolts(idx).y1 - oldY)
        r2 = Bolts(idx).r1 + d2 * Bolts(idx).dr / Bolts(idx).d
        Blade oldX, oldY, r2, Bolts(idx).x, Bolts(idx).y, Bolts(idx).r, Bolts(idx).k
        Blade oldX, oldY, .4 * r2, Bolts(idx).x, Bolts(idx).y, .4 * Bolts(idx).r, &H80FFFFFF
    End If

    Bolts(idx).frame = Bolts(idx).frame + 1 ' update frame number
    If Bolts(idx).frame > Bolts(idx).frames Then Bolts(idx).active = 0 ' job done!
End Sub

Sub Blade (x1, y1, r1, x2, y2, r2, K As _Unsigned Long)
    Dim PD2 As Double
    Dim As Single a, x3, y3, x4, y4, x5, y5, x6, y6, r1d2, r2d2
    PD2 = 1.570796326794897 ' pi/2
    a = _Atan2(y2 - y1, x2 - x1)
    r1d2 = r1 / 2: r2d2 = r2 / 2
    x3 = x1 + r1d2 * Cos(a + PD2)
    y3 = y1 + r1d2 * Sin(a + PD2)
    x4 = x1 + r1d2 * Cos(a - PD2)
    y4 = y1 + r1d2 * Sin(a - PD2)
    x5 = x2 + r2d2 * Cos(a + PD2)
    y5 = y2 + r2d2 * Sin(a + PD2)
    x6 = x2 + r2d2 * Cos(a - PD2)
    y6 = y2 + r2d2 * Sin(a - PD2)
    ftri x6, y6, x4, y4, x3, y3, K
    ftri x3, y3, x5, y5, x6, y6, K
End Sub

'2019-12-16 fix by Steve saves some time with STATIC and saves and restores last dest
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
    Dim D As Long
    Static a&
    D = _Dest
    If a& = 0 Then a& = _NewImage(1, 1, 32)
    _Dest a&
    _DontBlend a& '  '<<<< new 2019-12-16 fix
    PSet (0, 0), K
    _Blend a& '<<<< new 2019-12-16 fix
    _Dest D
    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
End Sub

Sub FCirc (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

Sub DrawShip (x, y, colr As _Unsigned Long) 'needs FCirc and FEllipse subs
    Static ls ' tracks the last light position in string of lights
    Dim light As Long, r As Long, g As Long, b As Long
    r = _Red32(colr): g = _Green32(colr): b = _Blue32(colr)
    FEllipse x, y, 6, 15, _RGB32(r, g - 120, b - 100)
    FEllipse x, y, 18, 11, _RGB32(r, g - 60, b - 50)
    FEllipse x, y, 30, 7, _RGB32(r, g, b)
    For light = 0 To 5
        FCirc x - 30 + 11 * light + ls, y, 1, _RGB32(ls * 50, ls * 50, ls * 50)
    Next
    ls = ls + 1
    If ls > 5 Then ls = 0
End Sub

Sub FEllipse (CX As Long, CY As Long, xr As Long, yr As Long, C As _Unsigned Long)
    If xr = 0 Or yr = 0 Then Exit Sub
    Dim h2 As _Integer64, w2 As _Integer64, h2w2 As _Integer64
    Dim x As Long, y As Long
    w2 = xr * xr: h2 = yr * yr: h2w2 = h2 * w2
    Line (CX - xr, CY)-(CX + xr, CY), C, BF
    Do While y < yr
        y = y + 1
        x = Sqr((h2w2 - y * y * w2) \ h2)
        Line (CX - x, CY + y)-(CX + x, CY + y), C, BF
        Line (CX - x, CY - y)-(CX + x, CY - y), C, BF
    Loop
End Sub

Sub makeBackground
    bk = _NewImage(_Width, _Height, 32)
    _Dest bk
    Dim As Long i, stars, horizon
    For i = 0 To _Height
        Line (0, i)-(_Width, i), _RGB32(70, 60, i / _Height * 160)
    Next
    stars = _Width * _Height * 10 ^ -4
    For i = 1 To stars 'stars in sky
        PSet (Rnd * _Width, Rnd * _Height), _RGB32(175 + Rnd * 80, 175 + Rnd * 80, 175 + Rnd * 80)
    Next
    stars = stars / 2
    For i = 1 To stars
        FCirc Rnd * _Width, Rnd * _Height, 1, _RGB32(175 + Rnd * 80, 175 + Rnd * 80, 175 + Rnd * 80)
    Next
    stars = stars / 2
    For i = 1 To stars
        FCirc Rnd * _Width, Rnd * horizon, 2, _RGB32(175 + Rnd * 80, 175 + Rnd * 80, 175 + Rnd * 80)
    Next
    _PutImage , 0, bk
    _Dest 0
End Sub



Attached Files Thumbnail(s)
   
Print this item

  Cropcircles
Posted by: James D Jarvis - 07-23-2023, 01:08 AM - Forum: Programs - Replies (10)

working on a larger image generation projects and realized a little piece of it looked like crop circles, so here we go with a goofy low end crop circle demo:

Code: (Select All)
'crop circles version 0.1
'by James D. Jarvis, July 2023
'this is modifed from a larger image generation program I am working on so if you read the code some of thsi is goign to be strange
'there are likely stubs and variables not actually used in the cropcircle generation that are used in the original, but it works for a goofy little demo
ymax = 800
xmax = 800
'$dynamic
Screen _NewImage(xmax, ymax, 32)
Dim flrklr As _Unsigned Long
tilescale = 4
Type roomtype
    fill As Integer
    rx As Integer
    ry As Integer
    nw As Integer
    sw As Integer
    ew As Integer
    ww As Integer
    cnx As Integer
End Type
Dim Shared rm(0) As roomtype
Dim Shared floorklr As _Unsigned Long
Dim Shared wallklr As _Unsigned Long
Dim Shared emptyklr As _Unsigned Long
floorklr = _RGB32(220, 220, 0)
wallklr = _RGB32(50, 50, 50)
emptyklr = _RGB32(80, 200, 15)

Type band_type
    rad As Integer
    s As Integer
    e As Integer
    spoke As Integer
    thk As Single
End Type

Dim Shared band(0) As band_type
Dim Shared oring(0) As band_type
Dim Shared tessfix
Dim Shared roomfix, excludeturrets
Dim Shared fillcellchance, defaulthallwidth
Dim Shared bumpchance, antennachance
bumpchance = 20
antennachance = 60
floorgrid = 0
forcegeneration = 0
linkgeneration = 0
tessfix = 0
roomfix = 0
fillcellchance = 50
firstpass = 1
Cls
Do

    Cls , emptyklr

    'grassfill 0, 0, xmax, ymax

    cb = 2 + Int(Rnd * 8)
    ReDim band(cb) As band_type
    mr = Int(_Height / 4 + Rnd * _Height / 6)
    mrp = Int(mr / cb)
    r = 0
    For c = 1 To cb
        r = r + Int((mrp / 3) * Int(2 + Rnd * 2))
        band(c).rad = r
        If c = 1 Then
            band(c).s = Int(Rnd * 360)
            band(c).e = band(c).s + band(c).s + (10 * Int(Rnd * 36))
        Else
            band(c).s = band(c - 1).spoke - (Int(1 + Rnd * 60) * 3)
            band(c).e = band(c - 1).spoke + (Int(1 + Rnd * 60) * 3)
            ppx1 = cx + band(c - 1).rad * Cos(0.01745329 * band(c - 1).spoke)
            ppy1 = cy + band(c - 1).rad * Sin(0.01745329 * band(c - 1).spoke)
            ppx2 = cx + band(c).rad * Cos(0.01745329 * band(c - 1).spoke)
            ppy2 = cy + band(c).rad * Sin(0.01745329 * band(c - 1).spoke)
            fatline ppx1, ppy1, ppx2, ppy2, 2, floorklr
        End If
        bsiz = band(c).e - band(c).s
        band(c).spoke = Int(band(c).s + Rnd * bsiz)

        If Rnd * 100 < bumpchance Then
            rs = band(c).s: re = band(c).e
            bsiz = re - rs
            nb = Int((1 + Rnd * 12) / Int(1 + Rnd * 4))
            If nb < 1 Then nb = 1
            For bb = 1 To nb
                srangle = Int(rs + Rnd * bsiz)
                erangle = srangle + (Int(2 + Rnd * 11) * 3)
                bd = Int(1 + Rnd * 5) * tilescale
                If Rnd * 200 < bumpchance Then bd = bd * 2

                For d = 0.5 To bd Step 0.5
                    fatarc cx, cy, 2, band(c).rad + d, srangle, erangle, floorklr
                Next d
            Next bb
        End If

    Next

    roomcount = 0
    lastcount = 0
    For b = 1 To cb
        rs = band(b).s: re = band(b).e
        bsiz = re - rs
        mrbc = (bsiz * 0.01745329 * band(b).rad) / ((tilescale * tilescale) * 4)
        roomcount = roomcount + Int(1 + Rnd * mrbc)
        ReDim _Preserve rm(roomcount) As roomtype
        For r = lastcount + 1 To roomcount
            rangle = Int(rs + Rnd * bsiz)
            'rangle = Int(Rnd * 90) * 4
            rm(r).rx = cx + band(b).rad * Cos(0.01745329 * rangle)
            rm(r).ry = cy + band(b).rad * Sin(0.01745329 * rangle)
            rm(r).nw = 3 + Int(Rnd * 6) * tilescale
            rm(r).sw = 3 + Int(Rnd * 6) * tilescale
            rm(r).ew = 3 + Int(Rnd * 6) * tilescale
            rm(r).ww = 3 + Int(Rnd * 6) * tilescale

            If (Rnd * 101) < fillcellchance Then
                rm(r).fill = Int(1 + Rnd * 10) * (tilescale / 2)
            Else
                rm(r).fill = 0
            End If
            If rm(r).fill = 0 Then
                ' Circle (rm(r).rx, rm(r).ry), rm(r).nw, floorklr
                fatarc rm(r).rx, rm(r).ry, 2, rm(r).nw, 0, 359, floorklr
            Else
                fcirc rm(r).rx, rm(r).ry, rm(r).fill, floorklr
            End If
        Next r
        lastcount = roomcount
    Next b

    For c = 1 To cb
        cx = _Width \ 2: cy = _Height \ 2

        fatarc cx, cy, 2, band(c).rad, band(c).s, band(c).e, floorklr


        If c > 1 Then
            k = Int(c / 2 + Rnd * (c * 1.2))

            For n = 1 To k
                rs = band(c - 1).s: re = band(c - 1).e
                bsiz = re - rs
                ang = Int(rs + Rnd * bsiz)
                ppx1 = cx + band(c - 1).rad * Cos(0.01745329 * ang)
                ppy1 = cy + band(c - 1).rad * Sin(0.01745329 * ang)
                ppx2 = cx + band(c).rad * Cos(0.01745329 * ang)
                ppy2 = cy + band(c).rad * Sin(0.01745329 * ang)
                fatline ppx1, ppy1, ppx2, ppy2, 2, floorklr
            Next
        End If

        If c = cb Then
            rs = band(c).s: re = band(c).e
            bsiz = re - rs
            ang = -1 * Int(rs + Rnd * bsiz)
            fx = 0
            fy = 0
            ppx2 = cx + band(c).rad * Cos(0.01745329 * ang)
            ppy2 = cy + band(c).rad * Sin(0.01745329 * ang)
            cc = cb
            Do
                cc = cc - 1
                xc = cx + band(cc).rad * Cos(0.01745329 * ang)
                yc = cy + band(cc).rad * Sin(0.01745329 * ang)
                If Point(xc, yc) <> emptyklr Then
                    fx = xc
                    fy = yc
                End If

            Loop Until fx <> 0 And fy <> 0 Or cc = 1
            If fx = 0 Then
                fx = cx
                fy = cy
                rs = band(1).s: re = band(1).e
                bsiz = re - rs
                ang = Int(rs + Rnd * bsiz)
                tx = cx + band(1).rad * Cos(0.01745329 * ang)
                ty = cy + band(1).rad * Sin(0.01745329 * ang)

                fatline cx, cy, tx, ty, 2, floorklr
            End If
            fatline fx, fy, ppx2, ppy2, 2, floorklr

        End If
    Next c
    For a = 1 To 5
        If Rnd * 100 < antennachance Then
            tb = Int(1 + Rnd * cb)
            rs = band(tb).s: re = band(tb).e
            bsiz = re - rs
            bangle = Int(rs + Rnd * bsiz)
            DB = mr + 20
            dx = cx + DB * Cos(0.01745329 * bangle)
            dy = cy + DB * Sin(0.01745329 * bangle)
            ppx2 = cx + band(tb).rad * Cos(0.01745329 * bangle)
            ppy2 = cy + band(tb).rad * Sin(0.01745329 * bangle)
            fatline dx, dy, ppx2, ppy2, 2, floorklr
            Select Case Int(1 + Rnd * 16)
                ' Select Case 14
                Case 1, 2
                    fcirc dx, dy, Int(5 + Rnd * 10), floorklr
                Case 3, 4, 5, 6, 7, 8
                    fangs = bangle - Int(2 + Rnd * 10)
                    fange = bangle + Int(2 + Rnd * 10)
                    bd = Int(1 + Rnd * 5) * tilescale

                    For d = 0.5 To bd Step 0.5
                        fatarc cx, cy, 2, DB + d, fangs, fange, floorklr
                    Next d
                Case 10, 11, 12
                    fanga = Int(2 + Rnd * 10) * 10

                    bd = Int(2 + Rnd * 10) * tilescale

                    For da = bangle - fanga To bangle + fanga
                        DB = mr + 20
                        nx = dx + bd * Cos(0.01745329 * da)
                        ny = dy + bd * Sin(0.01745329 * da)
                        fatline dx, dy, nx, ny, 2, floorklr
                    Next da
                Case 13, 14, 15, 16
                    orrc = Int(2 + Rnd * 3)
                    ReDim oring(orrc) As band_type
                    r2 = 0
                    For o = 1 To orrc
                        r2 = r2 + Int(2 + Rnd * 2) * tilescale
                        oring(o).rad = r2
                        oring(o).s = 0
                        oring(o).e = 359
                        oring(o).thk = 0.75
                        fatarc dx, dy, 2, oring(o).rad, 0, 359, floorklr
                    Next o


            End Select

        End If
    Next
    Do
        redraw = 0
        Do
            _Limit 60
            kk$ = InKey$
            If firstpass = 1 Then
                firstpass = 0
                redraw = 1
                kk$ = "go"
            End If
        Loop Until kk$ <> ""


        Select Case kk$
            Case "c" 'copy to clipboard.... this is only supported in windows
                _ClipboardImage = dngi&

            Case "m", "M"
                rrr$ = Str$(tilescale)
                getroun$ = _InputBox$("Shape Magnitude", "Enter new magnitude (4) is standard.", rrr$)
                tilescale = Int(Val(getroun$))
                If tilescale < 1 Then tilescale = 1
            Case Else
                redraw = 1
        End Select
    Loop Until redraw = 1

Loop Until kk$ = Chr$(27)


Sub fcirc (CX As Long, CY As Long, R, klr As _Unsigned Long)
    'draw a filled circle with the quickest filled circle routine in qb64, not my development
    Dim subRadius As Long, RadiusError As Long
    Dim X As Long, Y As Long
    subRadius = Abs(R)
    RadiusError = -subRadius
    X = subRadius
    Y = 0
    If subRadius = 0 Then PSet (CX, CY): Exit Sub
    Line (CX - X, CY)-(CX + X, CY), klr, 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), klr, BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), klr, BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), klr, BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), klr, BF
    Wend
End Sub


Sub fatarc (cx, cy, thk, r, sang, eang, klr As _Unsigned Long)

    For rangle = sang To eang Step 0.5
        ax = cx + r * Cos(0.01745329 * rangle)
        ay = cy + r * Sin(0.01745329 * rangle)
        fcirc ax, ay, thk, klr
    Next rangle
End Sub

Sub fatline (x0, y0, x1, y1, r, klr As _Unsigned Long)
    'draw a line with dots with a radial thickness of r    from x0,y0 to x1,y1 in color klr
    If r > 0.5 Then
        If Abs(y1 - y0) < Abs(x1 - x0) Then
            If x0 > x1 Then

                lineLow x1, y1, x0, y0, r, klr
            Else

                lineLow x0, y0, x1, y1, r, klr
            End If
        Else
            If y0 > y1 Then
                lineHigh x1, y1, x0, y0, r, klr
            Else
                lineHigh x0, y0, x1, y1, r, klr
            End If
        End If
    Else
        Line (x0, y0)-(x1, y1), klr 'line with r of <= 0.5 don't render properly so we force them to be 1 pixel wide on screen
    End If
End Sub
Sub lineLow (x0, y0, x1, y1, r, klr As _Unsigned Long)
    dx = x1 - x0
    dy = y1 - y0
    yi = 1
    If dy < 0 Then
        yi = -1
        dy = -dy
    End If
    d = (dy + dy) - dx
    y = y0
    For x = x0 To x1
        fcirc x, y, r, klr
        If d > 0 Then
            y = y + yi
            d = d + ((dy - dx) + (dy - dx))
        Else
            d = d + dy + dy
        End If
    Next x
End Sub
Sub lineHigh (x0, y0, x1, y1, r, klr As _Unsigned Long)
    dx = x1 - x0
    dy = y1 - y0
    xi = 1
    If dx < 0 Then
        xi = -1
        dx = -dx
    End If
    D = (dx + dx) - dy
    x = x0
    For y = y0 To y1
        fcirc x, y, r, klr
        If D > 0 Then
            x = x + xi
            D = D + ((dx - dy) + (dx - dy))
        Else
            D = D + dx + dx
        End If
    Next y
End Sub

Function inscreen (xx, yy)
    'check if point is inside the boreders of the current screen
    ii = 1
    If xx < 1 Or xx > _Width - 1 Then ii = 0
    If yy < 1 Or yy > _Height - 1 Then ii = 0
    inscreen = ii
End Function
Sub paintifborder (xx, yy, klr As _Unsigned Long)
    If xx = 0 Or xx = _Width Or yy = 0 Or yy = _Height Then
        PSet (xx, yy), klr
    End If
End Sub
Sub grassfill (x1, y1, x2, y2)
    Cls
    Line (x1, y1)-(x2, y2), _RGB32(40, 240, 40), BF
    For yy = y1 To y2
        For xx = x1 To x2 Step 2
            bx = Int(Rnd * 2)
            Line (xx + bx, yy)-(xx + bx, yy - Int(Rnd * 3)), _RGB32(55 + Int(Rnd * 10), 225 + Int(Rnd * 10), 15 + Int(Rnd * 10))


        Next
    Next


End Sub

edit: darn aliens

Print this item

  "I'm Having Fun."
Posted by: James D Jarvis - 07-21-2023, 03:57 AM - Forum: General Discussion - Replies (6)

The wife and I are sitting on the couch after dinner and I have my laptop in front of me working on a program cursing, swearing, and muttering as I go.

She tells me "The working day is over, time for some rest or fun"

I of course reply to her "I'm having fun."

Print this item

  how to, playlist
Posted by: random1 - 07-21-2023, 01:45 AM - Forum: General Discussion - Replies (3)

Hi all
Is there a simple way to create a playlist for _SndPlay? 
R1.

Print this item

  _SndPlayFile not starting sound file
Posted by: eoredson - 07-20-2023, 03:35 AM - Forum: Help Me! - Replies (11)

Hi,

I have been looking at converting a .mp3 to .m4a to reduce the sound file by 50% for distribution purposes but the .m4a won't play.

Is there any other sound file less than an .mp3 that I could convert to? I have also tried a .wav file but it is bigger than the .mp3

I am using _SndPlayFile <filename>

Erik.

Print this item

  QB64pe Banner
Posted by: johnno56 - 07-18-2023, 09:51 PM - Forum: General Discussion - Replies (20)

I had just realised that I did not thank "the powers that be" for the website banner... "Summer"... So nice to see especially being the middle of winter here in Melbourne..  I do miss the warmth.  Thank you for the 'psychological' relief...

J

Print this item

  A dice parser
Posted by: James D Jarvis - 07-18-2023, 09:29 PM - Forum: Programs - Replies (2)

A dice parser to return a score from a string that describes a dice roll. 
roll("2d6") would return a score from 2 to 12
These routines are part of a Role Playing Game related program and mat be useful to others.

This sample program demonstrates 12 different string and the results generated.

Code: (Select All)
'dice parser  july 2023
'by James D. Jarvis
'a simpe dice parser for an RPG game that will evalute a string and generate the roll described
' d = dice,standard equal distribution range
' s = short dice, trends to generate low value in range
' f = fat dice, trends to generate median value in range
' t = tall dice, trend to generate higher values in range
' e = exploding die
'******************************************************
'Include these in nay program using the routines here
'$dynamic
Randomize Timer
Dim Shared de$(0) 'dice experssion
Dim Shared drf$(0) 'dice function
Dim Shared dn
Dim Shared ds
'*******************************************************

'setting up  sample rolls to demonstarte routines
Dim r$(12)
r$(1) = "1d6"
r$(2) = "2d6"
r$(3) = "1s8"
r$(4) = "1e8"
r$(5) = "2t10"
r$(6) = "1d6+1d3"
r$(7) = "1d12+1s4"
r$(8) = "-2t100"
r$(9) = "1d4+1d6+1d8"
r$(10) = "1s20+1f5"
r$(11) = "1d10000/1s4"
r$(12) = "1t200-1s200"

Do
    For x = 1 To 12
        rr = roll(r$(x))
        Print r$(x); "= "; rr
    Next x
    Print
    Print "Press any key for more rolls, <esc> to exit"
    Do
        _Limit 60
        kk$ = InKey$
    Loop Until kk$ <> ""
    Cls
Loop Until kk$ = Chr$(27)
'roll dice
Function rolld (num, sides)
    score = 0
    For n = 1 To num
        score = score + Int(1 + Rnd * sides)
    Next n
    rolld = score
End Function
'roll short dice
Function rolls (num, sides)
    score = 0
    For n = 1 To num
        A = Int(1 + Rnd * sides)
        B = Int(1 + Rnd * sides)
        C = Int(1 + Rnd * sides)
        add = A
        If add > B Then add = B
        If add > C Then add = C
        score = score + add
    Next n
    rolls = score
End Function
'roll tall dice
Function rollt (num, sides)
    score = 0
    For n = 1 To num
        A = Int(1 + Rnd * sides)
        B = Int(1 + Rnd * sides)
        C = Int(1 + Rnd * sides)
        add = A
        If B > add Then add = B
        If C > add Then add = C
        score = score + add
    Next n
    rollt = score
End Function
'roll fat dice
Function rollf (num, sides)
    score = 0
    For n = 1 To num * 3
        score = score + Int(1 + Rnd * sides)
    Next n
    rollf = Int(score / 3)
End Function
'roll exploding die
Function rolle (num, sides)
    score = 0
    b = 0
    For n = 1 To num
        a = Int(1 + Rnd * sides)
        score = score + a
        If a = sides Then
            Do
                b = Int(1 + Rnd * sides)
                score = score + b
            Loop Until b < sides
        End If
    Next n
    rolle = score
End Function
'break out the individual rolls
Sub find_rolls (idd$)
    c = 0
    w$ = ""
    xc = 0
    dd$ = idd$ + "#" 'okay I'm lazy i added a termination symbol to the string
    last$ = "+"
    Do
        c = c + 1
        A$ = Mid$(dd$, c, 1)
        Select Case A$
            Case "+", "-", "/", "*", "#"
                xc = xc + 1
                ReDim _Preserve de$(xc)
                ReDim _Preserve drf$(xc)
                de$(xc) = w$
                drf$(xc) = last$
                w$ = ""
                last$ = A$
            Case Else
                w$ = w$ + A$
        End Select
    Loop Until c >= Len(dd$)
End Sub
'the main fuction that is called to return a rolled value from the described dice roll
Function roll (idd$)
    find_rolls idd$
    dn = UBound(de$)
    Dim ss(dn)
    score = 0
    For n = 1 To dn
        dit$ = doroll$(de$(n))
        Select Case doroll$(de$(n))
            Case "d"
                ss(n) = rolld(finddn(de$(n), dit$), findds(de$(n), dit$))
            Case "s"
                ss(n) = rolls(finddn(de$(n), dit$), findds(de$(n), dit$))
            Case "t"
                ss(n) = rollt(finddn(de$(n), dit$), findds(de$(n), dit$))
            Case "f"
                ss(n) = rollf(finddn(de$(n), dit$), findds(de$(n), dit$))
            Case "e"
                ss(n) = rolle(finddn(de$(n), dit$), findds(de$(n), dit$))
            Case "V"
                ss(n) = Val(de$(n))
        End Select
        Select Case drf$(n)
            Case "+"
                score = score + ss(n)
            Case "-"
                score = score - ss(n)
            Case "/" 'divides the previolsy generated score
                score = score / ss(n)
            Case "*" 'multiplies the previolsy generated score
                score = score * ss(n)
        End Select
    Next n
    roll = score
End Function
Function doroll$ (dd$)
    c = 1
    Dim a$(6)
    a$(1) = "d": a$(2) = "s": a$(3) = "f": a$(4) = "t": a$(5) = "e": a$(6) = "V"
    d$ = "V"
    Do
        If InStr(dd$, a$(c)) > 0 Then
            d$ = a$(c)
            c = 6
        End If
        c = c + 1
    Loop Until c > 6
    doroll$ = d$
End Function
Function finddn (dd$, r$)
    rp = InStr(dd$, r$)
    a = Val(Left$(dd$, rp - 1))
    finddn = a
End Function
Function findds (dd$, r$)
    rp = InStr(dd$, r$)
    a = Val(Right$(dd$, Len(dd$) - rp))
    findds = a
End Function

Print this item