winplot.pas

Delphi 的数学控件

    CheckPoint := not(XOutOfBounds(Xp) or YOutOfBounds(Yp));
  end;

  procedure PlotSymbol(Canvas       : TCanvas;
                       Xp, Yp       : Integer;
                       Symbol, Size : Integer);
  { Plots a symbol at pixel coordinates (Xp, Yp)
    with the current canvas settings }
  var
    Xp1, Xp2, Yp1, Yp2 : Integer;
  begin
    if (Symbol < 0) or (Symbol > MAXSYMBOL) then Exit;

    Size := Size * SymbolSizeUnit;
    Xp1 := Xp - Size;
    Yp1 := Yp - Size;
    Xp2 := Xp + Size + 1;
    Yp2 := Yp + Size + 1;

    with Canvas do
      case Symbol of
        0    : Pixels[Xp, Yp] := Brush.Color;
        1, 2 : Ellipse(Xp1, Yp1, Xp2, Yp2);    { Circle }
        3, 4 : Rectangle(Xp1, Yp1, Xp2, Yp2);  { Square }
        5, 6 : Polygon([Point(Xp1, Yp2 - 1),
                        Point(Xp2, Yp2 - 1),
                        Point(Xp, Yp1 - 1)]);  { Triangle }
        7 : begin                              { + }
              MoveTo(Xp, Yp1);
              LineTo(Xp, Yp2);
              MoveTo(Xp1, Yp);
              LineTo(Xp2, Yp);
            end;
        8 : begin                              { x }
              MoveTo(Xp1, Yp1);
              LineTo(Xp2, Yp2);
              MoveTo(Xp1, Yp2 - 1);
              LineTo(Xp2, Yp1 - 1);
            end;
        9 : begin                              { * }
              MoveTo(Xp, Yp1);
              LineTo(Xp, Yp2);
              MoveTo(Xp1, Yp);
              LineTo(Xp2, Yp);
              MoveTo(Xp1, Yp1);
              LineTo(Xp2, Yp2);
              MoveTo(Xp1, Yp2 - 1);
              LineTo(Xp2, Yp1 - 1);
            end;
        end;
  end;

  procedure PlotLine(Canvas             : TCanvas;
                     Xp1, Yp1, Xp2, Yp2 : Integer);
  { Plots a line with the current canvas settings }
  begin
    Canvas.MoveTo(Xp1, Yp1);
    Canvas.LineTo(Xp2, Yp2);
  end;

  procedure PlotPoint(Canvas     : TCanvas;
                      X, Y       : Float;
                      PointParam : TPointParam);
  var
    Xp, Yp : Integer;
    BrushStyle : TBrushStyle;
    PenColor, BrushColor : TColor;
  begin
    if XAxis.Scale = LOG_SCALE then X := Log10(X);
    if YAxis.Scale = LOG_SCALE then Y := Log10(Y);

    if not CheckPoint(X, Y, Xp, Yp) then Exit;

    with Canvas do
      begin
        { Save current settings }
        PenColor := Pen.Color;
        BrushColor := Brush.Color;
        BrushStyle := Brush.Style;

        Pen.Color := PointParam.Color;
        Brush.Color := PointParam.Color;
        if PointParam.Symbol in [0, 1, 3, 5] then
          Brush.Style := bsSolid
        else
          Brush.Style := bsClear;

        PlotSymbol(Canvas, Xp, Yp, PointParam.Symbol, PointParam.Size);

        { Restore settings }
        Pen.Color := PenColor;
        Brush.Color := BrushColor;
        Brush.Style := BrushStyle;
      end;
  end;

  procedure PlotErrorBar(Canvas       : TCanvas;
                         Y, S         : Float;
                         Ns           : Integer;
                         Xp, Yp, Size : Integer);
  { Plots an error bar with the current canvas settings }
  var
    Delta, Y1 : Float;
    Yp1 : Integer;
  begin
    Size := Size * SymbolSizeUnit;

    Delta := Ns * S;
    Y1 := Y - Delta;
    if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1);
    Yp1 := Ypixel(Y1);

    if Yp1 <= YmaxPixel then
      begin
        PlotLine(Canvas, Xp - Size, Yp1, Xp + Size + 1, Yp1);
        PlotLine(Canvas, Xp, Yp, Xp, Yp1);
      end
    else
      PlotLine(Canvas, Xp, Yp, Xp, YmaxPixel);

    Y1 := Y + Delta;
    if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1);
    Yp1 := Ypixel(Y1);

    if Yp1 >= YminPixel then
      begin
        PlotLine(Canvas, Xp - Size, Yp1, Xp + Size + 1, Yp1);
        PlotLine(Canvas, Xp, Yp, Xp, Yp1);
      end
    else
      PlotLine(Canvas, Xp, Yp, Xp, YminPixel);
  end;

  procedure GenPlotCurve(Canvas         : TCanvas;
                         X, Y, S        : TVector;
                         Ns             : Integer;
                         Lbound, Ubound : Integer;
                         CurvParam      : TCurvParam;
                         ErrorBars      : Boolean);
  { General curve plotting routine }
  var
    X1, Y1, X2, Y2 : Float;
    Xp1, Yp1, Xp2, Yp2 : Integer;
    I : Integer;
    Flag1, Flag2 : Boolean;
    PenWidth : Integer;
    PenStyle : TpenStyle;
    PenColor, BrushColor : TColor;
    BrushStyle : TBrushStyle;
  begin
    with Canvas do
      begin
        { Save current settings }
        PenColor := Pen.Color;
        PenStyle := Pen.Style;
        PenWidth := Pen.Width;
        BrushColor := Brush.Color;
        BrushStyle := Brush.Style;

        Pen.Color := CurvParam.LineParam.Color;
        Pen.Style := CurvParam.LineParam.Style;
        Pen.Width := CurvParam.LineParam.Width;
        Brush.Color := CurvParam.PointParam.Color;

        if CurvParam.PointParam.Symbol in [0, 1, 3, 5] then
          Brush.Style := bsSolid
        else
          Brush.Style := bsClear;

        { Plot first point }
        X1 := X[Lbound]; if XAxis.Scale = LOG_SCALE then X1 := Log10(X1);
        Y1 := Y[Lbound]; if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1);
        Flag1 := CheckPoint(X1, Y1, Xp1, Yp1);
        if Flag1 then
          begin
            PlotSymbol(Canvas, Xp1, Yp1, CurvParam.PointParam.Symbol,
                                 CurvParam.PointParam.Size);
            if ErrorBars and (S[Lbound] > 0.0) then
              PlotErrorBar(Canvas, Y[Lbound], S[Lbound], Ns, Xp1, Yp1,
                                 CurvParam.PointParam.Size);
          end;

        { Plot other points and connect them by lines if necessary }
        I := Lbound + CurvParam.Step;
        while I <= Ubound do
          begin
            X2 := X[I]; if XAxis.Scale = LOG_SCALE then X2 := Log10(X2);
            Y2 := Y[I]; if YAxis.Scale = LOG_SCALE then Y2 := Log10(Y2);
            Flag2 := CheckPoint(X2, Y2, Xp2, Yp2);
            if Flag2 then
              begin
                PlotSymbol(Canvas, Xp2, Yp2, CurvParam.PointParam.Symbol,
                                       CurvParam.PointParam.Size);
                if ErrorBars and (S[I] > 0.0) then
                  PlotErrorBar(Canvas, Y[I], S[I], Ns, Xp2, Yp2,
                                  CurvParam.PointParam.Size);
                if CurvParam.Connect and Flag1 then
                  PlotLine(Canvas, Xp1, Yp1, Xp2, Yp2);
              end;

            Xp1 := Xp2;
            Yp1 := Yp2;
            Flag1 := Flag2;
            Inc(I, CurvParam.Step);
          end;

        { Restore settings }
        Pen.Color := PenColor;
        Pen.Style := PenStyle;
        Pen.Width := PenWidth;
        Brush.Color := BrushColor;
        Brush.Style := BrushStyle;
      end;
  end;

  procedure PlotCurve(Canvas         : TCanvas;
                      X, Y           : TVector;
                      Lbound, Ubound : Integer;
                      CurvParam      : TCurvParam);
  const
    Ns = 0;    { Dummy variables }
    S  = nil;
  begin
    GenPlotCurve(Canvas, X, Y, S, Ns, Lbound, Ubound, CurvParam, False);
  end;

  procedure PlotCurveWithErrorBars(Canvas         : TCanvas;
                                   X, Y, S        : TVector;
                                   Ns             : Integer;
                                   Lbound, Ubound : Integer;
                                   CurvParam      : TCurvParam);
  begin
    GenPlotCurve(Canvas, X, Y, S, Ns, Lbound, Ubound, CurvParam, True);
  end;

  procedure PlotFunc(Canvas     : TCanvas;
                     Func       : TFunc;
                     Xmin, Xmax : Float;
                     Npt        : Integer;
                     LineParam  : TLineParam);
  var
    PenColor : TColor;
    PenStyle : TpenStyle;
    PenWidth : Integer;
    X1, Y1, X2, Y2, H : Float;
    Xp1, Yp1, Xp2, Yp2 : Integer;
    Flag1, Flag2 : Boolean;
    I : Integer;
  begin
    if (Npt < 2) or (LineParam.Style = psClear) then Exit;

    if Xmin >= Xmax then
      begin
        Xmin := XAxis.Min;
        Xmax := XAxis.Max;
      end;

    H := (Xmax - Xmin) / Npt;

    with Canvas do
      begin
        { Save current settings }
        PenColor := Pen.Color;
        PenStyle := Pen.Style;
        PenWidth := Pen.Width;

        Pen.Color := LineParam.Color;
        Pen.Style := LineParam.Style;
        Pen.Width := LineParam.Width;

        { Check first point }
        X1 := Xmin;
        if XAxis.Scale = LIN_SCALE then
          Y1 := Func(X1)
        else
          Y1 := Func(Exp10(X1));
        if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1);
        Flag1 := CheckPoint(X1, Y1, Xp1, Yp1);

        { Check other points and plot lines if possible }
        for I := 1 to Npt do
          begin
            X2 := X1 + H;
            if XAxis.Scale = LIN_SCALE then
              Y2 := Func(X2)
            else
              Y2 := Func(Exp10(X2));
            if YAxis.Scale = LOG_SCALE then Y2 := Log10(Y2);
            Flag2 := CheckPoint(X2, Y2, Xp2, Yp2);
            if Flag1 and Flag2 then
              PlotLine(Canvas, Xp1, Yp1, Xp2, Yp2);
            X1 := X2;
            Xp1 := Xp2;
            Yp1 := Yp2;
            Flag1 := Flag2;
          end;

        { Restore settings }
        Pen.Color := PenColor;
        Pen.Style := PenStyle;
        Pen.Width := PenWidth;
      end;
  end;

  procedure DimCurvParamVector(var CurvParam : TCurvParamVector;
                               Ubound : Integer);
  var
    I : Integer;
  begin
    { Check bounds }
    if Ubound < 0 then
      begin
        CurvParam := nil;
        Exit;
      end;

    { Allocate vector }
    SetLength(CurvParam, Succ(Ubound));
    if CurvParam = nil then Exit;

    { Initialize curve parameters }
    for I := 0 to Ubound do
      with CurvParam[I] do
        begin
          if I = 0 then
            begin
              PointParam.Symbol := 0;
              PointParam.Size := 0;
              PointParam.Color := clBlack;
              Legend := '';
            end
          else
            begin
              PointParam.Symbol := (I - 1) mod MAXSYMBOL + 1;
              PointParam.Size := 1;
              PointParam.Color := CurvColor[(I - 1) mod MAXCOLOR + 1];
              Legend := 'Y' + IntToStr(I);
            end;
          LineParam.Width := 1;
          LineParam.Style := psSolid;
          LineParam.Color := PointParam.Color;
          Connect := False;
          Step := 1;
        end;
  end;

  procedure WriteLegend(Canvas     : TCanvas;
                        NCurv      : Integer;
                        CurvParam  : TCurvParamVector;
                        ShowPoints,
                        ShowLines  : Boolean);

  var
    CharHeight, I, L, Lmax, N, Nmax, Xp, Xl, Y : Integer;
    PenWidth : Integer;
    PenStyle : TpenStyle;
    PenColor, BrushColor : TColor;
    BrushStyle : TBrushStyle;
  begin
    N := 0;     { Nb of legends to be plotted  }
    Lmax := 0;  { Length of the longest legend }

    for I := 1 to NCurv do
      if CurvParam[I].Legend <> '' then
        begin
          Inc(N);
          L := Canvas.TextWidth(CurvParam[I].Legend);
          if L > Lmax then Lmax := L;
        end;

    if (N = 0) or (Lmax = 0) then Exit;

    { Character height }
    CharHeight := Canvas.TextHeight('M');

    { Max. number of legends which may be plotted }
    Nmax := Round((YmaxPixel - YminPixel) / CharHeight) - 1;
    if N > Nmax then N := Nmax;

    { Draw rectangle around the legends }
    Canvas.Rectangle(XmaxPixel + Round(0.02 * GraphWidth), YminPixel,
                     XmaxPixel + Round(0.12 * GraphWidth) + Lmax,
                     YminPixel + (N + 1) * CharHeight);

    L := Round(0.02 * GraphWidth);  { Half-length of line }
    Xp := XmaxPixel + 3 * L;        { Position of symbol  }
    Xl := XmaxPixel + 5 * L;        { Position of legend  }

    { Save current settings }
    with Canvas do
      begin
        PenColor := Pen.Color;
        PenStyle := Pen.Style;
        PenWidth := Pen.Width;
        BrushColor := Brush.Color;
        BrushStyle := Brush.Style;
      end;

    for I := 0 to Min(NCurv, Nmax) do
      with Canvas do
        begin
          Pen.Color := CurvParam[I].LineParam.Color;
          Pen.Style := CurvParam[I].LineParam.Style;
          Pen.Width := CurvParam[I].LineParam.Width;
          Brush.Color := CurvParam[I].PointParam.Color;

          if CurvParam[I].PointParam.Symbol in [0, 1, 3, 5] then
            Brush.Style := bsSolid
          else
            Brush.Style := bsClear;

          { Plot point and line }
          Y := YminPixel + I * CharHeight;
          if ShowPoints then
            PlotSymbol(Canvas, Xp, Y, CurvParam[I].PointParam.Symbol,
                                      CurvParam[I].PointParam.Size);
          if ShowLines then
            PlotLine(Canvas, Xp - L, Y, Xp + L, Y);

          { Write legend }
          Brush.Style := bsClear;
          Canvas.TextOut(Xl, Y - CharHeight div 2, CurvParam[I].Legend);
        end;

    { Restore settings }
    with Canvas do
      begin
        Pen.Color := PenColor;
        Pen.Style := PenStyle;
        Pen.Width := PenWidth;
        Brush.Color := BrushColor;
        Brush.Style := BrushStyle;
      end;
  end;

end.