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 >
Text File  |  2006-06-14  |  9KB  |  294 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "clsFourier"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. ' Fast Fourier Transformation - FFT
  15. '
  16. ' ...and it is fast indeed - will transform 2048 samples in
  17. ' S1 mSec now on an Atlon 1800 MHz CPU with a clockrate of
  18. ' 1533 MHz (with a little help from my friends)
  19. '
  20. ' by Ulli
  21.  
  22. Option Explicit
  23.  
  24. Private Declare Function QueryPerformanceFrequency Lib "kernel32" ( _
  25.     lpFrequency As Currency _
  26. ) As Long
  27.  
  28. Private Declare Function QueryPerformanceCounter Lib "kernel32" ( _
  29.     lpPerformanceCount As Currency _
  30. ) As Long
  31.  
  32. Private Declare Sub MemCopy Lib "kernel32" _
  33. Alias "RtlMoveMemory" ( _
  34.     ByVal Destination As Long, _
  35.     ByVal Source As Long, _
  36.     ByVal Length As Long _
  37. )
  38.  
  39. Private AtStart             As Currency
  40. Private AtEnd               As Currency
  41. Private CPUSpeed            As Currency
  42.  
  43. Private Const Mirror_FON    As Long = 11
  44. Private Mirror_Bin()        As Byte
  45. 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"
  46.  
  47. Private Const Ioor          As String = "Index out of range or number of samples unknown"
  48. Private Const Nosm          As String = "Number of samples must be a positive value of the form 2 ^ n"
  49.  
  50. Private UnknownSize         As Boolean
  51. Private NeedsDoing          As Boolean
  52. Private myTimeWindow        As Long
  53. Private UBSamples           As Long     'upper bound of samples
  54. Private NumBits             As Long     'number of bits needed to express above
  55. Private StageSize           As Long     'the number of samples in current computation stage
  56. Private NumButter           As Long     'the number of butterflies in current stage
  57. Private i                   As Long     'helpers, enumerators and such
  58. Private j                   As Long
  59. 'Private Align8              As Long     'this padding (if necessary) improves speed by about 20 to 25%
  60. '                                       'apparently there's a severe penalty on misaliged operands (at least with the Athlon)
  61. Private Pi                  As Double   'what it says:  pi
  62. Private TwoPi               As Double
  63. Private tmp                 As Double
  64.  
  65. Private Type Sample                     'sample consists of a real and an imaginary value in gaussian complex plane
  66.     Real                    As Double
  67.     Imag                    As Double
  68. End Type
  69.  
  70. Private s                   As Sample
  71. Private t                   As Sample
  72. Private U                   As Sample
  73. Private Values()            As Sample
  74.  
  75. Private Sub Butterfly( _
  76.     ByRef pS As Sample, _
  77.     ByRef pU As Sample, _
  78.     ByRef oJ As Sample, _
  79.     ByRef oK As Sample _
  80. )
  81.  
  82.     t.Real = pU.Real * oK.Real - pU.Imag * oK.Imag
  83.     t.Imag = pU.Imag * oK.Real + pU.Real * oK.Imag
  84.     oK.Real = oJ.Real - t.Real
  85.     oJ.Real = oJ.Real + t.Real
  86.     oK.Imag = oJ.Imag - t.Imag
  87.     oJ.Imag = oJ.Imag + t.Imag
  88.     tmp = pS.Real * pU.Real + pS.Imag * pU.Imag
  89.     pU.Imag = pU.Imag + pS.Imag * pU.Real - pS.Real * pU.Imag
  90.     pU.Real = pU.Real - tmp
  91. End Sub
  92.  
  93. Private Sub Class_Initialize()
  94.     Pi = 4 * Atn(1)
  95.     TwoPi = Pi + Pi
  96.     ReDim Values(0)
  97.  
  98.     UnknownSize = True
  99.     QueryPerformanceFrequency CPUSpeed
  100.  
  101.     Patch Mirror_FON, Mirror_Hex, Mirror_Bin
  102.  
  103.     i = VarPtr(Pi) Mod 8
  104.  
  105. '    If i Then
  106. '        MsgBox "For improved speed insert padding of " & 8 - i & " bytes before Variable Pi", vbExclamation, "Developer:"
  107. '    End If
  108. End Sub
  109.  
  110. Public Property Get ComplexOut( _
  111.     Index As Long _
  112. ) As Double
  113.  
  114.     With GetIt(Index)
  115.         ComplexOut = Sqr(.Real * .Real + .Imag * .Imag)
  116.     End With 'GETIT(INDEX)
  117. End Property
  118.  
  119. Private Function GetIt( _
  120.     Index As Long _
  121. ) As Sample
  122.  
  123.     If UnknownSize Or Index < 1 Or Index > UBSamples + 1 Then
  124.         Err.Raise 381, , Ioor
  125.       Else 'NOT UNKNOWNSIZE...
  126.         If NeedsDoing Then
  127.             NeedsDoing = False
  128.  
  129.             '=======================================================================================
  130.             'Begin Fast Fourier Transformation
  131.  
  132.             QueryPerformanceCounter AtStart
  133.  
  134.             StageSize = 1
  135.             Do
  136.                 'divide and conquer
  137.                 NumButter = StageSize
  138.                 StageSize = NumButter * 2
  139.                 tmp = Pi / StageSize
  140.                 s.Real = Sin(tmp)
  141.                 s.Real = 2 * s.Real * s.Real
  142.                 s.Imag = Sin(tmp * 2)
  143.                 For i = 0 To UBSamples Step StageSize
  144.                     U.Real = 1
  145.                     U.Imag = 0
  146.                     For j = i To i + NumButter - 1
  147.                         Butterfly s, U, Values(j), Values(j + NumButter) 'butterfly calculation
  148.                 Next j, i
  149.             Loop Until StageSize > UBSamples
  150.  
  151.             QueryPerformanceCounter AtEnd
  152.  
  153.             'End Fast Fourier Transformation
  154.             '=======================================================================================
  155.  
  156.         End If
  157.         GetIt = Values(Index - 1)
  158.     End If
  159. End Function
  160.  
  161. Public Property Let ImagIn( _
  162.     ByVal Index As Long, _
  163.     nuValueIn As Double _
  164. )
  165.  
  166.     If UnknownSize Or Index < 1 Or Index > UBSamples + 1 Then
  167.         Err.Raise 381, , Ioor
  168.       Else 'NOT UNKNOWNSIZE...
  169.         Values(Mirror(Index - 1, NumBits)).Imag = nuValueIn
  170.         NeedsDoing = True
  171.     End If
  172. End Property
  173.  
  174. Public Property Get ImagOut( _
  175.     ByVal Index As Long _
  176. ) As Double
  177.  
  178.     ImagOut = GetIt(Index).Imag
  179. End Property
  180.  
  181. Private Function Mirror( _
  182.     ByVal Index As Long, _
  183.     ByVal NumBits As Long _
  184. ) As Long
  185.  
  186.   'dummy -- will be patched by
  187.   '
  188.   '         xor   eax, eax          ;clear result
  189.   '         mov   edx, [esp + 8]    ;get Index from stack
  190.   '         mov   ecx, [esp + 12]   ;get NumBits from stack
  191.   '         jcxz  GetOut            ;zero? -> get out
  192.   '     Again:
  193.   '         rcr   edx, 1            ;shift LSB of index into carry flag
  194.   '         adc   eax, eax          ;double result and add carry
  195.   '         dec   ecx               ;NumBits - 1
  196.   '         jnz   Again             ;not zero? -> do it again
  197.   '     GetOut:
  198.   '         mov   edx, [esp + 16]   ;get address of function variable from stack
  199.   '         mov   [edx], eax        ;put result there
  200.   '         ret   16                ;return tidying stack
  201.  
  202.     For j = 1 To NumBits
  203.         Mirror = Mirror * 2 Or (Index And 1)
  204.         Index = Index \ 2
  205.     Next j
  206. End Function
  207.  
  208. Public Property Let NumberOfSamples( _
  209.     ByVal nuNumSam As Long _
  210. )
  211.  
  212.     If nuNumSam > 1 And (nuNumSam - 1 And nuNumSam) = 0 Then
  213.         ReDim Values(0 To nuNumSam - 1)
  214.         UnknownSize = False
  215.         UBSamples = nuNumSam - 1
  216.         NumBits = Log(nuNumSam) / Log(2) 'the number of bits needed to express UBSamples
  217.         NeedsDoing = True
  218.       Else 'NOT NUNUMSAM...
  219.         Err.Raise 380, , Nosm
  220.     End If
  221. End Property
  222.  
  223. Private Sub Patch( _
  224.     ByVal FON As Long, _
  225.     HexCode As String, _
  226.     BinCode() As Byte _
  227. ) 'FON is the Function's Ordinal Number in vTable
  228.  
  229.   'Convert hex to binary and patch vTable entry
  230.  
  231.   Dim st()          As String
  232.   Dim p             As Long
  233.   Dim CodeAddress   As Long
  234.   Dim VTableAddress As Long
  235.  
  236.     st = Split(HexCode, " ")
  237.     ReDim BinCode(0 To UBound(st))
  238.     'Convert hex to binary
  239.     For p = 0 To UBound(st)
  240.         BinCode(p) = Val("&H" & st(p))
  241.     Next p
  242.  
  243.     'Patch vTable entry
  244.     CodeAddress = VarPtr(BinCode(0))
  245.     MemCopy VarPtr(VTableAddress), ObjPtr(Me), 4 'get vTable address
  246.     MemCopy VTableAddress + FON * 4 + 28, VarPtr(CodeAddress), 4 'patch proper entry in vTable
  247. End Sub
  248.  
  249. Public Property Let RealIn( _
  250.     ByVal Index As Long, _
  251.     nuValueIn As Double _
  252. )
  253.  
  254.     If UnknownSize Or Index < 1 Or Index > UBSamples + 1 Then
  255.         Err.Raise 381, , Ioor
  256.       Else 'NOT UNKNOWNSIZE...
  257.         Index = Index - 1
  258.         With Values(Mirror(Index, NumBits))
  259.             If myTimeWindow Then
  260.                 tmp = TwoPi * Index / UBSamples
  261.                 'three term blackman time window function
  262.                 .Real = nuValueIn * (0.42 - 0.5 * Cos(tmp) + 0.08 * Cos(2 * tmp))
  263.               Else 'MYTIMEWINDOW = FALSE/0
  264.                 .Real = nuValueIn / 2
  265.             End If
  266.             .Imag = 0
  267.         End With 'VALUES(MIRROR(INDEX,
  268.         NeedsDoing = True
  269.     End If
  270. End Property
  271.  
  272. Public Property Get RealOut( _
  273.     ByVal Index As Long _
  274. ) As Double
  275.  
  276.     RealOut = GetIt(Index).Real
  277. End Property
  278.  
  279. Public Property Get Timing( _
  280. ) As Single
  281.  
  282.     Timing = (AtEnd - AtStart) / CPUSpeed * 1000
  283. End Property
  284.  
  285. Public Property Let WithTimeWindow( _
  286.     ByVal nuTimeWindow As Long _
  287. )
  288.  
  289.     myTimeWindow = nuTimeWindow
  290. End Property
  291.  
  292. ':) Ulli's VB Code Formatter V2.21.6 (2006-Apr-24 11:50)  Decl: 45  Code: 201  Total: 246 Lines
  293. ':) CommentOnly: 31 (12,6%)  Commented: 19 (7,7%)  Empty: 57 (23,2%)  Max Logic Depth: 6
  294.