winplot.pas

Delphi 的数学控件

{ **********************************************************************
  *                          Unit WINPLOT.PAS                          *
  *                            Version 1.3d                            *
  *                      (c) J. Debord, May 2002                       *
  **********************************************************************
                      Plotting routines for DELPHI
  ********************************************************************** }

unit winplot;

interface

uses
  { DELPHI units }
  WinTypes,
  Graphics,
  { TPMath units }
  fmath,
  matrices,
  pastring,
  plotvar;

const
  MAXCOLOR = 10;

const
  CurvColor : array[1..MAXCOLOR] of TColor =
    (clRed,
     clGreen,
     clBlue,
     clFuchsia,
     clAqua,
     clLime,
     clNavy,
     clOlive,
     clPurple,
     clTeal);

type     
  TPointParam = record         { Point parameters }
    Symbol : Integer;          { Symbol index }
    Size   : Integer;          { Symbol size in 1/250 of graphic width }
    Color  : TColor;
  end;

  TLineParam = record          { Line parameters }
    Width : Integer;
    Style : TPenStyle;
    Color : TColor;
  end;

  TCurvParam = record          { Curve parameters }
    PointParam : TPointParam;
    LineParam  : TLineParam;
    Legend     : String[30];   { Legend of curve }
    Step       : Integer;      { Plot 1 point every Step points }
    Connect    : Boolean;      { Connect points with line? }
  end;

  TCurvParamVector = array of TCurvParam;

procedure InitGraph(Canvas        : TCanvas;
                    Width, Height : Integer);
{ ----------------------------------------------------------------------
  Initializes the graphic
  ----------------------------------------------------------------------
  The parameters refer to the object on which the graphic is plotted.

  Examples:

  To draw on a TImage object:
  InitGraph(Image1.Canvas, Image1.Width, Image1.Height);

  To print the graphic:
  InitGraph(Printer.Canvas, Printer.PageWidth, Printer.PageHeight);
  ---------------------------------------------------------------------- }

procedure PlotXAxis(Canvas : TCanvas);
{ ----------------------------------------------------------------------
  Plots the X axis
  ---------------------------------------------------------------------- }

procedure PlotYAxis(Canvas : TCanvas);
{ ----------------------------------------------------------------------
  Plots the Y axis
  ---------------------------------------------------------------------- }

procedure WriteTitle(Canvas : TCanvas);
{ ----------------------------------------------------------------------
  Writes the title of the graph
  ---------------------------------------------------------------------- }

procedure PlotGrid(Canvas : TCanvas);
{ ----------------------------------------------------------------------
  Plots a grid on the graph
  ---------------------------------------------------------------------- }

procedure PlotPoint(Canvas     : TCanvas;
                    X, Y       : Float;
                    PointParam : TPointParam);
{ ----------------------------------------------------------------------
  Plots a point
  ----------------------------------------------------------------------
  X, Y       : point coordinates
  PointParam : point parameters
  ---------------------------------------------------------------------- }

procedure PlotCurve(Canvas         : TCanvas;
                    X, Y           : TVector;
                    Lbound, Ubound : Integer;
                    CurvParam      : TCurvParam);
{ ----------------------------------------------------------------------
  Plots a curve
  ----------------------------------------------------------------------
  X, Y           : point coordinates
  Lbound, Ubound : indices of first and last points
  CurvParam      : curve parameters
  ---------------------------------------------------------------------- }

procedure PlotCurveWithErrorBars(Canvas         : TCanvas;
                                 X, Y, S        : TVector;
                                 Ns             : Integer;
                                 Lbound, Ubound : Integer;
                                 CurvParam      : TCurvParam);
{ ----------------------------------------------------------------------
  Plots a curve with error bars
  ----------------------------------------------------------------------
  X, Y           : point coordinates
  S              : errors (e.g. standard deviations)
  Ns             : error multiplier (e.g. 2 for plotting 2 SD's) 
  Lbound, Ubound : indices of first and last points
  CurvParam      : curve parameters
  ---------------------------------------------------------------------- }

procedure PlotFunc(Canvas     : TCanvas;
                   Func       : TFunc;
                   Xmin, Xmax : Float;
                   Npt        : Integer;
                   LineParam  : TLineParam);
{ ----------------------------------------------------------------------
  Plots a function
  ----------------------------------------------------------------------
  Func       : function to be plotted
               must be programmed as: function Func(X : Float) : Float;
  Xmin, Xmax : abscissae of 1st and last point to plot
  Npt        : number of points
  LineParam  : line parameters
  ---------------------------------------------------------------------- }

procedure WriteLegend(Canvas     : TCanvas;
                      NCurv      : Integer;
                      CurvParam  : TCurvParamVector;
                      ShowPoints,
                      ShowLines  : Boolean);
{ ----------------------------------------------------------------------
  Writes the legends for the plotted curves
  ----------------------------------------------------------------------
  NCurv      : number of curves
  CurvParam  : curve parameters
  ShowPoints : for displaying points
  ShowLines  : for displaying lines
  ---------------------------------------------------------------------- }

procedure DimCurvParamVector(var CurvParam : TCurvParamVector;
                             Ubound : Integer);
{ ----------------------------------------------------------------------
  Creates a vector of curve parameters: CurvParam[0..Ubound]
  ---------------------------------------------------------------------- }

function Xpixel(X : Float) : Integer;
{ ----------------------------------------------------------------------
  Converts user abscissa X to screen coordinate
  ---------------------------------------------------------------------- }

function Ypixel(Y : Float) : Integer;
{ ----------------------------------------------------------------------
  Converts user ordinate Y to screen coordinate
  ---------------------------------------------------------------------- }

function Xuser(X : Integer) : Float;
{ ----------------------------------------------------------------------
  Converts screen coordinate X to user abscissa
  ---------------------------------------------------------------------- }

function Yuser(Y : Integer) : Float;
{ ----------------------------------------------------------------------
  Converts screen coordinate Y to user ordinate
  ---------------------------------------------------------------------- }

implementation

uses
  Classes, SysUtils;

const
  MAXPIXEL = 30000;

var
  GraphWidth, GraphHeight, SymbolSizeUnit : Integer;

  XminPixel, YminPixel : Integer;  { Pixel coord. of upper left corner }
  XmaxPixel, YmaxPixel : Integer;  { Pixel coord. of lower right corner }
  FactX, FactY         : Float;    { Scaling factors }
  HugeX, HugeY         : Float;    { Max. values of X and Y }

  function Xpixel(X : Float) : Integer;
  var
    Delta : Float;
  begin
    Delta := X - XAxis.Min;
    if Abs(Delta) > HugeX then
      Xpixel := MAXPIXEL
    else
      Xpixel := Round(FactX * Delta) + XminPixel;
  end;

  function Ypixel(Y : Float) : Integer;
  var
    Delta : Float;
  begin
    Delta := YAxis.Max - Y;
    if Abs(Delta) > HugeY then
      Ypixel := MAXPIXEL
    else
      Ypixel := Round(FactY * Delta) + YminPixel;
  end;

  function Xuser(X : Integer) : Float;
  begin
    Xuser := XAxis.Min + (X - XminPixel) / FactX;
  end;

  function Yuser(Y : Integer) : Float;
  begin
    Yuser := YAxis.Max - (Y - YminPixel) / FactY;
  end;

  procedure PlotXAxis(Canvas : TCanvas);
  var
    W, X, Z : Float;
    N, I, J, TickLength, MinorTickLength, Wp, Xp : Integer;
    XLabel : String;
    NSZ : Boolean;
  begin
    TickLength := Canvas.TextHeight('M') div 2;
    MinorTickLength := Round(0.67 * TickLength);  { For log scale }

    { Draw axis }
    Canvas.MoveTo(XminPixel, YmaxPixel);
    Canvas.LineTo(XmaxPixel, YmaxPixel);

    NSZ := NSZero;
    NSZero := False;    { Don't write non significant zero's }

    N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); { Nb of intervals }

    X := XAxis.Min;     { Tick mark position }
    for I := 0 to N do  { Label axis }
      begin
        if (XAxis.Scale = LIN_SCALE) and (Abs(X) < EPS) then X := 0.0;
        Xp := Xpixel(X);

        { Draw tick mark }
        Canvas.MoveTo(Xp, YmaxPixel);
        Canvas.LineTo(Xp, YmaxPixel + TickLength);

        { Write label }
        if XAxis.Scale = LIN_SCALE then Z := X else Z := Exp10(X);
        XLabel := Trim(Float2Str(Z));
        Canvas.TextOut(Xp - Canvas.TextWidth(XLabel) div 2,
                       YmaxPixel + TickLength, XLabel);

        { Plot minor divisions on logarithmic scale }
        if (XAxis.Scale = LOG_SCALE) and (I < N) then
          for J := 2 to 9 do
            begin
              W := X + Log10(J);
              Wp := Xpixel(W);
              Canvas.MoveTo(Wp, YmaxPixel);
              Canvas.LineTo(Wp, YmaxPixel + MinorTickLength);
            end;
        X := X + XAxis.Step;
      end;

    NSZero := NSZ;

    { Write axis title }
    if XAxis.Title <> '' then
      Canvas.TextOut(XminPixel + (XmaxPixel - XminPixel -
                          Canvas.TextWidth(XAxis.Title)) div 2,
                     YmaxPixel + 2 * Canvas.TextHeight('M'),
                     XAxis.Title);
  end;

  procedure PlotYAxis(Canvas : TCanvas);
  var
    W, Y, Z : Float;
    N, I, J, Wp, Yp : Integer;
    TickLength, MinorTickLength, Yoffset : Integer;
    YLabel : String;
    NSZ : Boolean;
  begin
    TickLength := Canvas.TextWidth('M') div 2;
    MinorTickLength := Round(0.67 * TickLength);  { For log scale }

    Yoffset := Canvas.TextHeight('M') div 2;

    { Draw axis }
    Canvas.MoveTo(XminPixel, YminPixel);
    Canvas.LineTo(XminPixel, YmaxPixel);

    NSZ := NSZero;
    NSZero := False;    { Don't write non significant zero's }

    N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); { Nb of intervals }

    Y := YAxis.Min;     { Tick mark position }
    for I := 0 to N do  { Label axis }
      begin
        if (YAxis.Scale = LIN_SCALE) and (Abs(Y) < EPS) then Y := 0.0;
        Yp := Ypixel(Y);

        { Draw tick mark }
        Canvas.MoveTo(XminPixel, Yp);
        Canvas.LineTo(XminPixel - TickLength, Yp);

        { Write label }
        if YAxis.Scale = LIN_SCALE then Z := Y else Z := Exp10(Y);
        YLabel := Trim(Float2Str(Z));
        Canvas.TextOut(XminPixel - TickLength - Canvas.TextWidth(YLabel),
                       Yp - Yoffset, YLabel);

        { Plot minor divisions on logarithmic scale }
        if (YAxis.Scale = LOG_SCALE) and (I < N) then
          for J := 2 to 9 do
            begin
              W := Y + Log10(J);
              Wp := Ypixel(W);
              Canvas.MoveTo(XminPixel, Wp);
              Canvas.LineTo(XminPixel - MinorTickLength, Wp);
            end;
        Y := Y + YAxis.Step;
      end;

    NSZero := NSZ;

    { Write axis title }
    if YAxis.Title <> '' then
      Canvas.TextOut(XminPixel, YminPixel - 3 * Yoffset, YAxis.Title);
  end;

  procedure InitGraph(Canvas : TCanvas; Width, Height : Integer);
  begin
    GraphWidth := Width;
    GraphHeight := Height;
    SymbolSizeUnit := GraphWidth div 250;

    XminPixel := Round(Xwin1 / 100 * Width);
    YminPixel := Round(Ywin1 / 100 * Height);
    XmaxPixel := Round(Xwin2 / 100 * Width);
    YmaxPixel := Round(Ywin2 / 100 * Height);

    FactX := (XmaxPixel - XminPixel) / (XAxis.Max - XAxis.Min);
    FactY := (YmaxPixel - YminPixel) / (YAxis.Max - YAxis.Min);

    HugeX := MAXPIXEL / FactX;
    HugeY := MAXPIXEL / FactY;

    if GraphBorder then
      Canvas.Rectangle(XminPixel, YminPixel, Succ(XmaxPixel), Succ(YmaxPixel));
  end;

  procedure WriteTitle(Canvas : TCanvas);
  begin
    if GraphTitle <> '' then
      with Canvas do
        TextOut((XminPixel + XmaxPixel - TextWidth(GraphTitle)) div 2,
                 YminPixel - 2 * TextHeight(GraphTitle), GraphTitle);
  end;

  procedure PlotGrid(Canvas : TCanvas);
  var
    X, Y : Float;
    I, N, Xp, Yp : Integer;
    PenStyle : TpenStyle;
  begin
    { Save current settings }
    PenStyle := Canvas.Pen.Style;
    Canvas.Pen.Style := psDot;

    if Grid in [HORIZ_GRID, BOTH_GRID] then  { Horizontal lines }
      begin
        N := Round((YAxis.Max - YAxis.Min) / YAxis.Step);  { Nb of intervals }
        for I := 1 to Pred(N) do
          begin
            Y := YAxis.Min + I * YAxis.Step;  { Origin of line }
            Yp := Ypixel(Y);
            Canvas.MoveTo(XminPixel, Yp);
            Canvas.LineTo(XmaxPixel, Yp);
          end;
      end;

    if Grid in [VERTIC_GRID, BOTH_GRID] then  { Vertical lines }
      begin
        N := Round((XAxis.Max - XAxis.Min) / XAxis.Step);
        for I := 1 to Pred(N) do
          begin
            X := XAxis.Min + I * XAxis.Step;
            Xp := Xpixel(X);
            Canvas.MoveTo(Xp, YminPixel);
            Canvas.LineTo(Xp, YmaxPixel);
          end;
      end;

    { Restore settings }
    Canvas.Pen.Style := PenStyle;
  end;

  function XOutOfBounds(X : Integer) : Boolean;
  { Checks if an absissa is outside the graphic bounds }
  begin
    XOutOfBounds := (X < XminPixel) or (X > XmaxPixel);
  end;

  function YOutOfBounds(Y : Integer) : Boolean;
  { Checks if an ordinate is outside the graphic bounds }
  begin
    YOutOfBounds := (Y < YminPixel) or (Y > YmaxPixel);
  end;

  function CheckPoint(X, Y       : Float;
                      var Xp, Yp : Integer) : Boolean;
  { Computes the pixel coordinates of a point and
    checks if it is enclosed within the graph limits }
  begin
    Xp := Xpixel(X);
    Yp := Ypixel(Y);