ddoc.pas

KSDev.BlockEngine.v3.03.rar 界面控件

function RectByPoint(X1, Y1, X2, Y2: Float): FloatRect;
begin
  if X1 < X2 then
  begin
    Result.Left := X1;
    Result.Right := X2;
  end
  else
  begin
    Result.Left := X2;
    Result.Right := X1;
  end;
  if Y1 < Y2 then
  begin
    Result.Top := Y1;
    Result.Bottom := Y2;
  end
  else
  begin
    Result.Top := Y2;
    Result.Bottom := Y1;
  end;
end;

function GPRectByPoint(X1, Y1, X2, Y2: Float): TGPRectF;
var
  R: FloatRect;
begin
  R := RectByPoint(X1, Y1, X2, Y2);
  Result := MakeRect(R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top);
end;

function RectByBlock(ABlock: Block): FloatRect;
var
  i: integer;
begin
  Result.Left := $FFFFFF;
  Result.Top := $FFFFFF;
  Result.Right := -$FFFFFF;
  Result.Bottom := -$FFFFFF;
  for i := 0 to ABlock.Points.Count - 1 do
  begin
    if ABlock.Points[i].X < Result.Left then Result.Left := ABlock.Points[i].X;
    if ABlock.Points[i].Y < Result.Top then Result.Top := ABlock.Points[i].Y;
    if ABlock.Points[i].X > Result.Right then Result.Right := ABlock.Points[i].X;
    if ABlock.Points[i].Y > Result.Bottom then Result.Bottom := ABlock.Points[i].Y;
  end;
end;

function GPRectByBlock(ABlock: Block): TGPRectF;
var
  R: FloatRect;
begin
  R := RectByBlock(ABlock);
  Result := MakeRect(R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top);
end;

function RectByPoints(Pts: array of FloatPoint): FloatRect;
var
  i: integer;
begin
  Result.Left := $FFFFFF;
  Result.Top := $FFFFFF;
  Result.Right := -$FFFFFF;
  Result.Bottom := -$FFFFFF;
  for i := Low(Pts) to High(Pts) do
  begin
    if Pts[i].X < Result.Left then Result.Left := Pts[i].X;
    if Pts[i].Y < Result.Top then Result.Top := Pts[i].Y;
    if Pts[i].X > Result.Right then Result.Right := Pts[i].X;
    if Pts[i].Y > Result.Bottom then Result.Bottom := Pts[i].Y;
  end;
end;

function GPRectByPoints(Pts: array of FloatPoint): TGPRectF;
var
  R: FloatRect;
begin
  R := RectByPoints(Pts);
  Result := MakeRect(R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top);
end;

function StringToArray(S: string): TNotificationResult;
var
  i: integer;
begin
  SetLength(Result, Length(S));
  for i := 1 to Length(S) do
    Result[i - 1] := Ord(S[i]);
end;

function ArrayToString(A: array of Double): string;
var
  i: integer;
begin
  SetLength(Result, Length(A));
  for i := 0 to High(A) do
    Result[i + 1] := Char(Trunc(A[i]));
end;

{ BlockList ===================================================================}

destructor BlockList.Destroy;
var
  i: integer;
begin
  for i := 0 to Count - 1 do
    Blocks[i].Free;
  inherited;
end;

function BlockList.GetBlock(Index: integer): Block;
begin
  Result := Block(Items[Index]);
end;

{ FillStyle ===================================================================}

constructor FillStyle.Create;
begin
  inherited Create;
  FColor := aclWhite;
  FPatternColor := aclBlack;
  FGradientColor := aclBlack;
  FTexture := TBitmap.Create;
  FTexture.HandleType := bmDIB;
  FTexture.PixelFormat := pf24bit;
  FTexture.Width := 1;
  FTexture.Height := 1;
end;

destructor FillStyle.Destroy;
begin
  FTexture.Free;
  inherited;
end;

procedure FillStyle.Assign(Source: TPersistent);
begin
  if Source is FillStyle then
  begin
    Color := (Source as FillStyle).Color;
    Style := (Source as FillStyle).Style;
    Pattern := (Source as FillStyle).Pattern;
    PatternColor := (Source as FillStyle).PatternColor;
    GradientColor := (Source as FillStyle).GradientColor;
    GradientAngle := (Source as FillStyle).GradientAngle;
    Texture := (Source as FillStyle).Texture;
  end
  else
    inherited;
end;

function FillStyle.GetBrush(Left, Top, Right, Bottom: Float): TGPBrush;
var
  B: TGPBitmap;
begin
  case FStyle of
    FillNone:
      begin
        Result := TGPSolidBrush.Create($00000000);
      end;
    FillSolid:
      begin
        Result := TGPSolidBrush.Create(FColor);
      end;
    FillPattern:
      begin
        Result := TGPHatchBrush.Create(THatchStyle(FPattern), FPatternColor, FColor);
      end;
    FillLinearGradient:
      begin
        Result := TGPLinearGradientBrush.Create(MakeRect(Left, Top, Right - Left, Bottom - Top),
          FColor, FGradientColor, FGradientAngle);
      end;
    FillPathGradient:
      begin
        Result := TGPSolidBrush.Create(FColor);
      end;
    FillTexture:
      begin
        B := TGPBitmap.Create(FTexture.Handle, FTexture.Palette);
        Result := TGPTextureBrush.Create(B);
        B.Free;
      end;
  else
    Result := nil;
  end;
end;

procedure FillStyle.SetTexture(const Value: TBitmap);
begin
  if (Value <> nil) then
  begin
    FTexture.Width := Value.Width;
    FTexture.Height := Value.Height;
    FTexture.Canvas.Draw(0, 0, Value);
  end;
end;

{ StrokeStyle =================================================================}

procedure StrokeStyle.Assign(Source: TPersistent);
begin
  if Source is StrokeStyle then
  begin
    Clear := (Source as StrokeStyle).Clear;
    Cap := (Source as StrokeStyle).Cap;
    Color := (Source as StrokeStyle).Color;
    Pattern := (Source as StrokeStyle).Pattern;
    Width := (Source as StrokeStyle).Width;
  end
  else
    inherited;
end;

constructor StrokeStyle.Create;
begin
  inherited Create;
  FColor := aclBlack;
  FWidth := 0.02;
end;

destructor StrokeStyle.Destroy;
begin

  inherited;
end;

function StrokeStyle.GetPen: TGPPen;
begin
  if FClear then
  begin
    Result := TGPPen.Create($00000000);
    Exit;
  end;

  Result := TGPPen.Create(FColor);
  Result.SetWidth(FWidth);
  case Cap of
    CapFlat: Result.SetLineCap(LineCapFlat, LineCapFlat, DashCapFlat);
    CapRound: Result.SetLineCap(LineCapRound, LineCapRound, DashCapRound);
    CapSquare: Result.SetLineCap(LineCapSquare, LineCapSquare, DashCapFlat);
    CapTriangle: Result.SetLineCap(LineCapTriangle, LineCapTriangle, DashCapTriangle);
  end;
  Result.SetLineJoin(LineJoinRound);
  Result.SetDashStyle(DashStyle(FPattern));
end;

{ BlockPoint ==================================================================}

constructor BlockPoint.Create(Collection: TCollection);
begin
  inherited;
  FHot := false;
  FStyle := [];
  FEnabled := true;
  FConnectedPoints := TList.Create;
  FName := ClassName + IntToStr(Integer(Self));
end;

destructor BlockPoint.Destroy;
begin
  FConnectedPoints.Free;
  inherited;
end;

procedure BlockPoint.CopyFrom(Source: BlockPoint);
begin
  FName := Source.Name;
  FX := Source.X;
  FY := Source.Y;
  FKind := Source.Kind;
  FStyle := Source.Style;
  FMoveStyle := Source.MoveStyle;
  { !!! }
  FCenterPoint := Source.CenterPoint;

  FAlign := Source.Align;
  FEnabled := Source.Enabled;
  FCenterPointName := Source.CenterPointName;

  SetConnectedPointsList(Source.FConnectedPointsStr);
end;

function BlockPoint.GetOwnerBlock: Block;
begin
  Result := BlockPoints(Collection).FBlock;
end;

function BlockPoint.GetConnectedPointsList: string;
var
  i: integer;
begin
  for i := 0 to FConnectedPoints.Count - 1 do
  begin
    Result := Result + BlockPoint(FConnectedPoints[i]).Owner.Name + '=' + BlockPoint(FConnectedPoints[i]).Name;
    if i < FConnectedPoints.Count - 1 then
      Result := Result + ',';
  end;
end;

procedure BlockPoint.SetConnectedPointsList(const Value: string);
var
  i: integer;
  S: TStrings;
  Sp: Block;
  P: BlockPoint;
  Sv: string;
  R: TNotificationResult;
begin
  FConnectedPointsStr := Value;

  R := nil;
  S := TStringList.Create;
  try
    S.CommaText := Value;

    for i := 0 to S.Count - 1 do
    begin
      Sv := S.Names[i];
      R := Owner.PerformNotification(deFindBlockByName, Owner, StringToArray(Sv));
      if High(R) >= 0 then
      begin
        Sp := Block(Trunc(R[0]));
        if Sp <> nil then
        begin
          P := Sp.PointByName(S.Values[S.Names[i]]);
          if P <> nil then
          begin
            FConnectedPoints.Add(P);
            P.FDockBlock := Owner;
          end;
        end;
      end;
    end;
  finally
    S.Free;
  end;
end;

function BlockPoint.GetCenterPointName: string;
begin
  if FCenterPoint <> nil then
    Result := FCenterPoint.Name
  else
    Result := '';
end;

procedure BlockPoint.SetCenterPointName(const Value: string);
begin
  if (Value <> '') and (Owner <> nil) then
  begin
    FCenterPoint := Owner.PointByName(Value);
  end;
end;

{ BlockPoints =================================================================}

function BlockPoints.GetPoint(Index: integer): BlockPoint;
begin
  Result := BlockPoint(GetItem(Index));
end;

{ Block =======================================================================}

constructor Block.Create;
begin
  CreateNew(AOwner, true, true);
end;

constructor Block.CreateNew(AOwner: TComponent; CreateTextBlock: boolean; CreatePoints: boolean);
var
  P: BlockPoint;
begin
  inherited Create(AOwner);

  FBlocks := BlockList.Create;
//  Name := ClassName + IntToStr(Integer(Self)) + UniqueName(ClassName);
  FBlockName := ClassName;
  FFill := FillStyle.Create;
  FStroke := StrokeStyle.Create;
  FStroke.Width := 0.01;
  FWidth := 1;
  FHeight := 1;
  FRotateCenter := MakePoint(0.5, 0.5);

  FPoints := BlockPoints.Create(BlockPoint);
  FPoints.FBlock := Self;

  if CreatePoints then
  begin
    P := BlockPoint(FPoints.Add);
    P.Kind := pkLeftTop;
    P.Name := 'lefttop';
    P.X := 0;
    P.Y := 0;
    P := BlockPoint(FPoints.Add);
    P.Kind := pkTop;
    P.Name := 'top';
    P.X := 0.5;
    P.Y := 0;
    P := BlockPoint(FPoints.Add);
    P.Kind := pkRightTop;
    P.Name := 'righttop';
    P.X := 1;
    P.Y := 0;
    P := BlockPoint(FPoints.Add);
    P.Kind := pkRight;
    P.Name := 'right';
    P.X := 1;
    P.Y := 0.5;
    P := BlockPoint(FPoints.Add);
    P.Kind := pkRightBottom;
    P.Name := 'rightbottom';
    P.X := 1;
    P.Y := 1;
    P := BlockPoint(FPoints.Add);
    P.Kind := pkBottom;
    P.Name := 'bottom';
    P.X := 0.5;
    P.Y := 1;
    P := BlockPoint(FPoints.Add);
    P.Kind := pkLeftBottom;
    P.Name := 'leftbottom';
    P.X := 0;
    P.Y := 1;
    P := BlockPoint(FPoints.Add);
    P.Kind := pkLeft;
    P.Name := 'left';
    P.X := 0;
    P.Y := 0.5;

    { Rotate }
    P := BlockPoint(FPoints.Add);
    P.Kind := pkRotateLeftTop;
    P.X := 0;
    P.Y := 0;
    P := BlockPoint(FPoints.Add);
    P.Kind := pkRotateRightTop;
    P.X := 1;
    P.Y := 0;
    P := BlockPoint(FPoints.Add);
    P.Kind := pkRotateRightBottom;
    P.X := 1;
    P.Y := 1;
    P := BlockPoint(FPoints.Add);
    P.Kind := pkRotateLeftBottom;
    P.X := 0;
    P.Y := 1;

    { new style rotate }
    P := BlockPoint(FPoints.Add);
    P.Name := 'rotate';
    P.Kind := pkRotate;
    P.Align := paTop;
    P.X := 0.5;
    P.Y := -0.20;

    P := BlockPoint(FPoints.Add);
    P.Kind := pkRotateCenter;
    P.Name := 'rotatecenter';
    P.X := FRotateCenter.X;
    P.Y := FRotateCenter.Y;
  end;

  if CreateTextBlock then
  begin
    { Text }