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.
' Content of the HTTP response is returned. The statusCode is also assigned.
Function Download$ (url As String, statusCode As Long)
h& = _OpenClient("HTTP:" + url)
statusCode = _StatusCode(h&)
While Not EOF(h&)
_Limit 60
Get #h&, , s$
content$ = content$ + s$
Wend
Close #h&
Download$ = content$
End Function
I failed to come up with a quick example for the new third parameter of _LOADIMAGE(), didn't pay attention that the string is supposed to be just like one that could be loaded from JPEG, PNG, PCX etc. graphics file format. Enjoy this, it's my first successful experiment ever with _MEMCOPY. A good improvement is to change the palette, either as greyscale or along a cool gradient.
Code: (Select All)
'by mnrvovrfc 20-Feb-2023
DIM a$, b AS STRING * 256000
DIM AS INTEGER v, i, j
DIM AS LONG ascr, ctop, cbot
DIM amem AS _MEM, bmem AS _MEM
ctop = 1
cbot = 640 * 399 + 1
a$ = SPACE$(640)
b = SPACE$(256000)
FOR j = 1 TO 200
FOR i = 1 TO 640
IF i MOD 2 = 0 THEN
MID$(a$, i, 1) = CHR$(150 + v + (i MOD 56))
ELSE
MID$(a$, i, 1) = CHR$(v + (i MOD 16))
END IF
NEXT
MID$(b, ctop, 640) = a$
MID$(b, cbot, 640) = a$
ctop = ctop + 640
cbot = cbot - 640
v = v + 1
IF v >= 50 THEN v = 0
NEXT
#286 - Added support for opening image from memory using _LOADIMAGE() - @a740g, @mkilgore
_LOADIMAGE() has a new optional requirements$ argument, similar to the string argument to _SNDOPEN():
_LOADIMAGE(fileName$[, [mode&][, requirements$]])
Providing "memory" in the requirements will cause _LOADIMAGE() to treat the contents of the fileName$ argument as an image file itself, rather than attempting to open a file.
Bug Fixes
#287, #296 - Fixed building QB64-PE on MacOS High Sierra - @mkilgore
Hello. I found a MemSound bug (see attached test program) that makes Phoenix 3.5.0 MemSound unable to be used properly and causing my programs to crash, unlike QB64 2.02. The attached program exactly shows the occurrence of the error.
Code: (Select All)
$NoPrefix
s = SndOpen("0.mp3")
Dim As MEM l, r
l = MemSound(s, 1)
r = MemSound(s, 2)
Print "MemSound bug"
Print
Print "Value returned for left audio channel:"; l.SIZE
Print "Value returned for right audio channel:"; r.SIZE
chan& = SndLen(s) * 2 * SndRate
If l.SIZE = r.SIZE And r.SIZE = chan& Then Print "All ok!": End
Print "the size of the ONE audio track channel, that is expected:"; chan&
Print "Value returned with SndOpen:"; s;
If s > 0 Then Print "[correct audio file]" Else Print "[unsupported audio file]"
Print
Print "press key for try play this file"
Sleep
SndPlay s
If SndPlaying(s) Then Print "Both channels playing, bug is not in SndOpen." Else Print "Bug is in SndOpen"
Posted by: Petr - 02-19-2023, 10:50 AM - Forum: Petr
- Replies (4)
Note, this source code runs in QB64 2.02 and older. Phoenix version comming soon.
What is scratching? It's an effect where the DJ slows down or speeds up the turntable while the sound is playing.
This program tries to simulate this at random times during playback.
Before run it, please write correct music file name in source code to line 13.
Code: (Select All)
_Title "Petr's scratching"
'What is scratching? It's an effect where the DJ slows down or speeds up the turntable while the sound is playing.
'This program tries to simulate this at random times during playback.
misto = 44100 * 5 '5 seconds after music start playing start effect
mistoE = misto + 88200 'effect ends 2 seconds after effect start
rychlost = 88200
Dim As _MEM L, R, L2, R2
Dim As Integer LS, RS
file$ = "al.mp3"
Print "Opening sound file "; file$
f = _SndOpen(file$)
L = _MemSound(f, 1)
R = _MemSound(f, 2)
Type SND
L As Integer
R As Integer
End Type
Dim snd(_SndRate * _SndLen(f)) As SND
Print "Creating standard array"
Do Until Done& = L.SIZE
snd(i).L = _MemGet(L, L.OFFSET + Done&, Integer)
snd(i).R = _MemGet(R, R.OFFSET + Done&, Integer)
i = i + 1
Done& = Done& + 2
Loop
i = i - 2
Dim snd2(3 * UBound(snd)) As SND 'this time i do not calculate array size - because this demo use random output lenght
zacatek = misto
konec = mistoE
psi2 = _Pi(1) / (zacatek - konec)
Dim As Long misto, mistoE
copy = 0
Print "Creating pseudo mix"
Randomize Timer
Do Until copy >= UBound(snd) - 2
If original > misto And original < mistoE Then
k2 = k2 + psi2
newi = Sin(k2) * 44100
copy = ocopy + newi
original = original + Abs(Sin(k2))
Else
ocopy = copy
copy = copy + 1
original = Int(original + 1)
End If
If original > mistoE + 44100 Then 'pause between two mix hits (44100 = 1 sec)
misto = original + 44100 * Rnd 'effect start in samples (44100 x time)
mistoE = misto + 44100 * 2 * Rnd + 500 'effect end in samples
zacatek = misto
konec = mistoE
psi2 = _Pi(1 + Rnd) / (zacatek - konec)
If psi2 = 0 Then psi2 = .01
If misto > UBound(snd2) Or misto2 > UBound(snd2) Then misto = 0: mistoE = 0
End If
If original > UBound(snd2) Then Print "Snd2 overlow": Exit Do
If copy > UBound(snd) Then Print "Snd overlow"; copy; krok: Exit Do
'For test = 0 To original
'_SndRaw snd2(test).L / 32768, snd2(test).R / 32768
'Next
Dim SNDSAVE As _MEM
SNDSAVE = _Mem(snd2())
SAVESOUND16S SNDSAVE, "scratch.wav"
Print "Playing..."
_SndPlayFile "scratch.wav"
_Delay 1
_MemFree SNDSAVE
Kill "scratch.wav"
End
Sub SAVESOUND16S (arr As _MEM, file As String)
Type head16
chunk As String * 4 ' 4 bytes (RIFF)
size As Long ' 4 bytes (file size)
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 Long ' 4 bytes Data block size
End Type ' 44 bytes total
Dim H16 As head16
ch = FreeFile
If _FileExists(file$) Then Kill file$
Audio$ = Space$(ConvertOffset&&(arr.SIZE))
_MemGet arr, arr.OFFSET, Audio$
Open file$ For Binary As #ch
Put #ch, , H16
Put #ch, , Audio$
Audio$ = ""
Close ch
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
Posted by: Petr - 02-19-2023, 09:58 AM - Forum: Petr
- Replies (2)
NOTE! This program is created to QB64 2.02 (and older, Phoenix version comming soon!)
Compile this program in its own folder (maybe call it echo test, it doesn't matter) and then copy some music files into that folder. The program is built on an older version of QB64, so it only supports MP3, OGG and WAV formats (you can add the other formats there on line 36 in the source code, but it is not tested with it. The program will play music files in the folder with an echo effect after running. The attached direntry.h file is needed for the function.
Code: (Select All)
'Program create new WAV soundtrack + add echo
_Title "Petr's echo player"
EchoLenght = 0.12 '0.12 seconds is echo duration
OverSampling = 10 'number of echoes sample passes
Echo& = _SndRate * EchoLenght
'to create an echo effect you need to repeat a couple of sound samples - it's the same as playing the same song twice in quick succession,
'the sound samples are also mixed. This is the principle of the function of this program.
'the number of samples to be repeated indicates the length of the echo. For 25 milliseconds, that's 25 * 441 samples.
Do Until Echo& Mod 2 = 0
Echo& = Echo& + 1
Loop
Dim Left As _MEM, Right As _MEM, NewSound As _MEM, Audio As Integer, Audio2 As Integer, Audio3 As Integer, Audio4 As Integer
ReDim PlayableFiles(0) As String 'for music files list
'INPUT "Insert audio file name:"; a1$
Declare CustomType Library ".\direntry" 'need file direntry.h, available in SMcNeill's libraries
Function load_dir& (s As String)
Function has_next_entry& ()
Sub close_dir ()
Sub get_next_entry (s As String, flags As Long, file_size As Long)
End Declare
ReDim Dir(0) As String, File(0) As String
GetFileList _CWD$, Dir(), File() 'load files in current directory
For s = LBound(file) To UBound(file)
Select Case UCase$(Right$(File(s), 3))
Case "MP3", "OGG", "WAV" 'available music formats under QB64 2.02
PlayableFiles(i) = File(s)
i = i + 1
ReDim _Preserve PlayableFiles(i) As String
End Select
Next
Print "Files to play: "; i
For playit = 0 To i - 1 'play all music files (MP3, OGG, WAV) in current directory (this file list is created using direntry.h)
a1$ = PlayableFiles(playit)
Print "Opening file "; playit + 1; "/"; i; " - "; PlayableFiles(playit)
If a Then _SndClose a
a = _SndOpen(a1$)
If a Then Print "Audio file opened" Else Print "Audio file "; a1$; " opening error.": End
LENa = _Ceil(_SndLen(a) + EchoLenght)
Print "Audio file lenght:"; LENa; "[sec]"
NewTrackTime = LENa
Print "New sound created. Saving as Tracks-mix4.wav..."
SAVESOUND16S NewSound, "Tracks-mix4.wav"
Print "Sound saved, erasing RAM..."
_MemFree Left
_MemFree Right
_MemFree NewSound
Print "Playing mixed sound"
snd = _SndOpen("tracks-mix4.wav")
_SndPlay snd
Do Until _SndPlaying(snd) = 0
Locate 12
Print "Time: "; Int(_SndGetPos(snd)); "[sec] "
Loop
Cls
_SndClose snd
Kill "tracks-mix4.wav"
Next
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 SAVESOUND16S (arr As _MEM, file As String)
Type head16
chunk As String * 4 ' 4 bytes (RIFF)
size As Long ' 4 bytes (file size)
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 Long ' 4 bytes Data block size
End Type ' 44 bytes total
Dim H16 As head16
ch = FreeFile
Open file$ For Binary As #ch
Put #ch, , H16
Put #ch, , Audio$
Audio$ = ""
Close ch
End Sub
Sub GetFileList (SearchDirectory As String, DirList() As String, FileList() As String)
Const IS_DIR = 1
Const IS_FILE = 2
Dim flags As Long, file_size As Long
If load_dir(SearchDirectory) Then
Do
length = has_next_entry
If length > -1 Then
nam$ = Space$(length)
get_next_entry nam$, flags, file_size
If (flags And IS_DIR) Or _DirExists(SearchDirectory + nam$) Then
DirCount = DirCount + 1
If DirCount > UBound(DirList) Then ReDim _Preserve DirList(UBound(DirList) + 100)
DirList(DirCount) = nam$
ElseIf (flags And IS_FILE) Or _FileExists(SearchDirectory + nam$) Then
FileCount = FileCount + 1
If FileCount > UBound(filelist) Then ReDim _Preserve FileList(UBound(filelist) + 100)
FileList(FileCount) = nam$
End If
End If
Loop Until length = -1
close_dir
Else
End If
ReDim _Preserve DirList(DirCount)
ReDim _Preserve FileList(FileCount)
End Sub
Hello. I went through the forum and found some questions about saving sound and also questions about whether it is possible to create and save sound in QB64. The answer to both is yes. The attached program is from January 5, 2021, when I was actively involved. Then the forum was destroyed and I vowed not to spend time on something that would just disappear overnight. I'm here today after a long time (I'm using QB64 2.02) and I see that there might be interest in this, so I'm posting it here. My SaveSound16S will be useful, it saves your sound in stereo WAV file format and I used it for testing because SNDRAW had problems with stereo (I don't know how it is with this command now).
This program open your music file, then create WAV file from it named as TestEff3.wav (contains stereo switching) and then play it using SNDPLAYFILE statement.
Code: (Select All)
DIM left AS _MEM
DIM Right AS _MEM
DIM AudioL AS INTEGER
DIM AudioR AS INTEGER
DIM L AS INTEGER
DIM R AS INTEGER
DIM NewSound AS _MEM
INPUT "Insert music STEREO file name"; snd$
IF _FILEEXISTS(snd$) THEN
snd = _SNDOPEN(snd$)
IF snd > 0 THEN
left = _MEMSOUND(snd, 1)
Right = _MEMSOUND(snd, 2)
IF Right.SIZE > 0 THEN
NewSound = _MEMNEW(left.SIZE * 2)
DO UNTIL s& = left.SIZE
_MEMGET left, left.OFFSET + s&, AudioL
_MEMGET Right, Right.OFFSET + s&, AudioR
L = AudioL * ABS(SIN(sinus)) ' SINUS is LEFT/RIGHT CHANNEL SWITCH :)
R = AudioR * ABS(COS(sinus))
_MEMPUT NewSound, NewSound.OFFSET + t&, L
_MEMPUT NewSound, NewSound.OFFSET + t& + 2, R
sinus = sinus + .00001
s& = s& + 2
t& = t& + 4
LOOP
ELSE
PRINT "This sound file is not stereo!"
END
END IF
ELSE
PRINT "File exists, bud this music format is not supported."
END
END IF
ELSE
PRINT "File "; snd$; " not found."
END
END IF
SAVESOUND16S NewSound, "TestEff3.wav"
_SNDPLAYFILE "TestEff3.wav"
END
SUB SAVESOUND16S (arr AS _MEM, file AS STRING)
TYPE head16
chunk AS STRING * 4 ' 4 bytes (RIFF)
size AS LONG ' 4 bytes (file size)
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 LONG ' 4 bytes Data block size
END TYPE ' 44 bytes total
DIM H16 AS head16
ch = FREEFILE
H16.chunk = "RIFF"
H16.size = 44 + ConvertOffset&&(arr.SIZE) / _SNDRATE / 4 'two channels, it create 16 bit, stereo wav file, one sample use 2 bytes to one channel
H16.fomat = "WAVE"
H16.sub1 = "fmt "
H16.subchunksize = 16
H16.format = 1
H16.channels = 2
H16.rate = 44100
H16.ByteRate = 44100 * 2 * 16 / 8
H16.Block = 4
H16.Bits = 16
H16.subchunk2 = "data"
H16.lenght = ConvertOffset&&(arr.SIZE)
' $END IF
IF _FILEEXISTS(file$) THEN KILL file$
Audio$ = SPACE$(ConvertOffset&&(arr.SIZE))
_MEMGET arr, arr.OFFSET, Audio$
OPEN file$ FOR BINARY AS #ch
PUT #ch, , H16
PUT #ch, , Audio$
Audio$ = ""
CLOSE ch
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
and to querstion 2 - is possible creating and saving sound using QB64? YES:
Code: (Select All)
'this program is from SNDRAW help, create sound using QB64, modifie so, it also save this sound.
t = 0
tmp$ = "Sample = ##.##### Time = ##.#####"
Locate 1, 60: Print "Rate:"; _SndRate
'------ modification -------
Dim SNDREC(44100 * 3.1) As Integer 'sound duration is 3 seconds, use 44100 samples/sec
'------ modification -------
Do
'queue some sound
Do While _SndRawLen < 0.1 'you may wish to adjust this
sample = Sin(t * 440 * Atn(1) * 8) '440Hz sine wave (t * 440 * 2Ď€)
sample = sample * Exp(-t * 3) 'fade out eliminates clicks after sound
_SndRaw sample
t = t + 1 / _SndRate 'sound card sample frequency determines time
Loop
'do other stuff, but it may interrupt sound
Locate 1, 1: Print Using tmp$; sample; t
Loop While t < 3.0 'play for 3 seconds
Do While _SndRawLen > 0 'Finish any left over queued sound!
Loop
Print rec
'------ modification -------
Dim L As _MEM
Dim LR As _MEM
Dim REC As Integer
L = _Mem(SNDREC())
'because created sound is MONO but we recording it as stereo, create here pseudo stereo memory array:
LR = _MemNew(L.SIZE * 2)
done = 0
Do Until done = L.SIZE
_MemGet L, L.OFFSET + done, REC
_MemPut LR, LR.OFFSET + RECINDEX, REC 'left
_MemPut LR, LR.OFFSET + RECINDEX + 2, REC 'right
done = done + 2 'switch by 2 bytes in L MEM array
RECINDEX = RECINDEX + 4 'switch by 4 bytes in LR MEM array
Loop
_MemFree L
Print "Saving sound as ding.wav..."
SAVESOUND16S LR, "ding.wav"
_MemFree LR
Print "Playing created file ding.wav..."
_SndPlayFile "ding.wav"
End
Sub SAVESOUND16S (arr As _MEM, file As String)
Type head16
chunk As String * 4 ' 4 bytes (RIFF)
size As Long ' 4 bytes (file size)
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 Long ' 4 bytes Data block size
End Type ' 44 bytes total
Dim H16 As head16
ch = FreeFile
H16.chunk = "RIFF"
H16.size = 44 + ConvertOffset&&(arr.SIZE) / _SndRate / 4 'two channels, it create 16 bit, stereo wav file, one sample use 2 bytes to one channel
H16.fomat = "WAVE"
H16.sub1 = "fmt "
H16.subchunksize = 16
H16.format = 1
H16.channels = 2
H16.rate = 44100
H16.ByteRate = 44100 * 2 * 16 / 8
H16.Block = 4
H16.Bits = 16
H16.subchunk2 = "data"
H16.lenght = ConvertOffset&&(arr.SIZE)
' $END IF
If _FileExists(file$) Then Kill file$
Audio$ = Space$(ConvertOffset&&(arr.SIZE))
_MemGet arr, arr.OFFSET, Audio$
Open file$ For Binary As #ch
Put #ch, , H16
Put #ch, , Audio$
Audio$ = ""
Close ch
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
Program create sound (used for this is program from QB64 SNDRAW help) and then easily modified for saving this sound in WAV format.
For some time now I've been trying do something like this recursively:
Code: (Select All)
_Title "Checkered Checkers, press any for another screen..." ' b+ 2023-02-17
Screen _NewImage(641, 641, 12)
_ScreenMove 300, 60
d = 8: sq = 640 / d: sq8 = sq / d: dm1 = d - 1
Dim arr(d, d)
While _KeyDown(27) = 0
For j = 0 To dm1
For i = 0 To dm1
If Rnd < .5 Then arr(i, j) = 1 Else arr(i, j) = 0
Next
Next
For y = 0 To dm1
For x = 0 To dm1
If arr(x, y) Then
For yy = 0 To dm1
For xx = 0 To dm1
If arr(xx, yy) Then
Line (x * sq + xx * sq8, y * sq + yy * sq8)-(x * sq + xx * sq8 + sq8 - 1, y * sq + yy * sq8 + sq8 - 1), , BF
Else
Line (x * sq + xx * sq8, y * sq + yy * sq8)-(x * sq + xx * sq8 + sq8 - 1, y * sq + yy * sq8 + sq8 - 1), , B
End If
Next
Next
End If
Line (x * sq, y * sq - 1)-(x * sq + sq, y * sq + sq - 1), , B
Next
Next
Sleep
Cls
Wend
So it wouldn't take more code lines to do deeper levels. With recursion you could just keep going deeper as long as the side length of a checker was >=1 pixel.
