ezlib.pas

很管用的GIS控件

Function SetRealToPoint( Const P: TEzPoint ): TPoint;
Function SetPointToReal( Const P: TPoint ): TEzPoint;
Function SetRectToReal( Const R: TRect ): TEzRect;
Function SetRealToRect( Const R: TEzRect ): TRect;
Function IsRectEmpty2D( Const R: TEzRect ): Boolean;
Procedure OffsetRect2D( Var R: TEzRect; Const dx, dy: double );
Procedure InflateRect2D( Var R: TEzRect; Const dx, dy: Double );
Procedure MaxBound( Var bounds: TEzPoint; Const pt: TEzPoint );
Procedure MinBound( Var bounds: TEzPoint; Const pt: TEzPoint );

//Matrix functions
Function MultiplyMatrix2D( Const m, t: TEzMatrix ): TEzMatrix;
Function TransformPoint2D( Const P: TEzPoint; Const T: TEzMatrix ): TEzPoint;
Function TransformRect2D( Const R: TEzRect; Const T: TEzMatrix ): TEzRect;
Function Translate2D( Const Tx, Ty: Double ): TEzMatrix;
Function Rotate2D( Const phi: Double; Const refPt: TEzPoint ): TEzMatrix;
Function Scale2D( Const Sx, Sy: Double; Const refPt: TEzPoint ): TEzMatrix;
Function MirrorAroundX: TEzMatrix;

{ Clipping functions }
Function IntersectRect2D( Const r1, r2: TEzRect ): TEzRect;
Function ClipLine2D( Const Clip: TEzRect; Var X1, Y1, X2, Y2: Double ): TEzClipCodes;
Function ClipLineLeftRight2D( Const Clip: TEzRect; Var X1, Y1, X2, Y2: Double ): TEzClipCodes;
Function ClipLineUpBottom2D( Const Clip: TEzRect; Var X1, Y1, X2, Y2: Double ): TEzClipCodes;
Function IsNearPoint2D( Const RP, P: TEzPoint; Const Aperture: Double; Var Dist: Double ): Boolean;
Function Dist2D( Const Pt1, Pt2: TEzPoint ): Double;
Function Area2D( Vector: TEzVector ): Double;
Function Angle2D( Const P1, P2: TEzPoint ): Double;

Function IsRectVisible( Const ARect, AClip: TEzRect ): Boolean;
Function IsRectVisibleForPlace( Const ARect, AClip: TEzRect ): Boolean;

Function dMax( Const A, B: Double ): Double;
Function dMin( Const A, B: Double ): Double;
Function IMax( A, B: Integer ): Integer;
Function IMin( A, B: Integer ): Integer;
Function IsPointInBox2D( Const Pt: TEzPoint; Const Box: TEzRect ): Boolean;
Function IsBoxInBox2D( Const Box1, Box2: TEzRect ): Boolean;
Function IsBoxFullInBox2D( Const Box1, Box2: TEzRect ): Boolean;
Function BoxOutBox2D( Box1, Box2: TEzRect ): TEzRect;
//Function BoxFilling2D( Const Box1, Box2: TEzRect ): Integer;
Function TransformBoundingBox2D( const Box: TEzRect; Const Matrix: TEzMatrix ): TEzRect;
Function ChangeToOrtogonal( Const Pt1, Pt2: TEzPoint ): TEzPoint;
Function VectIntersect( Vector1, Vector2, IntersectVector: TEzVector;
  StrictlyBetween: Boolean; CheckLimits: Boolean = False ): Boolean;
Procedure FindCG( Vector: TEzVector; Var CG: TEzPoint; ComputeCG: Boolean );
Function IsCounterClockWise( Vector: TEzVector ): Boolean;
Function IsPointOnMe( Const C, A, B: TEzPoint ): Boolean;
Function PrintersInstalled: Boolean;
Function LineRel( Const P1, P2, D1, D2: TEzPoint; Var P: TEzPoint ): TEzLineRelations;
Procedure ClipPolygonToArea( Vector, ClippedVector: TEzVector; Const ClipArea: TEzRect );
// this code was generousely donated by Jens Gruschel
Procedure GetMinimumDistance2D( Poly1, Poly2: TEzVector;
  Var Distance: Double; Var Min1, Min2: TEzPoint );
//Function PointLineDistance2D( Const P, P1, P2: TEzPoint; Var Dist: Double ): Boolean;
{ this function returns the perpendicular projection of point C on
  the lines that goes from A to B }
Function Perpend( Const C, A, B: TEzPoint ): TEzPoint;
Function GDICheck( Value: Integer ): Integer;
Procedure GDIError;

Const
  MAXCOORD = 1.0E+100;
  MINCOORD = -1.0E+100;
  IDENTITY_MATRIX2D: TEzMatrix = ( Matrix:( ( 1, 0, 0 ), ( 0, 1, 0 ), ( 0, 0, 1 ) ) );
  INVALID_EXTENSION: TEzRect = ( X1: MAXCOORD; Y1: MAXCOORD; X2: MINCOORD; Y2: MINCOORD );
  NULL_EXTENSION: TEzRect = ( X1: 0.0; Y1: 0.0; X2: 0.0; Y2: 0.0 );
  DEFAULT_EXTENSION: TEzRect = ( X1: 0.0; Y1: 0.0; X2: 100.0; Y2: 100.0 );
  INVALID_POINT: TEzPoint = (X: MINCOORD; Y: MINCOORD );
  NULL_POINT: TEzPoint = (X:0; Y:0);
  TOL_EPSILON = 1E-8;

Implementation

Uses
  Consts,
  WinSpool, Math, EzConsts, EzSystem, Ezbase, EzGraphics, EzEntities,
  EzLineDraw, EzBaseExpr, EzExprLex, EzExprYacc, EzLexLib, EzYaccLib,
  EzExpressions ;

Const
  Fuzz = 1.0E-6;

Type

  TEzOutCode = Set Of ( left, bottom, right, top, infront, behind );

  PDouble = ^Double;

Function Defuzz( Const x: Double ): Double;
Begin
  If Abs( x ) < Fuzz Then
    Result := 0.0
  Else
    Result := x;
End;

Function PointLineDistance2D( Const P, P1, P2: TEzPoint; Var Dist: Double ):
  Boolean;
Var
  r, L, LQ, DX, DY: Double;
Begin
  Result := False;
  DX := P2.X - P1.X;
  DY := P2.Y - P1.Y;
  L := Sqrt( DX * DX + DY * DY );
  If L = 0 Then
    Exit;
  LQ := L * L;
  r := ( ( P1.Y - P.Y ) * ( -DY ) - ( P1.X - P.X ) * DX ) / LQ;
  Result := ( r >= 0 ) And ( r <= 1 );
  If Not Result Then
    Exit;
  Dist := Abs( ( ( P1.Y - P.Y ) * DX - ( P1.X - P.X ) * DY ) / L );
End;

{ TEzVector class implementation }

Constructor TEzVector.Create( Size: Integer );
Begin
  Inherited Create;
  FCount := 0;
  FLast := Size;
  GetMem( FPoints, Size * SizeOf( TEzPoint ) );
  FDisableEvents := False;
  FCanGrow := True;
  FParts := TIntegerList.Create;
End;

Destructor TEzVector.Destroy;
Begin
  FreeMem( FPoints, FLast * SizeOf( TEzPoint ) );
  FParts.Free;
  Inherited Destroy;
End;

Procedure TEzVector.SetCapacity( Value: Integer );
Begin
  If FLast >= Value Then
    Exit;
  FLast := Value;
  If FPoints = Nil Then
    GetMem( FPoints, FLast * SizeOf( TEzPoint ) )
  Else
    ReAllocMem( FPoints, FLast * SizeOf( TEzPoint ) );
End;

Function TEzVector.Get( Index: Integer ): TEzPoint;
Begin
  If Index < FCount Then
    Result := FPoints^[Index]
  Else
    EzGISError( SVectorOutOfBound );
End;

Function TEzVector.GetExtension: TEzRect;
Var
  I: Integer;
  Item: TEzPoint;
Begin
  Result := INVALID_EXTENSION;
  For I := 0 To fCount - 1 Do
  Begin
    Item := FPoints^[I];
    If Item.X > Result.X2 Then
      Result.X2 := Item.X;
    If Item.X < Result.X1 Then
      Result.X1 := Item.X;
    If Item.Y > Result.Y2 Then
      Result.Y2 := Item.Y;
    If Item.Y < Result.Y1 Then
      Result.Y1 := Item.Y;
  End;
End;

Procedure TEzVector.SetCount(Value: Integer);
Begin
  If (Value < 0) Or ((Value > FCount) and Not FCanGrow) Then
    EzGISError( SVectorOutOfBound );
  FCount := Value;
End;

Procedure TEzVector.Put( Index: Integer; Const Item: TEzPoint );
Begin
  If Index < FLast Then
  Begin
    FPoints^[Index] := Item;
    If Index >= FCount Then
      FCount := Index + 1;
  End
  Else If FCanGrow Then
  Begin
    { Resize the vector }
    ReAllocMem( FPoints, ( Index + 1 ) * SizeOf( TEzPoint ) );
    FPoints^[Index] := Item;
    FCount := Index + 1;
    FLast := FCount;
  End
  Else
    EzGISError( SVectorOutOfBound );
  If Not FDisableEvents And Assigned( FOnChange ) Then
    FOnChange;
End;

Procedure TEzVector.LoadFromStream( Stream: TStream );
Var
  I, tmpw, n: Integer;
  tmpbool: Boolean;
  P: TEzPoint;
Begin
  tmpbool := FDisableEvents;
  FDisableEvents := true;
  Clear;
  { read number of parts }
  Stream.Read( n, SizeOf( n ) );
  If n > 1 Then
  Begin
    FParts.Capacity := n;
    For i := 1 To n Do
    Begin
      Stream.Read( tmpw, SizeOf( tmpw ) );
      FParts.Add( tmpw );
    End;
  End;
  { read the points }
  With Stream Do
  Begin
    Read( n, sizeof( n ) );
    If n > 0 Then
      SetCapacity( n );
    For I := 1 To n Do
    Begin
      Read( P, sizeof( TEzPoint ) );
      Add( P );
    End;
  End;
  FDisableEvents := tmpbool;
End;

Procedure TEzVector.SaveToStream( Stream: TStream );
Var
  i, tmpw, n: Integer;
Begin
  { write the parts }
  n := FParts.Count;
  If n = 1 Then n := 0;
  Stream.Write( n, SizeOf( n ) );
  For i := 0 To n - 1 Do
  Begin
    tmpw := FParts[i];
    Stream.Write( tmpw, SizeOf( tmpw ) );
  End;
  { write the points }
  With Stream Do
  Begin
    n := FCount;
    Write( n, sizeof( n ) );
    For I := 0 To n - 1 Do
      Write( FPoints^[I], sizeof( TEzPoint ) );
  End;
End;

Procedure TEzVector.Add( Const Item: TEzPoint );
Begin
  Put( FCount, Item );
End;

Procedure TEzVector.AddPoint( Const AX, AY: Double );
Begin
  Put( FCount, Point2D( AX, AY ) );
End;

Function TEzVector.GetX( Index: Integer ): Double;
Begin
  Result := 0;
  If Index < FCount Then
    Result := FPoints^[Index].X
  Else
    EzGISError( SVectorOutOfBound );
End;

Function TEzVector.GetY( Index: Integer ): Double;
Begin
  Result := 0;
  If Index < FCount Then
    Result := FPoints^[Index].Y
  Else
    EzGISError( SVectorOutOfBound );
End;

Procedure TEzVector.PutX( Index: Integer; Const Value: Double );
Var
  Item: TEzPoint;
Begin
  Item := Get( Index );
  Item.X := Value;
  Put( Index, Item );
End;

Procedure TEzVector.PutY( Index: Integer; Const Value: Double );
Var
  Item: TEzPoint;
Begin
  Item := Get( Index );
  Item.Y := Value;
  Put( Index, Item );
End;

Procedure TEzVector.Assign( Source: TEzVector );
Var
  cnt: Integer;
  TmpBool: Boolean;
Begin
  If ( Not FCanGrow ) And ( Source.Count > FLast ) Then
    EzGISError( SVectorOutOfBound );
  TmpBool := FDisableEvents;
  FDisableEvents := True;
  Clear;
  Try
    For cnt := 0 To Source.Count - 1 Do
      Put( FCount, Source[cnt] );
    For cnt := 0 To Source.Parts.Count - 1 Do
      FParts.Add( Source.Parts[cnt] );
  Finally
    FDisableEvents := TmpBool;
  End;
  FCanGrow:= Source.CanGrow;
  If Not FDisableEvents And Assigned( FOnChange ) Then
    FOnChange;
End;

Procedure TEzVector.AddPoints( Const Items: Array Of TEzPoint );
Var
  cnt: Integer;
  TmpBool: Boolean;
Begin
  If ( Not FCanGrow ) And ( High( Items ) - Low( Items ) > FLast ) Then
    EzGISError( SVectorOutOfBound );
  TmpBool := FDisableEvents;
  FDisableEvents := True;
  Try
    For cnt := Low( Items ) To High( Items ) Do
      Put( FCount, Items[cnt] );
  Finally
    FDisableEvents := TmpBool;
  End;
  If Not FDisableEvents And Assigned( FOnChange ) Then
    FOnChange;
End;

Procedure TEzVector.Clear;
Begin
  FCount := 0;
  FParts.Count:= 0;
  If Not FDisableEvents And Assigned( FOnChange ) Then
    FOnChange;
End;

Procedure TEzVector.Delete( Index: Integer );
Var
  i, n, cnt, Idx1, Idx2: Integer;
  TmpList: TIntegerList;
Begin
  If (Index < 0) Or (Index >= FCount) Then
    EzGISError( SVectorOutOfBound );
  If FCount >= 2 Then
    For cnt := Index To FCount - 2 Do
      FPoints^[cnt] := FPoints^[cnt + 1];
  { reindex the parts }
  If FParts.Count > 1 Then
  Begin
    TmpList := TIntegerList.Create;
    Try
      n := 0;
      Idx1 := FParts[n];
      Idx2 := FParts[n + 1] - 1;
      Repeat
        For i := Idx1 To Idx2 Do
          TmpList.Add( n );
        Inc( n );
        If n >= FParts.Count Then Break;

        Idx1 := FParts[n];
        If n < FParts.Count - 1 Then
          Idx2 := FParts[n + 1] - 1
        Else
          Idx2 := FCount - 1;
      Until false;
      TmpList.Delete( Index );

      TmpList.Reindex;

      FParts.Count:= 0;
      If TmpList.Count = 0 Then Exit;

      FParts.Add( 0 );
      n := TmpList[0];
      I := 1;
      While I <= TmpList.Count - 1 Do
      Begin
        If n <> TmpList[I] Then
        Begin
          FParts.Add( I );
          n := TmpList[I];
        End;
        Inc( I );
      End;
      If FParts.Count < 2 Then
        FParts.Clear;
    Finally
      TmpList.Free;
    End;
  End;
  Dec( FCount );
  If Not FDisableEvents And Assigned( FOnChange ) Then
    FOnChange;
End;