flexpath.pas

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

     ProcessSegment(Path, @Next);
     exit;
    end;
   end;
   // distance from (x1,y1) to the line is less than 1
   // distance from (x2,y2) to the line is less than 1
   Path.p1.x := Round(x3);
   Path.p1.y := Round(y3);
  end;
 with Path do begin
  case Func of
   pfFlatten:
     with PointList do begin
      if Count = Capacity then Grow;
      Data[Count].Point := p1;
      Data[Count].PointType := ptNode;
      inc(Count);
     end;
   pfOnLine:
     if not IsOnLine or Assigned(Nearest) then begin
      if IsFigureClosed
       then TempList := ScanLine
       else TempList := Nil;
      IsOnLine :=
        PointOnLine(CheckPoint, p0, p1, StrokeWidth, TempList, Nearest) or
        IsOnLine;
      if Assigned(Nearest) and
         Nearest.IsNewMin and Assigned(Bezier) then with Nearest^ do begin
       // Correct index
       if Bezier.p3pos < 1 then MinIndex := Index0;
       // Calc bezier curve position (t)
       if p1.x <> p0.x then
        CurvePos := Bezier.p0pos + (Bezier.p3pos - Bezier.p0pos) *
          ( (Point.x - p0.x) / (p1.x - p0.x) )
       else
        CurvePos := Bezier.p0pos;
      end;
     end;
   pfRange:
     with Range^ do begin
      if Left > p1.x then Left := p1.x else
      if Right < p1.x then Right := p1.x;
      if Top > p1.y then Top := p1.y else
      if Bottom < p1.y then Bottom := p1.y;
     end;
   pfPaint:
     LineTo(PaintDC, p1.x, p1.y);
  end;
  p0 := p1;
 end;
end;

function ProcessPath(const Points: TPointArray; const Types: TPointTypeArray;
  var Params: TPathParams): boolean;
var FigIndex, FigEndIndex, Index, Count: integer;
    Bezier: TBezierParams;
    UseBezier: PBezierParams;
    InternalInfo: boolean;
    PathNearest: PNearestPoint;
begin
 Result := true;
 Count := Length(Points);
 if Count <> Length(Types) then begin
  Result := false;
  exit;
 end;
 if (Count = 0) or (not Params.UseClosed and not Params.UseNotClosed) then
  // Empty path - do nothing
  exit;
 InternalInfo := not Assigned(Params.Info);
 with Params do
 try
  if InternalInfo then begin
   New(Info);
   GetPathInfo(Points, Types, Info^);
  end;
  if (Count <> Info.PointCount) then begin
   Result := false;
   exit;
  end;
  if Func = pfOnLine
   then PathNearest := Params.Nearest
   else PathNearest := Nil;
  // Process all figures
  for FigIndex:=0 to Length(Info.Figures)-1 do
   with Info.Figures[FigIndex] do begin
    if (IsClosed and not UseClosed) or (not IsClosed and not UseNotClosed) then
    begin
     // Skip figure
     Complete := false;
     continue;
    end;
    p0 := Points[FirstNode];
    // BEGIN FIGURE
    case Func of
     pfFlatten:
       with PointList do begin
        if Count = Capacity then Grow;
        Data[Count].Point := p0;
        Data[Count].PointType := ptNode;
        inc(Count);
       end;
     pfRange:
       with Range^ do begin
        if Left > p0.x then Left := p0.x else
        if Right < p0.x then Right := p0.x;
        if Top > p0.y then Top := p0.y else
        if Bottom < p0.y then Bottom := p0.y;
       end;
     pfPaint:
       MoveToEx(PaintDC, p0.x, p0.y, Nil);
    end;
    IsFigureClosed := IsClosed;
    // PROCESS FIGURE POINTS
    Index := FirstNode;
    if IsClosed
     then FigEndIndex := LastNode
     else FigEndIndex := LastNode-1;
    while Index <= FigEndIndex do begin
     if Types[Index] = ptControl then begin
      // error
      Result := false;
      break;
     end;
     if Assigned(PathNearest) then PathNearest.Index0 := Index;
     if (Index < Count-2) and (Types[Index+1] = ptControl) then begin
      // Bezier curve segment
      UseBezier := @Bezier;
      with Bezier do
       if Params.OriginalBezier then begin
        OrigPoints[0] := Points[Index+0];
        OrigPoints[1] := Points[Index+1];
        OrigPoints[2] := Points[Index+2];
        if Types[Index] = ptEndNodeClose
         then OrigPoints[3] := Points[FirstNode]
         else OrigPoints[3] := Points[Index+3];
       end else begin
        // Init bezier parameters (convert to float values)
        p0pos := 0;
        p3pos := 1;
        x0 := Points[Index+0].x;
        y0 := Points[Index+0].y;
        x1 := Points[Index+1].x;
        y1 := Points[Index+1].y;
        x2 := Points[Index+2].x;
        y2 := Points[Index+2].y;
        if Types[Index] = ptEndNodeClose then begin
         // Closed curve - use first point of the figure
         x3 := Points[FirstNode].x;
         y3 := Points[FirstNode].y;
         if Assigned(PathNearest) then PathNearest.Index1 := FirstNode;
        end else begin
         // Use next node as end point of the bezier curve
         x3 := Points[Index+3].x;
         y3 := Points[Index+3].y;
         if Assigned(PathNearest) then PathNearest.Index1 := Index+3; 
        end;
       end;
      inc(Index, 3);
     end else begin
      // Line segment
      UseBezier := Nil;
      if Types[Index] = ptEndNodeClose then begin
       p1 := Points[FirstNode];
       if Assigned(PathNearest) then PathNearest.Index1 := FirstNode;
      end else begin
       p1 := Points[Index+1];
       if Assigned(PathNearest) then PathNearest.Index1 := Index+1;
      end;
      inc(Index);
     end;
     // Process path segment
     ProcessSegment(Params, UseBezier);
     case Func of
      pfOnLine: if IsOnLine and not Assigned(Nearest) then break;
     end;
    end;
    // Check error
    if not Result then break;
    // END FIGURE
    case Func of
     pfFlatten:
       with PointList do
        if IsClosed then begin
         dec(Count);
         Data[Count-1].PointType := ptEndNodeClose
        end else
         Data[Count-1].PointType := ptEndNode;
     pfOnLine:
       if IsOnLine and not Assigned(Nearest) then break;
     pfPaint:
       if IsClosed then CloseFigure(PaintDC);
    end;
   end;
 finally
  if InternalInfo and Assigned(Info) then begin
   Dispose(Info);
   Info := Nil;
  end;
 end;
end;

// Interface routines /////////////////////////////////////////////////////////

function CalcPath(const Points: TPointArray; const Types: TPointTypeArray;
  var Range: TRect; Info: PPathInfo = Nil): boolean;
var Path: TPathParams;
begin
 if Length(Points) = 0 then begin
  SetRectEmpty(Range);
  Result := false;
 end else begin
  with Range do begin
   Left := Points[0].x;
   Top := Points[0].y;
   Right := Points[0].x;
   Bottom := Points[0].y;
  end;
  Path.UseClosed := true;
  Path.UseNotClosed := true;
  Path.OriginalBezier := false;
  Path.Curvature := 1;
  Path.Info := Info;
  Path.Func := pfRange;
  Path.Range := @Range;
  Result := ProcessPath(Points, Types, Path);
 end;
end;

function CreatePath(DC: HDC; const Points: TPointArray;
  const Types: TPointTypeArray; UseClosed, UseNotClosed: boolean;
  var Complete: boolean; OriginalBezier: boolean = false;
  Info: PPathInfo = Nil): boolean;
var Path: TPathParams;
begin
 Path.UseClosed := UseClosed;
 Path.UseNotClosed := UseNotClosed;
 Path.OriginalBezier := OriginalBezier;
 Path.Curvature := 1;
 Path.Info := Info;
 Path.Func := pfPaint;
 Path.PaintDC := DC;
 Result := BeginPath(DC);
 Result := Result and ProcessPath(Points, Types, Path);
 if Result
  then EndPath(DC)
  else AbortPath(DC);
 Complete := Result and Path.Complete;
end;

function PointOnPath(const Points: TPointArray; const Types: TPointTypeArray;
  const Point: TPoint; Stroked, Filled: boolean; StrokeWidth: integer = 0;
  Nearest: PNearestPoint = Nil; Info: PPathInfo = Nil): boolean;
var ScanList: TList;
    Index: integer;
    Path: TPathParams;
begin
 ScanList := Nil;
 try
  if Assigned(Nearest) then begin
   FillChar(Nearest^, SizeOf(Nearest^), 0);
   Nearest.MinIndex := -1;
  end;
  if Filled then begin
   ScanList := TList.Create;
   ScanList.Capacity := 64;
  end;
  if not Stroked then StrokeWidth := 0;
  Path.UseClosed := Stroked or Filled;
  Path.UseNotClosed := Stroked;
  Path.OriginalBezier := false;
  Path.Curvature := 1;
  Path.Info := Info;
  Path.Func := pfOnLine;
  Path.CheckPoint := Point;
  Path.StrokeWidth := StrokeWidth;
  Path.IsOnLine := false;
  Path.ScanLine := ScanList;
  Path.Nearest := Nearest;
  if ProcessPath(Points, Types, Path) then begin
   Result := Path.IsOnLine;
   if not Result and Filled then begin
    // Check ScanList
    Index := ListScanLess(pointer(Point.x), ScanList.List, ScanList.Count);
    Result := (Index < ScanList.Count) and (Index and 1 <> 0);
   end;
  end else
   Result := false;
 finally
  ScanList.Free;
 end;
end;

function FlattenPath(var Points: TPointArray; var Types: TPointTypeArray;
  Curvature: single; Info: PPathInfo = Nil): boolean;
var Path: TPathParams;
    PointList: TPointList;
    i: integer;
begin
 PointList := Nil;
 try
  Path.UseClosed := true;
  Path.UseNotClosed := true;
  Path.OriginalBezier := false;
  Path.Curvature := Curvature;
  Path.Info := Info;
  Path.Func := pfFlatten;
  PointList := TPointList.Create;
  Path.PointList := PointList;
  Result := ProcessPath(Points, Types, Path);
  if Result then begin
   SetLength(Points, PointList.Count);
   SetLength(Types, PointList.Count);
   for i:=0 to PointList.Count-1 do begin
    Points[i] := PointList.Data[i].Point;
    Types[i] := PointList.Data[i].PointType;
   end;
  end;
 finally
  PointList.Free;
 end;
end;

function InsertPathPoint(var Points: TPointArray; var Types: TPointTypeArray;
  FirstIndex, NextIndex: integer; const Point: TPoint;
  StickThreshold: integer = 0; Info: PPathInfo = Nil): integer;
var Count: integer;
    InternalInfo: boolean;
    IsOutOfFigure, IsLastFirst, IsSegmentCurve: boolean;
    FigIndex, Index: integer;
    Path: TPathParams;
    Bezier: TBezierParams;
    Nearest: TNearestPoint;
    Ofs: TPoint;

 function CalcBezier(a, b, c, t: single): single;
 var mt: single;
 begin
  mt := 1 - t;
  Result := mt*mt*a + 2*t*mt*b + t*t*c;
 end;

begin
 Result := -1;
 Count := Length(Points);
 // Check indexes values
 if (Count <> Length(Types)) or (FirstIndex = NextIndex) or
    (FirstIndex < 0) or (FirstIndex > Count-1) or
    (NextIndex < -1) or (NextIndex > Count) then exit;
 // Check points types
 if (Types[FirstIndex] = ptControl) or
  ( (NextIndex >= 0) and (NextIndex < Count) and
    (Types[NextIndex] = ptControl) ) then exit;
 InternalInfo := not Assigned(Info);
 try
  // Check path info
  if InternalInfo then begin
   New(Info);
   GetPathInfo(Points, Types, Info^);
  end;
  if Info.PointCount <> Count then exit;
  // Find figure
  FigIndex := GetFigureIndex(Info^, FirstIndex);
  if FigIndex < 0 then exit;
  // Validate indexes
  with Info.Figures[FigIndex] do begin
   IsOutOfFigure := (NextIndex < FirstNode) or (NextIndex > LastNode);
   IsLastFirst := (NextIndex = FirstNode) and (FirstIndex = LastNode);
   if IsOutOfFigure then begin
    // NextIndex is out of figure
    if IsClosed or
       ((FirstIndex <> FirstNode) and (NextIndex < FirstNode)) or
       ((FirstIndex <> LastNode) and (NextIndex > LastNode)) then exit;
   end else begin
    if IsLastFirst and not IsClosed then exit;
    // Check index order
    if (NextIndex < FirstIndex) <> IsLastFirst then begin