Chip 2002 September/Chip_2002-09_cd1.bin/zkuste/delphi/kompon/d6/YPPARSER.ZIP/Components/GraphBldr.pas

Pascal/Delphi Source File | 2002-06-14 | 21.0 KB | 677 lines

{********************************************************}
{                                                        }
{                    TGraphBldr                          }
{             IMPORTANT-READ CAREFULLY:                  }
{                                                        }
{    This End-User License Agreement is a legal          }
{    agreement between you (either an individual         }
{    or a single entity) and Pisarev Yuriy for           }
{    the software product identified above, which        }
{    includes computer software and may include          }
{    associated media, printed materials, and "online"   }
{    or electronic documentation ("SOFTWARE PRODUCT").   }
{    By installing, copying, or otherwise using the      }
{    SOFTWARE PRODUCT, you agree to be bound by the      }
{    terms of this LICENSE AGREEMENT.                    }
{                                                        }
{    If you do not agree to the terms of this            }
{    LICENSE AGREEMENT, do not install or use            }
{    the SOFTWARE PRODUCT.                               }
{                                                        }
{    License conditions                                  }
{                                                        }
{    No part of the software or the manual may be        }
{    multiplied, disseminated or processed in any        }
{    way without the written consent of Pisarev          }
{    Yuriy. Violations of these conditions will be       }
{    prosecuted in every case.                           }
{                                                        }
{    The use of the software is done at your own         }
{    risk. The manufacturer and developer accepts        }
{    no liability for any damages, either as direct      }
{    or indirect consequence of the use of this          }
{    product or software.                                }
{                                                        }
{    Only observance of these conditions allows you      }
{    to use the hardware and software in your computer   }
{    system.                                             }
{                                                        }
{    All rights reserved.                                }
{    Copyright 2002 Pisarev Yuriy                        }
{                                                        }
{                 [e-mail]                 }
{                                                        }
{********************************************************}

unit GraphBldr;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, ExtCtrls, Graphics, Math,
  DataEditor;

type
  TPoints = array of array of TPoint;
  TCoord = record
    X, Y: Double;
  end;
  TTraceEvent = procedure(Sender: TObject; X, Y: Double) of object;
  TGraphBldr = class(TCustomControl)
  private
    FTracing: Boolean;
    FShowAxis: Boolean;
    FShowText: Boolean;
    FShowGrid: Boolean;
    FVertSpacing: Double;
    FHorzSpacing: Double;
    FCurrXValue: Double;
    FMargin: Integer;
    FXValueID: Integer;
    FBorderSize: Integer;
    FYMaxValue: Integer;
    FXMaxValue: Integer;
    FDetailLevel: Integer;
    FPicture: TBitmap;
    FSavedBrush: TBrush;
    FDataEditor: TDataEditor;
    FAxisFont: TFont;
    FTextFont: TFont;
    FGridPen: TPen;
    FSaved: TPen;
    FTracePen: TPen;
    FGraphPen: TPen;
    FAxisPen: TPen;
    FPoints: TPoints;
    FTracePoints: TPoints;
    FOnTrace: TTraceEvent;
    procedure DeletePoints(var Points: TPoints);
    function NumFunction(FunctionID: Integer; TypeID: Integer;
      var Value1: Double; Value2, Value3: Double): Boolean;
    procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    function GetBevelWidth: TBevelWidth;
    function GetBorderWidth: TBorderWidth;
    function GetText: string;
    procedure SetAxisFont(const Value: TFont);
    procedure SetBevelWidth(const Value: TBevelWidth);
    procedure SetBorderWidth(const Value: TBorderWidth);
    procedure SetFont(const Value: TFont);
    procedure SetMargin(const Value: Integer);
    procedure SetText(const Value: string);
  protected
    procedure FilterPoints(var Points: TPoints; X, Y: Integer);
    procedure Paint; override;
    property CurrXValue: Double read FCurrXValue write FCurrXValue;
    property Points: TPoints read FPoints write FPoints;
    property SavedBrush: TBrush read FSavedBrush write FSavedBrush;
    property Saved: TPen read FSaved write FSaved;
    property TracePoints: TPoints read FTracePoints write FTracePoints;
    property XValueID: Integer read FXValueID write FXValueID;
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Draw; virtual;
    procedure Calculate; virtual;
    procedure Clear; virtual;
    function XCoord(X: Double): Double;
    function YCoord(Y: Double): Double;
    function Coordinates(X, Y: Double): TCoord;
    property BorderSize: Integer read FBorderSize;
    property Picture: TBitmap read FPicture write FPicture;
    property DataEditor: TDataEditor read FDataEditor write FDataEditor;
    property DockManager;
  published
    property Align;
    property Anchors;
    property AutoSize;
    property AxisFont: TFont read FAxisFont write SetAxisFont;
    property AxisPen: TPen read FAxisPen write FAxisPen;
    property BevelInner default bvLowered;
    property BevelOuter default bvRaised;
    property BevelWidth: TBevelWidth read GetBevelWidth write SetBevelWidth;
    property BiDiMode;
    property BorderWidth: TBorderWidth read GetBorderWidth
      write SetBorderWidth default 5;
    property Color;
    property Constraints;
    property Ctl3D;
    property Cursor default crCross;
    property UseDockManager;
    property DetailLevel: Integer read FDetailLevel write FDetailLevel default 1;
    property DockSite;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property GraphPen: TPen read FGraphPen write FGraphPen;
    property GridPen: TPen read FGridPen write FGridPen;
    property Height default 150;
    property HorzSpacing: Double read FHorzSpacing write FHorzSpacing;
    property Margin: Integer read FMargin write SetMargin default 5;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowAxis: Boolean read FShowAxis write FShowAxis default True;
    property ShowGrid: Boolean read FShowGrid write FShowGrid default True;
    property ShowHint;
    property ShowText: Boolean read FShowText write FShowText default False;
    property TabOrder;
    property TabStop;
    property Text: string read GetText write SetText;
    property TextFont: TFont read FTextFont write SetFont;
    property TracePen: TPen read FTracePen write FTracePen;
    property Tracing: Boolean read FTracing write FTracing default True;
    property VertSpacing: Double read FVertSpacing write FVertSpacing;
    property Visible;
    property Width default 300;
    property XMaxValue: Integer read FXMaxValue write FXMaxValue default 5;
    property YMaxValue: Integer read FYMaxValue write FYMaxValue default 5;
    property OnCanResize;
    property OnClick;
    property OnConstrainedResize;
    property OnContextPopup;
    property OnDockDrop;
    property OnDockOver;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGetSiteInfo;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property OnStartDock;
    property OnStartDrag;
    property OnUnDock;
    property OnTrace: TTraceEvent read FOnTrace write FOnTrace;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TGraphBldr]);
end;

{ TGraphBldr }

procedure TGraphBldr.Calculate;

  procedure Split(var Points: TPoints; var Index: Integer);
  begin
    if Length(FPoints[Index]) > 0 then begin
      Index := Length(FPoints);
      SetLength(FPoints, Index + 1);
    end;
  end;

var
  I, J: Integer;
  Index, Value1, Value2, Factor1, Factor2, Factor3: Double;
  Center: TCoord;
  Rect: TRect;
begin
  FDataEditor.StringToNumScript(AnsiLowerCase(GetText));
  I := ClientWidth;
  J := ClientHeight;
  Center.X := I / 2;
  Center.Y := J / 2;
  Dec(I, FBorderSize);
  Dec(J, FBorderSize);
  Factor1 := (Center.X - FBorderSize) / FXMaxValue;
  Factor2 := (Center.Y - FBorderSize) / FYMaxValue;
  Factor3 := FXMaxValue / I / FDetailLevel;
  Rect := Classes.Rect(FBorderSize, FBorderSize, I, J);
  DeletePoints(FPoints);
  DeletePoints(FTracePoints);
  J := 0;
  SetLength(FPoints, J + 1);
  Index := - FXMaxValue;
  while Index <= FXMaxValue do begin
    FCurrXValue := Index;
    try
      Value2 := Center.Y - FDataEditor.ExecuteNum * Factor2;
      Value1 := Center.X + Index * Factor1;
      if (Value1 >= Rect.Left) and (Value1 <= Rect.Right) and
        (Value2 >= Rect.Top) and (Value2 <= Rect.Bottom) then begin
          I := Length(FPoints[J]);
          SetLength(FPoints[J], I + 1);
          FPoints[J][I].X := Round(Value1);
          FPoints[J][I].Y := Round(Value2);
        end else Split(FPoints, J);
    except
      Split(FPoints, J);
    end;
    Index := Index + Factor3;
  end;
  FilterPoints(FPoints, 1, 1);
end;

procedure TGraphBldr.Clear;
begin
  SetText('');
  FDataEditor.Script := nil;
  DeletePoints(FPoints);
  DeletePoints(FTracePoints);
end;

function TGraphBldr.Coordinates(X, Y: Double): TCoord;
begin
  Result.X := XCoord(X);
  Result.Y := YCoord(Y);
end;

constructor TGraphBldr.Create(AOwner: TComponent);
begin
  inherited;
  BevelInner := bvLowered;
  BevelOuter := bvRaised;
  ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
    csSetCaption, csOpaque, csDoubleClicks, csReplicatable];
  Cursor := crCross;
  Height := 150;
  Width := 300;
  TabStop := False;
  FAxisFont := TFont.Create;
  FAxisPen := TPen.Create;
  FShowAxis := True;
  inherited BorderWidth := 5;
  FMargin := 5;
  FBorderSize := GetBevelWidth + GetBorderWidth + FMargin;
  FDataEditor := TDataEditor.Create(Self);
  with FDataEditor do begin
    RegisterNumFunction(FXValueID, 'x', False, False);
    SortNumFunctionsData;
    OnNumFunction := NumFunction;
    with AttrsManager do begin
      Strings.Add('x');
      UpdateStrings;
    end;
  end;
  FDetailLevel := 1;
  FGraphPen := TPen.Create;
  FGraphPen.Color := clRed;
  FGridPen := TPen.Create;
  with FGridPen do begin
    Color := clGray;
    Style := psDot;
  end;
  FSaved := TPen.Create;
  FSaved.Assign(Canvas.Pen);
  FTextFont := TFont.Create;
  FTracePen := TPen.Create;
  with FTracePen do begin
    Mode := pmNotXor;
    Color := clBlue;
    Style := psDot;
  end;
  FTracing := True;
  FShowGrid := True;
  FHorzSpacing := 1;
  FPicture := TBitmap.Create;
  FPicture.PixelFormat := pf24bit;
  FShowGrid := True;
  FShowText := False;
  FVertSpacing := 1;
  FXMaxValue := 5;
  FYMaxValue := 5;
end;

procedure TGraphBldr.DeletePoints(var Points: TPoints);
var
  I: Integer;
begin
  for I := Low(Points) to High(Points) do Points[I] := nil;
  Points := nil;
end;

destructor TGraphBldr.Destroy;
begin
  DeletePoints(FPoints);
  DeletePoints(FTracePoints);
  FAxisFont.Free;
  FAxisPen.Free;
  FGraphPen.Free;
  FGridPen.Free;
  FSaved.Free;
  FTextFont.Free;
  FTracePen.Free;
  FPicture.Free;
  inherited;
end;

procedure TGraphBldr.Draw;
begin
  Paint;
end;

procedure TGraphBldr.FilterPoints(var Points: TPoints; X, Y: Integer);
var
  I, J, K: Integer;
  Point, NewPoint: TPoint;
  NewPoints: TPoints;
begin
  SetLength(NewPoints, Length(Points));
  for I := Low(Points) to High(Points) do
    for J := Low(Points[I]) to High(Points[I]) do
      if J = Low(Points[I]) then Point := Points[I][J]
      else begin
        NewPoint.X := Abs(Points[I][J].X - Point.X);
        NewPoint.Y := Abs(Points[I][J].Y - Point.Y);
        if (NewPoint.X >= X) or (NewPoint.Y >= Y) then begin
          K := Length(NewPoints[I]);
          SetLength(NewPoints[I], K + 1);
          NewPoints[I][K] := Points[I][J];
          Point := Points[I][J];
        end;
      end;
  Points := nil;
  Points := NewPoints;
end;

function TGraphBldr.GetBevelWidth: TBevelWidth;
begin
  Result := inherited BevelWidth;
end;

function TGraphBldr.GetBorderWidth: TBorderWidth;
begin
  Result := inherited BorderWidth;
end;

function TGraphBldr.GetText: string;
begin
  Result := FDataEditor.Text;
end;

function TGraphBldr.NumFunction(FunctionID, TypeID: Integer;
  var Value1: Double; Value2, Value3: Double): Boolean;
begin
  if FunctionID = FXValueID then Value1 := FCurrXValue
  else begin
    Result := True;
    Exit;
  end;
  Result := False;
end;

procedure TGraphBldr.Paint;
const
  Alignments: array[TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER);
var
  I, J, K: Integer;
  Factor1, Factor2: Double;
  Center: TPoint;
  Points: array of TPoint;
  Value: string;
  Rect: TRect;
  TopColor, BottomColor: TColor;

  procedure AdjustColors(Bevel: TBevelCut);
  begin
    TopColor := clBtnHighlight;
    if Bevel = bvLowered then TopColor := clBtnShadow;
    BottomColor := clBtnShadow;
    if Bevel = bvLowered then BottomColor := clBtnHighlight;
  end;

begin
  inherited;
  DeletePoints(FTracePoints);
  with FPicture, Canvas do begin
    I := ClientWidth;
    J := ClientHeight;
    Width := I;
    Height := J;
    Center.X := I div 2;
    Center.Y := J div 2;
    Dec(I, FBorderSize);
    Dec(J, FBorderSize);
    Brush.Color := Color;
    FillRect(ClientRect);
    if FShowGrid and ((FHorzSpacing > 0) or (FVertSpacing > 0)) then begin
      Pen.Assign(FGridPen);
      if FHorzSpacing > 0 then begin
        // ─δΦφα ∩εδεΓΦφ√ ε±Φ X:
        Factor1 := I - Center.X;
        // ─δΦφα Φφ≥σ≡Γαδα:
        Factor2 := Factor1 * FHorzSpacing / FXMaxValue;
        if Factor2 <= Factor1 then begin
          SetRoundMode(rmDown);
          Factor1 := Center.X;
          while Round(Factor1) <= I do begin
            MoveTo(Round(Factor1), FBorderSize);
            LineTo(Round(Factor1), J);
            Factor1 := Factor1 + Factor2;
          end;
          SetRoundMode(rmUp);
          Factor1 := Center.X;
          while Round(Factor1) >= FBorderSize do begin
            MoveTo(Round(Factor1), FBorderSize);
            LineTo(Round(Factor1), J);
            Factor1 := Factor1 - Factor2;
          end;
        end;
      end;
      if FVertSpacing > 0 then begin
        // ─δΦφα ∩εδεΓΦφ√ ε±Φ Y:
        Factor1 := J - Center.Y;
        // ─δΦφα Φφ≥σ≡Γαδα:
        Factor2 := Factor1 * FVertSpacing / FYMaxValue;
        if Factor2 <= Factor1 then begin
          SetRoundMode(rmDown);
          Factor1 := Center.Y;
          while Round(Factor1) <= J do begin
            MoveTo(FBorderSize, Round(Factor1));
            LineTo(I, Round(Factor1));
            Factor1 := Factor1 + Factor2;
          end;
          SetRoundMode(rmUp);
          Factor1 := Center.Y;
          while Round(Factor1) >= FBorderSize do begin
            MoveTo(FBorderSize, Round(Factor1));
            LineTo(I, Round(Factor1));
            Factor1 := Factor1 - Factor2;
          end;
        end;
      end;
      SetRoundMode(rmNearest);
    end;
    if FShowAxis then begin
      Pen.Assign(FAxisPen);
      K := FAxisPen.Width - 1;
      // ╬±ⁿ X:
      MoveTo(FBorderSize + K, Center.Y);
      LineTo(I - K, Center.Y);
      // ╬±ⁿ Y:
      MoveTo(Center.X, J - K);
      LineTo(Center.X, FBorderSize + K);
      Pen.Width := 1;
      Brush.Color := Pen.Color;
      SetLength(Points, 3);
      try
        // ┬σ≡°Φφα ε±Φ X:
        Points[0].X := I - 15;
        Points[0].Y := Center.Y - 10;
        Points[1].X := I;
        Points[1].Y := Center.Y;
        Points[2].X := I - 15;
        Points[2].Y := Center.Y + 10;
        Polygon(Points);
        // ┬σ≡°Φφα ε±Φ Y:
        SetLength(Points, 3);
        Points[0].X := Center.X - 10;
        Points[0].Y := FBorderSize + 15;
        Points[1].X := Center.X;
        Points[1].Y := FBorderSize;
        Points[2].X := Center.X + 10;
        Points[2].Y := FBorderSize + 15;
        Polygon(Points);
      finally
        Points := nil;
      end;
      Brush.Style := bsClear;
      Font.Assign(FAxisFont);
      TextOut(I - TextWidth('X'), Center.Y - 20 - TextHeight('X'), 'X');
      Value := IntToStr(FXMaxValue);
      TextOut(I - TextWidth(Value), Center.Y + 20, Value);
      TextOut(FBorderSize, Center.Y + 20, '-' + Value);
      TextOut(Center.X - 20 - TextWidth('Y'), FBorderSize, 'Y');
      Value := IntToStr(FYMaxValue);
      TextOut(Center.X + 20, FBorderSize, Value);
      TextOut(Center.X + 20, J - TextHeight('-' + Value), '-' + Value);
    end;
    if FShowText then begin
      Brush.Style := bsClear;
      Font.Assign(FTextFont);
      Value := Trim(GetText);
      if Value <> '' then TextOut(FBorderSize, FBorderSize,
        Format('Y = %s', [Value]));
    end;
    Pen.Assign(FGraphPen);
    //for I := Low(FPoints) to High(FPoints) do Polyline(FPoints[I]);
    for I := Low(FPoints) to High(FPoints) do
      for J := Low(FPoints[I]) to High(FPoints[I]) do
        with FPoints[I][J] do if J = Low(FPoints[I]) then MoveTo(X, Y)
        else LineTo(X, Y);
  end;
  Canvas.Pen.Assign(FSaved);
  Canvas.Draw(0, 0, FPicture);
  Rect := ClientRect;
  if BevelOuter <> bvNone then
  begin
    AdjustColors(BevelOuter);
    Frame3D(Canvas, Rect, TopColor, BottomColor, GetBevelWidth);
  end;
  Frame3D(Canvas, Rect, Color, Color, GetBorderWidth);
  if BevelInner <> bvNone then
  begin
    AdjustColors(BevelInner);
    Frame3D(Canvas, Rect, TopColor, BottomColor, GetBevelWidth);
  end;
end;

procedure TGraphBldr.SetAxisFont(const Value: TFont);
begin
  FAxisFont.Assign(Value);
end;

procedure TGraphBldr.SetBevelWidth(const Value: TBevelWidth);
begin
  inherited BevelWidth := Value;
  FBorderSize := Value + GetBorderWidth + FMargin;
end;

procedure TGraphBldr.SetBorderWidth(const Value: TBorderWidth);
begin
  inherited BorderWidth := Value;
  FBorderSize := Value + GetBevelWidth + FMargin;
end;

procedure TGraphBldr.SetFont(const Value: TFont);
begin
  FTextFont.Assign(Value);
end;

procedure TGraphBldr.SetMargin(const Value: Integer);
begin
  FMargin := Value;
  FBorderSize := Value + GetBevelWidth + GetBorderWidth;
end;

procedure TGraphBldr.SetText(const Value: string);
begin
  FDataEditor.Text := Value;
end;

procedure TGraphBldr.WMMouseMove(var Message: TWMMouseMove);

  procedure DrawLines;
  var
    I: Integer;
  begin
    with Canvas do begin
      Pen.Assign(FTracePen);
      for I := Low(FTracePoints) to High(FTracePoints) do
        Polyline(FTracePoints[I]);
    end;
  end;

var
  I, J: Integer;
  Center: TCoord;
  Value1, Value2, Factor: Double;
  Rect: TRect;
begin
  inherited;
  if not FTracing or (Trim(GetText) = '') then Exit;
  DrawLines;
  I := ClientWidth;
  J := ClientHeight;
  Center.X := I / 2;
  Center.Y := J / 2;
  Dec(I, FBorderSize);
  Dec(J, FBorderSize);
  Factor := (Center.Y - FBorderSize) / FYMaxValue;
  Rect := Classes.Rect(FBorderSize, FBorderSize, I, J);
  FCurrXValue := XCoord(Message.XPos);
  try
    Value1 := FDataEditor.ExecuteNum;
    Value2 := Center.Y - Value1 * Factor;
    if (Message.XPos >= Rect.Left) and (Message.XPos <= Rect.Right) and
      (Value2 >= Rect.Top) and (Value2 <= Rect.Bottom) then begin
        if Assigned(FOnTrace) then FOnTrace(Self, FCurrXValue, Value1);
        SetLength(FTracePoints, 2);
        SetLength(FTracePoints[0], 2);
        SetLength(FTracePoints[1], 2);
        FTracePoints[0][0].X := Round(Message.XPos);
        FTracePoints[0][0].Y := FBorderSize;
        FTracePoints[0][1].X := Round(Message.XPos);
        FTracePoints[0][1].Y := J;
        FTracePoints[1][0].X := FBorderSize;
        FTracePoints[1][0].Y := Round(Value2);
        FTracePoints[1][1].X := I;
        FTracePoints[1][1].Y := Round(Value2);
      end else DeletePoints(FTracePoints);
  except
    DeletePoints(FTracePoints);
  end;
  DrawLines;
end;

procedure TGraphBldr.WMSize(var Message: TWMSize);
begin
  inherited;
  if Trim(GetText) <> '' then Calculate else DeletePoints(FPoints);
  Paint;
end;

function TGraphBldr.XCoord(X: Double): Double;
var
  Center: Double;
begin
  Center := ClientWidth / 2 - FBorderSize;
  Result := (X - FBorderSize - Center) * FXMaxValue / Center;
end;

function TGraphBldr.YCoord(Y: Double): Double;
var
  Center: Double;
begin
  Center := ClientHeight / 2 - FBorderSize;
  Result := (Center - (Y - FBorderSize)) * FYMaxValue / Center;
end;

end.