mmfirflt.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: [phone]                   =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  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;