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.
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
snd2(original).L = snd(copy).L
snd2(original).R = snd(copy).R
Loop
Print "Saving mix as scratch.wav"
'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
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)
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