I need to open each of the files present in a given folder/directory and process them one by one.
A crude way would be to use DIR to create a text file containing all of the file names, then read that to obtain each of the filenames, line by line.
However, I'm wondering if QB64 has a function to Get Next Filename into a string that can be called in a loop until there are no more files in the directory?
Posted by: Petr - 02-26-2023, 10:25 AM - Forum: Petr
- Replies (1)
As you know, if you need to color an object, for example a rectangle, but it have its borders not colored with the same color, you cannot use the Paint statement because the color will spread everywhere. This version solves this and with this program you can color solids even though they have different colored borders. This problem is solved using mask image, this version is just for 32 bit images.
Code: (Select All)
Screen _NewImage(1024, 768, 32)
$Color:32
Do
Cls , Red
For c = 1 To 40
Circle (Rnd * 980, Rnd * 740), Rnd * 100 + 10, _RGB32(25 * Rnd, 75 * Rnd, 127 * Rnd)
X = Rnd * 1024
Y = Rnd * 768
Lwidth = Rnd * 100
Lheight = Rnd * 100
Line (X, Y)-(X + Lwidth, Y + Lheight), _RGB32(55 * Rnd, 145 * Rnd, 255 * Rnd), BF
Next
_Delay .1
_MouseMove 512, 384
Do Until K& = 27
K& = _KeyHit
While _MouseInput: Wend
If _MouseButton(1) Then Paint2 _MouseX, _MouseY, DarkBlue
Loop
K& = 0
Loop
Sub Paint2 (x, y, c~&)
W = _Width: H = _Height
Virtual = _NewImage(W, H, 32)
Dim m As _MEM, n As _MEM, Bck As _Unsigned Long
m = _MemImage(_Source)
n = _MemImage(Virtual)
'create mask (2 color image)
position& = (y * W + x) * 4
_MemGet m, m.OFFSET + position&, Bck
Clr2~& = _RGB32(_Red32(Bck) - 1, _Green32(Bck) - 1, _Blue32(Bck) - 1)
D& = 0
Do Until D& = n.SIZE
CLR~& = _MemGet(m, m.OFFSET + D&, _Unsigned Long)
If CLR~& = Bck~& Then _MemPut n, n.OFFSET + D&, CLR~& Else _MemPut n, n.OFFSET + D&, Clr2~&
D& = D& + 4
Loop
d = _Dest
_Dest Virtual
Paint (x, y), c~&, Clr2~&
_Dest d
_ClearColor Clr2~&, Virtual
_PutImage , Virtual, d
_MemFree m
_MemFree n
_FreeImage Virtual
End Sub
I'm dating myself here. Those who were programming during the DOS era will likely recall Vern Buerg's fantastic shareware directory and file utility called LIST. Once you used it you could not live without it.
Over the years many people petitioned VB to create a 32-bit version of it, but he was disinclined to do that. Vern died in December 2009 at the age of 62.
Anyway, thankfully for those of us who love LIST, circa 2016 Clark Woodworth wrote a new incarnation of it called ZBLIST.
It has a similar look and feel to the classic LIST and includes new features:
Screen 12: For N = 0 To 15: Palette N, N * 263172: Next N
For Z = 0 To 100 Step .25: For A = 0 To 6.2831853 Step .001
R = 100 + Cos(20 * A + Z / 20) * 15
X1 = Cos(A) * R + 220: Y1 = Sin(A) * R / 3 + 240 - Z / 2
R = 50 + Sin(-10 * A + Z / 20) * 15
X2 = Cos(A) * R + 370: Y2 = Sin(A) * R / 3 + 240 - Z / 2
PSet (X1, Y1), Z * .125 + 2.5: PSet (X2, Y2), Z * .125 + 2.5
If Z = 100 Then Line (220, 240 - Z / 2)-(X1, Y1), 8: Line (370, 240 - Z / 2)-(X2, Y2), 5
Next A: Next Z
B+ Mods
Code: (Select All)
_Title "Fixed 2 Turning Gears mod B+ 2023-02-25"
Screen 12: For N = 0 To 15: Palette N, N * 263172: Next N
Do: Cls: For Z = 0 To 20 Step .5: For A = 0 To 6.2831853 Step .001
R = 100 + Cos(20 * A) * 15: X1 = Cos(A + ao) * R + 220: Y1 = Sin(A + ao) * R / 3 + 240 - Z / 2
R = 50 + Sin(-10 * A) * 15: X2 = Cos(A - 2 * ao) * R + 390: Y2 = Sin(A - 2 * ao) * R / 3 + 240 - Z / 2
PSet (X1, Y1), Z * .125 + 2.5: PSet (X2, Y2), Z * .125 + 2.5
If Z = 20 Then Line (220, 240 - Z / 2)-(X1, Y1), 8: Line (370, 240 - Z / 2)-(X2, Y2), 5
Next A: Next Z: _Display: _Limit 200: ao = ao + .04: Loop
I am trying to modify my tokenizer written in FB to QB64
and i am getting error ..what i am doing wrong ?
Code: (Select All)
'tokenizer in QB (fb) by Aurel
'INT startTime ,endTime: float procTime ' GetTickCount -timer init
declare function tokenizer( src as string) as integer
declare function run_tokenizer(inputCode as string) as integer
Dim shared tokList(1024) As string 'token array
Dim shared typList(1024) As integer 'token type array
Dim shared p As Long : p=1
Dim shared start as Long : start = 1
Dim shared tp as long
Dim shared tn as long
Dim shared n as long
Dim shared ltp as long : lpt = 1
Dim shared nTokens As long 'nTokens -> number of tokens
Dim shared lineCount As integer
Dim shared Lpar as integer
Dim shared Rpar as integer
Dim shared Lbrk as integer
Dim shared Rbrk as integer
Dim shared tokerr as integer
Dim shared codeLen as integer
Dim shared code As String
Dim shared chs As String
Dim shared tch As String
Dim shared tk As String
Dim shared crlf As String
Dim shared bf As String
Dim shared ntk As String
crlf = chr$(13) + chr$(10)
'test string .......................................
Dim test as string : test = "func tokenizer in QB64"
'...................................................
'call fn tokenizer()
call tokenizer(test)
' *** MAIN TOKENIZER FUNCTION ***
FUNCTION tokenizer& (src as string)
print "tokenizer run:" + src
lineCount=0:ltp=start : nTokens = 0
Function RoundText& (text As String, InternalRadius As Integer, StartRadius As Single)
D = _Dest: So = _Source
VImg& = _NewImage(_PrintWidth(text) + 1, _FontHeight + 1, 32)
Ob = (InternalRadius + _FontHeight)
Ol = InternalRadius
_Dest VImg&: _PrintString (0, 0), text$: _Dest D
R& = _NewImage((InternalRadius + _FontHeight) * 2, (InternalRadius + _FontHeight) * 2, 32)
U = _Width(R&) / 2
Dim X(4), Y(4), sX(4), sY(4)
S = 200
PW = _PrintWidth(text)
p2 = CInt(PW / S)
For C = StartRadius To StartRadius + _Pi(2) Step (_Pi(2) / S) ' 200 steps
'dest
X(1) = U + Cos(C) * Ob
Y(1) = U + Sin(C) * Ob
X(2) = U + Cos(C) * Ol
Y(2) = U + Sin(C) * Ol
X(3) = U + Cos(C + _Pi(2) / S) * Ob
Y(3) = U + Sin(C + _Pi(2) / S) * Ob
X(4) = U + Cos(C + _Pi(2) / S) * Ol
Y(4) = U + Sin(C + _Pi(2) / S) * Ol
'source
sX(1) = (PW / S) * n
sY(1) = 0
sX(2) = sX(1)
sY(2) = _FontHeight
sX(3) = sX(1) + PW / S
sY(3) = 0
sX(4) = sX(3)
sY(4) = sY(2)
n = n + p2
If n > S Then Exit For
_MapTriangle (sX(1), sY(1))-(sX(2), sY(2))-(sX(3), sY(3)), VImg& To(X(1), Y(1))-(X(2), Y(2))-(X(3), Y(3)), R&
_MapTriangle (sX(2), sY(2))-(sX(3), sY(3))-(sX(4), sY(4)), VImg& To(X(2), Y(2))-(X(3), Y(3))-(X(4), Y(4)), R&
Next
RoundText& = R&
End Function
Very simply, this little program will count the lines in your code and output the results
to a file. You specify the code file and output file, then it scans and counts. It ignores
whitespace and comments, and gives a line count for each sub and function, as well as a total
for the whole program.
Not terribly useful, but gives more exact and detailed info than just copypasting your code
into something like pastebin.
Code: (Select All)
$noprefix
const true = -1
const false = 0
screen 12
cls , 15
color 0, 15
do
input "Code file: ", f1$
loop until fileexists(f1$) = true
do
input "Output file: ", f2$
loop until fileexists(f2$) = false
open f1$ for input as #1
line_count = 0
dim l$(line_count)
do until eof(1)
line_count = line_count + 1
redim preserve l$(line_count)
line input #1, l$(line_count)
loop
close #1
total_lines = 0
sub_count = 0
for n = 1 to line_count
if processed_left$(l$(n), 4) = "sub " or processed_left$(l$(n), 9) = "function " then sub_count = sub_count + 1
if processed_left$(l$(n), 1) = "'" or trim$(l$(n)) = "" then continue
total_lines = total_lines + 1
next n
dim sub_lines(sub_count)
dim sub_name$(sub_count)
sub_name$(0) = "[Main]"
current_sub = 0
for n = 1 to line_count
if processed_left$(l$(n), 1) = "'" or trim$(l$(n)) = "" then continue
if processed_left$(l$(n), 4) = "sub " or processed_left$(l$(n), 9) = "function " then
current_sub = current_sub + 1
sub_name$(current_sub) = before$(ltrim$(lcase$(l$(n))), "(")
end if
sub_lines(current_sub) = sub_lines(current_sub) + 1
next n
print
total_test = 0
open f2$ for output as #1
for n = 0 to sub_count
double_print sub_name$(n) + ":" + str$(sub_lines(n))
total_test = total_test + sub_lines(n)
next n
double_print ""
double_print "Total by count:" + str$(total_lines)
double_print "Total by sum:" + str$(total_test)
close #1
function processed_left$(t$, c)
processed_left$ = left$(ltrim$(lcase$(t$)), c)
end function
sub double_print(t$)
print t$
print #1, t$
end sub
function before$(t$, c$)
p = instr(t$, c$)
if p = false then p = len(t$) + 1
before$ = left$(t$, p - 1)
end function
This routine will apply a desaturation effect to a graphics surface. You pass the handle
and a number from 0 to 1, where 0 does not desaturate at all, and 1 turns everything to greyscale.
Code: (Select All)
sub desaturate(d~&, rate)
' Desaturate image surface d~& at a rate of 0 (no desaturation) to 1 (full greyscale)
preserve1& = source
preserve2& = dest
_source d~&
_dest d~&
for y = 0 to _width: for x = 0 to _height
h& = point(x, y)
r = _red(h&): g = _green(h&): b = _blue(h&)
grey = int((r + g + b) * 0.333)
r = r + ((grey - r) * rate)
g = g + ((grey - g) * rate)
b = b + ((grey - b) * rate)
pset(x, y), _rgb(r, g, b)
next x: next y
_source preserve1&
_dest preserve2&
end sub
Limitations:
- The desaturation is rather expensive, so you may have performance issues if you are doing this
many times per second. The way I've used this in my own project is to desaturate a background
that isn't going to change, then store the desaturated version for use in redrawing the screen,
so the desaturation effect only needs to be applied once.
- This is currently using _rgb(), which means it's not accounting for alpha values. I haven't
tested extensively how point() interacts with alpha, and I seem to remember having some issues
in the past, so I have no plans to update this to use _rgba() or _rgba32(). So if you use this
on a graphics surface, expect to lose any transparency.
Posted by: Petr - 02-24-2023, 07:22 PM - Forum: Petr
- Replies (5)
Hello. I wrote a function that you just push a music file, set the echo length and volume (in the range from 0 to 1) and the program will generate a new sound straight away. I used _SndNew for this.
Print "Program create new sound handle ("; news&; " )"
Print " This new handle is not full compatible:"
Print "_SndLen return: "; _SndLen(news&)
Sleep 2
Print "_SndGetPos return: "; _SndGetPos(news&)
Sleep 4
Print "Trying use _SndSetPos to begin this track..."
_SndSetPos news&, 0
Function MakeEcho& (InputSound As Long, SoundDelay As Single, EchoVolume As Single)
If SoundDelay < 0 Then Print "Error: EchoDelay must be higher than zero.": Exit Function
'EchoVolume in range 0 to 1!
Dim SourceSound As _MEM
SourceSound = _MemSound(InputSound&, 0)
Select Case GetBites(SourceSound)
Case 1, 2: Multiply = 4
Case 3: Multiply = 2
Case 4: Multiply = 1
End Select
Select Case SourceSound.TYPE
Case 260 ' 32-bit floating point
If SourceSound.ELEMENTSIZE = 4 Then
SndChannels = 1
ElseIf SourceSound.ELEMENTSIZE = 8 Then
SndChannels = 2
End If
Case 132 ' 32-bit integer
If SourceSound.ELEMENTSIZE = 4 Then
SndChannels = 1
ElseIf SourceSound.ELEMENTSIZE = 8 Then
SndChannels = 2
End If
Case 130: ' 16-bit integer
If SourceSound.ELEMENTSIZE = 2 Then
SndChannels = 1
ElseIf SourceSound.ELEMENTSIZE = 4 Then
SndChannels = 2
End If
Case 1153: ' 8-bit unsigned integer
If SourceSound.ELEMENTSIZE = 1 Then
SndChannels = 1
ElseIf SourceSound.ELEMENTSIZE = 2 Then
SndChannels = 2
End If
End Select
Dim As Long i, BB
Dim As Double sampL, sampL2, sampR, sampR2
Select Case SndChannels
Case 1
Select Case ME.TYPE
Case 260: _MemPut ME, ME.OFFSET + i, LeftOut As SINGLE ' 32-bit floating point
Case 132: _MemPut ME, ME.OFFSET + i, LeftOut * 2147483648 As LONG ' 32-bit integer
Case 130: _MemPut ME, ME.OFFSET + i, LeftOut * 32768 As INTEGER ' 16-bit integer
Case 1153: _MemPut ME, ME.OFFSET + i, 128 - (LeftOut * 128) As _UNSIGNED _BYTE ' 8-bit unsigned integer
End Select
Case 2
Select Case ME.TYPE
Case 260: _MemPut ME, ME.OFFSET + i, LeftOut As SINGLE: _MemPut ME, ME.OFFSET + i + ME.ELEMENTSIZE \ 2, RightOut As SINGLE ' 32-bit floating point
Case 132: _MemPut ME, ME.OFFSET + i, LeftOut * 2147483648 As LONG: _MemPut ME, ME.OFFSET + i + ME.ELEMENTSIZE \ 2, RightOut * 2147483648 As LONG ' 32-bit integer
Case 130: _MemPut ME, ME.OFFSET + i, LeftOut * 32768 As INTEGER: _MemPut ME, ME.OFFSET + i + ME.ELEMENTSIZE \ 2, RightOut * 32768 As INTEGER ' 16-bit integer
Case 1153: _MemPut ME, ME.OFFSET + i, 128 - (LeftOut * 128) As _UNSIGNED _BYTE: _MemPut ME, ME.OFFSET + i + ME.ELEMENTSIZE \ 2, 128 - (128 * RightOut) As _UNSIGNED _BYTE ' 8-bit unsigned integer
End Select
End Select
i = i + Multiply * 2
Loop
MakeEcho& = _SndCopy(MakeEch&)
_SndClose MakeEch&
If ME.SIZE Then _MemFree ME
If SourceSound.SIZE Then _MemFree SourceSound
End Function
Function GetBites (handle As _MEM)
Select Case handle.TYPE
Case 260: GetBites = 1 ' 32-bit floating point SINGLE
Case 132: GetBites = 2 ' 32-bit integer LONG
Case 130: GetBites = 3 ' 16-bit integer INTEGER
Case 1153: GetBites = 4 ' 8-bit unsigned integer
End Select
End Function
Sub PlaySound (handle As Long, rs As Long)
Dim SampleData As _MEM
Dim channels As _Unsigned _Byte
Dim sampL As Single, sampR As Single
Dim i As _Offset
channels = SndChannels(handle)
SampleData = _MemSound(handle, 0)
If SampleData.SIZE = 0 Then
Print "PlaySound: Sample data array is empty."
Exit Sub
End If
Do Until i = SampleData.SIZE - SampleData.ELEMENTSIZE
Select Case channels
Case 1
Select Case SampleData.TYPE
Case 260: sampL = _MemGet(SampleData, SampleData.OFFSET + i, Single) ' 32-bit floating point
Case 132: sampL = _MemGet(SampleData, SampleData.OFFSET + i, Long) / 2147483648 ' 32-bit integer
Case 130: sampL = _MemGet(SampleData, SampleData.OFFSET + i, Integer) / 32768 ' 16-bit integer
Case 1153: sampL = (_MemGet(SampleData, SampleData.OFFSET + i, _Unsigned _Byte) - 128) / 128 ' 8-bit unsigned integer
End Select
Case 2
Select Case SampleData.TYPE
Case 260: sampL = _MemGet(SampleData, SampleData.OFFSET + i, Single): sampR = _MemGet(SampleData, SampleData.OFFSET + i + SampleData.ELEMENTSIZE \ 2, Single) ' 32-bit floating point
Case 132: sampL = _MemGet(SampleData, SampleData.OFFSET + i, Long) / 2147483648: sampR = _MemGet(SampleData, SampleData.OFFSET + i + SampleData.ELEMENTSIZE \ 2, Long) / 2147483648 ' 32-bit integer
Case 130: sampL = _MemGet(SampleData, SampleData.OFFSET + i, Integer) / 32768: sampR = _MemGet(SampleData, SampleData.OFFSET + i + SampleData.ELEMENTSIZE \ 2, Integer) / 32768 ' 16-bit integer
Case 1153: sampL = (_MemGet(SampleData, SampleData.OFFSET + i, _Unsigned _Byte) - 128) / 128: sampR = (_MemGet(SampleData, SampleData.OFFSET + i + SampleData.ELEMENTSIZE \ 2, _Unsigned _Byte) - 128) / 128 ' 8-bit unsigned integer
End Select
End Select
If channels Mod 2 = 0 Then
_SndRaw sampL, sampR, rs 'stereo
Else
_SndRaw sampL, sampL, rs 'mono = left channel in both speakers
End If
i = i + SampleData.ELEMENTSIZE
Loop
_MemFree SampleData
End Sub
Function ConvertOffset&& (value As _Offset)
$Checking:Off
Dim m As _MEM 'Define a memblock
m = _Mem(value) 'Point it to use value
$If 64BIT Then
'On 64 bit OSes, an OFFSET is 8 bytes in size. We can put it directly into an Integer64
_MEMGET m, m.OFFSET, ConvertOffset&& 'Get the contents of the memblock and put the values there directly into ConvertOffset&&
$Else
'However, on 32 bit OSes, an OFFSET is only 4 bytes. We need to put it into a LONG variable first
_MemGet m, m.OFFSET, temp& 'Like this
ConvertOffset&& = temp& 'And then assign that long value to ConvertOffset&&
$End If
_MemFree m 'Free the memblock
$Checking:On
End Function
