sglines.pas

FlexGraphics是一套创建矢量图形的VCL组件

{************************************************************}
{                   Delphi VCL Extensions                    }
{                                                            }
{                    Drawing dotted lines                    }
{                                                            }
{      Copyright (c) 2002-2007 SoftGold software company     }
{                                                            }
{************************************************************}

unit SGLines;

interface

uses Windows, Classes, Math, sgConsts, SysUtils;

type
  TsgLines = class
  private
    FTicks: TList;
    FScale: Double;
    FIndex: Integer;
    FIsUniform: Boolean;
    FPatternLength: Single;
    function GetTick(Index: Integer): Single;
    procedure Reset;
    procedure AddLine(Pt1, Pt2: TFPoint; DottedSingPts: TList);
    procedure AddHatchLine(Pt1, Pt2, BasePt: TFPoint; DottedSingPts: TList);
    procedure AddCurve(SingPts, DottedSingPts: TList; Close: Boolean);
    procedure AddPoly(SingPts, DottedSingPts: TList; Close: Boolean);
    procedure SetScale(const Value: Double);
  public
    constructor Create;
    destructor Destroy; override;
    function Count: Integer;
    procedure Assign(ASource: TsgLines);
    procedure AddTick(Value: Single);
    procedure AddTicks(const AParts: array of Single);
    procedure Line(Pt1, Pt2: TFPoint; DottedSingPts: TList);
    procedure HatchLine(Pt1, Pt2, BasePt: TFPoint; DottedSingPts: TList);
    procedure Poly(SingPts, DottedSingPts: TList; Close: Boolean);
    procedure Curve(SingPts, DottedSingPts: TList; Close: Boolean);
    procedure SetPatternLength(Value: Single);// for future version
    procedure Clear;
    procedure Check;
    property IsUniform: Boolean read FIsUniform write FIsUniform;
    property Scale: Double read FScale write SetScale;
    property List: TList read FTicks;
    property Ticks[Index: Integer]: Single read GetTick;
    property PatternLength: Single read FPatternLength;
    function IsSolid: Boolean;
  end;

procedure DrawPolyPolyLine(DC: HDC; IntPoints: TList);
procedure DrawPolyLine(DC: HDC; IntPoints: TList);
function SGFloor(AValue: Double): Integer;

implementation

function SGFloor(AValue: Double): Integer;
begin
  Result := Round(AValue);
  if Result > AValue then
    Result := Result - 1;
end;

constructor TsgLines.Create;
begin
  FTicks := TList.Create;
  FScale := 1.0;
  FPatternLength := 0.0;
  FIsUniform := False;
end;

destructor TsgLines.Destroy;
begin
  FTicks.Free;
end;

procedure TsgLines.SetPatternLength(Value: Single);
begin
  FPatternLength := Value;
end;

{ TsgLines.Count

  Returns the total number of line elements (dash, dot and spaces). }
function TsgLines.Count: Integer;
begin
  Result := FTicks.Count;
end;

{ TsgLines.IsSolid

  Returns true, if this line continuous
  (there are no elements of a line).    }
function TsgLines.IsSolid: Boolean;
begin
  Result := False;
  if FTicks.Count <= 1 then// if one tick then the line interprated as solid
    Result := True;
end;

{ TsgLines.GetTick

  Returns specific line element (dash, dot or space). }
function TsgLines.GetTick(Index: Integer): Single;
begin
  Result := Single(FTicks[Index]);
end;

procedure TsgLines.Reset;
begin
  FIndex := 0;
end;

{ TsgLines.AddLine

  Creates the points-list for drawing a line}
procedure TsgLines.AddLine(Pt1, Pt2: TFPoint; DottedSingPts: TList);
var
  DX, DY, DZ, Cur, Len, PartLineLength: Double;
  I, AmountPatterns, CounterPatterns, vTicksCount: Integer;
  Beginning, vISOdot: Boolean;
  PSingPt: PFPoint;

  procedure AddPt;
  begin
    New(PSingPt);
    PSingPt^.X := Pt1.X + DX * Cur / Len;
    PSingPt^.Y := Pt1.Y + DY * Cur / Len;
    PSingPt^.Z := Pt1.Z + DZ * Cur / Len;
    DottedSingPts.Add(PSingPt);
    Inc(FIndex);
    if FIndex > vTicksCount - 1 then
    begin
      FIndex := 0;
      Inc(CounterPatterns);// one pattern has been added
    end;
  end;

begin
  vTicksCount := (FTicks.Count shr 1) shl 1;
  try
    DX := Pt2.X - Pt1.X;
    DY := Pt2.Y - Pt1.Y;
    DZ := Pt2.Z - Pt1.Z;
    Len := Sqrt(DX*DX + DY*DY + DZ*DZ) / FScale;

    // Length of a pattern
    FPatternLength := 0.0;
    for I := 0 to (vTicksCount - 1) do
      FPatternLength := FPatternLength + Abs(Ticks[I]);
    if (Len = 0) or (FPatternLength = 0)
      or ((Len / FPatternLength) > iMaxNumDottedLines) then
    begin
      if Len = 0 then Pt2 := Pt1;
      // starting point
      New(PSingPt);
      PSingPt^ := Pt1;
      DottedSingPts.Add(PSingPt);
      // ending point
      New(PSingPt);
      PSingPt^ := Pt2;
      DottedSingPts.Add(PSingPt);
      Exit;
    end;

    Cur := 0;
    FIndex := -1;
    Beginning:= True;
    vISOdot := (Ticks[0] = 0) and ((vTicksCount<=1) or ((vTicksCount>1) and (Ticks[1]<0)));
    CounterPatterns := 0;
    // Amount of patterns in the line
    AmountPatterns := SGFloor(Len / FPatternLength);

    // Length of a part of a line
    // (Important: Ticks[0] is a solid component of the line)

    if not FIsUniform then
      PartLineLength := (Ticks[0] + (Len - AmountPatterns * FPatternLength)) / 2
    else
      PartLineLength := Ticks[0];

    if AmountPatterns = 0 then PartLineLength := Len;

    AddPt;// adding of a starting point
    while True do
    begin
      if (Beginning or (CounterPatterns = AmountPatterns)) and (FIndex <> -1) then
      begin
        if vISOdot then       // For "ISO dot"-linetypes
        begin
          AddPt;
          // Is added last point of a curve
          if (CounterPatterns = AmountPatterns) or (AmountPatterns = 1) then
          begin
            Cur := Len;
            AddPt;
            AddPt;
            Exit;
          end;
          Inc(CounterPatterns);
          Cur := Cur + Abs(Ticks[FIndex]);
        end;
        Cur := Cur + PartLineLength;
        Beginning := False;
      end
      else
        Cur := Cur + Abs(Ticks[FIndex]);
      if Cur > Len then
        Cur := Len;
      AddPt;
      if Abs(Cur - Len) < fAccuracy then
        Exit;
    end;
  finally
    if (DottedSingPts.Count shr 1) shl 1 <> DottedSingPts.Count then
    begin
      Dispose(DottedSingPts.Last);
      DottedSingPts.Delete(DottedSingPts.Count - 1);
    end;
  end;
end;

{ TsgLines.AddHatchLine

  Creates the points-list for drawing a line of hatch}
procedure TsgLines.AddHatchLine(Pt1, Pt2, BasePt: TFPoint; DottedSingPts: TList);
var
  vDX, vDY, vCur, vLen, vPartLen: Double;
  vHatchLineAng, vDist1, vDist2: Single;
  I, vTicksCount, vAmountPatterns: Integer;
  vPFPoint: PFPoint;
  vPt: TFPoint;


  procedure IncFIndex;
  begin
    Inc(FIndex);
    if FIndex > vTicksCount - 1 then
      FIndex := 0;
  end;

  procedure AddPt;
  begin
    New(vPFPoint);
    vPFPoint^.X := Pt1.X + vDX * vCur / vLen;
    vPFPoint^.Y := Pt1.Y + vDY * vCur / vLen;
    vPFPoint^.Z := 0.0;
    DottedSingPts.Add(vPFPoint);
    IncFIndex;
  end;

begin
  vTicksCount := (FTicks.Count shr 1) shl 1;
  // Length of a pattern
  FPatternLength := 0.0;
  for I := 0 to (vTicksCount - 1) do
    FPatternLength := FPatternLength + Abs(Ticks[I]);

  vDX := Pt2.X - Pt1.X;
  vDY := Pt2.Y - Pt1.Y;
  vLen := Sqrt(Sqr(vDX) + Sqr(vDY)) / FScale;
  if (Abs(vLen) < 0.0001) or (FPatternLength = 0)
    or ((vLen / FPatternLength) > iMaxNumDottedLines) then
  begin
    if vLen = 0 then Pt2 := Pt1;
    // starting point
    New(vPFPoint);
    vPFPoint^ := Pt1;
    DottedSingPts.Add(vPFPoint);
    // ending point
    New(vPFPoint);
    vPFPoint^ := Pt2;
    DottedSingPts.Add(vPFPoint);
    Exit;
  end;

  //Hatch line angle
  if Pt1.X <> Pt2.X then
    vHatchLineAng := ArcTan((Pt2.Y - Pt1.Y) / (Pt2.X - Pt1.X))
  else
    vHatchLineAng := Pi / 2;

  //Moving the base point under bottom boundary on distance less then length of the pattern
  if not((Abs(BasePt.Y - Pt1.Y) < fAccuracy) and (Abs(BasePt.Y - Pt2.Y) < fAccuracy)) then
  begin
    if Pt1.Y < Pt2.Y then
      vDist1 := Sqrt(Sqr(Pt1.X-BasePt.X) + Sqr(Pt1.Y-BasePt.Y)) / FScale
    else
      vDist1 := Sqrt(Sqr(Pt2.X-BasePt.X) + Sqr(Pt2.Y-BasePt.Y)) / FScale;
    if (BasePt.Y > Pt1.Y) or (BasePt.Y > Pt2.Y) then
    begin
      vAmountPatterns := SGFloor(vDist1 / FPatternLength) + 1;
      if Abs(vHatchLineAng - Pi / 2) > fAccuracy then
        if Tan(vHatchLineAng) >= 0 then
        begin
          BasePt.X := BasePt.X - FPatternLength * vAmountPatterns * Cos(vHatchLineAng);
          BasePt.Y := BasePt.Y - FPatternLength * vAmountPatterns * Sin(vHatchLineAng);
        end
        else
        begin
          BasePt.X := BasePt.X + FPatternLength * vAmountPatterns * Cos(vHatchLineAng);
          BasePt.Y := BasePt.Y + FPatternLength * vAmountPatterns * Sin(vHatchLineAng);
        end
      else
        BasePt.Y := BasePt.Y - FPatternLength * vAmountPatterns;
    end
    else
    begin
      vAmountPatterns := SGFloor(vDist1 / FPatternLength);
      if Abs(vHatchLineAng - Pi / 2) > fAccuracy then
        if Tan(vHatchLineAng) >= 0 then
        begin
          BasePt.X := BasePt.X + FPatternLength * vAmountPatterns * Cos(vHatchLineAng);
          BasePt.Y := BasePt.Y + FPatternLength * vAmountPatterns * Sin(vHatchLineAng);
        end
        else
        begin
          BasePt.X := BasePt.X - FPatternLength * vAmountPatterns * Cos(vHatchLineAng);
          BasePt.Y := BasePt.Y - FPatternLength * vAmountPatterns * Sin(vHatchLineAng);
        end
      else
        BasePt.Y := BasePt.Y + FPatternLength * vAmountPatterns;
    end;
  end
  else
  begin
    if Pt1.X < Pt2.X then
      vDist1 := Sqrt(Sqr(Pt1.X-BasePt.X) + Sqr(Pt1.Y-BasePt.Y)) / FScale
    else
      vDist1 := Sqrt(Sqr(Pt2.X-BasePt.X) + Sqr(Pt2.Y-BasePt.Y)) / FScale;
    if (BasePt.X > Pt1.X) or (BasePt.Y > Pt2.Y) then
    begin
      vAmountPatterns := SGFloor(vDist1 / FPatternLength) + 1;
      BasePt.X := BasePt.X - FPatternLength * vAmountPatterns;
    end
    else
    begin
      vAmountPatterns := SGFloor(vDist1 / FPatternLength);
      BasePt.X := BasePt.X + FPatternLength * vAmountPatterns;
    end;
  end;

  vDist1 := Sqrt(Sqr(Pt1.X-BasePt.X) + Sqr(Pt1.Y-BasePt.Y)) / FScale;
  vDist2 := Sqrt(Sqr(Pt2.X-BasePt.X) + Sqr(Pt2.Y-BasePt.Y)) / FScale;
  if vDist1 > vDist2 then
  begin
    vDist1 := vDist2;
    vPt := Pt1;
    Pt1 := Pt2;
    Pt2 := vPt;
    vDX := Pt2.X - Pt1.X;
    vDY := Pt2.Y - Pt1.Y;
  end;

  vCur := 0.0;
  if FPatternLength <> vDist1 then
  begin
    I := -1;
    vPartLen := 0.0;
    repeat
      Inc(I);
      if I > vTicksCount - 1 then
      begin
        Exit;
      end;
      vPartLen := vPartLen + Abs(Ticks[I]);
    until vPartLen >= vDist1;
    if Ticks[I] >= 0 then
      AddPt;
    vCur := vPartLen - vDist1;
    if vCur >= vLen then
    begin
      vCur := vLen;
      if Ticks[I] >= 0 then
        AddPt;
      Exit;
    end;
    if not ((I <> vTicksCount - 1) and (Ticks[I] * Ticks[I + 1] > 0)
      or (I = vTicksCount - 1) and (Ticks[I] * Ticks[0] > 0)) then
      AddPt;
    Inc(I);
    while I <= vTicksCount - 1 do
    begin
      vCur := vCur + Abs(Ticks[I]);
      if vCur >= vLen then
      begin
        vCur := vLen;
        if Ticks[I] >= 0 then
          AddPt;
        Exit;
      end;
      if not ((I <> vTicksCount - 1) and (Ticks[I] * Ticks[I + 1] > 0)
        or (I = vTicksCount - 1) and (Ticks[I] * Ticks[0] > 0)) then
        AddPt;
      Inc(I);
    end;
  end
  else
    if Ticks[0] >= 0 then
      AddPt;
  FIndex := 0;
  while True do
  begin
    vCur := vCur + Abs(Ticks[FIndex]);
    if (Abs(vCur - vLen) < FAccuracy) or (vCur > vLen) then
    begin
      vCur := vLen;
      if Ticks[FIndex] >= 0 then
        AddPt;
      Exit;
    end;
    if not ((FIndex <> vTicksCount - 1) and (Ticks[FIndex] * Ticks[FIndex + 1] > 0)
      or (FIndex = vTicksCount - 1) and (Ticks[FIndex] * Ticks[0] > 0)) then
      AddPt
    else
      IncFIndex;
  end;
end;