home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Planet Source Code Jumbo …e CD Visual Basic 1 to 7
/
4_2005-2006.ISO
/
data
/
Zips
/
WaveIn_Rec2001136152006.psc
/
clsFourier.cls
< prev
next >
Wrap
Text File
|
2006-06-14
|
9KB
|
294 lines
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "clsFourier"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' Fast Fourier Transformation - FFT
'
' ...and it is fast indeed - will transform 2048 samples in
' S1 mSec now on an Atlon 1800 MHz CPU with a clockrate of
' 1533 MHz (with a little help from my friends)
'
' by Ulli
Option Explicit
Private Declare Function QueryPerformanceFrequency Lib "kernel32" ( _
lpFrequency As Currency _
) As Long
Private Declare Function QueryPerformanceCounter Lib "kernel32" ( _
lpPerformanceCount As Currency _
) As Long
Private Declare Sub MemCopy Lib "kernel32" _
Alias "RtlMoveMemory" ( _
ByVal Destination As Long, _
ByVal Source As Long, _
ByVal Length As Long _
)
Private AtStart As Currency
Private AtEnd As Currency
Private CPUSpeed As Currency
Private Const Mirror_FON As Long = 11
Private Mirror_Bin() As Byte
Private Const Mirror_Hex As String = "31 C0 8B 54 24 08 8B 4C 24 0C 67 E3 07 D1 DA 11 C0 49 75 F9 8B 54 24 10 89 02 C2 10 00"
Private Const Ioor As String = "Index out of range or number of samples unknown"
Private Const Nosm As String = "Number of samples must be a positive value of the form 2 ^ n"
Private UnknownSize As Boolean
Private NeedsDoing As Boolean
Private myTimeWindow As Long
Private UBSamples As Long 'upper bound of samples
Private NumBits As Long 'number of bits needed to express above
Private StageSize As Long 'the number of samples in current computation stage
Private NumButter As Long 'the number of butterflies in current stage
Private i As Long 'helpers, enumerators and such
Private j As Long
'Private Align8 As Long 'this padding (if necessary) improves speed by about 20 to 25%
' 'apparently there's a severe penalty on misaliged operands (at least with the Athlon)
Private Pi As Double 'what it says: pi
Private TwoPi As Double
Private tmp As Double
Private Type Sample 'sample consists of a real and an imaginary value in gaussian complex plane
Real As Double
Imag As Double
End Type
Private s As Sample
Private t As Sample
Private U As Sample
Private Values() As Sample
Private Sub Butterfly( _
ByRef pS As Sample, _
ByRef pU As Sample, _
ByRef oJ As Sample, _
ByRef oK As Sample _
)
t.Real = pU.Real * oK.Real - pU.Imag * oK.Imag
t.Imag = pU.Imag * oK.Real + pU.Real * oK.Imag
oK.Real = oJ.Real - t.Real
oJ.Real = oJ.Real + t.Real
oK.Imag = oJ.Imag - t.Imag
oJ.Imag = oJ.Imag + t.Imag
tmp = pS.Real * pU.Real + pS.Imag * pU.Imag
pU.Imag = pU.Imag + pS.Imag * pU.Real - pS.Real * pU.Imag
pU.Real = pU.Real - tmp
End Sub
Private Sub Class_Initialize()
Pi = 4 * Atn(1)
TwoPi = Pi + Pi
ReDim Values(0)
UnknownSize = True
QueryPerformanceFrequency CPUSpeed
Patch Mirror_FON, Mirror_Hex, Mirror_Bin
i = VarPtr(Pi) Mod 8
' If i Then
' MsgBox "For improved speed insert padding of " & 8 - i & " bytes before Variable Pi", vbExclamation, "Developer:"
' End If
End Sub
Public Property Get ComplexOut( _
Index As Long _
) As Double
With GetIt(Index)
ComplexOut = Sqr(.Real * .Real + .Imag * .Imag)
End With 'GETIT(INDEX)
End Property
Private Function GetIt( _
Index As Long _
) As Sample
If UnknownSize Or Index < 1 Or Index > UBSamples + 1 Then
Err.Raise 381, , Ioor
Else 'NOT UNKNOWNSIZE...
If NeedsDoing Then
NeedsDoing = False
'=======================================================================================
'Begin Fast Fourier Transformation
QueryPerformanceCounter AtStart
StageSize = 1
Do
'divide and conquer
NumButter = StageSize
StageSize = NumButter * 2
tmp = Pi / StageSize
s.Real = Sin(tmp)
s.Real = 2 * s.Real * s.Real
s.Imag = Sin(tmp * 2)
For i = 0 To UBSamples Step StageSize
U.Real = 1
U.Imag = 0
For j = i To i + NumButter - 1
Butterfly s, U, Values(j), Values(j + NumButter) 'butterfly calculation
Next j, i
Loop Until StageSize > UBSamples
QueryPerformanceCounter AtEnd
'End Fast Fourier Transformation
'=======================================================================================
End If
GetIt = Values(Index - 1)
End If
End Function
Public Property Let ImagIn( _
ByVal Index As Long, _
nuValueIn As Double _
)
If UnknownSize Or Index < 1 Or Index > UBSamples + 1 Then
Err.Raise 381, , Ioor
Else 'NOT UNKNOWNSIZE...
Values(Mirror(Index - 1, NumBits)).Imag = nuValueIn
NeedsDoing = True
End If
End Property
Public Property Get ImagOut( _
ByVal Index As Long _
) As Double
ImagOut = GetIt(Index).Imag
End Property
Private Function Mirror( _
ByVal Index As Long, _
ByVal NumBits As Long _
) As Long
'dummy -- will be patched by
'
' xor eax, eax ;clear result
' mov edx, [esp + 8] ;get Index from stack
' mov ecx, [esp + 12] ;get NumBits from stack
' jcxz GetOut ;zero? -> get out
' Again:
' rcr edx, 1 ;shift LSB of index into carry flag
' adc eax, eax ;double result and add carry
' dec ecx ;NumBits - 1
' jnz Again ;not zero? -> do it again
' GetOut:
' mov edx, [esp + 16] ;get address of function variable from stack
' mov [edx], eax ;put result there
' ret 16 ;return tidying stack
For j = 1 To NumBits
Mirror = Mirror * 2 Or (Index And 1)
Index = Index \ 2
Next j
End Function
Public Property Let NumberOfSamples( _
ByVal nuNumSam As Long _
)
If nuNumSam > 1 And (nuNumSam - 1 And nuNumSam) = 0 Then
ReDim Values(0 To nuNumSam - 1)
UnknownSize = False
UBSamples = nuNumSam - 1
NumBits = Log(nuNumSam) / Log(2) 'the number of bits needed to express UBSamples
NeedsDoing = True
Else 'NOT NUNUMSAM...
Err.Raise 380, , Nosm
End If
End Property
Private Sub Patch( _
ByVal FON As Long, _
HexCode As String, _
BinCode() As Byte _
) 'FON is the Function's Ordinal Number in vTable
'Convert hex to binary and patch vTable entry
Dim st() As String
Dim p As Long
Dim CodeAddress As Long
Dim VTableAddress As Long
st = Split(HexCode, " ")
ReDim BinCode(0 To UBound(st))
'Convert hex to binary
For p = 0 To UBound(st)
BinCode(p) = Val("&H" & st(p))
Next p
'Patch vTable entry
CodeAddress = VarPtr(BinCode(0))
MemCopy VarPtr(VTableAddress), ObjPtr(Me), 4 'get vTable address
MemCopy VTableAddress + FON * 4 + 28, VarPtr(CodeAddress), 4 'patch proper entry in vTable
End Sub
Public Property Let RealIn( _
ByVal Index As Long, _
nuValueIn As Double _
)
If UnknownSize Or Index < 1 Or Index > UBSamples + 1 Then
Err.Raise 381, , Ioor
Else 'NOT UNKNOWNSIZE...
Index = Index - 1
With Values(Mirror(Index, NumBits))
If myTimeWindow Then
tmp = TwoPi * Index / UBSamples
'three term blackman time window function
.Real = nuValueIn * (0.42 - 0.5 * Cos(tmp) + 0.08 * Cos(2 * tmp))
Else 'MYTIMEWINDOW = FALSE/0
.Real = nuValueIn / 2
End If
.Imag = 0
End With 'VALUES(MIRROR(INDEX,
NeedsDoing = True
End If
End Property
Public Property Get RealOut( _
ByVal Index As Long _
) As Double
RealOut = GetIt(Index).Real
End Property
Public Property Get Timing( _
) As Single
Timing = (AtEnd - AtStart) / CPUSpeed * 1000
End Property
Public Property Let WithTimeWindow( _
ByVal nuTimeWindow As Long _
)
myTimeWindow = nuTimeWindow
End Property
':) Ulli's VB Code Formatter V2.21.6 (2006-Apr-24 11:50) Decl: 45 Code: 201 Total: 246 Lines
':) CommentOnly: 31 (12,6%) Commented: 19 (7,7%) Empty: 57 (23,2%) Max Logic Depth: 6