editor/bass-sys/win/bass24/vb/Synth/modSynth.bas
2021-01-07 21:37:50 -06:00

58 lines
2.1 KiB
QBasic

Attribute VB_Name = "modSynth"
'//////////////////////////////////////////////////////////////////////////////
' modSynth.bas - Copyright (c) 2006-2007 (: JOBnik! :) [Arthur Aminov, ISRAEL]
' [http://www.jobnik.org]
' [ jobnik@jobnik.org ]
'
' Other source: frmSynth.frm
'
' BASS Simple Synth
' Originally translated from - synth.c - Example of Ian Luck
'//////////////////////////////////////////////////////////////////////////////
Option Explicit
Public info As BASS_INFO
Public Const PI = 3.14159265358979
Public Const TABLESIZE = 2048
Public sinetable(TABLESIZE) As Long ' sine table
Public Const KEYS_ = 20
Public keys As Variant
Public Const MAXVOL = 4000 ' higher value = longer fadeout
Public vol(KEYS_) As Long, pos(KEYS_) As Long ' keys' volume & pos
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As Long)
' stream writer
Public Function WriteStream(ByVal handle As Long, ByVal buffer As Long, ByVal length As Long, ByVal user As Long) As Long
Dim n As Long, s As Long, c As Long
Dim f As Single
Dim buf() As Integer
ReDim buf(length) As Integer
For n = 0 To KEYS_ - 1
If (vol(n)) Then
f = (2 ^ ((n + 3) / 12#)) * TABLESIZE * 440# / info.freq
c = 0
Do While (c < length / 4 And vol(n))
s = sinetable((pos(n) * f) And (TABLESIZE - 1)) * vol(n) / MAXVOL
pos(n) = pos(n) + 1
s = s + buf(c * 2)
' clip
If (s > 32767) Then s = 32767
If (s < -32768) Then s = -32768
' left and right channels are the same
buf(c * 2) = s
buf(c * 2 + 1) = s
If (vol(n) < MAXVOL) Then vol(n) = vol(n) - 1
c = c + 1
Loop
End If
Next n
Call CopyMemory(ByVal buffer, buf(0), length)
WriteStream = length
End Function