02-21-2023, 09:27 PM
So here is the QB64 version for Phoenix 3.5.0. I used the backward compatibility routine again but also had to use subsampling because I just didn't have enough memory (I have 3.5 GB in my laptop), QB64 2.02 use 44100 samples, Phoenix 192000.... I also made an adjustment there so that the effect runs throughout the song's entire decade, because the length and time are randomly generated, so whenever the array size runs out, another ten percent is allocated to the current size.
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.
Dim As Long misto, mistoE, zacatek, konec
misto = 44100 * 5 '5 seconds after music start playing start effect
mistoE = misto + 44100 * 2 'effect ends 2 seconds after effect start
Dim As _MEM L, R, L2, R2, O
Dim As Integer LS, RS
file$ = "02.mp3" '<------------------ INSERT CORRECT MUSIC FILE NAME HERE!
Print "Opening sound file "; file$
f = _SndOpen(file$)
O = _MemSound(f, 0)
BackCompatible O, L, R
'L = _MemSound(f, 1)
'R = _MemSound(f, 2)
_MemFree O
Type SND
L As Integer
R As Integer
End Type
Print "Creating standard array"
Dim i As Long
ratio! = CInt(_SndRate / 44100) * 2 'downsampling to 44100 samples
Dim snd(ConvertOffset(L.SIZE) \ ratio!) As SND
Do Until Done& >= L.SIZE - ratio! * 4
snd(i).L = _MemGet(L, L.OFFSET + Done&, Integer)
snd(i).R = _MemGet(R, R.OFFSET + Done&, Integer)
i = i + 1
Done& = Done& + ratio!
Loop
'Print i, UBound(snd)
'Sleep
i = i - 2
ReDim snd2(UBound(snd) * 1.3) As SND 'this time i do not calculate array size - because this demo use random output lenght
Dim As _Float original, psi2
zacatek = misto
konec = mistoE
psi2 = _Pi(1) / (zacatek - konec)
Dim As Long copy, ocopy, newi
copy = 0
Print "Creating pseudo mix"
Randomize Timer
Do Until copy = UBound(snd)
If original > misto And original < mistoE Then
k2 = k2 + psi2
newi = 1 + (Sin(k2) * 44100) \ 3
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 overflow - adding 10% size...": ReDim _Preserve snd2(UBound(snd2) * 1.1) As SND ' Exit Do
If copy > UBound(snd) Then Print "Snd overflow"; copy; krok: Exit Do
snd2(original).L = snd(copy).L
snd2(original).R = snd(copy).R
Loop
Print "Saving mix as scratch.wav"
Dim SNDSAVE As _MEM
SNDSAVE = _Mem(snd2())
SAVESOUND16S SNDSAVE, "scratch.wav" 'just for MEM, not use for _SNDNEW directly!
Print "Playing..."
_SndPlayFile "scratch.wav"
_Delay 1
_MemFree SNDSAVE
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) ' / 44100 / 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)
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
Sub BackCompatible (Snd As _MEM, Left As _MEM, Right As _MEM)
If Snd.SIZE = 0 Then
Print "Original sample data array is empty."
Exit Sub
End If
Dim SndChannels As Long, ChannelLenght As _Offset
Select Case Snd.TYPE
Case 260 ' 32-bit floating point
ChannelLenght = Snd.SIZE \ 4 'return size in INTEGERS
If Snd.ELEMENTSIZE = 4 Then
SndChannels = 1
ElseIf Snd.ELEMENTSIZE = 8 Then
SndChannels = 2
End If
Case 132 ' 32-bit integer
ChannelLenght = Snd.SIZE \ 4 'return size in INTEGERS
If Snd.ELEMENTSIZE = 4 Then
SndChannels = 1
ElseIf Snd.ELEMENTSIZE = 8 Then
SndChannels = 2
End If
Case 130: ' 16-bit integer
ChannelLenght = Snd.SIZE \ 2 'return size in INTEGERS
If Snd.ELEMENTSIZE = 2 Then
SndChannels = 1
ElseIf Snd.ELEMENTSIZE = 4 Then
SndChannels = 2
End If
Case 1153: ' 8-bit unsigned integer
ChannelLenght = Snd.SIZE 'return size in INTEGERS
If Snd.ELEMENTSIZE = 1 Then
SndChannels = 1
ElseIf Snd.ELEMENTSIZE = 2 Then
SndChannels = 2
End If
End Select
Left = _MemNew(ChannelLenght)
Right = _MemNew(ChannelLenght)
Dim As Integer LI, RI
Dim As Long Oi
Dim i As _Offset
Do Until i = Snd.SIZE - Snd.ELEMENTSIZE 'Read Phoenix MEMSOUND and convert it as back-compatible as QB64 2.02 MEMSOUND's output.
Select Case SndChannels
Case 1
Select Case Snd.TYPE
Case 260: sampL = _MemGet(Snd, Snd.OFFSET + i, Single) ' 32-bit floating point
Case 132: sampL = _MemGet(Snd, Snd.OFFSET + i, Long) / 2147483648 ' 32-bit integer
Case 130: sampL = _MemGet(Snd, Snd.OFFSET + i, Integer) / 32768 ' 16-bit integer
Case 1153: sampL = (_MemGet(Snd, Snd.OFFSET + i, _Unsigned _Byte) - 128) / 128 ' 8-bit unsigned integer
End Select
Case 2
Select Case Snd.TYPE
Case 260: sampL = _MemGet(Snd, Snd.OFFSET + i, Single): sampR = _MemGet(Snd, Snd.OFFSET + i + Snd.ELEMENTSIZE \ 2, Single) ' 32-bit floating point
Case 132: sampL = _MemGet(Snd, Snd.OFFSET + i, Long) / 2147483648: sampR = _MemGet(Snd, Snd.OFFSET + i + Snd.ELEMENTSIZE \ 2, Long) / 2147483648 ' 32-bit integer
Case 130: sampL = _MemGet(Snd, Snd.OFFSET + i, Integer) / 32768: sampR = _MemGet(Snd, Snd.OFFSET + i + Snd.ELEMENTSIZE \ 2, Integer) / 32768 ' 16-bit integer
Case 1153: sampL = (_MemGet(Snd, Snd.OFFSET + i, _Unsigned _Byte) - 128) / 128: sampR = (_MemGet(Snd, Snd.OFFSET + i + Snd.ELEMENTSIZE \ 2, _Unsigned _Byte) - 128) / 128 ' 8-bit unsigned integer
End Select
End Select
If SndChannels Mod 2 = 0 Then
LI = sampL * 32767
RI = sampR * 32767
_MemPut Left, Left.OFFSET + Oi, LI
_MemPut Right, Right.OFFSET + Oi, RI
Else
LI = sampL * 32767
_MemPut Left, Left.OFFSET + Oi, LI
_MemPut Right, Right.OFFSET + Oi, LI
End If
i = i + Snd.ELEMENTSIZE
Oi = Oi + 2
Loop
End Sub