Delphi控件源码

开发平台：
Delphi

MMFIRFlt.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: +0351-8012255                   =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 20.01.1998 - 18:00:00 $                                      =}
{========================================================================}
unit MMFIRFlt;
{$I COMPILER.INC}
interface
uses
    Windows,
    MMSystem,
    MMUtils,
    MMRegs;
{========================================================================}
const
     { constants for the DataType fields }
     DT_8BIT   = $00;  { x0 b }
     DT_16BIT  = $01;  { x1 b }
     DT_MONO   = $00;  { 0x b }
     DT_STEREO = $02;  { 1x b }
     { constants for channels }
     CH_BOTH   = $00;
     CH_LEFT   = $01;
     CH_RIGHT  = $02;
function GetDataType(pwfx: PWaveFormatEx): integer;
{==============================================================================}
const
    MAXTAPS = 4096;
type
    PFIRFilter = ^TFIRFilter;
    TFIRFilter = packed record
       DataType   : integer;             { DT_8BIT,DT_16BIT,DT_MONO,DT_STEREO  }
       Channel    : integer;             { on which channel do the filtering   }
       DLine      : array[0..8*MAXTAPS-1] of Smallint; { DelayLine             }
       fTaps      : array[0..MAXTAPS-1] of Float;    { array with float coeffs }
       sTaps      : array[0..4*MAXTAPS-1] of Smallint;{ array with short coeffs}
       pTaps      : Pointer;             { pointer to actual taps              }
       nTaps      : integer;             { number of coeffs in array           }
       uTaps      : integer;             { original number of taps             }
       TapsFactor : integer;             { ScaleFactor for short Taps          }
       Routine16M : Pointer;             { internal for asm stuff              }
       Routine16S : Pointer;
       RoutineFM  : Pointer;
       RoutineFS  : Pointer;
    end;
function  InitFIRFilter(pwfx: PWaveFormatEx): PFIRFilter;
procedure DoneFIRFilter(var pfir: PFIRFilter);
procedure SetFIRFilter(pfir: PFIRFilter; pCoeffs: PFloatArray; nCoeffs, iChannel: integer);
procedure ResetFIRFilter(pfir: PFIRFilter);
function  DoFIRFilterShort(pfir: PFIRFilter; BufIn, BufOut: PChar; Len: Longint): Boolean; pascal;
procedure DoFIRFilterFloat(pfir: PFIRFilter; BufIn, BufOut: PFloatArray; Len: Longint); pascal;
implementation
{========================================================================}
function GetDataType(pwfx: PWaveFormatEx): Integer;
begin
   Result := -1;
   if (pwfx <> Nil) and (pwfx^.wFormatTag = WAVE_FORMAT_PCM) then
   begin
      Result := 0;
      if (pwfx^.wBitsPerSample = 16) then Result := Result or DT_16BIT;
      if (pwfx^.nChannels = 2) then Result := Result or DT_STEREO;
   end;
end;
{==============================================================================}
{ -- FIR Filter --                                                             }
{==============================================================================}
{$IFDEF USEASM}
{$L MMFIRL.OBJ}
{$F+}
procedure SetFIRProc(pfir: PFIRFilter; CPUType: integer); pascal; external;
{$F-}
{$ENDIF}
{==============================================================================}
function InitFIRFilter(pwfx: PWaveFormatEx): PFIRFilter;
begin
   Result := GlobalAllocPtr(GHND, sizeOf(TFIRFilter));
   if (Result <> nil) then
   with Result^ do
   begin
      DataType  := GetDataType(pwfx);
      Channel   := CH_BOTH;
      if (DataType and DT_16BIT = DT_8BIT) then
      begin
         DoneFIRFilter(Result);
         exit;
      end;
      uTaps := 0;
      nTaps := 0;
      TapsFactor := 0;
      {$IFDEF USEASM}
      SetFIRProc(Result,GetCPUMode);
      {$ENDIF}
      ResetFIRFilter(Result);
   end;
end;
{========================================================================}
procedure DoneFIRFilter(var pfir: PFIRFilter);
begin
   if (pfir <> nil) then
   begin
      GlobalFreePtr(pfir);
      pfir := nil;
   end;
end;
{========================================================================}
procedure ResetFIRFilter(pfir: PFIRFilter);
begin
   if (pfir <> nil) then
   with pfir^ do
   begin
      FillChar(DLine,8*MAXTAPS*sizeOf(Smallint),0);
   end;
end;
{========================================================================}
procedure SetFIRFilter(pfir: PFIRFilter; pCoeffs: PFloatArray; nCoeffs, iChannel: integer);
var
   i,j,k: integer;
   sum: Float;
   TempTaps: array[0..MAXTAPS+6] of Smallint;
begin
   if (pfir <> nil) then
   with pfir^ do
   begin
      Channel := iChannel;
      uTaps := nCoeffs;
      if (uTaps > MAXTAPS) then uTaps := MAXTAPS;
      { simply copy the taps to our structure }
      nTaps := uTaps;
      for i := 0 to uTaps-1 do fTaps[i] := pCoeffs^[i];
      pTaps := @fTaps;
      {$IFDEF USEASM}
      if _USECPUEXT_ and ((_CPU_ > PENTIUM) or _MMX_) then
      begin
         { find the scale factor for short Taps }
         sum := 0;
         for i := 0 to uTaps-1 do sum := sum + abs(pCoeffs[i]);
         TapsFactor := 1;
         if (sum > 0) then
            while Round(sum * (1 shl TapsFactor)) < MAXSMALLINT do inc(TapsFactor);
         dec(TapsFactor);
         if _MMX_ then
         begin
            { MMX }
            nTaps := ((uTaps+6)div 4)*4;
            FillChar(TempTaps,sizeOf(TempTaps),0);
            { Scale the Taps and copy to Temp }
            for i := 0 to nCoeffs-1 do
                TempTaps[3+i] := Round(pCoeffs[i]*(1 shl TapsFactor));
            { reorder the Taps for fast asm calculation }
            k := 3;
            for i := 0 to (nTaps div 4)-1 do
            begin
               for j := 0 to 3 do
               begin
                  sTaps[4*(nTaps-4*i-j)-1] := TempTaps[k];
                  sTaps[4*(nTaps-4*i-j)-2] := TempTaps[k+1];
                  sTaps[4*(nTaps-4*i-j)-3] := TempTaps[k+2];
                  sTaps[4*(nTaps-4*i-j)-4] := TempTaps[k+3];
                  dec(k);
               end;
               inc(k,8);
            end;
         end
         else
         begin
            { Pentium PRO }
            nTaps := (uTaps+3)and not 3;
            for i := 0 to uTaps-1 do
                sTaps[nTaps-i] := Round(pCoeffs^[i]*(1 shl TapsFactor));
         end;
         pTaps := @sTaps;
      end;
      {$ENDIF}
   end;
end;
{==============================================================================}
{$IFDEF USEASM}
{$F+}
function DoFIRFilterShort(pfir: PFIRFilter; BufIn, BufOut: PChar; Len: Longint): Boolean; external;
{$F-}
{$ELSE}
function DoFIRFilterShort(pfir: PFIRFilter; BufIn, BufOut: PChar; Len: Longint): Boolean;
var
   n: Longint;
   {===========================================================================}
   procedure FillDLine(DLine,Input: PSmallArray; Count: integer);
   var
      i: integer;
   begin
      for i := 0 to Count-1 do DLine[i]:= Input[i];
   end;
   {===========================================================================}
   procedure FIRSegM(Input,Output: PSmallArray; Count: integer);
   var
      i,j: integer;
      sum: Double;
      s: Longint;
   begin
      for i := 0 to Count-1 do
      begin
         sum := 0;
         for j := pfir.nTaps-1 downto 0 do
             sum := sum + Input[i+j]*pfir.fTaps[j];
         s := Round(sum);
         if s > 32767 then
         begin
            Result := True;
            Output[i] := 32767;
         end
         else if s < -32768 then
         begin
            Result := True;
            Output[i] := -32768;
         end
         else Output[i] := s;
      end;
   end;
   {===========================================================================}
   procedure FIRSegSB(Input,Output: PSmallArray; Count: integer);
   var
      i,j: integer;
      sum,sum2: Double;
      s: Longint;
   begin
      for i := 0 to Count-1 do
      begin
         sum := 0;
         sum2:= 0;
         for j := pfir.nTaps-1 downto 0 do
         begin
             sum := sum + Input[2*(i+j)]*pfir.fTaps[j];
             sum2:= sum2 + Input[2*(i+j)+1]*pfir.fTaps[j];
         end;
         s := Round(sum);
         if s > 32767 then
         begin
            Result := True;
            Output[2*i] := 32767;
         end
         else if s < -32768 then
         begin
            Result := True;
            Output[2*i] := -32768;
         end
         else Output[2*i] := s;
         s := Round(sum2);
         if s > 32767 then
         begin
            Result := True;
            Output[2*i+1] := 32767;
         end
         else if s < -32768 then
         begin
            Result := True;
            Output[2*i+1] := -32768;
         end
         else Output[2*i+1] := s;
      end;
   end;
   {===========================================================================}
   procedure FIRSegSC(Input,Output: PSmallArray; Count,Channel: integer);
   var
      i,j,c: integer;
      sum: Double;
      s: Longint;
   begin
      c := Channel-1;
      for i := 0 to Count-1 do
      begin
         sum := 0;
         for j := pfir.nTaps-1 downto 0 do
         begin
             sum := sum + Input[2*(i+j)+c]*pfir.fTaps[j];
         end;
         s := Round(sum);
         if s > 32767 then
         begin
            Result := True;
            Output[2*i+c] := 32767;
         end
         else if s < -32768 then
         begin
            Result := True;
            Output[2*i+c] := -32768;
         end
         else Output[2*i+c] := s;
      end;
   end;
   {===========================================================================}
   procedure CopyData16(iChannel: integer; pIn,pOut: PSmallint; Len: Longint);
   var
      ci: integer;
   begin
      ci := iChannel+1;
      if (iChannel and CH_RIGHT = CH_RIGHT) then
      begin
         inc(pIn);
         inc(pOut);
         dec(Len,2);
         dec(ci);
      end;
      while Len > 0 do
      begin
         pOut^ := pIn^;
         inc(pOut,ci);
         inc(pIn,ci);
         dec(Len,2*ci);
      end;
   end;
begin
   { returns true on internal overflow }
   Result := False;
   if (pfir <> nil) and (pfir^.nTaps > 0) then
   with pfir^ do
   begin
      if (DataType and DT_STEREO = DT_STEREO) then    { stereo }
      begin
         Len := Len div 4;
         n := nTaps-1;
         if n > Len then n := Len;
         if (Channel = CH_BOTH) then
         begin
            { both channels }
            FillDLine(@DLine[2*(nTaps-1)],Pointer(BufIn),2*n);
            FIRSegSB(@DLine,Pointer(BufOut),n);
            FIRSegSB(Pointer(BufIn),Pointer(BufOut+4*n),Len-n);
            if n < nTaps-1 then
               FillDLine(@DLine[0],@DLine[2*n],2*(nTaps-n))
            else
               FillDLine(@DLine[0],Pointer(PChar(BufIn)+4*(Len-n)),2*(nTaps-1));
         end
         else
         begin
            { one channel only }
            FillDLine(@DLine[2*(nTaps-1)],Pointer(BufIn),2*n);
            FIRSegSC(@DLine,Pointer(BufOut),n,Channel);
            FIRSegSC(Pointer(BufIn),Pointer(BufOut+4*n),Len-n,Channel);
            if n < nTaps-1 then
               FillDLine(@DLine[0],@DLine[2*n],2*(nTaps-n))
            else
               FillDLine(@DLine[0],Pointer(PChar(BufIn)+4*(Len-n)),2*(nTaps-1));
            if (Channel and CH_LEFT = CH_LEFT) then
                CopyData16(CH_RIGHT,Pointer(BufIn),Pointer(BufOut),4*Len)
            else
                CopyData16(CH_LEFT,Pointer(BufIn),Pointer(BufOut),4*Len);
         end;
      end
      else                                            { Mono        }
      begin
         Len := Len div 2;
         n := nTaps-1;
         if n > Len then n := Len;
         FillDLine(@DLine[nTaps-1],Pointer(BufIn),n);
         FIRSegM(@DLine,Pointer(BufOut),n);
         FIRSegM(Pointer(BufIn),Pointer(BufOut+2*n),Len-n);
         if n < nTaps-1 then
             FillDLine(@DLine[0],@DLine[n],nTaps-n)
         else
             FillDLine(@DLine[0],Pointer(PChar(BufIn)+2*(Len-n)),nTaps-1);
      end;
   end;
end;
{$ENDIF}
{==============================================================================}
{$IFDEF USEASM}
{$F+}
procedure DoFIRFilterFloat(pfir: PFIRFilter; BufIn, BufOut: PFloatArray; Len: Longint); external;
{$F-}
{$ELSE}
procedure DoFIRFilterFloat(pfir: PFIRFilter; BufIn, BufOut: PFloatArray; Len: Longint);
var
   n: Longint;
   DLineF: PFloatArray;
   {===========================================================================}
   procedure FillDLine(DLine,Input: PFloatArray; Count: integer);
   var
      i: integer;
   begin
      for i := 0 to Count-1 do DLine[i]:= Input[i];
   end;
   {===========================================================================}
   procedure FIRSegM(Input,Output: PFloatArray; Count: integer);
   var
      i,j: integer;
      sum: Double;
   begin
      for i := 0 to Count-1 do
      begin
         sum := 0;
         for j := pfir.nTaps-1 downto 0 do
             sum := sum + Input[i+j]*pfir.fTaps[j];
         Output[i] := sum;
      end;
   end;
   {===========================================================================}
   procedure FIRSegSB(Input,Output: PFloatArray; Count: integer);
   var
      i,j: integer;
      sum,sum2: Double;
   begin
      for i := 0 to Count-1 do
      begin
         sum := 0;
         sum2:= 0;
         for j := pfir.nTaps-1 downto 0 do
         begin
             sum := sum + Input[2*(i+j)]*pfir.fTaps[j];
             sum2:= sum2 + Input[2*(i+j)+1]*pfir.fTaps[j];
         end;
         Output[2*i]   := sum;
         Output[2*i+1] := sum2;
      end;
   end;
   {===========================================================================}
   procedure FIRSegSC(Input,Output: PFloatArray; Count,Channel: integer);
   var
      i,j,c: integer;
      sum: Double;
   begin
      c := Channel-1;
      for i := 0 to Count-1 do
      begin
         sum := 0;
         for j := pfir.nTaps-1 downto 0 do
         begin
             sum := sum + Input[2*(i+j)+c]*pfir.fTaps[j];
         end;
         Output[2*i+c] := sum;
      end;
   end;
   {===========================================================================}
   procedure CopyData16(iChannel: integer; pIn,pOut: PFloat; Len: Longint);
   var
      ci: integer;
   begin
      ci := iChannel+1;
      if (iChannel and CH_RIGHT = CH_RIGHT) then
      begin
         inc(pIn);
         inc(pOut);
         dec(Len,sizeOf(Float));
         dec(ci);
      end;
      while Len > 0 do
      begin
         pOut^ := pIn^;
         inc(pOut,ci);
         inc(pIn,ci);
         dec(Len,sizeOf(Float)*ci);
      end;
   end;
begin
   { returns true on internal overflow }
   if (pfir <> nil) and (pfir^.nTaps > 0) then
   with pfir^ do
   begin
      DLineF := @pfir.DLine;
      
      if (DataType and DT_STEREO = DT_STEREO) then    { stereo }
      begin
         Len := Len div 2*sizeOf(Float);
         n := nTaps-1;
         if n > Len then n := Len;
         if (Channel = CH_BOTH) then
         begin
            { both channels }
            FillDLine(@DLineF[2*(nTaps-1)],BufIn,2*n);
            FIRSegSB(DLineF,Pointer(BufOut),n);
            FIRSegSB(BufIn,@BufOut[2*n],Len-n);
            if n < nTaps-1 then
               FillDLine(DLineF,@DLineF[2*n],2*(nTaps-n))
            else
               FillDLine(DLineF,Pointer(PChar(BufIn)+2*sizeOf(Float)*(Len-n)),2*(nTaps-1));
         end
         else
         begin
            { one channel only }
            FillDLine(@DLineF[2*(nTaps-1)],BufIn,2*n);
            FIRSegSC(DLineF,BufOut,n,Channel);
            FIRSegSC(BufIn,@BufOut[2*n],Len-n,Channel);
            if n < nTaps-1 then
               FillDLine(DLineF,@DLineF[2*n],2*(nTaps-n))
            else
               FillDLine(DLineF,@BufIn[2*(Len-n)],2*(nTaps-1));
            if (Channel and CH_LEFT = CH_LEFT) then
                CopyData16(CH_RIGHT,@BufIn[0],@BufOut[0],2*sizeOf(Float)*Len)
            else
                CopyData16(CH_LEFT,@BufIn[0],@BufOut[0],2*sizeOf(Float)*Len);
         end;
      end
      else                                            { Mono        }
      begin
         Len := Len div sizeOf(Float);
         n := nTaps-1;
         if n > Len then n := Len;
         FillDLine(@DLineF[nTaps-1],BufIn,n);
         FIRSegM(DLineF,BufOut,n);
         FIRSegM(BufIn,@BufOut[n],Len-n);
         if n < nTaps-1 then
             FillDLine(DLineF,@DLineF[n],nTaps-n)
         else
             FillDLine(DLineF,@BufIn[Len-n],nTaps-1);
      end;
   end;
end;
{$ENDIF}
end.

						