flexutils.pas

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

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

unit FlexUtils;

{$I FlexDefs.inc}

interface

uses
  Windows, Forms, Dialogs, Controls, Messages, Classes,
  SysUtils, {$IFNDEF FG_D5} TypInfo, {$ENDIF} Graphics, ClipBrd, Consts;

const
  // FlexGraphics document clipboard format
  CF_FLEXDOC : Word = 0;

  // Reserved word's in fxd format
  fcDocument  = 'document';
  fcClipboard = 'clipboard';
  fcLibrary   = 'library';
  fcObject    = 'object';
  fcProperty  = 'property';
  fcEnd       = 'end';

  // array of all reserved words
  fcReserved: array[0..5] of string = (
    fcDocument, fcClipboard, fcLibrary, fcObject, fcProperty, fcEnd );

  IndentStep  = '  ';

  // Cursors in InDesign mode
  crShapeCursor         = 1;
  crShapeAddCursor      = 2;
  crShapeDelCursor      = 3;
  crShapeCloseCursor    = 4;
  crShapeMoveCursor     = 5;

  crCreateControlCursor = 6;
  crCreateRectCursor    = 7;
  crCreateEllipseCursor = 8;
  crCreateTextCursor    = 9;
  crCreatePicCursor     = 10;
  crCreatePolyCursor    = 11;

  crZoomInCursor        = 12;
  crZoomOutCursor       = 13;

  crPanCursor           = 14;
  crPanningCursor       = 15;

  crLastFlexCursor      = 15;

  // Scaling
  FloatDisplayFormat: string = '%.3f';
  PixelScaleFactor = 1000;

type
  TFlexNotify = (
    fnName, fnRect, fnAnchorPoints, fnEditPoints, fnOrder,  fnLoaded,
    fnLayers, fnSchemes, fnCreated, fnDestroyed, fnSelect, fnSelectPoint,
    fnScale );

  PTranslateInfo = ^TTranslateInfo;
  TTranslateInfo = record
   Center: TPoint;  // in document (owner) coordinate system
   Rotate: integer; // counterclockwise degree
   Mirror: boolean; // horizontal mirroring
  end;

  TBooleanArray = array of boolean;

  TGradientStyle = (
    gsHorizontal, gsVertical, gsSquare, gsElliptic,
    gsTopLeft, gsTopRight, gsBottomLeft, gsBottomRight );

  TFlexFilerProcess = ( ppUnknown, ppLoad, ppSave, ppCopy );

  TFlexProgressEvent = procedure(Sender: TObject; Progress: integer;
    Process: TFlexFilerProcess) of object;

  TFlexFiler = class
  private
   FStream: TStream;
   FBuffer: Pointer;
   FBufSize: Integer;
   FBufPos: Integer;
   FBufEnd: Integer;
   FTotal: integer;
   FSaved: integer;
   FLoaded: integer;
   FProgress: integer;
   FOnProgress: TFlexProgressEvent;
   procedure SetSaved(const Value: integer);
   procedure SetTotal(const Value: integer);
  protected
   procedure ReadBuffer;
   procedure DoProgress(Process: TFlexFilerProcess);
   function  GetStreamSize: integer;
   property  Stream: TStream read FStream;
  public
   constructor Create(AStream: TStream);
   destructor Destroy; override;
   procedure SaveStr(const s: string);
   procedure SaveBuf(Buf: pointer; BufSize: integer);
   function  LoadStr: string;
   function  LoadStrCheck(out s: string): boolean;
   procedure LoadSkipToEnd;
   function  CheckLoadSkipToEnd(const First: string): boolean;
   function  IsEndOfStream: boolean;
   procedure Rewind;
   property  Total: integer read FTotal write SetTotal;
   property  Saved: integer read FSaved write SetSaved;
   property  Loaded: integer read FLoaded;
   property  StreamSize: integer read GetStreamSize;
   property  Progress: integer read FProgress;
   property  OnProgress: TFlexProgressEvent read FOnProgress write FOnProgress;
  end;

  TIdPool = class
  private
   FPool: TList;
   function  GetUsed(Value: cardinal): boolean;
  public
   constructor Create;
   destructor Destroy; override;
   function  Generate: cardinal;
   function  Use(Value: cardinal): boolean;
   function  Release(Value: cardinal): boolean;
   procedure Clear;
   property  Used[Value: cardinal]: boolean read GetUsed;
   property  PoolList: TList read FPool;
  end;

procedure LoadFlexCursors;

function  StrBeginsFrom(const S1, S2: string): boolean;
function  ExtractWord(const s: string; NumWord: integer; Delimiter: char): string;
function  HexCharsToByte(cw: word): byte;
function  ByteToHexChars(b: byte): word;
function  RectWidth(const ARect: TRect): integer;
function  RectHeight(const ARect: TRect): integer;

procedure GetPicReadWrite(Picture: TPicture;
  out ReadProc, WriteProc: TStreamProc);
function  NormalizeRect(const R: TRect): TRect;
function  PointInRect(const p: TPoint; const R: TRect): boolean;

function  IntersectClipRgn(ACanvas: TCanvas; ClipRgn: HRGN): HRGN;
function  IntersectClipPath(DC: HDC): HRGN;
procedure PaintGradient(ACanvas: TCanvas; ARect: TRect; Style: TGradientStyle;
  Color, EndColor: TColor; PenMode: TPenMode);
procedure PaintTailed(ACanvas: TCanvas; const PaintRect, RefreshRect: TRect;
  ABitmap: TBitmap);

function  ScaleValue(Value, Scale: integer): integer;
function  UnScaleValue(Value, Scale: integer): integer;
function  ScalePixels(Value: integer): integer;
function  UnScalePixels(Value: integer): integer;

function  ListScan(Value, List: Pointer; Count: integer): integer;
function  ListScanEx(Value, List: Pointer; Index, Count: integer): integer;
function  ListScanLess(Value, List: Pointer; Count: integer): integer;

{$IFNDEF FG_D5}
procedure FreeAndNil(var Obj);

function GetPropValue(Instance: TObject; const PropName: string;
  PreferStrings: Boolean): Variant;
procedure SetPropValue(Instance: TObject; const PropName: string;
  const Value: Variant);
function PropType(AClass: TClass; const PropName: string): TTypeKind;
{$ENDIF}

implementation

{$R cursors.res}

// TFlexFiler ////////////////////////////////////////////////////////////////

constructor TFlexFiler.Create(AStream: TStream);
begin
 inherited Create;
 FStream := AStream;
 FBufSize := 4096;
 GetMem(FBuffer, FBufSize);
 try
  FTotal := GetStreamSize;
  FLoaded := FStream.Seek(0, soFromCurrent);
 except

 end;
end;

destructor TFlexFiler.Destroy;
begin
 if Assigned(FBuffer) then begin
  FreeMem(FBuffer, FBufSize);
  FBuffer := Nil;
 end;
 inherited;
end;

procedure TFlexFiler.ReadBuffer;
begin
 FBufEnd := FStream.Read(FBuffer^, FBufSize);
 //if FBufEnd = 0 then raise EReadError.CreateRes(@SReadError);
 FBufPos := 0;
 inc(FLoaded, FBufEnd);
end;

procedure TFlexFiler.SaveStr(const s: string);
const EOLN = #$0D#$0A;
begin
 if Length(s) > 0 then FStream.Write(s[1], Length(s));
 FStream.Write(EOLN, Length(EOLN));
end;

procedure TFlexFiler.SaveBuf(Buf: pointer; BufSize: integer);
begin
 FStream.Write(Buf^, BufSize);
end;

function TFlexFiler.LoadStr: string;
begin
 LoadStrCheck(Result);
end;

function TFlexFiler.LoadStrCheck(out s: string): boolean;
var StrBeg, StrEnd, Len: integer;
    Delim: Char;
begin
 s := '';
 StrBeg := -1;
 StrEnd := -1;
 repeat
  if (FBufPos = FBufEnd) then begin
   ReadBuffer;
   if FBufEnd = 0 then break;
   StrBeg := FBufPos;
  end;
  if StrEnd < 0 then begin
   StrBeg := FBufPos;
   while (StrBeg < FBufEnd) and (PChar(FBuffer)[StrBeg] = ' ') do inc(StrBeg);
   FBufPos := StrBeg;
   if FBufPos = FBufEnd then continue;
  end;
  StrEnd := StrBeg;
  while (StrEnd < FBufEnd) and (PChar(FBuffer)[StrEnd] <> #$0D) and
        (PChar(FBuffer)[StrEnd] <> #$0A) do inc(StrEnd);
  Delim := PChar(FBuffer)[StrEnd];
  FBufPos := StrEnd;
  if StrEnd > StrBeg then begin
   Len := Length(s);
   SetLength(s, Len + (StrEnd - StrBeg));
   Move(PChar(FBuffer)[StrBeg], s[Len+1], StrEnd - StrBeg);
  end;
  if FBufPos = FBufEnd then continue;
  inc(FBufPos);
  if FBufPos = FBufEnd then begin
   ReadBuffer;
   if FBufEnd = 0 then break;
  end;
  if ((PChar(FBuffer)[FBufPos] = #$0D) or (PChar(FBuffer)[FBufPos] = #$0A)) and
     (PChar(FBuffer)[FBufPos] <> Delim) then
   inc(FBufPos);
  break;
 until false;
 Result := FBufEnd > 0;
 if Result and (FBufPos = FBufEnd) then begin
  ReadBuffer;
  Result := FBufEnd > 0;
 end;
 DoProgress(ppLoad);
end;

procedure TFlexFiler.LoadSkipToEnd;
var s: string;
    Level: integer;
begin
 Level := 1;
 while (Level > 0) and LoadStrCheck(s) do
  if StrBeginsFrom(s, fcEnd) then
   dec(Level)
  else
  if StrBeginsFrom(s, fcObject) or StrBeginsFrom(s, fcProperty) then
   inc(level);
end;

function TFlexFiler.CheckLoadSkipToEnd(const First: string): boolean;
begin
 Result :=
   StrBeginsFrom(First, fcDocument) or
   StrBeginsFrom(First, fcClipboard) or
   StrBeginsFrom(First, fcLibrary) or
   StrBeginsFrom(First, fcObject) or
   StrBeginsFrom(First, fcProperty);
 if Result then LoadSkipToEnd;
end;

function TFlexFiler.IsEndOfStream: boolean;
var EndPos, Pos: Longint;
begin
 Pos := FStream.Seek(0, soFromCurrent);
 EndPos := FStream.Seek(0, soFromEnd);
 FStream.Seek(Pos, soFromBeginning);
 Result := Pos = EndPos;
end;

procedure TFlexFiler.Rewind;
begin
 FStream.Position := 0;
 FLoaded := 0;
 FSaved := 0;
end;

function TFlexFiler.GetStreamSize: integer;
var Pos: integer;
begin
 try
  Pos := FStream.Seek(0, soFromCurrent);
  Result:= FStream.Seek(0, soFromEnd);
  FStream.Seek(Pos, soFromBeginning);
 except
  Result := 0;
 end;
end;

procedure TFlexFiler.SetSaved(const Value: integer);
begin
 if Value = FSaved then exit;
 FSaved := Value;
 DoProgress(ppSave);
end;

procedure TFlexFiler.SetTotal(const Value: integer);
begin
 if Value = FTotal then exit;
 FTotal := Value;
end;

procedure TFlexFiler.DoProgress(Process: TFlexFilerProcess);
var NewProgress: integer;
begin
 if not Assigned(FOnProgress) or (FTotal = 0) then exit;
 case Process of
  ppLoad: NewProgress := Round(FLoaded / FTotal * 100);
  ppSave: NewProgress := Round(FSaved / FTotal * 100);
  else exit;
 end;
 if NewProgress <> FProgress then begin
  FProgress := NewProgress;
  FOnProgress(Self, FProgress, Process);
 end;
end;

// TIdPool ///////////////////////////////////////////////////////////////

constructor TIdPool.Create;
begin
 FPool := TList.Create;
end;

destructor TIdPool.Destroy;
begin
 FPool.Free;
 inherited;
end;

function TIdPool.Generate: cardinal;
begin
 if FPool.Count = 0 then begin
  // Generate first identifier
  FPool.Add(pointer(1));
  FPool.Add(pointer(1));
  Result := 1;
 end else
 if integer(FPool[0]) > 1 then begin
  // The indentifier 1 is not used
  if integer(FPool[0]) = 2 then begin
   FPool[0] := pointer(1);
   Result := 1;
  end else begin
   FPool.Insert(0, pointer(1));
   FPool.Insert(0, pointer(1));
   Result := 1;
  end;
 end else begin
  Result := cardinal(FPool[1]);
  inc(Result);
  if (FPool.Count > 2) and (cardinal(FPool[2]) = Result+1) then begin
   // Combine neighbor regions
   FPool.Delete(2);
   FPool.Delete(1);
  end else
   // Use identifier
   FPool[1] := pointer(Result);
 end;
end;

function TIdPool.GetUsed(Value: cardinal): boolean;
var Index: integer;
begin
 Result := false;
 if Value <= 0 then exit;
 Index := ListScanLess(pointer(Value), FPool.List, FPool.Count);
 Result := (Index < FPool.Count) and
          ((Index and 1 <> 0) or (cardinal(FPool[Index]) = Value));
end;

function  TIdPool.Use(Value: cardinal): boolean;
var Index: integer;
begin
 Result := false;
 if Value <= 0 then exit;
 Index := ListScanLess(pointer(Value), FPool.List, FPool.Count);
 if Index = FPool.Count then begin
  // Value greater then last used identifier or FPool is empty
  if (FPool.Count > 0) and (cardinal(FPool[FPool.Count-1]) = Value-1) then
   FPool[FPool.Count-1] := pointer(Value)
  else begin
   FPool.Add(pointer(Value));
   FPool.Add(pointer(Value));
  end;
  Result := true;
 end else
 if (cardinal(FPool[Index]) <> Value) and (Index and 1 = 0) then begin
  // Value is not in use
  if cardinal(FPool[Index]) = Value+1 then begin
   // Insert value in used region
   if (Index > 0) and (cardinal(FPool[Index-1]) = Value-1) then begin
    // Cancat with previous region
    FPool.Delete(Index);
    FPool.Delete(Index-1);
   end else
    // insert
    FPool[Index] := pointer(Value);
  end else
  if (Index > 0) and (cardinal(FPool[Index-1]) = Value-1) then