mmfir.pas

一套及时通讯的原码

   for j := 0 to m do
   begin
      FIR_Interpolate(@dnpi,@amp,nPoints,j,a[j]);
   end;

   for i := 1 to m do  // Calculate the coefficient array
   begin
      xt := a[1] / 2.0;
      for j := 2 to m do
          xt := xt + a[j] * cos(q*((m-i)*(j-1)));
      hh[i-1] := 2.0 * xt / N;
   end;

   for i := m+1 to n do   // copy first n/2 coeff into last n/2 coeff
       hh[i-1] := hh[2*m-i-1];
end;

{==============================================================================}
procedure FIR_Coeffs(FIRType: TMMFIRFunction; SRate: integer; f1,f2: Float;
                     N: integer; hh: PFloatArray);
var
   k: integer;
   mm,a: Float;
   fg,fg2: Float;

begin
   case FIRType of
        ffLowpass:
        begin
           fg := f1/SRate;
           { build lowpass }
           for k := 0 to N-1 do
           begin
              mm := k-(N-1)/2.0;
              if (mm = 0) then
                  hh[k] := (fg*2*M_PI)/M_PI
              else
                  hh[k] := sin(mm*fg*2*M_PI)/(mm*M_PI);
           end;
        end;
        ffHighpass:
        begin
           fg := f1/SRate;
           { subtract a low pass from allpass }
           for k := 0 to N-1 do
           begin
              { simulate a allpass }
              if k = N div 2 then
                 a := 1.0
              else
                 a := 0.0;
              { the lowpass }
              mm := k-(N-1)/2.0;
              if (mm = 0) then
                  hh[k] := a-((fg*2*M_PI)/M_PI)
              else
                  hh[k] := a-(sin(mm*fg*2*M_PI)/(mm*M_PI));
           end;
        end;
        ffBandpass:
        begin
           fg := f1/SRate;
           fg2 := f2/SRate;
           { subtract a low pass from a low pass }
           for k := 0 to N-1 do
           begin
              mm := k-(N-1)/2.0;
              if (mm = 0) then
                  hh[k] := ((fg2*2*M_PI)/M_PI)-((fg*2*M_PI)/M_PI)
              else
                  hh[k] := (sin(mm*fg2*2*M_PI)/(mm*M_PI))-(sin(mm*fg*2*M_PI)/(mm*M_PI));
           end;
        end;
        ffBandstop:
        begin
           fg := f1/SRate;
           fg2:= f2/SRate;
           { build a bandpass and subtract it from a allpass }
           for k := 0 to N-1 do
           begin
              { simulate a allpass }
              if k = N div 2 then
                 a := 1.0
              else
                 a := 0.0;

              mm := k-(N-1)/2.0;
              if (mm = 0) then
                  hh[k] := a-((fg2*2*M_PI)/M_PI)-((fg*2*M_PI)/M_PI)
              else
                  hh[k] := a-(sin(mm*fg2*2*M_PI)/(mm*M_PI))-(sin(mm*fg*2*M_PI)/(mm*M_PI));
           end;
        end;
   end;
end;

{==============================================================================}
procedure FIR_Window(Window: TMMFFTWindow; N: integer; hh: PFloatArray);
const
   alpha = 5.0;   { Gaussian window parameter }
var
   i,N2: integer;

   function CalcWindow(idx: integer): Float;
   begin
      case ord(Window) of
              { Hamming }
	   1: Result := 0.54+0.46*cos(2*M_PI*idx/N);
              { Hanning }
           2: Result := 0.5+0.5*cos(2*M_PI*idx/N);
              { Blackman }
           3: Result := 0.42+0.5*cos(2*M_PI*idx/N)+0.08*cos(4*M_PI*idx/N);
	      { Gaussian }
           4: Result := exp( -alpha/(N*N) * (2*(N2-idx)-N)*(2*(N2-idx)-N)   );
              { Welch }
           5: Result := ((2*idx-N)/N)*((2*idx-N)/(N+1));
              { Parzen }
           6: Result := abs((2*idx-N)/(N+1));
              { Rectangular }
           else Result := 1;
      end;
   end;

begin
   N2 := N div 2;
   for i := 0 to N2 do
   begin
      hh[N2+i] := hh[N2+i] * CalcWindow(i);
      hh[N2-i] := hh[N2+i];
   end;
end;

{==============================================================================}
procedure FIR_Response(FirType,N:integer; hh: PFloatArray; dBScale: Boolean;
		       numPoints: integer; points: PFloatArray);
var
   index, L, i: integer;
   lambda, work: Float;

begin
   for L := 0 to NumPoints-1 do
   begin
      lambda := L*PI/NumPoints;
      case FirType of
	   1: begin
           	 work := hh[(N-1)div 2];
		 for i := 1 to ((N-1)div 2) do
		 begin
		    index := (N-1)div 2-i;
		    work := work+2.0*hh[index]*cos(i*lambda);
                 end;
              end;
	   2: begin
                 work := 0;
	         for i := 1 to (N div 2) do
		 begin
		    index := N div 2-i;
		    work := work+2.0*hh[index]*cos((i-0.05)*lambda);
                 end;
              end;
      end;
      if dbscale then
         points[L] := 20.0*log10(abs(work))
      else
      	 points[L] := abs(work);
   end;
end;

{==============================================================================}
procedure FIR_NormaliseResponse(dbscale: Boolean; NumPoints: integer; points: PFloatArray);
var
   i: integer;
   biggest: Float;

begin
   if dbscale then
   begin
      biggest := -100.0;
      for i := 0 to NumPoints-1 do
          if (points[i] > biggest) then biggest := points[i];

      for i := 0 to NumPoints-1 do
          points[i] := ((points[i]-biggest)/100)+1;
   end
   else
   begin
      biggest := 0.0;
      for i := 0 to NumPoints-1 do
	  if (points[i] > biggest) then biggest := points[i];

      for i := 0 to NumPoints-1 do
	  points[i] := points[i]/biggest;
   end;
end;

{== TMMFIRFilterItem ==========================================================}
constructor TMMFIRFilterItem.Create;
begin
   inherited Create;

   Ff1 := 0;
   FGain := 0;
   FOnChange := nil;
end;

{-- TMMFIRFilterItem ----------------------------------------------------------}
constructor TMMFIRFilterItem.CreateEx(af1,aGain: Float);
begin
   inherited Create;

   Ff1       := af1;
   FGain     := aGain;
   FOnChange := nil;
end;

{-- TMMFIRFilterItem ----------------------------------------------------------}
procedure TMMFIRFilterItem.Changed;
begin
   if assigned(FOnChange) then FOnChange(Self);
end;

{-- TMMFIRFilterItem ----------------------------------------------------------}
procedure TMMFIRFilterItem.SetParams(af1, aGain: Float);
begin
   if (af1 <> Ff1) or (aGain <> FGain) then
   begin
      Ff1 := af1;
      FGain := aGain;
      Changed;
   end;
end;

{-- TMMFIRFilterItem ----------------------------------------------------------}
procedure TMMFIRFilterItem.SetValue(index: integer; aValue: Float);
var
   af1,aGain: Float;

begin
   af1 := Ff1;
   aGain := FGain;
   case index of
       0: af1 := aValue;
       1: aGain := aValue;
   end;
   SetParams(af1, aGain);
end;

{-- TMMFIRFilterItem ----------------------------------------------------------}
procedure TMMFIRFilterItem.Store(S: TStream);
begin
   S.WriteBuffer(Ff1,SizeOf(Ff1));
   S.WriteBuffer(FGain,SizeOf(FGain));
end;

{-- TMMFIRFilterItem ----------------------------------------------------------}
procedure TMMFIRFilterItem.Load(S: TStream);
var
   af1,aGain: Float;

begin
   S.ReadBuffer(af1,SizeOf(af1));
   S.ReadBuffer(aGain,SizeOf(aGain));
   SetParams(af1,aGain);
end;

{-- TMMFIRFilterItem ----------------------------------------------------------}
procedure TMMFIRFilterItem.Assign(Source: TObject);
begin
   if Source is TMMFIRFilterItem then
   begin
      SetParams(TMMFIRFilterItem(Source).f1,
                TMMFIRFilterItem(Source).Gain);
   end;
end;

{-- TMMFIRFilterList ----------------------------------------------------------}
procedure TMMFIRFilterList.Sort;
var
   i,j,h: integer;
   flt: TMMFIRFilterItem;

begin          { Start Shell-Sort }
   h := 1;
   while h <= Count div 9 do h := h*3 + 1;
   while h > 0 do
   begin
      for i := h to Count-1 do
      begin
         flt := Items[i];
         j := i;
         while (j >= h) and (Items[j-h].f1 > flt.f1) do
         begin
            Items[j] := Items[j-h];
            dec(j, h);
         end;
         Items[j] := flt;
      end;
      h := h div 3;
   end;
end;

{-- TMMFIRFilterList ----------------------------------------------------------}
procedure TMMFIRFilterList.SetFilter(Index: integer; Filter: TMMFIRFilterItem);
begin
   Put(Index, Filter);
end;

{-- TMMFIRFilterList ----------------------------------------------------------}
function TMMFIRFilterList.GetFilter(Index: integer): TMMFIRFilterItem;
begin
   Result := TMMFIRFilterItem(Get(Index));
end;

{-- TMMFIRFilterList ----------------------------------------------------------}
function TMMFIRFilterList.AddObject(Item: TObject): TOLSize;
begin
   Result := inherited AddObject(Item);
   (Item as TMMFIRFilterItem).OnChange := FFIRFilter.FilterChanged;
end;

{-- TMMFIRFilterList ----------------------------------------------------------}
procedure TMMFIRFilterList.Assign(Source: TPersistent);
var
   i: integer;
   Filter: TMMFIRFilterItem;

begin
   if (Source is TMMFIRFilterList) or (Source = nil) then
   begin
      BeginUpdate;
      try
         if (FFIRFilter <> nil) then
             FFIRFilter.FUpdating := True;

         FreeAll;
         if (Source <> nil) then
         begin
            for i := 0 to TMMFIRFilterList(Source).Count-1 do
            begin
               Filter := TMMFIRFilterItem.Create;
               Filter.Assign(TMMFIRFilterList(Source)[i]);
               AddObject(Filter);
            end;
         end;

      finally
         if (FFIRFilter <> nil) then
             FFIRFilter.FUpdating := False;

         EndUpdate;
      end;
   end
   else inherited assign(Source);
end;

{-- TMMFIRFilterList ----------------------------------------------------------}
procedure TMMFIRFilterList.DefineProperties(Filer: TFiler);
begin
   Filer.DefineBinaryProperty('ObjectContainer', ReadData, WriteData, True);
end;

{-- TMMFIRFilterList ----------------------------------------------------------}
procedure TMMFIRFilterList.ReadData(S: TStream);
Var
   pBuf: PChar;
   Kennung: Longint;
   ObjCount,
   Index: TOLSize;
   Destroy: Boolean;
   Value: Longint;

begin
   BeginUpdate;
   try
      FFIRFilter.FUpdating := True;
      S.ReadBuffer(Kennung,sizeOf(STREAMKENNUNG));
      if (Kennung <> STREAMKENNUNG) then
         raise EStreamError.Create('Invalid Object stream');

      FreeAll;

      { load stream items }
      S.ReadBuffer(Destroy,SizeOf(Destroy));
      DestroyObjects := Destroy;

      { read string length }
      S.ReadBuffer(Value,SizeOf(Value));
      if Value > 0 then
      begin
         pBuf := StrAlloc(Value+1);
         try
            FillChar(pBuf^, Value+1, 0);
            S.ReadBuffer(pBuf^, Value);
            FFIRFilter.Description := StrPas(pBuf);
         finally
            StrDispose(pBuf);
         end;
      end;

      S.ReadBuffer(ObjCount,SizeOf(Objcount));  { Read in Object count }
      if Capacity-Count < ObjCount then Capacity := Count+ObjCount;

      { Read in Object Count }
      for Index := 0 to ObjCount-1 do
          AddObject(ReadObjectFromStream(S));

   finally
      FFIRFilter.FUpdating := False;
      EndUpdate;
   end;
end;

{-- TMMFIRFilterList ----------------------------------------------------------}
procedure TMMFIRFilterList.WriteData(S: TStream);
var
   Index,ObjCount: TOlSize;
   Destroy: Boolean;
   Value: Longint;

begin
   { Write list to Stream }
   S.WriteBuffer(STREAMKENNUNG,SizeOf(STREAMKENNUNG));
   Destroy := DestroyObjects;
   S.WriteBuffer(Destroy,SizeOf(Destroy));

   { write string length }
   Value := Length(FFIRFilter.FDescription);
   S.WriteBuffer(Value, SizeOf(Value));
   S.WriteBuffer(PChar(FFIRFilter.FDescription)^, Length(FFIRFilter.FDescription));

   ObjCount := Count;
   S.WriteBuffer(ObjCount,SizeOf(ObjCount));
   for Index := 0 to Count-1 do
       WriteObjectToStream(Items[Index],S);
end;

{== TMMFIRFilter ==============================================================}
constructor TMMFIRFilter.Create(aOwner: TComponent);
begin
   inherited Create(aOwner);

   FFilters := TMMFIRFilterList.Create;
   FFilters.OnChange := FiltersChanged;
   FFilters.FFIRFilter := Self;

   FOpen       := False;
   FEnabled    := defEnabled;
   FPFIR       := nil;
   FPTempFIR   := nil;

   FUpdating   := False;
   FDescription:= 'Untitled';
   Ffs         := defRate;
   FWindow     := defWindow;
   fnCoeffs    := defOrder;
   FChannel    := defChannel;
   FUpdating   := False;
   FResponse   := nil;
   FSpectrum   := nil;
   FTempBuffer := nil;

   CalcFilter;