sgr_scale.pas

图形控件,画实时曲线,等操作方便

unit sgr_scale;
{(c) S.P.Pod'yachev 1998-2001}
{ver. 2.4   8.02.2001}
{***************************************************}
{ Auxiliary persistent objects for using            }
{ in components with scale and axis                 }
{***************************************************}
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics;
Type
Tsp_CustomLineAttr=class(TPersistent)
private
 fColor:TColor;
 fStyle:TPenStyle;
 fWidth:word;
 fMode:TPenMode;
 fVisible:boolean;
 fOnChange:TNotifyEvent;
 procedure SetColor(const V:TColor);
 procedure SetStyle(const V:TPenStyle);
 procedure SetWidth(const V:word);
 procedure SetMode(const V:TPenMode);
 procedure SetVisible(const V:boolean);
protected
 procedure Changed; virtual;
public
 constructor Create;
 procedure Assign(Source: TPersistent); override;
 procedure AssignTo(Dest: TPersistent); override;
 procedure SetPenAttr(const APen:TPen);
 property Color:TColor read fColor write SetColor;
 property Style:TPenStyle read fStyle write SetStyle;
 property Width:word read fWidth write SetWidth;
 property Mode:TPenMode read fMode write SetMode;
 property Visible:boolean read fVisible write SetVisible;
 property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
Const
dblDfltAxisMin=0.0; dblDfltAxisMax=10.0;
Type
Tsp_LineAttr=class(Tsp_CustomLineAttr)
public
function IsSame(const LA:Tsp_CustomLineAttr):boolean;
published
 property Color;
 property Style default psSolid;
 property Width default 1;
 property Visible;
end;
Const
 MaxTicksCount=21;
 fbposVertical=0;
 fbposInversed=1;
 fbposNegMetr=2; 
 fbposNoTicks=3; 
 fbposNoTicksLabel=4;
 fbposRevertTicks=5; 
 fbposAutoMin=6;     
 fbposAutoMax=7;
 fbposLabelAsDate=8; 
 fbposNotAjustedTicks=9;
 sdfVertical=1 shl fbposVertical;
 sdfInversed=1 shl fbposInversed;
 sdfNegMetr=1 shl fbposNegMetr;
 sdfNoTicks=1 shl fbposNoTicks;  
 sdfNoTicksLabel=1 shl fbposNoTicksLabel;
 sdfRevertTicks=1 shl fbposRevertTicks;  
 sdfLabelAtTop=sdfRevertTicks; 
 sdfLabelOnRight=sdfRevertTicks;
 sdfAutoMin=1 shl fbposAutoMin; 
 sdfAutoMax=1 shl fbposAutoMax;
 sdfLabelAsDate=1 shl fbposLabelAsDate;
 sdfNotAjustedTicks=1 shl fbposNotAjustedTicks;
Type
Tsp_Scale = class(TPersistent)
private
 IMin, IMax : double;
 IntFactor : double; 
 IStep:integer;      
 rTksCount: Byte;    
 fOPos:integer;      
 fOVal   : double;   
 fM: Double;         
 procedure ReadFlags(Reader: TReader);
 procedure WriteFlags(Writer: TWriter);
 procedure ReadLinePos(Reader: TReader);
 procedure WriteLinePos(Writer: TWriter);
 procedure ReadMin(Reader: TReader);
 procedure WriteMin(Writer: TWriter);
 procedure ReadMax(Reader: TReader);
 procedure WriteMax(Writer: TWriter);
 function  GetVisible:boolean;
 function  GetOX: integer;  //2.4 add for C++
 function  GetOY: integer;  
protected
 fFlags:integer;  
 fO:TPoint;       
 fLen:integer;    
 fTicksCount:Byte;
 fLabelFormat: string;  
 fLineAttr:Tsp_LineAttr;
 fMin, fMax: double;    
 fInterval: double;     
 fTksPos: array [0..MaxTicksCount-1] of smallInt; 
 fTksDbl: array [0..MaxTicksCount-1] of double;   
 function TksDbl(i:integer):double;               
 procedure DefineProperties(Filer: TFiler); override;
 procedure FixMinMax(Mi,Ma:double);
 procedure CalcMetr;
 procedure CalcTicksVal;
 procedure CalcTicksPos;
 procedure ShiftScaleBy(pixel:boolean; idelta:double; fdelta:double);
 function  TickLabel(tickNum:integer): string; virtual;
 function  GetTicksCount:byte;
 procedure SetFlagBit(const BN:integer; const On:boolean);
 procedure ReSetFlagBit(const BN:integer; const Off:boolean);
 function  GetFlagBit(const BN:integer):boolean;
 function  NotFlagBit(const BN:integer):boolean;
 procedure FlagsChanged(const BN:integer; const On:boolean); virtual;
public
 constructor Create(Flags:integer);
 destructor Destroy; override;
 function BandWidth(FntWidth, FntHeight:integer):integer;
 function OrgIndent(FntWidth, FntHeight:integer):integer;
 function EndIndent(FntWidth, FntHeight:integer):integer;
 function CalcDrawBounds(fCanvas:TCanvas):TRect;
 procedure DrawLine(fCanvas:TCanvas; odec, einc:word);
 procedure DrawTicks(fCanvas:TCanvas);
 procedure SetLine(oX, oY, lLen:integer);
 procedure ChangeMinMax(aMin,aMax:double);
 procedure ScrollBy(delta:integer);
 function V2P(const V:double):integer;
 function P2V(const V:integer):double;
 property OPos:integer read fOPos;
 property OVal:double  read fOVal;
 property SM:double read fM;
 property Visible: boolean read GetVisible;
 property OX:integer read GetOX;
 property OY:integer read GetOY;
 property Len:integer read fLen;
 property NoTicks:boolean index fbposNoTicks read GetFlagBit
                                               write SetFlagBit stored False;
published
 property Inversed:boolean index fbposInversed read GetFlagBit
                                                write SetFlagBit stored False;
 property NoTicksLabel:boolean index fbposNoTicksLabel read GetFlagBit
                                               write SetFlagBit stored False;
 property TicksAdjusted:boolean index fbposNotAjustedTicks read NotFlagBit
                                               write ReSetFlagBit stored False;
 property TicksLines:boolean index fbposNoTicks read NotFlagBit
                                               write ReSetFlagBit stored False;
end;
IMPLEMENTATION
procedure Tsp_CustomLineAttr.Changed;
begin
 if Assigned(fOnChange) then fOnChange(Self);
end;
procedure Tsp_CustomLineAttr.SetColor(const V:TColor);
begin
 if V<>fColor then fColor:=V;
 Changed;
end;
procedure Tsp_CustomLineAttr.SetStyle(const V:TPenStyle);
begin
 if V<>fStyle then fStyle:=V;
 Changed;
end;
procedure Tsp_CustomLineAttr.SetWidth(const V:word);
begin
 if V<>fWidth then fWidth:=V;
 Changed;
end;
procedure Tsp_CustomLineAttr.SetVisible(const V:boolean);
begin
 if V<>fVisible then fVisible:=V;
 Changed;
end;
procedure Tsp_CustomLineAttr.SetMode(const V:TPenMode);
begin
 if V<>fMode then fMode:=V;
 Changed;
end;
constructor Tsp_CustomLineAttr.Create;
begin
 inherited Create;
 fOnChange:=nil;
 fColor:=clBlack;
 fStyle:=psSolid;
 fWidth:=1;
 fVisible:=True;
end;
procedure Tsp_CustomLineAttr.Assign(Source: TPersistent);
var ss:Tsp_CustomLineAttr;
begin
 if Source is Tsp_CustomLineAttr then
 begin
   ss:=Tsp_CustomLineAttr(Source);
   fColor:=ss.fColor;
   fStyle:=ss.fStyle;
   fWidth:=ss.fWidth;
   fVisible:=ss.fVisible;
 end else inherited Assign(Source);
end;
procedure Tsp_CustomLineAttr.AssignTo(Dest: TPersistent);
begin
 if Dest is Tsp_CustomLineAttr then Dest.Assign(Self)
 else inherited AssignTo(Dest);
end;
procedure Tsp_CustomLineAttr.SetPenAttr(const APen:TPen);
begin
 with APen do begin
  Color:=fColor;
  Style:=fStyle;
  Width:=fWidth;
  Mode:=pmCopy;
 end;
end;
function Tsp_LineAttr.IsSame(const LA:Tsp_CustomLineAttr):boolean;
begin
 with LA do
 Result:=(fColor= Color) and (fStyle= Style) and
         (fWidth= Width) and (fVisible= Visible);
end;
Const
 Ln10=2.30258509299405;
 sdfLineOnly=sdfNoTicks or sdfNoTicksLabel;
function Floor(x:double):double;
begin
 if Frac(x)<0 then Result:=Int(x)-1 else Result:=Int(x);
end;
function Ceil(x:double):double;
begin
 if Frac(x)>0 then Result:=Int(x)+1 else Result:=Int(x);
end;
procedure Tsp_Scale.ReadFlags(Reader: TReader);
begin
 fFlags:=Reader.ReadInteger;
end;
procedure Tsp_Scale.ReadLinePos(Reader: TReader);
begin
 with Reader do begin
   ReadListBegin;
   fO.x:=ReadInteger; fO.y:=ReadInteger; fLen:=ReadInteger;
   ReadListEnd;
 end
end;
procedure Tsp_Scale.ReadMin(Reader: TReader);
begin
 fMin:=Reader.ReadFloat;
end;
procedure Tsp_Scale.ReadMax(Reader: TReader);
begin
 ChangeMinMax(fMin,Reader.ReadFloat);                   
end;
procedure Tsp_Scale.WriteFlags(Writer: TWriter);
begin
 Writer.WriteInteger(fFlags)
end;
procedure Tsp_Scale.WriteLinePos(writer: TWriter);
begin
 with Writer do begin
  WriteListBegin;
  WriteInteger(fO.x);
  WriteInteger(fO.y);
  WriteInteger(fLen);
  WriteListEnd;
 end;
end;
procedure Tsp_Scale.WriteMin(Writer: TWriter);
begin
 Writer.WriteFloat(fMin)
end;
procedure Tsp_Scale.WriteMax(Writer: TWriter);
begin
 Writer.WriteFloat(fMax)
end;
function Tsp_Scale.GetVisible:boolean;
begin
 Result:=((fFlags and sdfLineOnly)<>sdfLineOnly) or fLineAttr.Visible;
end;
function Tsp_Scale.GetOX: integer; 
 begin Result := fO.x;
end;
function Tsp_Scale.GetOY: integer;
 begin Result := fO.y;
end;
function Tsp_Scale.TksDbl(i:integer):double;                        
begin
 if (fFlags and sdfNotAjustedTicks)=0 then Result:=fTksDbl[i]
 else if (fFlags and sdfInversed)=0 then Result:=fOVal+fInterval*fTksDbl[i]
      else Result:=fOVal-fInterval*fTksDbl[i];
end;
procedure Tsp_Scale.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(filer);
  Filer.DefineProperty('SFlags', ReadFlags, WriteFlags, True);
  Filer.DefineProperty('SLinePos', ReadLinePos, WriteLinePos, True);
  Filer.DefineProperty('fMin', ReadMin, WriteMin, fMin<>dblDfltAxisMin);
  Filer.DefineProperty('fMax', ReadMax, WriteMax, True);
end;
procedure Tsp_Scale.FixMinMax(Mi,Ma:double);
var  DecmlPos:integer;
begin
 if Mi>Ma then begin fMin:=Ma; fMax:=Mi end
 else begin fMin:=Mi; fMax:=Ma end;
 if fMin=fMax then begin
   if abs(fMax)<10 then begin
     fMax:=fMax+1; fMin:=fMax-1
   end else begin
     fMax:=fMax+abs(fMax)/10; fMin:=fMax-abs(fMax)/10;
   end;
 end;
 fInterval:=fMax-fMin;
 DecmlPos:=Trunc(Floor(Ln(fInterval)/Ln10));
 if DecmlPos>0 then IntFactor:=1/Int(exp((DecmlPos-1)*Ln10))
 else IntFactor:=Int(exp(-(DecmlPos-1)*Ln10));
 IMin:=Ceil(fMin*IntFactor);                                          
 IMax:=Floor(fMax*IntFactor);                                          
end;
procedure Tsp_Scale.CalcMetr;
begin
 if (fFlags and sdfInversed)=0 then begin
   fM:=fLen/fInterval;  fOVal:=fMin;
 end else begin
   fM:=-fLen/fInterval; fOVal:=fMax;
 end;
 if (fFlags and sdfVertical)=0 then fOPos:=fO.x
 else begin fOPos:=fO.y; fM:=-fM; end;
end;
procedure Tsp_Scale.CalcTicksVal;
  procedure LbldTicksVal;
  var j, sstep:integer; oid:double;
  begin
   if fTicksCount>1 then begin
      j:=Round(IMax-IMin);                         
      IStep:=j div (fTicksCount-1);
      if IStep=0 then inc(IStep);
      rTksCount:=(j div IStep)+1;
      if rTksCount>MaxTicksCount then rTksCount:=MaxTicksCount;
    end else IStep:=Round(IMax-IMin);
    if (fFlags and sdfInversed)=0 then begin oid:=IMin; sstep:=IStep; end
    else begin oid:=IMax; sstep:=-IStep; end;
    for j:=0 to rTksCount-1 do fTksDbl[j]:=Int(oid+sstep*j)/IntFactor;
  end;
  procedure TicksVal;
  var j:integer; step:double;
  begin
    if fTicksCount>1 then step:=1/(fTicksCount-1)
    else step:=1;
    for j:=0 to fTicksCount-1 do fTksDbl[j]:=step*j;
  end;
begin               
 rTksCount:=fTicksCount;
 if fTicksCount>0 then
  if (fFlags and (sdfNoTicksLabel or sdfNotAjustedTicks))=0 then LbldTicksVal
  else TicksVal;
end;                
procedure Tsp_Scale.CalcTicksPos;
  procedure LbldTicks;
  var j:integer;
  begin
   for j:=0 to rTksCount-1 do fTksPos[j]:=V2P(fTksDbl[j]);
  end;
  procedure NoLbldTicks;
  var j:integer;