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
I have written a small test using _loadimage and _FreeImage, and all goes well except when I try to clear the images (as I believe is necessary after using them).
I get an Illegal function call message at that point. Why is it so???
Code: (Select All)
Screen _NewImage(1500, 800, 32)
GetGridSize:
Locate 15, 66
Print "Choose a grid size, 1 to 4 (for 12, 20, 30 or 42 tiles)"
Play move$
Getsize:
_KeyClear: k = 0
While k < 1
_Limit 30
k = _KeyHit
Wend
Select Case k
Case Is = 49
numtiles = 12 ' numtiles is number of tiles for that size grid
numcols = 3 ' numcols is number of columns in the grid
Case Is = 50
numtiles = 20
numcols = 5
Case Is = 51
numtiles = 30
numcols = 5
Case Is = 52
numtiles = 42
numcols = 7
Case Else
GoTo Getsize
End Select
DisplayTiles: '
numrows = numtiles / numcols ' set number of rows needed for the numtiles and numcols
Dim tiles(numtiles) As Long
For a = 1 To numtiles
tiles(a) = _LoadImage("RecPics/test.jpg", 32) ' set tiles array with numpics copies of test.jpg
Next
For a = 1 To numtiles / 2
_PutImage (60 * a, 60), tiles(a) ' display first half of tiles array
Next
For a = numtiles / 2 + 1 To numtiles
_PutImage (60 * (a - numtiles / 2), 120), tiles(a) ' display second half of tiles array
Next
Sleep 2
For a = 1 To numtiles
_FreeImage (a) ' free all of the images from memory
Next
Print "I get an error message here: Illegal function call line 45 (the _FreeImage line)"
Sleep
' Set up the camera position
cx = 0 ' Camera X coordinate
cy = 0 ' Camera Y coordinate
cz = -10 ' Camera Z coordinate
' Set up the projection parameters
near_plane = 1 ' Distance to near plane
far_plane = 100 ' Distance to far plane
fov = 90 ' Field of view in degrees
' Calculate the projection matrix
f = 1 / TAN(fov / 2 * PI / 180) ' Calculate focal length
a = f * 640 / 480 ' Calculate aspect ratio
proj_matrix(1, 1) = a: proj_matrix(2, 2) = f
proj_matrix(3, 3) = far_plane / (far_plane - near_plane)
proj_matrix(3, 4) = -far_plane * near_plane / (far_plane - near_plane)
proj_matrix(4, 3) = 1
' Apply the projection matrix to the 3D coordinates and convert to 2D screen coordinates
FOR i = 1 TO 8
' Apply the projection matrix
x_proj = x(i) * proj_matrix(1, 1) + y(i) * proj_matrix(2, 1) + z(i) * proj_matrix(3, 1) + proj_matrix(4, 1)
y_proj = x(i) * proj_matrix(1, 2) + y(i) * proj_matrix(2, 2) + z(i) * proj_matrix(3, 2) + proj_matrix(4, 2)
w_proj = x(i) * proj_matrix(1, 4) + y(i) * proj_matrix(2, 4) + z(i) * proj_matrix(3, 4) + proj_matrix(4, 4)
' Convert to 2D screen coordinates
x_screen = 320 + x_proj / w_proj * 320 ' Center the X coordinate and scale to screen size
y_screen = 240 - y_proj / w_proj * 240 ' Center the Y coordinate and flip the Y axis
' Draw a point on the screen at the converted coordinates
PSET (x_screen, y_screen), 15
NEXT i
' Wait for the user to press a key
DO
SLEEP
LOOP UNTIL INKEY$ <> ""
Posted by: Petr - 02-20-2023, 07:05 PM - Forum: Petr
- Replies (4)
Hi team.
How it goes? Here I've modified my audio save routine quite a bit, cheekily borrowing a few things from @a740g and after some trouble it seems to work as expected. It's the first version, it can only do stereo, it doesn't even have subsampling. I will add all this gradually. Just one question: 32 bit WAV sound. Is the type SINGLE used in WAV containers? Windows media player didn't really want to understand it and played like if you ride a bike on a road paved with cobblestones and sing along... (so I converted it to the LONG type and it plays cleanly). Does anyone know?
Code: (Select All)
'SndStereoSave by Petr for PHOENIX 3.5.0
Dim Song As Long
Song = _SndOpen("vi.mp3") ' Replace file name with your sound file
Dim As _MEM N
N = _MemSound(Song, 0)
'convert MP3 as WAV!
If SndChannels(Song) < 2 Then Print "Sorry, this is just for stereo (first version).": End
SndStereoSave N, "Test.wav" 'tested on WAV 16bit stereo, XM file (stereo), MP3 (stereo), all pass
'create the same music as in Song, but so that it plays backwards. Lets try _SndNew!
'the same its for own music created in QB64
Select Case SNDGetBites(N)
Case 1, 2: bites& = 32
Case 3: bites& = 16
Case 4: bites& = 8
End Select
Dim Done As _Offset, PlusStep As _Offset, Value As Single, NewMusic As _MEM
NewMusic = _MemSound(NM&, 0)
Done = N.SIZE - N.ELEMENTSIZE
Do Until Done = 0
_MemGet N, N.OFFSET + Done, Value
_MemPut NewMusic, NewMusic.OFFSET + PlusStep, Value
Done = Done - 4
PlusStep = PlusStep + 4
Loop
SndStereoSave NewMusic, "Backward.wav"
_MemFree N
_MemFree NewMusic
End
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
Sub SndStereoSave (arr As _MEM, file As String)
Type head16
chunk As String * 4 ' 4 bytes (RIFF)
size As _Unsigned Long ' 4 bytes (file size) velikost souboru
fomat As String * 4 ' 4 bytes (WAVE)
sub1 As String * 4 ' 4 bytes (fmt )
subchunksize As Long ' 4 bytes (lo / hi), $00000010 for PCM audio
format As Integer ' 2 bytes (0001 = standard PCM, 0101 = IBM mu-law, 0102 = IBM a-law, 0103 = IBM AVC ADPCM)
channels As Integer ' 2 bytes (1 = mono, 2 = stereo)
rate As Long ' 4 bytes (sample rate, standard is 44100)
ByteRate As Long ' 4 bytes (= sample rate * number of channels * (bits per channel /8))
Block As Integer ' 2 bytes (block align = number of channels * bits per sample /8)
Bits As Integer ' 2 bytes (bits per sample. 8 = 8, 16 = 16)
subchunk2 As String * 4 ' 4 bytes ("data") contains begin audio samples
lenght As _Unsigned Long ' 4 bytes Data block size
End Type ' 44 bytes total
H16.subchunk2 = "data"
H16.lenght = ConvertOffset(arr.SIZE)
If _FileExists(file$) Then Kill file$
Audio$ = Space$(ConvertOffset(arr.SIZE))
If SNDGetBites(arr) = 1 Then 'convert values from SINGLE to LONG values, because Marena from the cowshed said it should be like that :) /Czech Joke/
Dim A As _MEM, VS As Single, VL As Long
A = _MemNew(arr.SIZE)
Do Until done& = arr.SIZE
VS = _MemGet(arr, arr.OFFSET + done&, Single)
VL& = 2147483648 * VS
_MemPut A, A.OFFSET + done&, VL&
done& = done& + 4
Loop
_MemGet A, A.OFFSET, Audio$
_MemFree A
Else
_MemGet arr, arr.OFFSET, Audio$
End If
Open file$ For Binary As #ch
Put #ch, , H16
Put #ch, , Audio$
Audio$ = ""
Close ch
End Sub
Function SNDGetBites (handle As _MEM)
Select Case handle.TYPE
Case 260: SNDGetBites = 1 ' 32-bit floating point SINGLE
Case 132: SNDGetBites = 2 ' 32-bit integer LONG
Case 130: SNDGetBites = 3 ' 16-bit integer INTEGER
Case 1153: SNDGetBites = 4 ' 8-bit unsigned integer
End Select
End Function
Function SndChannels~%% (handle As Long) 'work by a740g
Dim SampleData As _MEM
' Check if the sound is valid
SampleData = _MemSound(handle, 0)
If SampleData.SIZE = 0 Then
Print "SndChannels: MemSound return ZERO for audio data size!"
Exit Function
End If
' Check the data type and then decide if the sound is stereo or mono
Select Case SampleData.TYPE
Case 260 ' 32-bit floating point
If SampleData.ELEMENTSIZE = 4 Then
SndChannels = 1
ElseIf SampleData.ELEMENTSIZE = 8 Then
SndChannels = 2
End If
Case 132 ' 32-bit integer
If SampleData.ELEMENTSIZE = 4 Then
SndChannels = 1
ElseIf SampleData.ELEMENTSIZE = 8 Then
SndChannels = 2
End If
Case 130: ' 16-bit integer
If SampleData.ELEMENTSIZE = 2 Then
SndChannels = 1
ElseIf SampleData.ELEMENTSIZE = 4 Then
SndChannels = 2
End If
Case 1153: ' 8-bit unsigned integer
If SampleData.ELEMENTSIZE = 1 Then
SndChannels = 1
ElseIf SampleData.ELEMENTSIZE = 2 Then
SndChannels = 2
End If
End Select
_MemFree SampleData
End Function
It is good! I was so focused on functionality that I forgot to add labels to the program
So - on line 4, enter a valid name for your music file for Phoenix and then run it. The program is stingy with words, it doesn't write anything on your screen, it keeps secrets.
Your music file will be saved in WAV format to the file test.wav and backward.wav, then play them to check the functionality. Backward.wav is saved vice versa, plays from the end to begin.
![[Image: screenshot-todo-half.png]](https://i.ibb.co/ZzKwRx6/screenshot-todo-half.png)
![[Image: 122.png]](https://i.ibb.co/4th2Z1Q/122.png)
