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

Username/Email:
  

Password
  





Search Forums

(Advanced Search)

Forum Statistics
» Members: 495
» Latest member: EOTechggh
» Forum threads: 2,846
» Forum posts: 26,668

Full Statistics

Latest Threads
QBJS v0.9.0 - Release
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
1 minute ago
» Replies: 14
» Views: 162
1990's 3D Doom-Like Walls...
Forum: Programs
Last Post: SierraKen
12 minutes ago
» Replies: 7
» Views: 210
Fun with Ray Casting
Forum: a740g
Last Post: a740g
3 hours ago
» Replies: 2
» Views: 64
Big problem for me.
Forum: General Discussion
Last Post: bplus
5 hours ago
» Replies: 7
» Views: 60
discover graphics with xa...
Forum: Programs
Last Post: hsiangch_ong
7 hours ago
» Replies: 0
» Views: 22
another variation of "10 ...
Forum: Programs
Last Post: Jack002
7 hours ago
» Replies: 37
» Views: 542
Aloha from Maui guys.
Forum: General Discussion
Last Post: doppler
Yesterday, 03:32 PM
» Replies: 14
» Views: 328
Cautionary tale of open, ...
Forum: General Discussion
Last Post: doppler
Yesterday, 03:28 PM
» Replies: 0
» Views: 23
Extended KotD #22: _MOUSE...
Forum: Keyword of the Day!
Last Post: SMcNeill
Yesterday, 12:29 AM
» Replies: 0
» Views: 49
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: aurel
01-13-2025, 09:10 PM
» Replies: 111
» Views: 5,578

 
Music Control Audacious, play last 30 seconds of music
Posted by: mnrvovrfc - 12-29-2022, 01:41 AM - Forum: Utilities - No Replies

If you're on Linux, using Audacious music player and have loads of music that you don't have time to listen to entirely, I have written a tool to make your life a bit easier.

Press escape key at any time in the run to quit the program. This program expects Audacious started with a playlist ready to go. It prints on the screen the filename of the song that it's currently on. If you don't like this then press escape to get away from this QB64 user program, then change the current track in Audacious and try again to run this program.

Each song is first played for its first five seconds, then a seek is performed to about 30 seconds before the end to play that portion. These values could be adjusted in the program. It's easier to seek from the beginning of a song, but to seek from the end, first the playback length of the media file must be acquired.

While the 30 seconds of playback go down, the user could press escape to leave the program, or spacebar or enter to advance to the next track in the playlist.

This program makes use of an utility called "audtool" that should have been installed with Audacious. At the moment it works with one instance of Audacious that was ever opened.

Code: (Select All)
''by mnrvovrfc 2022-dec-28
option _explicit
dim as integer i, j, hm, hs, ff, coln
dim afile$, aname$, ke$, b$

afile$ = "audahelp-thistrak.txt"

_TITLE "Audacious App Helper"
do : loop until _screenexists

print "*** Make sure Audacious is running and with a playlist! ***"
print "Press escape to quit."
for i = 5 to 1 step -1
    print "Starting in..."; i
    _delay 1
    ke$ = inkey$
    if ke$ = chr$(27) then system
next
shell _hide "audtool -1 --playback-play"

for i = 1 to 20
    shell _hide "audtool -1 --current-song-length > " + afile$
    shell _hide "audtool -1 --current-song-filename >> " + afile$
    ff = freefile
    open afile$ for input as ff
    line input #ff, b$
    line input #ff, aname$
    close ff
    coln = instr(b$, ":")
    hm = val(left$(b$, coln - 1))
    hs = val(mid$(b$, coln + 1))
    hs = hs - 32
    if hs < 0 then
        hm = hm - 1
        hs = hs + 60
    end if
    hs = hs + hm * 60
    print i; "name: "; aname$
    print i; "for 5 seconds..."
    for j = 1 to 5
        _delay 1
        ke$ = inkey$
        if ke$ = chr$(27) then system
    next
    shell _hide "audtool -1 --playback-seek" + str$(hs)
    print i; "final 30 seconds..."
    for j = 1 to 30
        _delay 1
        ke$ = inkey$
        if ke$ = chr$(27) then system
        if ke$ = chr$(13) or ke$ = " " then exit for
    next
    if i = 20 then exit for
    shell _hide "audtool -1 --playlist-advance"
next

shell _hide "audtool -1 --playback-stop"
print "OVER"
_delay 5
system

Print this item

  Remove Spaces (or other characters) from a String
Posted by: George McGinn - 12-29-2022, 01:28 AM - Forum: Utilities - Replies (10)

Awhile back I needed to remove SPACES (and sometimes other characters) from a string in some of my C code.

The need to do so in QB64 reared its ugly head again today, so I resurrected my code and now have incorporated it into any QB64 program I will need it in.

You pass the function 2 parameters - The string you want to change, and the character(s) you want removed. For example, if I want spaces and periods to be removed from a sentence, I pass " ." in the second argument. You don't need to run this function multiple times to accomplish this.

Here is the C/C++ Header file:

Code: (Select All)
#include <stdio.h>
/* search for character(s) */
int string_search_chr(char *tokens,char s){
        if (!tokens || s=='\0')
        return 0;
    for (;*tokens; tokens++)
        if (*tokens == s)
            return 1;
    return 0;
}
char *string_remove_chr(char *str,const char *tokens) {
    char *src = str , *dst = str;
    /* validate input */
    if (!(str && tokens))
        return NULL;
    while(*src)
        if(string_search_chr(tokens,*src))
            src++;
        else
            *dst++ = *src++;  /* assign first, then incement */
    *dst='\0';
    return str;
}

Here is the QB64 program that tests the above:
Code: (Select All)
DECLARE LIBRARY "./removeStr"
    FUNCTION __REMOVESPACES$ ALIAS string_remove_chr(qString$, charValue$)
END DECLARE

QBMain:
    PRINT "QB64: Test #1 - Remove SPACES from 'New York Yankees"
    qString$ = "New York Yankees"
    retValue$ = __REMOVESPACES$(qString$+CHR$(0), " ")
    PRINT "QB64: qString$ = "; qString$
    PRINT "QB64: retValue$ = "; retValue$
    PRINT
    PRINT "QB64: Used in a PRINT stmt, function returns: "; __REMOVESPACES$(qString$+CHR$(0), " ")  
    PRINT

    PRINT "QB64: Test #2 -Remove SPACES and PERIODS from 'New York Yankees."
    qString$ = "New York Yankees"
    retValue$ = __REMOVESPACES$(qString$+CHR$(0), " .")
    PRINT "QB64: qString$ = "; qString$
    PRINT "QB64: retValue$ = "; retValue$
    PRINT
    PRINT "QB64: Used in a PRINT stmt, function returns: "; __REMOVESPACES$(qString$+CHR$(0), " ")  
    PRINT

    SYSTEM 0

This is the output from running the above code:
Quote:QB64: Test #1 - Remove SPACES from 'New York Yankees
QB64: qString$ = New York Yankees
QB64: retValue$ = NewYorkYankees

QB64: Used in a PRINT stmt, function returns: NewYorkYankees

QB64: Test #2 -Remove SPACES and PERIODS from 'New York Yankees.
QB64: qString$ = New York Yankees
QB64: retValue$ = NewYorkYankees

QB64: Used in a PRINT stmt, function returns: NewYorkYankees



------------------
(program exited with code: 0)
Press return to continue

Print this item

  so, there's no more manual built in?
Posted by: MrCreemy - 12-28-2022, 06:01 PM - Forum: General Discussion - Replies (8)

I am assuming, there's no more of that "auto manual" popping up in the IDE?

(I liked that)

looking like workaround, is....
download giant PDF file
do command checks by hand, like old days with manual?

or... is there a workaround to "hook things back up"

Print this item

  Miscellaneous handy goodies
Posted by: grymmjack - 12-28-2022, 01:44 AM - Forum: One Hit Wonders - Replies (9)

Well, damn.

I had a very nicely formatted post all queued up and the browser crashed when I right clicked on a word to check its definition and spelling in this text area.

Anyway.

I will return to this to explain but mostly this is self-explanatory stuff.

Code: (Select All)
' For concatenating integers and stripping spaces
FUNCTION n$ (integ%)
    n$ = _TRIM$(STR$(integ%))
END FUNCTION

' For showing friendly versions of my boolean constants
FUNCTION b$ (integ%)
    IF integ% = -1 THEN
        b$ = "TRUE"
    ELSEIF integ% = 0 THEN
        b$ = "FALSE"
    ENDIF
END FUNCTION

' For concatenating longs and stripping spaces
FUNCTION ln$ (longval!)
    ln$ = _TRIM$(STR$(longval!))
END FUNCTION


' For incrementing integers - x=inc(1) takes up 3 more chars than x=x+1 but inc is a bit easier for me to read.
FUNCTION inc% (value%)
    inc% = value% + 1
END FUNCTION

' Same as above but decrement
FUNCTION dec% (value%)
    dec% = value% - 1
END FUNCTION

' Inverting int
FUNCTION inv% (value%)
    inv% = value% * -1
END FUNCTION

' Force int to be not less than min
FUNCTION min% (value%, minimum%)
    IF value% < minimum% THEN value% = minimum%
    min% = value%
END FUNCTION

' Force int to be not more than max
FUNCTION max% (value%, maximum%)
    IF value% > maximum% THEN value% = maximum%
    max% = value%
END FUNCTION

' Force int to be between a min and a max, when greater - clamp it between min and max
FUNCTION clamp% (value%, minimum%, maximum%)
    IF value% > maximum% THEN
        clamp% = maximum%
    ELSEIF value% < minimum% THEN
        clamp% = minimum%
    ELSE
        clamp% = value%
    END IF
END FUNCTION

' Determine if a int is in range of a min and a max
FUNCTION in_range% (value%, minimum%, maximum%)
    IF value% >= minimum% AND value% <= maximum% THEN
        in_range% = TRUE
    ELSE
        in_range% = FALSE
    END IF
END FUNCTION

' Randomize the sign of an int
FUNCTION rand_sign% ()
    DIM r AS INTEGER
    r% = -1 + INT(RND*2)
    IF r% = 0 THEN r% = 1
    rand_sign% = r%
END FUNCTION

' Create a random integer between min and max
FUNCTION rand_in_range% (minimum%, maximum%)
    rand_in_range% = INT(RND * (maximum% - minimum% + 1)) + 1
END FUNCTION

' Randomly choose an int from an array of ints
FUNCTION rand_int_choice% (arr_choices%())
    DIM AS INTEGER minimum, maximum
    minimum% = LBOUND(arr_choices%) : maximum% = UBOUND(arr_choices%)
    rand_int_choice% = arr_choices%(rand_in_range(minimum%, maximum%))
END FUNCTION

' Randomly choose a string from an array of strings
FUNCTION rand_str_choice$ (arr_choices$())
    DIM AS INTEGER minimum, maximum
    minimum% = LBOUND(arr_choices$) : maximum% = UBOUND(arr_choices$)
    rand_str_choice$ = arr_choices$(rand_in_range(minimum%, maximum%))
END FUNCTION

Print this item

  MergeFile
Posted by: SMcNeill - 12-27-2022, 05:26 PM - Forum: Works in Progress - Replies (8)

Code: (Select All)
$If WIN Then
    Const Slash$ = "\"
$Else
        const Slash$ = "/"
$End If

target$ = ".\source\qb64pe.bas"
outfile$ = ".\qb64onefile.bas"

If target$ = "" Then
    Print "Give me a QB64 program to unravel => ";
    Input target$
    Print "Give me a name to save the new file under => ";
    Input outfile$
End If

Open outfile$ For Output As #1
MergeFile target$

Sub MergeFile (whatfile$)
    f = FreeFile
    CurrentDir$ = _CWD$
    i = _InStrRev(whatfile$, Slash$)
    newdir$ = Left$(whatfile$, i)
    If i > 0 Then
        ChDir newdir$
        whatfile$ = Mid$(whatfile$, i + 1)
    End If
    Open whatfile$ For Binary As #f
    Do
        Line Input #f, temp$
        If Left$(UCase$(_Trim$(temp$)), 11) = "'$INCLUDE:'" Then
            temp$ = _Trim$(temp$)
            file$ = Mid$(temp$, 12)
            file$ = Left$(file$, Len(file$) - 1)
            MergeFile file$
        Else
            Print #1, temp$
        End If
    Loop Until EOF(f)
    ChDir CurrentDir$
    Close #f
End Sub


@grymmjack Was asking for a quick little program to merge $INCLUDE files into a single BAS file, so I sat down and wrote this one up in about 15 minutes.  I haven't tested it extensively as I'm kinda distracted with my niece's kids visiting today, but it appeared to work without any issues with QB64PE.BAS and merged it all into one file easily enough.

Give it a try if you're interested in this type of thing, and if you manage to break it, post me a note on how you did so an I'll update it with a fix as soon as I get a little free time later.  Wink

Print this item

Lightbulb Pan around a large screen
Posted by: mnrvovrfc - 12-27-2022, 05:43 AM - Forum: Works in Progress - Replies (3)

The latest topics created are staying firmly with zero views. Also this new annoyance of "related topics" which picks up only one word such as "bug" or "clone" LOL. I hope there's an user preference to disable that.

Ahem! Here I am sharing an incomplete program that could be used by someone else. It allows the user to press the arrow keys to move around in a simple imaginary world created with SCREEN 0. The "world" isn't very complex, just colored boxes. Feel free to add more keypresses, or "automatic movement" although it could spoil the fun.

Code: (Select All)
DIM AS LONG bigscr
DIM AS INTEGER i, j, x, y, c, ii, fc, bc, xs, ys
DIM upd AS _BYTE
DIM ke$, ba$, blk$

blk$ = CHR$(219)
ba$ = CHR$(177)
RANDOMIZE TIMER

bigscr = _NEWIMAGE(1200, 1200, 0)
_DEST bigscr
FOR ii = 1 TO 5
    FOR i = 1 TO 1000
        DO
            fc = INT(RND * 16)
            bc = INT(RND * 7 + 1)
        LOOP WHILE fc = bc
        xs = INT(RND * INT(i / 25) + 4)
        ys = INT(RND * INT(i / 25) + 4)
        x = INT(RND * (1200 - xs) + 1)
        y = INT(RND * (1200 - ys) + 1)
        COLOR fc, bc
        LOCATE y, x: PRINT STRING$(xs, ba$);
        LOCATE y + ys - 1, x: PRINT STRING$(xs, ba$);
        FOR j = 1 TO ys - 2
            LOCATE y + j, x: PRINT STRING$(xs, ba$);
        NEXT
    NEXT
NEXT
COLOR 15, 0
LOCATE 1, 1: PRINT STRING$(1198, 219);
LOCATE 1200, 1: PRINT STRING$(1198, 219);
FOR j = 2 TO 1199
    LOCATE j, 1: PRINT CHR$(219);
    LOCATE j, 1200: PRINT CHR$(219);
NEXT

SCREEN _NEWIMAGE(100, 40, 0)
_SCREENMOVE 0, 0
_SOURCE bigscr

upd = 1
x = 576
y = 1201 - _HEIGHT
DO
    _LIMIT 50
    IF upd THEN
        FOR j = 39 TO 1 STEP -1
            FOR i = 1 TO 100
                c = SCREEN(y + j - 1, x + i - 1, 1)
                COLOR c MOD 16, c \ 8
                LOCATE j, i: PRINT CHR$(SCREEN(y + j - 1, x + i - 1));
            NEXT
        NEXT
        j = 40
        FOR i = 1 TO 98
            c = SCREEN(y + j - 1, x + i - 1, 1)
            COLOR c MOD 16, c \ 8
            LOCATE j, i: PRINT CHR$(SCREEN(y + j - 1, x + i - 1));
        NEXT
        _DISPLAY
    END IF
    ke$ = INKEY$
    IF ke$ = CHR$(27) THEN EXIT DO
    IF LEN(ke$) > 1 THEN
        kk = ASC(ke$, 2)
        SELECT CASE kk
            CASE 72
                IF y > 1 THEN y = y - 1: upd = 1
            CASE 75
                IF x > 1 THEN x = x - 1: upd = 1
            CASE 77
                IF x <= 1100 THEN x = x + 1: upd = 1
            CASE 80
                IF y <= 1160 THEN y = y + 1: upd = 1
        END SELECT
    END IF
LOOP
_AUTODISPLAY
SYSTEM

Print this item

  So... I *think* I found the cheese at the end of the maze?
Posted by: MrCreemy - 12-27-2022, 04:16 AM - Forum: General Discussion - Replies (11)

Good Lord.

I work away from home, and when I am away, I dont have internet

I am apt to be away for a long time.
I came home this time? Found... everything nuked.

freaked out by some tech journal article, how QB64 "blew up"...
I wasnt here, I only know what I *read*

Honestly, the story I found?
someone called someone a "nazi"
some kind of flame war ensued, I guess...

next thing, the wiki, the site, the forum, everything goes down

Question... am I in the right place? (I think I am)
Question #2... are there, like multiple forks of this QB64 language project now?

PS - I would have been "colonel panic" on the old site

Print this item

  Late Christmas Card to everyone
Posted by: Dav - 12-27-2022, 01:22 AM - Forum: Christmas Code - Replies (1)

I'm always late sending Christmas cards.  I posted this in the help forum weeks ago, should have put it here yesterday.  Merry Christmas.

code: DavXmas2022.bas (189k)
https://qb64phoenix.com/forum/attachment.php?aid=1109

- Dav

Print this item

  QB64 Pac-Man Clone
Posted by: TerryRitchie - 12-26-2022, 08:10 PM - Forum: Programs - Replies (49)

Finally! A working version I can share. This version is as about as close as you can get to the original without using MAME and ROM images.

I've been writing (and rewriting) this for 2 months now. There is still one known bug I need to track down. Sometimes the ghosts trapped in the ghost house will stop bobbing up and down. It doesn't affect game play and very rarely happens (which is why I'm having trouble tracking it down). I'll eventually find the bug and post an update, but in the meantime I need to take a break from it.

The ZIP file contains all the files needed (23 of them). The game creates a file when first executed called "pm.sav" that is two lines long and contains the options settings and high score.

Have fun! Waaka Waaka Waaka ...



Attached Files Thumbnail(s)
   

.zip   PacMan.zip (Size: 1.39 MB / Downloads: 141)
Print this item

  Xmas Star
Posted by: bplus - 12-25-2022, 05:51 PM - Forum: Christmas Code - Replies (3)

Code: (Select All)
_Title "Xmas Star" ' b+ 2022-12-25
Screen _NewImage(500, 500, 32)

star& = _NewImage(500, 500, 32)
XmasStar _Width / 2, _Height / 2, .1 * _Height, .2 * _Height, .45 * _Height, 125
_PutImage , 0, star&
s2& = _NewImage(500, 500, 32)
XmasStar _Width / 2, _Height / 2, .1 * _Height, .2 * _Height, .45 * _Height, 75
_PutImage , 0, s2&
d = 1

Do
    Cls
    For r = 0 To .45 * _Height Step 1
        fcirc _Width / 2, _Height / 2, r, _RGB32(255, 255, 255, 5)
    Next
    a = a + d * .05
    If Abs(a) < .05 Then
        If d < 0 Then a = -.05
        If d > 0 Then a = .05
    End If
    If a < -1 Then a = -1: d = 1
    If a > 1 Then a = 1: d = -1
    If a > 0 Then RotoZoom3 _Width / 2, _Height / 2, star&, a, 1, 0 Else RotoZoom3 _Width / 2, _Height / 2, s2&, a, 1, 0
    _Display
    _Limit 60
Loop Until _KeyDown(27)

Sub XmasStar (xc, yc, r1, r2, r3, c As _Unsigned Long)
    a = _Pi(2 / 16)
    For p = 0 To 200
        p1 = p / 200
        For i = 0 To 15
            If i Mod 2 = 1 Then
                x1 = xc + p1 * r1 * Cos(i * a): y1 = yc + p1 * r1 * Sin(i * a)
            ElseIf i Mod 4 = 0 Then
                x1 = xc + p1 * r3 * Cos(i * a): y1 = yc + p1 * r3 * Sin(i * a)
            ElseIf i Mod 4 = 2 Then
                x1 = xc + p1 * r2 * Cos(i * a): y1 = yc + p1 * r2 * Sin(i * a)
            End If
            If i > 0 Then Line (lastx, lasty)-(x1, y1), _RGB32(255 - (p1 * 192), 255 - (p1 * 192), c, 60) Else firstx = x1: firsty = y1
            lastx = x1: lasty = y1
        Next
        Line (lastx, lasty)-(firstx, firsty), _RGB32(255 - (p1 * 192), 255 - (p1 * 192), c, 60)
    Next
End Sub

Sub RotoZoom3 (X As Long, Y As Long, Image As Long, xScale As Single, yScale As Single, radianRotation As Single) ' 0 at end means no scaling of x or y
    Dim px(3) As Single: Dim py(3) As Single
    Dim W&, H&, sinr!, cosr!, i&, x2&, y2&
    W& = _Width(Image&): H& = _Height(Image&)
    px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2
    px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2
    sinr! = Sin(-radianRotation): cosr! = Cos(-radianRotation)
    For i& = 0 To 3
        x2& = xScale * (px(i&) * cosr! + sinr! * py(i&)) + X: y2& = yScale * (py(i&) * cosr! - px(i&) * sinr!) + Y
        px(i&) = x2&: py(i&) = y2&
    Next
    _MapTriangle _Seamless(0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
    _MapTriangle _Seamless(0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub

Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
    Dim Radius As Long, RadiusError As Long
    Dim X As Long, Y As Long
    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