mmfir.pas

一套及时通讯的原码

   CalcFilter;
end;

{-- TMMFIRFilter --------------------------------------------------------------}
procedure TMMFIRFilter.SetPWaveFormat(aValue: PWaveFormatEx);
begin
   if (aValue <> nil) then
   begin
      if not (csDesigning in ComponentState) then
         if not pcmIsValidFormat(aValue) or (aValue^.wBitsPerSample = 8) then
            raise EMMFIRError.Create(LoadResStr(IDS_INVALIDFORMAT));

      SampleRate := aValue^.nSamplesPerSec;
   end;
   inherited SetPWaveFormat(aValue);
end;

{-- TMMFIRFilter --------------------------------------------------------------}
procedure TMMFIRFilter.Assign(Source: TPersistent);
begin
   if (Source is TMMFIRFilter) then
   begin
      if (Source <> nil) then
      begin
         Channel    := TMMFIRFilter(Source).Channel;
         Enabled    := TMMFIRFilter(Source).Enabled;
         Description:= TMMFIRFilter(Source).Description;
         Order      := TMMFIRFilter(Source).Order;
         Window     := TMMFIRFilter(Source).Window;
         SampleRate := TMMFIRFilter(Source).SampleRate;
         Filters    := TMMFIRFilter(Source).Filters;
      end;
   end;
end;

{-- TMMFIRFilter --------------------------------------------------------------}
procedure TMMFIRFilter.Open;
begin
   if not FOpen then
   begin
      if pcmIsValidFormat(PWaveFormat) then
      begin
         FPFIR := InitFIRFilter(PWaveFormat);
         if (FPFIR = nil) then OutOfMemoryError
         else
         begin
            FTempBuffer := GlobalAllocMem(Max(QUEUE_READ_SIZE,BufferSize));
            FOpen := True;
         end;
      end;
   end;
end;

{-- TMMFIRFilter --------------------------------------------------------------}
procedure TMMFIRFilter.Start;
begin
   UpdateFilter;
end;

{-- TMMFIRFilter --------------------------------------------------------------}
procedure TMMFIRFilter.Close;
begin
   if FOpen then
   begin
      FOpen := False;
      DoneFIRFilter(FPFIR);
      GlobalFreeMem(Pointer(FTempBuffer));
   end;
end;

{-- TMMFIRFilter --------------------------------------------------------------}
procedure TMMFIRFilter.Process(Buffer: PChar; nBytes: Longint);
begin
   { process the buffer trough the delay line }
   if (FPFIR <> nil) then
   begin
      if DoFIRFilterShort(FPFIR, Buffer, FTempBuffer, nBytes) then
         GlobalSynchronize(PcmOverflow);

      GlobalMoveMem(FTempBuffer^,Buffer^,nBytes);
   end;
end;

{-- TMMFIRFilter --------------------------------------------------------------}
function TMMFIRFilter.CleanUp(Buffer: PChar; Length: integer): Longint;
begin
   { process the remaining bytes in the delay lines }
   if (FPFIR <> nil) and (FCleanup > 0) then
   begin
      FCleanup := Max(FCleanup - Length,0);
      FillChar(Buffer^, Length, 0);
      Process(Buffer, Length);
   end;
   { return the remaining bytes to process }
   Result := FCleanup;
end;

{-- TMMFIRFilter --------------------------------------------------------------}
procedure TMMFIRFilter.Opened;
begin
   inherited Opened;

   Open;
end;

{-- TMMFIRFilter --------------------------------------------------------------}
procedure TMMFIRFilter.Closed;
begin
   Close;

   inherited Closed;
end;

{-- TMMFIRFilter --------------------------------------------------------------}
procedure TMMFIRFilter.Started;
begin
   inherited Started;

   Start;
end;

{-- TMMFIRFilter --------------------------------------------------------------}
procedure TMMFIRFilter.BufferReady(lpwh: PWaveHdr);
begin
   if Enabled then
   begin
      Process(lpwh^.lpData,lpwh^.dwBytesRecorded);
   end;

   inherited BufferReady(lpwh);
end;

{-- TMMFIRFilter --------------------------------------------------------------}
procedure TMMFIRFilter.BufferLoad(lpwh: PWaveHdr; var MoreBuffers: Boolean);
var
   aLength: Longint;
begin
   inherited BufferLoad(lpwh, MoreBuffers);

   if Enabled and FOpen then
   begin
      if not MoreBuffers then
      begin
         aLength := lpwh^.dwBufferLength;
         if Cleanup(lpwh^.lpData, aLength) > 0 then MoreBuffers := True;
         lpwh^.dwBytesRecorded := aLength;
      end
      else Process(lpwh^.lpData, lpwh^.dwBytesRecorded);
   end;
end;

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

   Font.Style  := [fsBold];

   Ffs         := defRate;
   FnCoeffs    := 0;
   FGridColor  := defGridColor;
   FAxisColor  := defAxisColor;
   FRespColor  := defRespColor;
   FCoeffColor := defCoeffColor;
   FDBScale    := defDBScale;
   FNormalized := defNormalized;
   FShowCoeffs := defShowCoeffs;
   FScaleColor := defScaleColor;

   Color       := defColor;
   Width       := defWidth;
   Height      := defHeight;

   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;

{-- TMMFIRResponse ------------------------------------------------------------}
destructor TMMFIRResponse.Destroy;
begin

   inherited Destroy;
end;

{-- TMMFIRResponse ------------------------------------------------------------}
procedure TMMFIRResponse.AdjustClientSize;
begin
   FClient := BeveledRect;
   InflateRect(FClient,-30,-30);
end;

{-- TMMFIRResponse ------------------------------------------------------------}
procedure TMMFIRResponse.SetBounds(aLeft, aTop, aWidth, aHeight: integer);
begin
   inherited SetBounds(aLeft, aTop, aWidth, aHeight);

   AdjustClientSize;
end;

{-- TMMFIRResponse ------------------------------------------------------------}
procedure TMMFIRResponse.Changed;
begin
   AdjustClientSize;

   inherited Changed;
end;

{-- TMMFIRResponse ------------------------------------------------------------}
procedure TMMFIRResponse.SetCoeffs(pCoeffs: PFloatArray; nCoeffs: integer);
begin
   FnCoeffs := nCoeffs;
   if (FnCoeffs > 0) then
   begin
      GlobalMoveMem(pCoeffs^,FCoeffs,FnCoeffs*sizeOf(Float));
   end;
   Invalidate;
end;

{-- TMMFIRResponse ------------------------------------------------------------}
procedure TMMFIRResponse.SetBoolean(index: integer; aValue: Boolean);
begin
   case index of
      0: if (FShowCoeffs = aValue) then exit else FShowCoeffs := aValue;
      1: if (FDBScale = aValue) then exit else FDBScale := aValue;
      2: if (FNormalized = aValue) then exit else FNormalized := aValue;
   end;
   Invalidate;
end;

{-- TMMFIRResponse ------------------------------------------------------------}
procedure TMMFIRResponse.SetSampleRate(aValue: Longint);
begin
   if (aValue <> Ffs) then
   begin
      Ffs := MinMax(aValue,4000,100000);
      Invalidate;
   end;
end;

{-- TMMFIRResponse ------------------------------------------------------------}
procedure TMMFIRResponse.SetColors(index: integer; aValue: TColor);
begin
   case index of
       0: if (aValue = FGridColor) then exit else FGridColor := aValue;
       1: if (aValue = FAxisColor) then exit else FAxisColor := aValue;
       2: if (aValue = FRespColor) then exit else FRespColor := aValue;
       3: if (aValue = FCoeffColor) then exit else FCoeffColor := aValue;
       4: if (aValue = FScaleColor) then exit else FScaleColor := aValue;
   end;
   Invalidate;
end;

{-- TMMFIRResponse ------------------------------------------------------------}
procedure TMMFIRResponse.VLineDoted(aCanvas:TCanvas;x,y1,y2:integer;Clr:TColorRef);
var
   DC: HDC;
begin
   DC := aCanvas.Handle;
   if (y1 > y2) then SwapInt(y1,y2);
   while y1 < y2 do
   begin
      SetPixel(DC,x,y1,Clr);
      inc(y1,2);
   end;
end;

{-- TMMFIRResponse ------------------------------------------------------------}
procedure TMMFIRResponse.HLineDoted(aCanvas:TCanvas;x1,x2,y:integer;Clr:TColorRef);
var
   DC: HDC;
begin
   DC := aCanvas.Handle;
   if (x1 > x2) then SwapInt(x1,x2);
   while x1 < x2 do
   begin
      SetPixel(DC,x1,y,Clr);
      inc(x1,2);
   end;
end;

{-- TMMFIRResponse ------------------------------------------------------------}
procedure TMMFIRResponse.DrawBackground(Canvas: TCanvas; Client: TRect);
var
   i,x,y: integer;
   str: string;
   th,tw: integer;
   W,H: integer;
   Clr: Longint;
   NGrids: integer;

begin
   with Canvas,Client do
   begin
      W:= Right-Left;
      H:= Bottom-Top;

      Pen.Color := FAxisColor;
      Font.Color := FScaleColor;

      MoveTo(Left,Top);
      LineTo(Left,Bottom);
      LineTo(Right,Bottom);

      Font := Self.Font;
      SetTextAlign(Handle,TA_BASELINE or TA_CENTER);

(*
      case FFirFunc of
          ffLowPass : str := Format('Low Pass:';
          ffHighPass: str := Format('High Pass:';
          ffBandPass: str := Format('Band Pass:';
          ffBandStop: str := Format('Band Stop: f1 %d, f2 %d, %d taps',[;
          ffUser    : str := Format('User: f1 %d, f2 %d';

      str := Format(str+' Sample rate %d, f1 %d, %d taps',
                    [Ffs,0,FnCoeffs]);
  *)
      str := Format('FIR Filter Response: %f Khz, %d taps',[Ffs/1000,FnCoeffs]);
      TextOut(Left+W div 2,Top-10,str);

      Font.Handle:= CreateFont(-9,0,0,0,FW_NORMAL,0,0,0,DEFAULT_CHARSET,
                               OUT_TT_PRECIS,CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY,
                               VARIABLE_PITCH or FF_SWISS,'arial');

      SetTextAlign(Handle,TA_RIGHT);
      Clr := ColorToRGB(GridColor);

      th := TextHeight('W');
      if FNormalized then
         tw := TextWidth('0.5')
      else
         tw := TextWidth(' '+IntToStr(Ffs div 2));

      { calc the number of steps required }
      NGrids := 20;
      while (H div NGrids < th) or
            (W div NGrids < tw) do
      begin
         NGrids := NGrids div 2;
         if NGrids = 1 then break;
      end;

      for i := 0 to NGrids do
      begin
         y := (H*i)div NGrids;

    	 MoveTo(Left, Top+y);
         LineTo(Left-5, Top+y);

         if (i <> NGrids) then
            HLineDoted(Canvas,Left+1,Left+W,Top+y,Clr);

         if FDBScale then
         begin
	    if (i = 0) then
	       str := '0'
            else
	       str := Format('-%d',[(i*100)div NGrids]);

         end
         else str := Format('%d%',[100-(i*100)div NGrids]);

         TextOut(Left-7,Top+y-(th div 2),str);
      end;

      if FDBScale then
         TextOut(Left-8,Bottom+10,'dB')
      else
         TextOut(Left-7,Bottom+10,'%');

      // mark the frequency scale (linear as a function of sample frequency)
      SetTextAlign(Handle,TA_CENTER or TA_TOP);

      for i := 0 to NGrids do
      begin
         x := (i*W) div NGrids;
         MoveTo(Left+x,Bottom);
         LineTo(Left+x,Bottom+5);

         if (i > 0) then
            VLineDoted(Canvas,Left+x,Top,Top+H,Clr);

         if FNormalized then
            str := Format('%f',[(0.5*i)/NGrids])
         else
            str := Format('%d',[(Ffs div 2)*i div NGrids]);

         TextOut(Left+x,Bottom+10,str);
      end;

      if not FNormalized then
         TextOut(Left+x+(tw div 2)+5,Bottom+10,' Hz');
   end;
end;

{-- TMMFIRResponse ------------------------------------------------------------}
procedure TMMFIRResponse.DrawImpulseResponse(Canvas: TCanvas; Client: TRect);
const
     HS = 4;
var
   W,H,i,ftype: integer;
   coeffs: array[0..4096] of Float;

begin
   if (FnCoeffs > 0) then
   with Canvas,Client do
   begin
      if (FnCoeffs and 1 <> 0) then
          ftype := 1
      else
          ftype := 2;

      H := Bottom-Top;
      W := Right-Left;

      FIR_Response(ftype,FnCoeffs,@FCoeffs,FDBScale,W,@coeffs);
      FIR_NormaliseResponse(FDBScale,W,@coeffs);

      Pen.Color := FRespColor;
      MoveTo(Left,Bottom-Trunc(coeffs[0]*H));
      for i := 0 to W-1 do
      begin
         LineTo(Left+i,Bottom-Trunc(coeffs[i]*H));
      end;

      if FShowCoeffs then
      begin
         // last thing: draw the filter itself
         Pen.Color := FCoeffColor;
         MoveTo(Left,Bottom-Trunc(FCoeffs[0]));
         if (FnCoeffs > 1) then
         for i := 0 to FnCoeffs-1 do
         begin
            LineTo(Left+(W*i)div (FnCoeffs-1),
                   Bottom-Trunc(FCoeffs[i]*H));
         end;
      end;
   end;
end;

{-- TMMFIRResponse ------------------------------------------------------------}
procedure TMMFIRResponse.Paint;
begin
   inherited Paint;

   DrawBackground(Canvas,FClient);
   DrawImpulseResponse(Canvas,FClient);
end;

Initialization
   { register filter class for streaming ! }
   DoRegisterClass(@TMMFIRFilterItem.Load,
                   @TMMFIRFilterItem.Store,
                    TMMFIRFilterItem);
end.