flexpath.pas

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

/////////////////////////////////////////////////////////
//                                                     //
//    FlexGraphics library                             //
//    Copyright (c) 2002-2003, FlexGraphics software.  //
//                                                     //
//    Path procedures and functions                    //
//                                                     //
/////////////////////////////////////////////////////////

unit FlexPath;

{$I FlexDefs.inc}

interface

uses
  Windows, Classes;

type
  TPointType = ( ptNode, ptEndNode, ptEndNodeClose, ptControl );

  TPointArray = packed array of TPoint;
  TPointTypeArray = packed array of TPointType;
  TSelectedArray = packed array of boolean;
  TRectArray = packed array of TRect;

  TPathEditFunc   = ( pfOffset, {pfDelete, }pfJoin, pfBreak, pfClose,
    pfToLine, pfToCurve );
  TPathEditFuncs  = set of TPathEditFunc;

  PPathEditParams = ^TPathEditParams;
  TPathEditParams = record
   case TPathEditFunc of
    pfOffset: (
      Offset: TPoint;
      MoveControls: boolean;
    );
  end;

  PNearestPoint = ^TNearestPoint;
  TNearestPoint = record
   Point: TPoint;
   Index0: integer;
   Index1: integer;
   MinIndex: integer;
   MinSqrDist: single;
   CurvePos: single;
   IsNewMin: boolean;
  end;

  PPathFigureInfo = ^TPathFigureInfo;
  TPathFigureInfo = record
   FirstNode: integer;
   LastNode: integer;
   LastPoint: integer;
   IsClosed: boolean;
   IsCurve: boolean;
  end;

  TPathFigureInfos = array of TPathFigureInfo;

  PPathInfo = ^TPathInfo;
  TPathInfo = record
   PointCount: integer;
   IsCurve: boolean;
   Figures: TPathFigureInfos;
  end;

function  CalcPath(const Points: TPointArray; const Types: TPointTypeArray;
  var Range: TRect; Info: PPathInfo = Nil): boolean;
function  CreatePath(DC: HDC; const Points: TPointArray;
  const Types: TPointTypeArray; UseClosed, UseNotClosed: boolean;
  var Complete: boolean; OriginalBezier: boolean = false;
  Info: PPathInfo = Nil): boolean;
function  PointOnLine(const p, p0, p1: TPoint; StrokeWidth: integer;
  ScanLinePoints: TList = Nil; Nearest: PNearestPoint = Nil): boolean;
function  PointOnPath(const Points: TPointArray; const Types: TPointTypeArray;
  const Point: TPoint; Stroked, Filled: boolean; StrokeWidth: integer = 0;
  Nearest: PNearestPoint = Nil; Info: PPathInfo = Nil): boolean;
function  FlattenPath(var Points: TPointArray; var Types: TPointTypeArray;
  Curvature: single; Info: PPathInfo = Nil): boolean;

function  FindNearestPathSegment(const Points: TPointArray;
  const Types: TPointTypeArray; const Point: TPoint;
  var FirstIndex, NextIndex: integer; Info: PPathInfo = Nil): boolean;
function  InsertPathPoint(var Points: TPointArray; var Types: TPointTypeArray;
  FirstIndex, NextIndex: integer; const Point: TPoint;
  StickThreshold: integer = 0; Info: PPathInfo = Nil): integer;
function  InsertNearestPoint(var Points: TPointArray;
  var Types: TPointTypeArray; const Point: TPoint;
  StickThreshold: integer = 0; Info: PPathInfo = Nil): integer;

function  GetEditPathCaps(const Points: TPointArray;
  const Types: TPointTypeArray; const Selected: TSelectedArray): TPathEditFuncs;
function  EditPath(var Points: TPointArray; var Types: TPointTypeArray;
  const Selected: TSelectedArray; Func: TPathEditFunc;
  Params: PPathEditParams = Nil): boolean; overload;
function  EditPath(var Points: TPointArray; var Types: TPointTypeArray;
  const Indexes: array of integer; Func: TPathEditFunc;
  Params: PPathEditParams = Nil): boolean; overload;

procedure GetPathInfo(const Points: TPointArray; const Types: TPointTypeArray;
  var Info: TPathInfo);
function  GetFigureIndex(var Info: TPathInfo; PointIndex: integer): integer;
function  ChangePathCount(var Points: TPointArray; var Types: TPointTypeArray;
  Index, Delta: integer): boolean;

implementation

uses
  FlexUtils;

type
  TPathFunc = ( pfFlatten, pfOnLine, pfRange, pfPaint );

  TListPoint = packed record
   Point: TPoint;
   PointType: TPointType;
  end;

  PListPoints = ^TListPoints;
  TListPoints = array[0..(MaxInt div SizeOf(TListPoint))-1] of TListPoint;

  TPointList = class
   Data: PListPoints;
   Count: integer;
   Capacity: integer;
   Delta: integer;
   constructor Create(ACapacity: integer = 32);
   destructor Destroy; override;
   procedure Grow;
   procedure Clear;
  end;

  PBezierParams = ^TBezierParams;
  TBezierParams = record
   case Boolean {OriginalBezier} of
    False: (
      x0, y0: single;
      x1, y1: single;
      x2, y2: single;
      x3, y3: single;
      p0pos, p3pos: single;
     );
    True: (
      OrigPoints: array[0..3] of TPoint;
     );
  end;

  PPathParams = ^TPathParams;
  TPathParams = record
   UseClosed: boolean;
   UseNotClosed: boolean;
   Complete: boolean;
   OriginalBezier: boolean;
   IsFigureClosed: boolean;
   p0, p1: TPoint; // points of the current line segment
   Curvature: single; // [0.0, 1.0]
   Info: PPathInfo;
   case Func: TPathFunc of
    pfFlatten: (
      PointList: TPointList );
    pfOnLine: (
      CheckPoint: TPoint;
      StrokeWidth: integer;
      ScanLine: TList;
      Nearest: PNearestPoint;
      IsOnLine: boolean );
    pfRange: (
      Range: PRect );
    pfPaint: (
      PaintDC: HDC );
  end;

// TPointList /////////////////////////////////////////////////////////////////

constructor TPointList.Create(ACapacity: integer);
begin
 Capacity := ACapacity;
 Delta := ACapacity;
 if Capacity > 0 then GetMem(Data, Capacity * SizeOf(TListPoint));
end;

destructor TPointList.Destroy;
begin
 Clear;
end;

procedure TPointList.Clear;
begin
 FreeMem(Data);
 Data := Nil;
 Capacity := 0;
end;

procedure TPointList.Grow;
begin
 inc(Capacity, Delta);
 ReallocMem(Data, Capacity*SizeOf(TListPoint));
 inc(Delta, Delta);
end;

// Bezier curve and path routines /////////////////////////////////////////////

function PointOnLine(const p, p0, p1: TPoint; StrokeWidth: integer;
  ScanLinePoints: TList = Nil; Nearest: PNearestPoint = Nil): boolean;
var SqrDist, SqrLength, SqrDist0, SqrDist1, Coeff: single;
    px, py, p0x, p0y, p1x, p1y: single;
    R: TRect;
    InRange: boolean;
    Index: integer;
begin
 Result := StrokeWidth > 0;
 if Result then begin
  // Calculate normalized rect [p0, p1] inflated on StrokeWidth
  if p0.x < p1.x
   then begin R.Left  := p0.x - StrokeWidth; R.Right := p1.x + StrokeWidth end
   else begin R.Right := p0.x + StrokeWidth; R.Left  := p1.x - StrokeWidth end;
  if p0.y < p1.y
   then begin R.Top    := p0.y - StrokeWidth; R.Bottom := p1.y + StrokeWidth end
   else begin R.Bottom := p0.y + StrokeWidth; R.Top    := p1.y - StrokeWidth end;
  // Check that p in R
  Result := (p.x >= R.Left) and (p.x <= R.Right) and
            (p.y >= R.Top) and (p.y <= R.Bottom);
 end;
 if Result or Assigned(Nearest) then begin
  // Convert to float values and calculate length
  px := p.x;
  py := p.y;
  p0x := p0.x;
  p0y := p0.y;
  p1x := p1.x;
  p1y := p1.y;
  SqrLength := (p0x - p1x)*(p0x - p1x) + (p0y - p1y)*(p0y - p1y);
  SqrDist0 := (p0x - px)*(p0x - px) + (p0y - py)*(p0y - py);
  SqrDist1 := (p1x - px)*(p1x - px) + (p1y - py)*(p1y - py);
  // Check point-on-line
  if SqrLength < 1 then begin
   // Lenght too small
   SqrDist := SqrDist0; // There must be SqrDist0 = SqrDist1
   Result := Result and (Abs(p.x - p0.x) <= StrokeWidth)
                    and (Abs(p.y - p0.y) <= StrokeWidth);
  end else begin
   // Check distance
   SqrDist := Abs( 4*SqrDist0*SqrDist1 -
    (SqrLength - SqrDist0 - SqrDist1)*(SqrLength - SqrDist0 - SqrDist1) ) /
    (4*SqrLength);
   Result := Result and (SqrDist <= StrokeWidth*StrokeWidth);
  end;
  if Assigned(Nearest) then begin
   Nearest.IsNewMin := false;
   Index := Nearest.Index0;
   if (Nearest.MinIndex < 0) or (Nearest.MinSqrDist > SqrDist) then begin
    // Calculate nearest point
    if SqrLength = 0
     then Coeff := 0
     else Coeff := (SqrDist0 - SqrDist1 + SqrLength) / (2*SqrLength);
    R.Left := p0.x + Round((p1.x - p0.x) * Coeff);
    R.Top := p0.y + Round((p1.y - p0.y) * Coeff);
    if p0.x < p1.x
     then InRange := (R.Left >= p0.x) and (R.Left <= p1.x)
     else InRange := (R.Left >= p1.x) and (R.Left <= p0.x);
    if p0.y < p1.y
     then InRange := InRange and (R.Top >= p0.y) and (R.Top <= p1.y)
     else InRange := InRange and (R.Top >= p1.y) and (R.Top <= p0.y);
    if not InRange then begin
     if SqrDist0 < SqrDist1 then begin
      SqrDist := SqrDist0;
      R.Left := p0.x;
      R.Top := p0.y
     end else begin
      SqrDist := SqrDist1;
      R.Left := p1.x;
      R.Top := p1.y;
      Index := Nearest.Index1;
     end;
     InRange := (Nearest.MinIndex < 0) or (Nearest.MinSqrDist > SqrDist);
    end;
    if InRange then begin
     Nearest.Point.x := R.Left;
     Nearest.Point.y := R.Top;
     Nearest.MinIndex := Index;
     Nearest.MinSqrDist := SqrDist;
     Nearest.IsNewMin := true;
    end;
   end;
  end;
 end;
 if Assigned(ScanLinePoints) then begin
  if p1.y < p0.y
   then InRange := (p.y >= p1.y) and (p.y <= p0.y)
   else InRange := (p.y >= p0.y) and (p.y <= p1.y);
  if InRange then
   // Add point(s) to ScanList
   if p0.y = p1.y then begin
    // Add edge points
    ScanLinePoints.Insert(
      ListScanLess(pointer(p0.x), ScanLinePoints.List, ScanLinePoints.Count),
      pointer(p0.x)
    );
    ScanLinePoints.Insert(
      ListScanLess(pointer(p1.x), ScanLinePoints.List, ScanLinePoints.Count),
      pointer(p1.x)
    );
   end else begin
    // Add intersection point
    R.Left := p0.x + integer(int64(p1.x - p0.x)*(p.y - p0.y) div (p1.y - p0.y));
    ScanLinePoints.Insert(
      ListScanLess(pointer(R.Left), ScanLinePoints.List, ScanLinePoints.Count),
      pointer(R.Left)
    );
   end;
 end;
end;

procedure ProcessSegment(var Path: TPathParams; Bezier: PBezierParams);
var
 TempBezier: packed record
  xm, ym: single;
  case byte of
   1: (
     A, B, C, AB: single;
     CheckAB1, CheckAB2: single );
   2: (
     Next: TBezierParams );
 end;
 TempList: TList;

begin
 if Assigned(Bezier) then with TempBezier, Bezier^ do
  if Path.OriginalBezier and (Path.Func = pfPaint) then begin
   // Draw original bezier curve (GDI)
   PolyBezierTo(Path.PaintDC, OrigPoints[1], 3);
   Path.p1 := OrigPoints[3];
   Path.p0 := OrigPoints[3];
   exit;
  end else begin
   // Draw recoursive bezier curve
   A := y3 - y0;
   B := x0 - x3;
   C := A*x0 + B*y0;
   // Ax + By - C = 0  is line (x0,y0) - (x3,y3)
   AB := A*A + B*B;
   CheckAB1 := (A*x1 + B*y1 - C) * Path.Curvature;
   CheckAB2 := (A*x2 + B*y2 - C) * Path.Curvature;
   // Check subdivide
   if (CheckAB1*CheckAB1 >= AB) or (CheckAB2*CheckAB2 >= AB) then begin
    xm := (x0 + 3*x1 + 3*x2 + x3) * 0.125;
    ym := (y0 + 3*y1 + 3*y2 + y3) * 0.125;
    // Check small length
    if (xm <> x0) or (ym <> y0) then begin
     // Subdivide
     Next.x0 := x0;
     Next.y0 := y0;
     Next.x1 := (x0 + x1) * 0.5;
     Next.y1 := (y0 + y1) * 0.5;
     Next.x2 := (x0 + 2*x1 + x2) * 0.25;
     Next.y2 := (y0 + 2*y1 + y2) * 0.25;
     Next.x3 := xm;
     Next.y3 := ym;
     if Path.Func = pfOnLine then begin
      Next.p0pos := p0pos;
      Next.p3pos := p0pos + (p3pos - p0pos) * 0.5;
     end;
     ProcessSegment(Path, @Next);
     Next.x0 := xm;
     Next.y0 := ym;
     Next.x1 := (x1 + 2*x2 + x3) * 0.25;
     Next.y1 := (y1 + 2*y2 + y3) * 0.25;
     Next.x2 := (x2 + x3) * 0.5;
     Next.y2 := (y2 + y3) * 0.5;
     Next.x3 := x3;
     Next.y3 := y3;
     if Path.Func = pfOnLine then begin
      Next.p0pos := Next.p3pos;
      Next.p3pos := p3pos;
     end;