./lazpaint-7.1.6/ 0000775 0001750 0001750 00000000000 13762405135 013706 5 ustar circular circular ./lazpaint-7.1.6/commit.sh 0000775 0001750 0001750 00000000372 13761713342 015540 0 ustar circular circular #!/bin/bash
git checkout HEAD~ -- lazpaint/release/bin/i18n/*.po
git add .
git status
echo "Type commit description (or press Enter to cancel):"
read commitdesc
if test -z "$commitdesc"
then
git reset --
else
git commit -m "$commitdesc"
fi
cd ..
./lazpaint-7.1.6/configure 0000775 0001750 0001750 00000003767 13761713342 015633 0 ustar circular circular #!/usr/bin/env bash
echo For help type: ./configure --help
args=("$@")
haserror=false
defaultfpc=fpc
wantedfpc=$defaultfpc
if [ -f "debian/CONFIGURE_DEFAULT_FPCBIN" ]; then
wantedfpc=$(cat debian/CONFIGURE_DEFAULT_FPCBIN)
fi
defaultprefix=/usr/local
wantedprefix=$defaultprefix
if [ -f "debian/CONFIGURE_DEFAULT_LAZDIR" ]; then
wantedlazdir=$(cat debian/CONFIGURE_DEFAULT_LAZDIR)
else
wantedlazdir=
fi
for param in "${args[@]}"
do
if [ "$param" == "-h" ] || [ "$param" == "--help" ]; then
echo "Usage: ./configure [OPTIONS]"
echo ""
echo " --prefix=PREFIX"
echo " Specifies the install prefix."
echo " By default prefix is \"$defaultprefix\""
echo " For packages use \"/usr\""
echo ""
echo " --lazdir=BASE_DIRECTORY_OF_LAZARUS"
echo " Specifies to compile with FPC using the specified Lazarus sources."
echo " Otherwise lazbuild will be used."
echo ""
echo " --fpcbin=FPC_BINARY"
echo " Specifies the command to call Free Pascal Compiler."
echo " Default is \"$defaultfpc\""
exit 0
elif [ "${param:0:9}" == "--prefix=" ]; then
wantedprefix=${param:9}
elif [ "${param:0:9}" == "--lazdir=" ]; then
wantedlazdir=${param:9}
elif [ "${param:0:9}" == "--fpcbin=" ]; then
wantedfpc=${param:9}
else
echo "Warning: unknown option $param"
fi
done
echo "Prefix set to: $wantedprefix"
echo $wantedprefix >prefix
if [ "$wantedlazdir" == "" ]; then
echo "Using lazbuild"
rm -f lazdir
touch lazdir
rm -f fpcbin
else
echo "Using FPC with Lazarus source: $wantedlazdir"
if [ ! -d "$wantedlazdir" ]; then
echo "Error: directory not found!"
haserror=true
elif [ ! -d "$wantedlazdir/lcl" ]; then
echo "Warning: it does not seem to be the directory of Lazarus!"
fi
echo $wantedlazdir >lazdir
echo "Compiler set to: $wantedfpc"
rm -f fpcbin
echo $wantedfpc >fpcbin
fi
if [ "$haserror" = true ]; then
exit 1
else
if [ "$(uname)" == "FreeBSD" ]; then
echo "You can now type: gmake"
else
echo "You can now type: make"
fi
exit 0
fi
./lazpaint-7.1.6/lazpaintcontrols/ 0000775 0001750 0001750 00000000000 13762405135 017314 5 ustar circular circular ./lazpaint-7.1.6/lazpaintcontrols/lcvectorialfillcontrol.pas 0000664 0001750 0001750 00000036246 13761713342 024614 0 ustar circular circular // SPDX-License-Identifier: GPL-3.0-only
unit LCVectorialFillControl;
{$mode objfpc}{$H+}
interface
uses
Types, Classes, SysUtils, Controls, LCVectorialFillInterface,
LCVectorialFill, BGRABitmap, BGRABitmapTypes, BGRAGradientScanner,
LCVectorOriginal;
type
TLCFillTarget = LCVectorialFillInterface.TLCFillTarget;
const
ftPen = LCVectorialFillInterface.ftPen;
ftBack = LCVectorialFillInterface.ftBack;
ftOutline = LCVectorialFillInterface.ftOutline;
type
{ TLCVectorialFillControl }
TLCVectorialFillControl = class(TWinControl)
private
function GetAllowedFillTypes: TVectorialFillTypes;
function GetAverageColor: TBGRAPixel;
function GetCanAdjustToShape: boolean;
function GetCanEditGradTexPoints: boolean;
function GetEditingGradTexPoints: boolean;
function GetFillType: TVectorialFillType;
function GetGradEndColor: TBGRAPixel;
function GetGradInterp: TBGRAColorInterpolation;
function GetGradRepetition: TBGRAGradientRepetition;
function GetGradStartColor: TBGRAPixel;
function GetGradType: TGradientType;
function GetIsTarget: boolean;
function GetPreferredSizeAsSize: TSize;
function GetSolidColor: TBGRAPixel;
function GetTexOpacity: byte;
function GetTexRepetition: TTextureRepetition;
function GetTexture: TBGRABitmap;
function GetToolIconSize: integer;
function GetVerticalPadding: integer;
procedure InterfaceMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure InterfaceMouseEnter(Sender: TObject);
procedure InterfaceMouseLeave(Sender: TObject);
procedure InterfaceMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure InterfaceMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure SetAllowedFillTypes(AValue: TVectorialFillTypes);
procedure SetCanAdjustToShape(AValue: boolean);
procedure SetCanEditGradTexPoints(AValue: boolean);
procedure SetEditingGradTexPoints(AValue: boolean);
procedure SetFillType(AValue: TVectorialFillType);
procedure SetGradEndColor(AValue: TBGRAPixel);
procedure SetGradientType(AValue: TGradientType);
procedure SetGradInterpolation(AValue: TBGRAColorInterpolation);
procedure SetGradRepetition(AValue: TBGRAGradientRepetition);
procedure SetGradStartColor(AValue: TBGRAPixel);
procedure SetIsTarget(AValue: boolean);
procedure SetOnChooseColor(AValue: TChooseColorEvent);
procedure SetOnTextureClick(AValue: TNotifyEvent);
procedure SetSolidColor(AValue: TBGRAPixel);
procedure SetTexture(AValue: TBGRABitmap);
procedure SetTextureOpacity(AValue: byte);
procedure SetTextureRepetition(AValue: TTextureRepetition);
procedure SetToolIconSize(AValue: integer);
procedure SetVerticalPadding(AValue: integer);
protected
FInterface: TVectorialFillInterface;
FOnAdjustToShape: TNotifyEvent;
FOnEditGradTexPoints: TNotifyEvent;
FOnChooseColor: TChooseColorEvent;
FOnFillChange: TNotifyEvent;
FOnFillTypeChange: TNotifyEvent;
FOnTextureClick: TNotifyEvent;
FOnTextureChange: TNotifyEvent;
procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
{%H-}WithThemeSpace: Boolean); override;
procedure DoOnAdjustToShape(Sender: TObject);
procedure DoOnEditGradTexPoints(Sender: TObject);
procedure DoOnFillChange(Sender: TObject);
procedure DoOnFillTypeChange(Sender: TObject);
procedure DoOnTextureClick(Sender: TObject);
procedure DoOnTextureChange(Sender: TObject);
procedure DoOnResize; override;
procedure DoOnChooseColor({%H-}ASender: TObject; AButton: TMouseButton;
AColorIndex: integer; var AColorValue: TBGRAPixel; out AHandled: boolean);
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
procedure AssignFill(AFill: TVectorialFill);
function CreateShapeFill(AShape: TVectorShape): TVectorialFill;
procedure UpdateShapeFill(AShape: TVectorShape; ATarget: TLCFillTarget);
procedure UpdateFillExceptGeometry(ATargetFill: TVectorialFill);
property FillType: TVectorialFillType read GetFillType write SetFillType;
property IsTarget: boolean read GetIsTarget write SetIsTarget;
property AverageColor: TBGRAPixel read GetAverageColor;
property SolidColor: TBGRAPixel read GetSolidColor write SetSolidColor;
property GradientType: TGradientType read GetGradType write SetGradientType;
property GradStartColor: TBGRAPixel read GetGradStartColor write SetGradStartColor;
property GradEndColor: TBGRAPixel read GetGradEndColor write SetGradEndColor;
property GradRepetition: TBGRAGradientRepetition read GetGradRepetition write SetGradRepetition;
property GradInterpolation: TBGRAColorInterpolation read GetGradInterp write SetGradInterpolation;
property Texture: TBGRABitmap read GetTexture write SetTexture;
property TextureRepetition: TTextureRepetition read GetTexRepetition write SetTextureRepetition;
property TextureOpacity: byte read GetTexOpacity write SetTextureOpacity;
property CanAdjustToShape: boolean read GetCanAdjustToShape write SetCanAdjustToShape;
property PreferredSize: TSize read GetPreferredSizeAsSize;
published
property AutoSize;
property Align;
property Enabled;
property Visible;
property ToolIconSize: integer read GetToolIconSize write SetToolIconSize;
property VerticalPadding: integer read GetVerticalPadding write SetVerticalPadding;
property AllowedFillTypes: TVectorialFillTypes read GetAllowedFillTypes write SetAllowedFillTypes;
property CanEditGradTexPoints: boolean read GetCanEditGradTexPoints write SetCanEditGradTexPoints;
property EditingGradTexPoints: boolean read GetEditingGradTexPoints write SetEditingGradTexPoints;
property OnChooseColor: TChooseColorEvent read FOnChooseColor write SetOnChooseColor;
property OnFillChange: TNotifyEvent read FOnFillChange write FOnFillChange;
property OnTextureChange: TNotifyEvent read FOnTextureChange write FOnTextureChange;
property OnAdjustToShape: TNotifyEvent read FOnAdjustToShape write FOnAdjustToShape;
property OnEditGradTexPoints: TNotifyEvent read FOnEditGradTexPoints write FOnEditGradTexPoints;
property OnFillTypeChange: TNotifyEvent read FOnFillTypeChange write FOnFillTypeChange;
property OnTextureClick: TNotifyEvent read FOnTextureClick write SetOnTextureClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseEnter;
property OnMouseLeave;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Lazpaint Controls', [TLCVectorialFillControl]);
end;
{ TLCVectorialFillControl }
procedure TLCVectorialFillControl.DoOnChooseColor(ASender: TObject; AButton: TMouseButton;
AColorIndex: integer; var AColorValue: TBGRAPixel; out AHandled: boolean);
begin
If Assigned(FOnChooseColor) then
FOnChooseColor(self, AButton, AColorIndex, AColorValue, AHandled)
else
AHandled := false;
end;
procedure TLCVectorialFillControl.DoOnTextureClick(Sender: TObject);
begin
if Assigned(FOnTextureClick) then FOnTextureClick(self);
end;
function TLCVectorialFillControl.GetAllowedFillTypes: TVectorialFillTypes;
begin
result := FInterface.AllowedFillTypes;
end;
function TLCVectorialFillControl.GetAverageColor: TBGRAPixel;
begin
result := FInterface.AverageColor;
end;
function TLCVectorialFillControl.GetCanAdjustToShape: boolean;
begin
result := FInterface.CanAdjustToShape;
end;
function TLCVectorialFillControl.GetCanEditGradTexPoints: boolean;
begin
result := FInterface.CanEditGradTexPoints;
end;
function TLCVectorialFillControl.GetEditingGradTexPoints: boolean;
begin
result := FInterface.EditingGradTexPoints;
end;
function TLCVectorialFillControl.GetFillType: TVectorialFillType;
begin
result := FInterface.FillType;
end;
function TLCVectorialFillControl.GetGradEndColor: TBGRAPixel;
begin
result := FInterface.GradEndColor;
end;
function TLCVectorialFillControl.GetGradInterp: TBGRAColorInterpolation;
begin
result := FInterface.GradInterpolation;
end;
function TLCVectorialFillControl.GetGradRepetition: TBGRAGradientRepetition;
begin
result := FInterface.GradRepetition;
end;
function TLCVectorialFillControl.GetGradStartColor: TBGRAPixel;
begin
result := FInterface.GradStartColor;
end;
function TLCVectorialFillControl.GetGradType: TGradientType;
begin
result := FInterface.GradientType;
end;
function TLCVectorialFillControl.GetIsTarget: boolean;
begin
result := FInterface.IsTarget;
end;
function TLCVectorialFillControl.GetPreferredSizeAsSize: TSize;
begin
result.cx:= Width;
result.cy:= Height;
GetPreferredSize(result.cx, result.cy);
end;
function TLCVectorialFillControl.GetSolidColor: TBGRAPixel;
begin
result := FInterface.SolidColor;
end;
function TLCVectorialFillControl.GetTexOpacity: byte;
begin
result := FInterface.TextureOpacity;
end;
function TLCVectorialFillControl.GetTexRepetition: TTextureRepetition;
begin
result := FInterface.TextureRepetition;
end;
function TLCVectorialFillControl.GetTexture: TBGRABitmap;
begin
result := FInterface.Texture;
end;
function TLCVectorialFillControl.GetToolIconSize: integer;
begin
result := FInterface.ImageListSize.cy;
end;
function TLCVectorialFillControl.GetVerticalPadding: integer;
begin
result := FInterface.VerticalPadding;
end;
procedure TLCVectorialFillControl.InterfaceMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Assigned(OnMouseDown) then OnMouseDown(self, Button, Shift, X,Y);
end;
procedure TLCVectorialFillControl.InterfaceMouseEnter(Sender: TObject);
begin
if Assigned(OnMouseEnter) then OnMouseEnter(self);
end;
procedure TLCVectorialFillControl.InterfaceMouseLeave(Sender: TObject);
begin
if Assigned(OnMouseLeave) then OnMouseLeave(self);
end;
procedure TLCVectorialFillControl.InterfaceMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
begin
if Assigned(OnMouseMove) then OnMouseMove(self, Shift, X,Y);
end;
procedure TLCVectorialFillControl.InterfaceMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Assigned(OnMouseUp) then OnMouseUp(self, Button, Shift, X,Y);
end;
procedure TLCVectorialFillControl.SetAllowedFillTypes(
AValue: TVectorialFillTypes);
begin
FInterface.AllowedFillTypes:= AValue;
end;
procedure TLCVectorialFillControl.SetCanAdjustToShape(AValue: boolean);
begin
FInterface.CanAdjustToShape := AValue;
end;
procedure TLCVectorialFillControl.SetCanEditGradTexPoints(AValue: boolean);
begin
FInterface.CanEditGradTexPoints:= AValue;
end;
procedure TLCVectorialFillControl.SetEditingGradTexPoints(AValue: boolean);
begin
FInterface.EditingGradTexPoints := AValue;
end;
procedure TLCVectorialFillControl.SetFillType(AValue: TVectorialFillType);
begin
FInterface.FillType := AValue;
end;
procedure TLCVectorialFillControl.SetGradEndColor(AValue: TBGRAPixel);
begin
FInterface.GradEndColor := AValue;
end;
procedure TLCVectorialFillControl.SetGradientType(AValue: TGradientType);
begin
FInterface.GradientType := AValue;
end;
procedure TLCVectorialFillControl.SetGradInterpolation(
AValue: TBGRAColorInterpolation);
begin
FInterface.GradInterpolation := AValue;
end;
procedure TLCVectorialFillControl.SetGradRepetition(
AValue: TBGRAGradientRepetition);
begin
FInterface.GradRepetition := AValue;
end;
procedure TLCVectorialFillControl.SetGradStartColor(AValue: TBGRAPixel);
begin
FInterface.GradStartColor := AValue;
end;
procedure TLCVectorialFillControl.SetIsTarget(AValue: boolean);
begin
FInterface.IsTarget := AValue;
end;
procedure TLCVectorialFillControl.SetOnChooseColor(AValue: TChooseColorEvent);
begin
if FOnChooseColor=AValue then Exit;
FOnChooseColor:=AValue;
end;
procedure TLCVectorialFillControl.SetOnTextureClick(AValue: TNotifyEvent);
begin
if FOnTextureClick=AValue then Exit;
FOnTextureClick:=AValue;
if Assigned(FOnTextureClick) then
FInterface.OnTextureClick:= @DoOnTextureClick
else
FInterface.OnTextureClick:= nil;
end;
procedure TLCVectorialFillControl.SetSolidColor(AValue: TBGRAPixel);
begin
FInterface.SolidColor := AValue;
end;
procedure TLCVectorialFillControl.SetTexture(AValue: TBGRABitmap);
begin
FInterface.Texture := AValue;
end;
procedure TLCVectorialFillControl.SetTextureOpacity(AValue: byte);
begin
FInterface.TextureOpacity := AValue;
end;
procedure TLCVectorialFillControl.SetTextureRepetition(
AValue: TTextureRepetition);
begin
FInterface.TextureRepetition := AValue;
end;
procedure TLCVectorialFillControl.SetToolIconSize(AValue: integer);
begin
FInterface.ImageListSize := Size(AValue,AValue);
end;
procedure TLCVectorialFillControl.SetVerticalPadding(AValue: integer);
begin
FInterface.VerticalPadding:= AValue;
end;
procedure TLCVectorialFillControl.CalculatePreferredSize(var PreferredWidth,
PreferredHeight: integer; WithThemeSpace: Boolean);
begin
with FInterface.PreferredSize do
begin
PreferredWidth := cx;
PreferredHeight := cy;
end;
end;
procedure TLCVectorialFillControl.DoOnAdjustToShape(Sender: TObject);
begin
if Assigned(FOnAdjustToShape) then FOnAdjustToShape(self);
end;
procedure TLCVectorialFillControl.DoOnEditGradTexPoints(Sender: TObject);
begin
if Assigned(FOnEditGradTexPoints) then FOnEditGradTexPoints(self);
end;
procedure TLCVectorialFillControl.DoOnFillChange(Sender: TObject);
begin
if Assigned(FOnFillChange) then FOnFillChange(self);
end;
procedure TLCVectorialFillControl.DoOnFillTypeChange(Sender: TObject);
begin
InvalidatePreferredSize;
AdjustSize;
if Assigned(FOnFillTypeChange) then FOnFillTypeChange(self);
end;
procedure TLCVectorialFillControl.DoOnTextureChange(Sender: TObject);
begin
if Assigned(FOnTextureChange) then FOnTextureChange(self);
end;
procedure TLCVectorialFillControl.DoOnResize;
begin
inherited DoOnResize;
FInterface.LoadImageList;
FInterface.ContainerSizeChanged;
end;
constructor TLCVectorialFillControl.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
FInterface := TVectorialFillInterface.Create(nil, 16,16);
FInterface.OnChooseColor:=@DoOnChooseColor;
FInterface.OnFillChange:=@DoOnFillChange;
FInterface.OnTextureChange:=@DoOnTextureChange;
FInterface.OnAdjustToShape:=@DoOnAdjustToShape;
FInterface.OnEditGradTexPoints:=@DoOnEditGradTexPoints;
FInterface.OnFillTypeChange:=@DoOnFillTypeChange;
FInterface.OnMouseMove:=@InterfaceMouseMove;
FInterface.OnMouseDown:=@InterfaceMouseDown;
FInterface.OnMouseUp:=@InterfaceMouseUp;
FInterface.OnMouseEnter:=@InterfaceMouseEnter;
FInterface.OnMouseLeave:=@InterfaceMouseLeave;
FInterface.Container := self;
end;
destructor TLCVectorialFillControl.Destroy;
begin
FreeAndNil(FInterface);
inherited Destroy;
end;
procedure TLCVectorialFillControl.AssignFill(AFill: TVectorialFill);
begin
FInterface.AssignFill(AFill);
end;
function TLCVectorialFillControl.CreateShapeFill(AShape: TVectorShape): TVectorialFill;
begin
result := FInterface.CreateShapeFill(AShape);
end;
procedure TLCVectorialFillControl.UpdateShapeFill(AShape: TVectorShape;
ATarget: TLCFillTarget);
begin
FInterface.UpdateShapeFill(AShape, ATarget);
end;
procedure TLCVectorialFillControl.UpdateFillExceptGeometry(ATargetFill: TVectorialFill);
begin
FInterface.UpdateFillExceptGeometry(ATargetFill);
end;
end.
./lazpaint-7.1.6/lazpaintcontrols/lcscaledpi.pas 0000664 0001750 0001750 00000011662 13761713342 022133 0 ustar circular circular // SPDX-License-Identifier: GPL-3.0-only
unit LCScaleDPI;
{$mode objfpc}{$H+}
interface
uses
Forms, Graphics, Controls, ComCtrls;
procedure ScaleForms(FromDPI: Integer);
procedure ScaleControl(Control: TControl; FromDPI: Integer;
ToDPI_X: Integer = 0; ToDPI_Y: Integer = 0; ScaleToolbar: boolean = false);
procedure ScaleImageList(SourceList: TImageList; newWidth, newHeight: Integer; TargetList: TImageList);
function DoScaleX(Size: Integer; FromDPI: Integer; ToDPI: Integer = 0): integer;
function DoScaleY(Size: Integer; FromDPI: Integer; ToDPI: Integer = 0): integer;
function DoScaleXF(Size: single; FromDPI: Integer; ToDPI: Integer = 0): single;
function DoScaleYF(Size: single; FromDPI: Integer; ToDPI: Integer = 0): single;
implementation
uses BGRABitmap, BGRABitmapTypes, LCLType;
procedure ScaleForms(FromDPI: Integer);
var
i: Integer;
begin
for i:=0 to Screen.FormCount-1 do begin
ScaleControl(Screen.Forms[i],FromDPI);
end;
end;
procedure ScaleImageList(SourceList: TImageList; newWidth, newHeight: Integer; TargetList: TImageList);
var
TempBmp: TBitmap;
TempBGRA: array of TBGRABitmap;
i: Integer;
begin
if (TargetList = SourceList) and (newWidth = SourceList.Width) and
(newHeight = SourceList.Height) then exit;
setlength(TempBGRA, SourceList.Count);
TempBmp := TBitmap.Create;
for i := 0 to SourceList.Count-1 do
begin
SourceList.GetBitmap(i,TempBmp);
TempBGRA[i] := TBGRABitmap.Create(TempBmp);
TempBGRA[i].ResampleFilter := rfBestQuality;
if (TempBGRA[i].width=0) or (TempBGRA[i].height=0) then continue;
while (TempBGRA[i].Width < NewWidth) or (TempBGRA[i].Height < NewHeight) do
BGRAReplace(TempBGRA[i], TempBGRA[i].FilterSmartZoom3(moLowSmooth));
BGRAReplace(TempBGRA[i], TempBGRA[i].Resample(NewWidth,NewHeight));
BGRAReplace(TempBGRA[i], TempBGRA[i].FilterSharpen(0.50));
end;
TempBmp.Free;
TargetList.Clear;
TargetList.Width:= NewWidth;
TargetList.Height:= NewHeight;
for i := 0 to high(TempBGRA) do
begin
{$IFDEF LCLWin32}
If TBGRAPixel_RGBAOrder then TempBGRA[i].SwapRedBlue;
{$ENDIF}
TargetList.Add(TempBGRA[i].Bitmap,nil);
TempBGRA[i].Free;
end;
end;
function DoScaleX(Size: Integer; FromDPI: Integer; ToDPI: Integer): integer;
begin
if ToDPI = 0 then ToDPI := ScreenInfo.PixelsPerInchX;
if ToDPI <= FromDPI then
result := Size
else
Result := MulDiv(Size, ToDPI, FromDPI);
end;
function DoScaleY(Size: Integer; FromDPI: Integer; ToDPI: Integer): integer;
begin
if ToDPI = 0 then ToDPI := ScreenInfo.PixelsPerInchY;
if ToDPI <= FromDPI then
result := Size
else
Result := MulDiv(Size, ToDPI, FromDPI);
end;
function DoScaleXF(Size: single; FromDPI: Integer; ToDPI: Integer): single;
begin
if ToDPI = 0 then ToDPI := ScreenInfo.PixelsPerInchX;
if ToDPI <= FromDPI then
result := Size
else
Result := Size * ToDPI / FromDPI;
end;
function DoScaleYF(Size: single; FromDPI: Integer; ToDPI: Integer): single;
begin
if ToDPI = 0 then ToDPI := ScreenInfo.PixelsPerInchY;
if ToDPI <= FromDPI then
result := Size
else
Result := Size * ToDPI / FromDPI;
end;
procedure ScaleControl(Control: TControl; FromDPI: Integer; ToDPI_X: Integer;
ToDPI_Y: Integer; ScaleToolbar: boolean);
var
n: Integer;
WinControl: TWinControl;
ToolBarControl: TToolBar;
begin
if ToDPI_X = 0 then ToDPI_X := ScreenInfo.PixelsPerInchX;
if ToDPI_Y = 0 then ToDPI_Y := ScreenInfo.PixelsPerInchY;
if ToDPI_X < FromDPI then ToDPI_X := FromDPI;
if ToDPI_Y < FromDPI then ToDPI_Y := FromDPI;
if (ToDPI_X = FromDPI) and (ToDPI_Y = FromDPI) then exit;
with Control do begin
Left:=DoScaleX(Left,FromDPI,ToDPI_X);
Top:=DoScaleY(Top,FromDPI,ToDPI_Y);
Width:=DoScaleX(Width,FromDPI,ToDPI_X);
Height:=DoScaleY(Height,FromDPI,ToDPI_Y);
if not IsParentFont then
begin
if Font.Size = 0 then
Font.Height := -DoScaleY(12,FromDPI,ToDPI_Y)
else
Font.Size:= round(Font.Size * ToDPI_Y / FromDPI);
end;
end;
if Control is TToolBar then begin
if not ScaleToolbar then exit;
ToolBarControl:=TToolBar(Control);
with ToolBarControl do begin
ButtonWidth:=DoScaleX(ButtonWidth,FromDPI,ToDPI_X);
ButtonHeight:=DoScaleY(ButtonHeight,FromDPI,ToDPI_Y);
end;
exit;
end;
if Control is TWinControl then begin
WinControl:=TWinControl(Control);
with WinControl.ChildSizing do
begin
HorizontalSpacing := DoScaleX(HorizontalSpacing, FromDPI, ToDPI_X);
LeftRightSpacing := DoScaleX(LeftRightSpacing, FromDPI, ToDPI_X);
TopBottomSpacing := DoScaleY(TopBottomSpacing, FromDPI, ToDPI_Y);
VerticalSpacing := DoScaleY(VerticalSpacing, FromDPI, ToDPI_Y);
end;
if WinControl.ControlCount > 0 then begin
for n:=0 to WinControl.ControlCount-1 do begin
if WinControl.Controls[n] is TControl then begin
ScaleControl(WinControl.Controls[n],FromDPI,ToDPI_X,ToDPI_Y,
ScaleToolbar);
end;
end;
end;
end;
end;
end.
./lazpaint-7.1.6/lazpaintcontrols/lctoolbars.pas 0000664 0001750 0001750 00000021075 13761713342 022173 0 ustar circular circular // SPDX-License-Identifier: GPL-3.0-only
unit LCToolbars;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Controls, ComCtrls, Types, LResources, StdCtrls, BCTrackbarUpdown;
function CreateToolBar(AImages: TImageList; AOwner: TComponent = nil): TToolbar;
procedure ReorderToolbarContent(AToolbar: TToolbar);
function GetToolbarSize(AToolbar: TToolbar; APadding: integer = 1): TSize;
procedure SetToolbarImages(AToolbar: TToolbar; AImages: TImageList; HorizPadding: integer = 5; VertPadding: integer = 4);
procedure EnableDisableToolButtons(AButtons: array of TToolButton; AEnabled: boolean);
procedure ShowAppendToolButtons(AButtons: array of TControl);
function AddToolbarLabel(AToolbar: TToolbar; ACaption: string; AExistingContainer: TCustomControl): TLabel;
function AddToolbarCheckButton(AToolbar: TToolbar; ACaption: string; AImageIndex: integer;
AOnClick: TNotifyEvent; ADown: boolean; AGrouped: boolean = true; ATag: PtrInt = 0): TToolButton;
function AddToolbarButton(AToolbar: TToolbar; ACaption: string; AImageIndex: integer;
AOnClick: TNotifyEvent; ATag: PtrInt = 0): TToolButton;
function AddToolbarUpDown(AToolbar: TToolbar; ACaption: string; AMin,AMax,AValue: Integer; AOnChange: TTrackBarUpDownChangeEvent): TBCTrackbarUpdown;
function AddToolbarTextBox(AToolbar: TToolbar; ACaption: string; AText: string; AOnChange: TNotifyEvent): TEdit;
procedure AddToolbarControl(AToolbar: TToolbar; AControl: TControl);
function GetResourceString(AFilename: string): string;
procedure LoadToolbarImage(AImages: TImageList; AIndex: integer; AFilename: string);
implementation
uses BGRALazPaint, Graphics, BGRABitmap, BGRABitmapTypes, math, Toolwin;
function CreateToolBar(AImages: TImageList; AOwner: TComponent): TToolbar;
begin
result := TToolBar.Create(AOwner);
result.Align := alNone;
result.Height := AImages.Height+4;
result.ShowHint:= true;
result.ShowCaptions:= false;
result.Images := AImages;
result.ButtonWidth := AImages.Width+5;
result.ButtonHeight := AImages.Height+4;
result.ParentColor := false;
result.EdgeBorders:= [];
result.EdgeInner:= esNone;
result.EdgeOuter:= esNone;
end;
procedure ReorderToolbarContent(AToolbar: TToolbar);
var
i,x,y: Integer;
begin
AToolbar.BeginUpdate;
x := AToolbar.Indent;
y := 0;
for i := 0 to AToolbar.ControlCount-1 do
begin
with AToolbar.Controls[i] do
begin
if (x+Width > AToolbar.Width) and AToolbar.Wrapable then
begin
x := AToolbar.Indent;
y += AToolbar.ButtonHeight;
end;
Left := x;
Top := y;
x += Width;
end;
if (AToolbar.Controls[i] is TToolButton) and
TToolButton(AToolbar.Controls[i]).Wrap then
begin
x := AToolbar.Indent;
y += AToolbar.ButtonHeight;
end;
end;
AToolbar.EndUpdate;
end;
function GetToolbarSize(AToolbar: TToolbar; APadding: integer = 1): TSize;
var
i: Integer;
r: TRect;
begin
result := Size(APadding,APadding);
for i := 0 to AToolbar.ControlCount-1 do
if AToolbar.Controls[i].Visible then
begin
r := AToolbar.Controls[i].BoundsRect;
if r.Right > result.cx then result.cx := r.Right;
if r.Bottom > result.cy then result.cy := r.Bottom;
end;
result.cx += APadding;
result.cy += APadding;
end;
procedure SetToolbarImages(AToolbar: TToolbar; AImages: TImageList; HorizPadding: integer; VertPadding: integer);
begin
AToolbar.Images := AImages;
AToolbar.ButtonWidth:= AImages.Width+HorizPadding;
AToolbar.ButtonHeight:= AImages.Height+VertPadding;
end;
function GetResourceString(AFilename: string): string;
var
strStream: TStringStream;
resStream: TStream;
begin
resStream := BGRAResource.GetResourceStream(AFilename);
strStream := TStringStream.Create('');
strStream.CopyFrom(resStream, resStream.Size);
resStream.Free;
result:= strStream.DataString;
strStream.Free;
end;
procedure LoadToolbarImage(AImages: TImageList; AIndex: integer; AFilename: string);
var
iconImg: TBGRALazPaintImage;
iconFlat: array of TBGRABitmap;
bmpArray: array of TCustomBitmap;
i: Integer;
begin
iconImg := TBGRALazPaintImage.Create;
iconImg.LoadFromResource(AFilename);
if AImages.ResolutionCount = 0 then
AImages.RegisterResolutions([AImages.Width]);
setlength(iconFlat, AImages.ResolutionCount);
setlength(bmpArray, length(iconFlat));
for i := 0 to high(iconFlat) do
begin
iconImg.Resample(AImages.ResolutionByIndex[i].Width,
AImages.ResolutionByIndex[i].Height,
rmFineResample,rfBestQuality);
iconFlat[i] := TBGRABitmap.Create(iconImg.Width, iconImg.Height);
iconImg.Draw(iconFlat[i],0,0);
bmpArray[i] := iconFlat[i].Bitmap;
end;
iconImg.Free;
if AImages.Count < AIndex then
begin
for i := 0 to high(iconFlat) do
AImages.Replace(AIndex, bmpArray[i],nil, false);
end
else
AImages.AddMultipleResolutions(bmpArray);
for i := 0 to high(iconFlat) do
iconFlat[i].Free;
end;
function AddToolbarLabel(AToolbar: TToolbar; ACaption: string;
AExistingContainer: TCustomControl): TLabel;
var
lbl: TLabel;
begin
lbl := TLabel.Create(AToolbar);
lbl.AutoSize:= false;
lbl.Alignment:= taCenter;
lbl.Layout := tlCenter;
lbl.Caption := ACaption;
lbl.Width := AExistingContainer.Canvas.TextWidth(lbl.Caption)+(AToolbar.ButtonHeight div 4);
lbl.Height := AToolbar.ButtonHeight;
AddToolbarControl(AToolbar, lbl);
result := lbl;
end;
function AddToolbarCheckButton(AToolbar: TToolbar; ACaption: string; AImageIndex: integer;
AOnClick: TNotifyEvent; ADown: boolean; AGrouped: boolean = true; ATag: PtrInt = 0): TToolButton;
var
btn: TToolButton;
begin
btn := TToolButton.Create(AToolbar);
btn.Style := tbsCheck;
btn.Caption := ACaption;
btn.Hint := ACaption;
btn.ImageIndex := AImageIndex;
btn.Down:= ADown;
btn.Grouped := AGrouped;
btn.OnClick:= AOnClick;
btn.Tag:= ATag;
AddToolbarControl(AToolbar, btn);
result := btn;
end;
function AddToolbarButton(AToolbar: TToolbar; ACaption: string;
AImageIndex: integer; AOnClick: TNotifyEvent; ATag: PtrInt): TToolButton;
var
btn: TToolButton;
begin
btn := TToolButton.Create(AToolbar);
btn.Style := tbsButton;
btn.Caption := ACaption;
btn.Hint := ACaption;
btn.ImageIndex := AImageIndex;
btn.OnClick:= AOnClick;
btn.Tag:= ATag;
AddToolbarControl(AToolbar, btn);
result := btn;
end;
function AddToolbarUpDown(AToolbar: TToolbar; ACaption: string; AMin,
AMax, AValue: Integer; AOnChange: TTrackBarUpDownChangeEvent): TBCTrackbarUpdown;
begin
result := TBCTrackbarUpdown.Create(AToolbar);
result.Width := AToolbar.ButtonWidth*2;
result.Height:= AToolbar.ButtonHeight;
result.MinValue := AMin;
result.MaxValue := AMax;
result.Value := AValue;
result.Hint := ACaption;
result.ShowHint:= true;
result.OnChange:= AOnChange;
AddToolbarControl(AToolbar, result);
end;
function AddToolbarTextBox(AToolbar: TToolbar; ACaption: string; AText: string;
AOnChange: TNotifyEvent): TEdit;
begin
result := TEdit.Create(AToolbar);
result.Width := AToolbar.ButtonWidth*5;
result.Font.Height := round(AToolbar.Height*0.5);
result.Hint := ACaption;
result.ShowHint:= true;
result.Text := AText;
result.OnChange:= AOnChange;
AddToolbarControl(AToolbar, result);
end;
procedure AddToolbarControl(AToolbar: TToolbar; AControl: TControl);
var
x,y, i: Integer;
begin
x := AToolbar.Indent;
y := 0;
for i := 0 to AToolbar.ControlCount-1 do
begin
if AToolbar.Controls[i] is TToolButton then
begin
inc(x, AToolbar.ButtonWidth);
if TToolButton(AToolbar.Controls[i]).Wrap then
begin
x := 0;
inc(y, AToolbar.ButtonHeight);
end;
end
else inc(x, AToolbar.Controls[i].Width);
end;
AControl.Left := x;
AControl.Top := y;
AControl.Parent := AToolbar;
end;
procedure EnableDisableToolButtons(AButtons: array of TToolButton; AEnabled: boolean);
var
i: Integer;
begin
for i := 0 to high(AButtons) do
AButtons[i].Enabled:= AEnabled;
end;
procedure ShowAppendToolButtons(AButtons: array of TControl);
var btnCount,x,y, i: integer;
toolbar: TToolBar;
begin
if length(AButtons) = 0 then exit;
toolbar := AButtons[0].Parent as TToolBar;
x := 0;
y := 0;
btnCount := 0;
for i := 0 to toolbar.ControlCount-1 do
if toolbar.Controls[i].Visible then
begin
x := max(toolbar.Controls[i].Left+toolbar.Controls[i].Width,x);
y := max(toolbar.Controls[i].Top+toolbar.Controls[i].Height,y);
inc(btnCount);
end;
toolbar.BeginUpdate;
x:= max(btnCount * toolbar.ButtonWidth,x);
for i := 0 to high(AButtons) do
begin
AButtons[i].Left := x;
AButtons[i].Visible:= true;
x += toolbar.ButtonWidth;
end;
toolbar.EndUpdate;
end;
end.
./lazpaint-7.1.6/lazpaintcontrols/lcvectorclipboard.pas 0000664 0001750 0001750 00000010012 13761713342 023515 0 ustar circular circular // SPDX-License-Identifier: GPL-3.0-only
unit LCVectorClipboard;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Clipbrd, LCLType, LCVectorOriginal, BGRATransform, BGRABitmapTypes;
function CopyShapesToClipboard(AShapes: array of TVectorShape; const AMatrix: TAffineMatrix): boolean;
procedure PasteShapesFromClipboard(ATargetContainer: TVectorOriginal; const ATargetMatrix: TAffineMatrix; const ABounds: TRectF);
function ClipboardHasShapes: boolean;
implementation
uses math;
var
vectorClipboardFormat : TClipboardFormat;
function CopyShapesToClipboard(AShapes: array of TVectorShape; const AMatrix: TAffineMatrix): boolean;
var
tempContainer: TVectorOriginal;
mem: TMemoryStream;
i, j: Integer;
s: TVectorShape;
multiSel: IVectorMultishape;
begin
result:= false;
if length(AShapes)=0 then exit;
tempContainer := TVectorOriginal.Create;
mem := TMemoryStream.Create;
try
for i := 0 to high(AShapes) do
begin
if AShapes[i] is VectorMultiselectionFactory then
begin
multiSel := AShapes[i].GetAsMultishape;
for j := 0 to multiSel.ShapeCount-1 do
begin
s := multiSel.GetShape(j).Duplicate;
s.Transform(AMatrix);
tempContainer.AddShape(s);
end;
end else
begin
s := AShapes[i].Duplicate;
s.Transform(AMatrix);
tempContainer.AddShape(s);
end;
end;
tempContainer.SaveToStream(mem);
Clipboard.Clear;
mem.Position:= 0;
result := Clipboard.AddFormat(vectorClipboardFormat, mem);
finally
mem.Free;
tempContainer.Free;
end;
end;
procedure PasteShapesFromClipboard(ATargetContainer: TVectorOriginal; const ATargetMatrix: TAffineMatrix; const ABounds: TRectF);
var
tempContainer: TVectorOriginal;
mem: TMemoryStream;
i: Integer;
pastedShape: TVectorShape;
pastedShapes: TVectorShapes;
invMatrix, m: TAffineMatrix;
pastedBounds: TRectF;
ofs: TPointF;
begin
if not IsAffineMatrixInversible(ATargetMatrix) then exit;
invMatrix := AffineMatrixInverse(ATargetMatrix);
if Clipboard.HasFormat(vectorClipboardFormat) then
begin
mem := TMemoryStream.Create;
tempContainer := TVectorOriginal.Create;
try
if Clipboard.GetFormat(vectorClipboardFormat, mem) then
begin
mem.Position:= 0;
tempContainer.LoadFromStream(mem);
pastedBounds := EmptyRectF;
ofs := PointF(0, 0);
if not ABounds.IsEmpty then
begin
for i := 0 to tempContainer.ShapeCount-1 do
pastedBounds := pastedBounds.Union(pastedBounds,
tempContainer.Shape[i].GetAlignBounds(InfiniteRect, AffineMatrixIdentity), true);
if (pastedBounds.Left < ABounds.Left) and (pastedBounds.Right < ABounds.Right) then
ofs.x := ceil(ABounds.Left - pastedBounds.Left) else
if (pastedBounds.Right > ABounds.Right) and (pastedBounds.Left > ABounds.Left) then
ofs.x := floor(ABounds.Right - pastedBounds.Right);
if (pastedBounds.Top < ABounds.Top) and (pastedBounds.Bottom < ABounds.Bottom) then
ofs.y := ceil(ABounds.Top - pastedBounds.Top) else
if (pastedBounds.Bottom > ABounds.Bottom) and (pastedBounds.Top > ABounds.Top) then
ofs.y := floor(ABounds.Bottom - pastedBounds.Bottom);
end;
m := invMatrix*AffineMatrixTranslation(ofs.x,ofs.y);
ATargetContainer.DeselectShapes;
pastedShapes := TVectorShapes.Create;
for i := 0 to tempContainer.ShapeCount-1 do
begin
pastedShape := tempContainer.Shape[i].Duplicate;
pastedShape.Transform(m);
pastedShapes.Add(pastedShape);
end;
ATargetContainer.AddShapes(pastedShapes);
ATargetContainer.SelectShapes(pastedShapes);
pastedShapes.Free;
end;
finally
tempContainer.Free;
mem.Free;
end;
end;
end;
function ClipboardHasShapes: boolean;
begin
result := Clipboard.HasFormat(vectorClipboardFormat);
end;
initialization
vectorClipboardFormat := RegisterClipboardFormat('TVectorOriginal');
end.
./lazpaint-7.1.6/lazpaintcontrols/lcvectorpolyshapes.pas 0000664 0001750 0001750 00000143321 13761713342 023757 0 ustar circular circular // SPDX-License-Identifier: GPL-3.0-only
unit LCVectorPolyShapes;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Types, LCVectorOriginal, BGRABitmapTypes, BGRALayerOriginal,
BGRABitmap, BGRATransform, BGRAGradients, BGRAGraphics,
BGRASVGShapes, BGRASVGType, BGRAUnits, BGRAPath;
type
TArrowKind = (akNone, akTail, akTip, akNormal, akCut, akFlipped, akFlippedCut,
akTriangle, akTriangleBack1, akTriangleBack2,
akHollowTriangle, akHollowTriangleBack1, akHollowTriangleBack2);
const
errShapeNotHandled = 'Shape not handled';
ArrowKindToStr: array[TArrowKind] of string =
('none', 'tail', 'tip', 'normal', 'cut', 'flipped', 'flipped-cut',
'triangle', 'triangle-back1', 'triangle-back2',
'hollow-triangle', 'hollow-triangle-back1', 'hollow-triangle-back2');
LineCapToStr: array[TPenEndCap] of string =
('round','square','flat');
function StrToArrowKind(AStr: string): TArrowKind;
function StrToLineCap(AStr: string): TPenEndCap;
type
TCustomPolypointShape = class;
TCustomPolypointPoint = record
coord: TPointF;
editorIndex: integer;
data: cardinal;
end;
{ TCustomPolypointShapeDiff }
TCustomPolypointShapeDiff = class(TVectorShapeDiff)
protected
FStartPoints: array of TCustomPolypointPoint;
FStartClosed: boolean;
FStartArrowStartKind,FStartArrowEndKind: TArrowKind;
FStartArrowSize: TPointF;
FStartLineCap: TPenEndCap;
FEndPoints: array of TCustomPolypointPoint;
FEndClosed: boolean;
FEndArrowStartKind,FEndArrowEndKind: TArrowKind;
FEndArrowSize: TPointF;
FEndLineCap: TPenEndCap;
public
constructor Create(AStartShape: TVectorShape); override;
procedure ComputeDiff(AEndShape: TVectorShape); override;
procedure Apply(AStartShape: TVectorShape); override;
procedure Unapply(AEndShape: TVectorShape); override;
procedure Append(ADiff: TVectorShapeDiff); override;
function IsIdentity: boolean; override;
end;
{ TCustomPolypointShape }
TCustomPolypointShape = class(TVectorShape)
private
FClosed: boolean;
function GetHoverPoint: integer;
function GetLineCap: TPenEndCap;
function GetPoint(AIndex: integer): TPointF;
function GetPointCount: integer;
procedure SetArrowEndKind(AValue: TArrowKind);
procedure SetArrowSize(AValue: TPointF);
procedure SetArrowStartKind(AValue: TArrowKind);
procedure SetCenterPoint(AValue: TPointF);
procedure SetHoverCenter(AValue: boolean);
procedure SetHoverPoint(AValue: integer);
procedure SetLineCap(AValue: TPenEndCap);
procedure SetPoint(AIndex: integer; AValue: TPointF);
protected
FPoints: array of TCustomPolypointPoint;
FCenterPoint: TPointF;
FCenterPointEditorIndex: integer;
FCurPoint: integer;
FAddingPoint: boolean;
FMousePos: TPointF;
FHoverPoint: integer;
FHoverCenter: boolean;
FArrowStartKind,FArrowEndKind: TArrowKind;
FArrowSize: TPointF;
FViewMatrix, FViewMatrixInverse, FGridMatrix: TAffineMatrix;
procedure OnMovePoint({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; {%H-}AShift: TShiftState);
procedure OnMoveCenterPoint({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; {%H-}AShift: TShiftState);
procedure OnStartMove({%H-}ASender: TObject; APointIndex: integer; {%H-}AShift: TShiftState);
function GetCurve(AMatrix: TAffineMatrix): ArrayOfTPointF; virtual;
function GetPath(AMatrix: TAffineMatrix): TBGRAPath; virtual;
procedure SetUsermode(AValue: TVectorShapeUsermode); override;
function GetClosed: boolean; virtual;
procedure SetClosed(AValue: boolean); virtual;
function PointsEqual(const APoint1, APoint2: TPointF): boolean;
procedure OnHoverPoint({%H-}ASender: TObject; APointIndex: integer); virtual;
procedure OnClickPoint({%H-}ASender: TObject; APointIndex: integer; {%H-}AShift: TShiftState); virtual;
procedure DoClickPoint({%H-}APointIndex: integer; {%H-}AShift: TShiftState); virtual;
function CanMovePoints: boolean; virtual;
procedure InsertPointAuto(AShift: TShiftState);
function ComputeStroke(APoints: ArrayOfTPointF; AClosed: boolean;
AStrokeMatrix: TAffineMatrix): ArrayOfTPointF; override;
function GetLoopStartIndex: integer;
function GetLoopPointCount: integer;
function GetIsFollowingMouse: boolean; override;
public
constructor Create(AContainer: TVectorOriginal); override;
procedure Clear;
function AddPoint(const APoint: TPointF): integer; virtual;
function RemovePoint(AIndex: integer): boolean;
procedure RemovePointRange(AFromIndex, AToIndexPlus1: integer);
procedure InsertPoint(AIndex: integer; APoint: TPointF);
function GetPointBounds(AMatrix: TAffineMatrix): TRectF;
procedure MouseMove({%H-}Shift: TShiftState; X, Y: single; var {%H-}ACursor: TOriginalEditorCursor; var AHandled: boolean); override;
procedure MouseDown(RightButton: boolean; {%H-}Shift: TShiftState; {%H-}X, {%H-}Y: single; var {%H-}ACursor: TOriginalEditorCursor; var AHandled: boolean); override;
procedure KeyDown({%H-}Shift: TShiftState; Key: TSpecialKey; var AHandled: boolean); override;
procedure QuickDefine(constref APoint1,APoint2: TPointF); override;
procedure LoadFromStorage(AStorage: TBGRACustomOriginalStorage); override;
procedure SaveToStorage(AStorage: TBGRACustomOriginalStorage); override;
procedure ConfigureCustomEditor(AEditor: TBGRAOriginalEditor); override;
procedure TransformFrame(const AMatrix: TAffineMatrix); override;
class function Usermodes: TVectorShapeUsermodes; override;
class function DefaultArrowSize: TPointF;
property Points[AIndex:integer]: TPointF read GetPoint write SetPoint;
property PointCount: integer read GetPointCount;
property Closed: boolean read GetClosed write SetClosed;
property HoverPoint: integer read GetHoverPoint write SetHoverPoint;
property HoverCenter: boolean read FHoverCenter write SetHoverCenter;
property ArrowStartKind: TArrowKind read FArrowStartKind write SetArrowStartKind;
property ArrowEndKind: TArrowKind read FArrowEndKind write SetArrowEndKind;
property ArrowSize: TPointF read FArrowSize write SetArrowSize;
property LineCap: TPenEndCap read GetLineCap write SetLineCap;
property Center: TPointF read FCenterPoint write SetCenterPoint;
end;
{ TPolylineShape }
TPolylineShape = class(TCustomPolypointShape)
public
class function Fields: TVectorShapeFields; override;
procedure Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix; ADraft: boolean); overload; override;
function AppendToSVG(AContent: TSVGContent; ADefs: TSVGDefine): TSVGElement; override;
function GetRenderBounds({%H-}ADestRect: TRect; AMatrix: TAffineMatrix; AOptions: TRenderBoundsOptions = []): TRectF; override;
function PointInShape(APoint: TPointF): boolean; overload; override;
function PointInShape(APoint: TPointF; ARadius: single): boolean; overload; override;
function PointInBack(APoint: TPointF): boolean; overload; override;
function PointInPen(APoint: TPointF): boolean; overload; override;
function GetIsSlow(const {%H-}AMatrix: TAffineMatrix): boolean; override;
class function StorageClassName: RawByteString; override;
end;
TCurveShape = class;
{ TCurveShapeDiff }
TCurveShapeDiff = class(TVectorShapeDiff)
protected
FStartCosineAngle: single;
FStartSplineStyle: TSplineStyle;
FEndCosineAngle: single;
FEndSplineStyle: TSplineStyle;
public
constructor Create(AStartShape: TVectorShape); override;
procedure ComputeDiff(AEndShape: TVectorShape); override;
procedure Apply(AStartShape: TVectorShape); override;
procedure Unapply(AEndShape: TVectorShape); override;
procedure Append(ADiff: TVectorShapeDiff); override;
function IsIdentity: boolean; override;
end;
{ TCurveShape }
TCurveShape = class(TPolylineShape)
private
FCosineAngle: single;
FSplineStyle: TSplineStyle;
function GetCurveMode(AIndex: integer): TEasyBezierCurveMode;
procedure SetCosineAngle(AValue: single);
procedure SetCurveMode(AIndex: integer; AValue: TEasyBezierCurveMode);
procedure SetSplineStyle(AValue: TSplineStyle);
protected
function GetCurve(AMatrix: TAffineMatrix): ArrayOfTPointF; override;
function GetPath(AMatrix: TAffineMatrix): TBGRAPath; override;
function CanMovePoints: boolean; override;
procedure DoClickPoint(APointIndex: integer; {%H-}AShift: TShiftState); override;
public
class function Usermodes: TVectorShapeUsermodes; override;
constructor Create(AContainer: TVectorOriginal); override;
constructor CreateFrom(AContainer: TVectorOriginal; AShape: TVectorShape);
class function CanCreateFrom(AShape: TVectorShape): boolean;
function AddPoint(const APoint: TPointF): integer; overload; override;
function AddPoint(const APoint: TPointF; AMode: TEasyBezierCurveMode): integer; overload;
procedure KeyPress(UTF8Key: string; var AHandled: boolean); override;
procedure LoadFromStorage(AStorage: TBGRACustomOriginalStorage); override;
procedure SaveToStorage(AStorage: TBGRACustomOriginalStorage); override;
class function StorageClassName: RawByteString; override;
property SplineStyle: TSplineStyle read FSplineStyle write SetSplineStyle;
property CurveMode[AIndex: integer]: TEasyBezierCurveMode read GetCurveMode write SetCurveMode;
property CosineAngle: single read FCosineAngle write SetCosineAngle;
end;
procedure ApplyArrowStyle(AArrow: TBGRACustomArrow; AStart: boolean; AKind: TArrowKind; ASize: TPointF);
implementation
uses BGRAPen, BGRAFillInfo, math, LCVectorialFill,
BGRAArrow, LCVectorRectShapes, LCResourceString;
function StrToArrowKind(AStr: string): TArrowKind;
var
ak: TArrowKind;
begin
for ak := low(TArrowKind) to high(TArrowKind) do
if CompareText(AStr, ArrowKindToStr[ak])=0 then exit(ak);
result := akNone;
end;
function StrToLineCap(AStr: string): TPenEndCap;
var
ec: TPenEndCap;
begin
for ec := low(TPenEndCap) to high(TPenEndCap) do
if CompareText(AStr, LineCapToStr[ec])=0 then exit(ec);
result := pecRound;
end;
procedure ApplyArrowStyle(AArrow: TBGRACustomArrow; AStart: boolean; AKind: TArrowKind; ASize: TPointF);
var backOfs: single;
begin
backOfs := 0;
if (ASize.x = 0) or (ASize.y = 0) then AKind := akNone;
if AKind in[akTriangleBack1,akHollowTriangleBack1] then backOfs := 0.25;
if AKind in[akTriangleBack2,akHollowTriangleBack2] then backOfs := 0.50;
case AKind of
akTail: if AStart then AArrow.StartAsTail else AArrow.EndAsTail;
akTip: if AStart then AArrow.StartAsTriangle else AArrow.EndAsTriangle;
akNormal,akCut,akFlipped,akFlippedCut:
if AStart then AArrow.StartAsClassic(AKind in[akFlipped,akFlippedCut], AKind in[akCut,akFlippedCut])
else AArrow.EndAsClassic(AKind in[akFlipped,akFlippedCut], AKind in[akCut,akFlippedCut]);
akTriangle,akTriangleBack1,akTriangleBack2:
if AStart then AArrow.StartAsTriangle(backOfs) else AArrow.EndAsTriangle(backOfs);
akHollowTriangle,akHollowTriangleBack1,akHollowTriangleBack2:
if AStart then AArrow.StartAsTriangle(backOfs,False,True) else AArrow.EndAsTriangle(backOfs,False,True);
else if AStart then AArrow.StartAsNone else AArrow.EndAsNone;
end;
if (AKind = akTip) and not ((ASize.x = 0) or (ASize.y = 0)) then
ASize := ASize*(0.5/ASize.y);
if AStart then AArrow.StartSize := ASize else AArrow.EndSize := ASize;
end;
procedure IncludePointF(var ARectF: TRectF; APointF: TPointF);
begin
if APointF.x < ARectF.Left then ARectF.Left := APointF.x;
if APointF.x > ARectF.Right then ARectF.Right := APointF.x;
if APointF.y < ARectF.Top then ARectF.Top := APointF.y;
if APointF.y > ARectF.Bottom then ARectF.Bottom := APointF.y;
end;
function GetPointsBoundsF(const APoints: array of TPointF): TRectF;
var
i: Integer;
firstPoint: Boolean;
begin
result:= EmptyRectF;
firstPoint := true;
for i:= 0 to high(APoints) do
if not isEmptyPointF(APoints[i]) then
begin
if firstPoint then
begin
result.TopLeft := APoints[i];
result.BottomRight := APoints[i];
firstPoint := false;
end else
IncludePointF(result, APoints[i]);
end;
end;
{ TCurveShapeDiff }
constructor TCurveShapeDiff.Create(AStartShape: TVectorShape);
begin
with (AStartShape as TCurveShape) do
begin
FStartCosineAngle:= FCosineAngle;
FStartSplineStyle:= FSplineStyle;
end;
end;
procedure TCurveShapeDiff.ComputeDiff(AEndShape: TVectorShape);
begin
with (AEndShape as TCurveShape) do
begin
FEndCosineAngle:= FCosineAngle;
FEndSplineStyle:= FSplineStyle;
end;
end;
procedure TCurveShapeDiff.Apply(AStartShape: TVectorShape);
begin
with (AStartShape as TCurveShape) do
begin
BeginUpdate;
FCosineAngle := FEndCosineAngle;
FSplineStyle := FEndSplineStyle;
EndUpdate;
end;
end;
procedure TCurveShapeDiff.Unapply(AEndShape: TVectorShape);
begin
with (AEndShape as TCurveShape) do
begin
BeginUpdate;
FCosineAngle := FStartCosineAngle;
FSplineStyle := FStartSplineStyle;
EndUpdate;
end;
end;
procedure TCurveShapeDiff.Append(ADiff: TVectorShapeDiff);
var
next: TCurveShapeDiff;
begin
next := ADiff as TCurveShapeDiff;
FEndCosineAngle:= next.FEndCosineAngle;
FEndSplineStyle:= next.FEndSplineStyle;
end;
function TCurveShapeDiff.IsIdentity: boolean;
begin
result := (FStartCosineAngle = FEndCosineAngle) and
(FStartSplineStyle = FEndSplineStyle);
end;
{ TCustomPolypointShapeDiff }
constructor TCustomPolypointShapeDiff.Create(AStartShape: TVectorShape);
var
i: Integer;
begin
with (AStartShape as TCustomPolypointShape) do
begin
setlength(FStartPoints, length(FPoints));
for i := 0 to high(FPoints) do FStartPoints[i] := FPoints[i];
FStartClosed:= FClosed;
FStartArrowStartKind := FArrowStartKind;
FStartArrowEndKind:= FArrowEndKind;
FStartArrowSize:= FArrowSize;
FStartLineCap:= Stroker.LineCap;
end;
end;
procedure TCustomPolypointShapeDiff.ComputeDiff(AEndShape: TVectorShape);
var
i: Integer;
begin
with (AEndShape as TCustomPolypointShape) do
begin
setlength(FEndPoints, length(FPoints));
for i := 0 to high(FPoints) do FEndPoints[i] := FPoints[i];
FEndClosed:= FClosed;
FEndArrowStartKind := FArrowStartKind;
FEndArrowEndKind:= FArrowEndKind;
FEndArrowSize:= FArrowSize;
FEndLineCap:= Stroker.LineCap;
end;
end;
procedure TCustomPolypointShapeDiff.Apply(AStartShape: TVectorShape);
var
i: Integer;
begin
with (AStartShape as TCustomPolypointShape) do
begin
BeginUpdate;
setlength(FPoints, length(FEndPoints));
for i := 0 to high(FPoints) do FPoints[i] := FEndPoints[i];
FClosed := FEndClosed;
FArrowStartKind := FEndArrowStartKind;
FArrowEndKind := FEndArrowEndKind;
FArrowSize := FEndArrowSize;
Stroker.LineCap:= FEndLineCap;
EndUpdate;
end;
end;
procedure TCustomPolypointShapeDiff.Unapply(AEndShape: TVectorShape);
var
i: Integer;
begin
with (AEndShape as TCustomPolypointShape) do
begin
BeginUpdate;
setlength(FPoints, length(FStartPoints));
for i := 0 to high(FPoints) do FPoints[i] := FStartPoints[i];
FClosed := FStartClosed;
FArrowStartKind := FStartArrowStartKind;
FArrowEndKind := FStartArrowEndKind;
FArrowSize := FStartArrowSize;
Stroker.LineCap:= FStartLineCap;
EndUpdate;
end;
end;
procedure TCustomPolypointShapeDiff.Append(ADiff: TVectorShapeDiff);
var
next: TCustomPolypointShapeDiff;
i: Integer;
begin
next := ADiff as TCustomPolypointShapeDiff;
setlength(FEndPoints, length(next.FEndPoints));
for i := 0 to high(FEndPoints) do FEndPoints[i] := next.FEndPoints[i];
FEndClosed := next.FEndClosed;
FEndArrowStartKind := next.FEndArrowStartKind;
FEndArrowEndKind := next.FEndArrowEndKind;
FEndArrowSize := next.FEndArrowSize;
FEndLineCap:= next.FEndLineCap;
end;
function TCustomPolypointShapeDiff.IsIdentity: boolean;
var
i: Integer;
begin
result := (length(FStartPoints) = length(FEndPoints)) and
(FStartClosed = FEndClosed) and
(FStartArrowStartKind = FEndArrowStartKind) and
(FStartArrowEndKind = FEndArrowEndKind) and
(FStartArrowSize = FEndArrowSize) and
(FStartLineCap = FEndLineCap);
if result then
begin
for i := 0 to high(FStartPoints) do
if (FStartPoints[i].coord<>FEndPoints[i].coord) or
(FStartPoints[i].data<>FEndPoints[i].data) then
begin
result := false;
break;
end;
end;
end;
{ TCustomPolypointShape }
function TCustomPolypointShape.GetClosed: boolean;
begin
result := FClosed;
end;
function TCustomPolypointShape.GetPoint(AIndex: integer): TPointF;
begin
if (AIndex < 0) or (AIndex >= length(FPoints)) then
raise ERangeError.Create(rsIndexOutOfBounds);
result := FPoints[AIndex].coord;
end;
function TCustomPolypointShape.GetLineCap: TPenEndCap;
begin
result := Stroker.LineCap;
end;
function TCustomPolypointShape.GetHoverPoint: integer;
begin
if (FHoverPoint >= 0) and (FHoverPoint < PointCount) and
not Points[FHoverPoint].IsEmpty then
result := FHoverPoint else result := -1;
end;
function TCustomPolypointShape.GetPointCount: integer;
begin
result:= length(FPoints);
end;
procedure TCustomPolypointShape.SetArrowEndKind(AValue: TArrowKind);
begin
if FArrowEndKind=AValue then Exit;
BeginUpdate(TCustomPolypointShapeDiff);
FArrowEndKind:=AValue;
EndUpdate;
end;
procedure TCustomPolypointShape.SetArrowSize(AValue: TPointF);
begin
if FArrowSize=AValue then Exit;
BeginUpdate(TCustomPolypointShapeDiff);
FArrowSize:=AValue;
EndUpdate;
end;
procedure TCustomPolypointShape.SetArrowStartKind(AValue: TArrowKind);
begin
if FArrowStartKind=AValue then Exit;
BeginUpdate(TCustomPolypointShapeDiff);
FArrowStartKind:=AValue;
EndUpdate;
end;
procedure TCustomPolypointShape.SetCenterPoint(AValue: TPointF);
var
i: Integer;
delta: TPointF;
begin
if FCenterPoint=AValue then Exit;
BeginUpdate(TCustomPolypointShapeDiff);
delta := AValue - FCenterPoint;
for i := 0 to PointCount-1 do
Points[i] := Points[i]+delta;
if vsfBackFill in Fields then
BackFill.Transform(AffineMatrixTranslation(delta.x, delta.y));
if vsfPenFill in Fields then
PenFill.Transform(AffineMatrixTranslation(delta.x, delta.y));
FCenterPoint:=AValue;
EndUpdate;
end;
procedure TCustomPolypointShape.SetHoverCenter(AValue: boolean);
begin
if FHoverCenter=AValue then Exit;
BeginEditingUpdate;
if AValue then FHoverPoint := -1;
FHoverCenter:=AValue;
EndEditingUpdate;
end;
procedure TCustomPolypointShape.SetHoverPoint(AValue: integer);
begin
if (AValue < 0) or (AValue >= PointCount) or
Points[AValue].IsEmpty then AValue := -1;
if AValue <> FHoverPoint then
begin
BeginEditingUpdate;
FHoverPoint := AValue;
if AValue <> -1 then FHoverCenter:= false;
EndEditingUpdate;
end;
end;
procedure TCustomPolypointShape.SetLineCap(AValue: TPenEndCap);
begin
if Stroker.LineCap=AValue then Exit;
BeginUpdate(TCustomPolypointShapeDiff);
Stroker.LineCap:=AValue;
EndUpdate;
end;
procedure TCustomPolypointShape.SetClosed(AValue: boolean);
begin
if AValue = FClosed then exit;
BeginUpdate(TCustomPolypointShapeDiff);
FClosed := AValue;
EndUpdate;
end;
procedure TCustomPolypointShape.SetPoint(AIndex: integer; AValue: TPointF);
begin
if (AIndex < 0) or (AIndex > length(FPoints)) then
raise ERangeError.Create(rsIndexOutOfBounds);
BeginUpdate(TCustomPolypointShapeDiff);
if AIndex = length(FPoints) then
begin
setlength(FPoints, length(FPoints)+1);
FPoints[AIndex].coord := AValue;
FPoints[AIndex].editorIndex := -1;
FPoints[AIndex].data := 0;
end
else
FPoints[AIndex].coord := AValue;
EndUpdate;
end;
procedure TCustomPolypointShape.OnMovePoint(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
if FCurPoint = -1 then exit;
Points[FCurPoint] := ANewCoord;
end;
procedure TCustomPolypointShape.OnMoveCenterPoint(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
Center := ANewCoord;
end;
procedure TCustomPolypointShape.OnStartMove(ASender: TObject; APointIndex: integer;
AShift: TShiftState);
var
i: Integer;
begin
FCurPoint:= -1;
for i:= 0 to PointCount-1 do
if FPoints[i].editorIndex = APointIndex then
begin
FCurPoint:= i;
break;
end;
end;
function TCustomPolypointShape.GetCurve(AMatrix: TAffineMatrix): ArrayOfTPointF;
var
i: Integer;
m: TAffineMatrix;
begin
setlength(result, PointCount);
m:= MatrixForPixelCentered(AMatrix);
for i := 0 to PointCount-1 do
result[i] := m*Points[i];
end;
function TCustomPolypointShape.GetPath(AMatrix: TAffineMatrix): TBGRAPath;
begin
result := TBGRAPath.Create(GetCurve(AMatrix));
end;
class function TCustomPolypointShape.Usermodes: TVectorShapeUsermodes;
begin
Result:= inherited Usermodes + [vsuCreate];
end;
class function TCustomPolypointShape.DefaultArrowSize: TPointF;
begin
result := PointF(2,2);
end;
procedure TCustomPolypointShape.SetUsermode(AValue: TVectorShapeUsermode);
var
add: Boolean;
begin
add := AValue = vsuCreate;
if add and (PointCount = 0) then exit;
if FAddingPoint and not add then
begin
if (PointCount>1) and PointsEqual(Points[PointCount-1],Points[PointCount-2]) then
RemovePoint(PointCount-1);
FAddingPoint:= add;
end else
if not FAddingPoint and add then
begin
if not isEmptyPointF(FMousePos) then
AddPoint(FMousePos)
else
AddPoint(Points[PointCount-1]);
FAddingPoint:= add;
end;
inherited SetUsermode(AValue);
end;
function TCustomPolypointShape.PointsEqual(const APoint1, APoint2: TPointF
): boolean;
begin
if isEmptyPointF(APoint1) then
exit(isEmptyPointF(APoint2))
else
if isEmptyPointF(APoint2) then exit(false)
else
exit((APoint1.x = APoint2.x) and (APoint1.y = APoint2.y));
end;
procedure TCustomPolypointShape.OnHoverPoint(ASender: TObject;
APointIndex: integer);
var
i, newHoverPoint: Integer;
begin
if APointIndex = FCenterPointEditorIndex then
begin
HoverCenter := true;
exit;
end;
newHoverPoint:= -1;
if APointIndex <> -1 then
begin
for i:= 0 to PointCount-1 do
if FPoints[i].editorIndex = APointIndex then
begin
newHoverPoint:= i;
break;
end;
end;
HoverPoint := newHoverPoint;
HoverCenter:= false;
end;
procedure TCustomPolypointShape.OnClickPoint(ASender: TObject;
APointIndex: integer; AShift: TShiftState);
var
i: Integer;
begin
if APointIndex <> -1 then
begin
for i:= 0 to PointCount-1 do
if FPoints[i].editorIndex = APointIndex then
begin
DoClickPoint(i, AShift);
break;
end;
end;
end;
procedure TCustomPolypointShape.DoClickPoint(APointIndex: integer;
AShift: TShiftState);
var
nb: Integer;
begin
if FAddingPoint and ((APointIndex = GetLoopStartIndex) or
((APointIndex = PointCount-2) and (ssRight in AShift))) then
begin
nb := GetLoopPointCount;
if nb > 2 then
begin
BeginUpdate;
RemovePoint(PointCount-1);
if APointIndex < PointCount-2 then Closed := true;
EndUpdate;
UserMode := vsuEdit;
end else
begin
if GetLoopStartIndex = 0 then
Remove
else
begin
BeginUpdate;
while nb > 0 do
begin
RemovePoint(PointCount-1);
dec(nb);
end;
RemovePoint(PointCount-1); //remove separator
end;
end;
end;
end;
function TCustomPolypointShape.CanMovePoints: boolean;
begin
result := true;
end;
procedure TCustomPolypointShape.InsertPointAuto(AShift: TShiftState);
var
i,j, loopStart: Integer;
bestSegmentIndex,bestPointIndex: integer;
bestSegmentDist,bestPointDist, segmentLen, segmentPos: single;
u, n, bestProjection: TPointF;
segmentDist: single;
isLooping: Boolean;
begin
if isEmptyPointF(FMousePos) then exit;
for i := 0 to PointCount-1 do
if (Points[i] = FMousePos) and not (FAddingPoint and (i = PointCount-1)) then exit;
bestSegmentIndex := -1;
bestSegmentDist := MaxSingle;
bestProjection := EmptyPointF;
loopStart := 0;
for i := 0 to PointCount-1 do
if FAddingPoint and (i >= PointCount-2) then break else
begin
if IsEmptyPointF(Points[i]) then
begin
loopStart := i+1;
continue;
end;
isLooping := (i = PointCount-1) or IsEmptyPointF(Points[i+1]);
if isLooping and not Closed then break;
if isLooping then
j := loopStart
else j := i+1;
u := Points[j] - Points[i];
segmentLen := VectLen(u);
if segmentLen > 0 then
begin
u *= 1/segmentLen;
segmentPos := (FMousePos-Points[i])*u;
if (segmentPos > 0) and (segmentPos< segmentLen) then
begin
n := PointF(u.y,-u.x);
segmentDist := abs((FMousePos-Points[i])*n);
if segmentDist <= bestSegmentDist then
begin
bestSegmentDist := segmentDist;
bestSegmentIndex := i;
bestProjection := Points[i]+segmentPos*u;
end;
end;
end;
end;
bestPointIndex := -1;
bestPointDist := MaxSingle;
if not FAddingPoint then
for i := 0 to PointCount-1 do
if ((i = 0) or isEmptyPointF(Points[i-1])) and
((i = PointCount-1) or isEmptyPointF(Points[i+1])) then
begin
segmentDist := VectLen(FMousePos-Points[i]);
if segmentDist < bestPointDist then
begin
bestPointDist := segmentDist;
bestPointIndex := i;
end;
end;
if (bestPointIndex <> -1) and ((bestSegmentIndex = -1) or (bestPointDist < bestSegmentDist)) then
begin
InsertPoint(bestPointIndex+1, FMousePos);
HoverPoint := bestPointIndex+1;
end else
if bestSegmentIndex <> -1 then
begin
if ssShift in AShift then
InsertPoint(bestSegmentIndex+1, bestProjection)
else
InsertPoint(bestSegmentIndex+1, FMousePos);
HoverPoint:= bestSegmentIndex+1;
end;
end;
function TCustomPolypointShape.ComputeStroke(APoints: ArrayOfTPointF;
AClosed: boolean; AStrokeMatrix: TAffineMatrix): ArrayOfTPointF;
begin
if Stroker.Arrow = nil then
begin
Stroker.Arrow := TBGRAArrow.Create;
Stroker.ArrowOwned:= true;
end;
Stroker.Arrow.LineCap:= LineCap;
ApplyArrowStyle(Stroker.Arrow, true, ArrowStartKind, ArrowSize);
ApplyArrowStyle(Stroker.Arrow, false, ArrowEndKind, ArrowSize);
Result:=inherited ComputeStroke(APoints, AClosed, AStrokeMatrix);
Stroker.Arrow.StartAsNone;
Stroker.Arrow.EndAsNone;
end;
function TCustomPolypointShape.GetLoopStartIndex: integer;
var
i: Integer;
begin
for i := PointCount-1 downto 0 do
if isEmptyPointF(Points[i]) then exit(i+1);
exit(0);
end;
function TCustomPolypointShape.GetLoopPointCount: integer;
begin
result := PointCount-GetLoopStartIndex;
end;
function TCustomPolypointShape.GetIsFollowingMouse: boolean;
begin
Result:= Usermode = vsuCreate;
end;
constructor TCustomPolypointShape.Create(AContainer: TVectorOriginal);
begin
inherited Create(AContainer);
FMousePos := EmptyPointF;
FClosed:= false;
FHoverPoint:= -1;
FCenterPoint := EmptyPointF;
end;
procedure TCustomPolypointShape.Clear;
begin
RemovePointRange(0, PointCount);
end;
function TCustomPolypointShape.AddPoint(const APoint: TPointF): integer;
begin
result := PointCount;
Points[result] := APoint;
end;
function TCustomPolypointShape.RemovePoint(AIndex: integer): boolean;
begin
if (AIndex < 0) or (AIndex >= PointCount) then exit(false);
RemovePointRange(AIndex,AIndex+1);
result := true;
end;
procedure TCustomPolypointShape.RemovePointRange(AFromIndex, AToIndexPlus1: integer);
var
i, delCount: Integer;
begin
if AFromIndex < 0 then AFromIndex:= 0;
if AToIndexPlus1 > PointCount then AToIndexPlus1:= PointCount;
if AFromIndex >= AToIndexPlus1 then exit;
BeginUpdate(TCustomPolypointShapeDiff);
delCount := AToIndexPlus1-AFromIndex;
for i := AFromIndex to PointCount-DelCount-1 do
FPoints[i] := FPoints[i+delCount];
setlength(FPoints, PointCount-delCount);
if (HoverPoint >= AFromIndex) and (HoverPoint < AToIndexPlus1) then HoverPoint := -1
else if (HoverPoint <> -1) and (HoverPoint >= AToIndexPlus1) then HoverPoint := HoverPoint - delCount;
EndUpdate;
end;
procedure TCustomPolypointShape.InsertPoint(AIndex: integer; APoint: TPointF);
var
i: Integer;
begin
if (AIndex < 0) or (AIndex > PointCount) then raise exception.Create(rsIndexOutOfBounds);
BeginUpdate(TCustomPolypointShapeDiff);
setlength(FPoints, PointCount+1);
for i := PointCount-1 downto AIndex+1 do
FPoints[i] := FPoints[i-1];
FPoints[AIndex].coord := APoint;
FPoints[AIndex].editorIndex:= -1;
FPoints[AIndex].data := 0;
if (HoverPoint <> -1) and (HoverPoint >= AIndex) then HoverPoint := HoverPoint + 1;
EndUpdate;
end;
function TCustomPolypointShape.GetPointBounds(AMatrix: TAffineMatrix): TRectF;
begin
result := GetPointsBoundsF(GetCurve(AMatrix));
end;
procedure TCustomPolypointShape.MouseMove(Shift: TShiftState; X, Y: single; var
ACursor: TOriginalEditorCursor; var AHandled: boolean);
begin
FMousePos := PointF(X,Y);
if FAddingPoint then
begin
BeginUpdate;
if (PointCount = 1) and (FMousePos <> Points[PointCount-1]) then
Points[PointCount] := FMousePos
else
Points[PointCount-1] := FMousePos;
FillFit;
EndUpdate;
AHandled:= true;
end;
end;
procedure TCustomPolypointShape.MouseDown(RightButton: boolean;
Shift: TShiftState; X, Y: single; var ACursor: TOriginalEditorCursor; var
AHandled: boolean);
begin
FMousePos := PointF(X,Y);
if FAddingPoint then
begin
if not RightButton then
begin
if (PointCount>1) and not PointsEqual(FMousePos,Points[PointCount-2]) then
begin
BeginUpdate;
Points[PointCount-1] := FMousePos;
AddPoint(FMousePos);
EndUpdate;
end;
end else
Usermode := vsuEdit;
AHandled:= true;
end else
begin
if (ssShift in Shift) and (Usermode = vsuEdit) then
begin
BeginUpdate;
AddPoint(EmptyPointF);
AddPoint(FMousePos);
FillFit;
EndUpdate;
UserMode := vsuCreate;
AHandled:= true;
end;
end;
end;
procedure TCustomPolypointShape.KeyDown(Shift: TShiftState; Key: TSpecialKey;
var AHandled: boolean);
var
nb, idx: Integer;
dx, dy, d: TPointF;
begin
if (Key = skDelete) and (FAddingPoint or (HoverPoint <> -1)) then
begin
if (HoverPoint <> -1) then
begin
BeginUpdate(TCustomPolypointShapeDiff);
idx := HoverPoint;
RemovePoint(idx);
if ((idx = PointCount) or IsEmptyPointF(Points[idx])) and
((idx = 0) or IsEmptyPointF(Points[idx-1])) then
begin
if idx < PointCount then
RemovePoint(idx)
else if idx > 0 then
RemovePoint(idx-1);
end;
EndUpdate;
if PointCount = 0 then self.Remove;
end;
AHandled:= true;
end else
if (Key = skBackspace) and FAddingPoint then
begin
nb := GetLoopPointCount;
if nb > 2 then
RemovePoint(PointCount-2)
else
begin
if GetLoopStartIndex = 0 then self.Remove
else
begin
RemovePointRange(PointCount-3, PointCount);
Usermode:= vsuEdit;
end;
end;
AHandled:= true;
end else
if (Key = skInsert) then
begin
InsertPointAuto(Shift);
AHandled := true;
end else
if (Key in [skLeft,skUp,skRight,skDown]) and ((HoverPoint <> -1) or HoverCenter) then
begin
if ssCtrl in Shift then
begin
dx := PointF(FGridMatrix[1,1], FGridMatrix[2,1]);
dy := PointF(FGridMatrix[1,2], FGridMatrix[2,2]);
end else
begin
dx := PointF(FViewMatrixInverse[1,1], FViewMatrixInverse[2,1]);
dy := PointF(FViewMatrixInverse[1,2], FViewMatrixInverse[2,2]);
end;
case Key of
skLeft: d := -dx;
skRight: d := dx;
skUp: d := -dy;
skDown: d := dy;
end;
if HoverCenter then
Center := Center + d
else
Points[HoverPoint] := Points[HoverPoint] + d;
AHandled := true;
end else
inherited KeyDown(Shift, Key, AHandled);
end;
procedure TCustomPolypointShape.QuickDefine(constref APoint1, APoint2: TPointF);
begin
BeginUpdate(TCustomPolypointShapeDiff);
FPoints := nil;
AddPoint(APoint1);
if not PointsEqual(APoint1,APoint2) then
AddPoint(APoint2);
EndUpdate;
FMousePos := APoint2;
end;
procedure TCustomPolypointShape.LoadFromStorage(AStorage: TBGRACustomOriginalStorage);
var
x,y: Array of Single;
i: Integer;
begin
BeginUpdate;
inherited LoadFromStorage(AStorage);
Clear;
x := AStorage.FloatArray['x'];
y := AStorage.FloatArray['y'];
setlength(FPoints, max(length(x),length(y)));
for i := 0 to high(FPoints) do
begin
FPoints[i].coord := PointF(x[i],y[i]);
FPoints[i].editorIndex := -1;
FPoints[i].data := 0;
end;
FClosed:= AStorage.Bool['closed'];
if AStorage.HasAttribute('arrow-size') then
FArrowSize := AStorage.PointF['arrow-size']
else FArrowSize := DefaultArrowSize;
FArrowStartKind:= StrToArrowKind(AStorage.RawString['arrow-start-kind']);
FArrowEndKind:= StrToArrowKind(AStorage.RawString['arrow-end-kind']);
Stroker.LineCap := StrToLineCap(AStorage.RawString['line-cap']);
EndUpdate;
end;
procedure TCustomPolypointShape.SaveToStorage(AStorage: TBGRACustomOriginalStorage);
var
x,y: Array of Single;
i: Integer;
begin
inherited SaveToStorage(AStorage);
setlength(x, PointCount);
setlength(y, PointCount);
for i:= 0 to PointCount-1 do
begin
x[i] := Points[i].x;
y[i] := Points[i].y;
end;
AStorage.FloatArray['x'] := x;
AStorage.FloatArray['y'] := y;
AStorage.Bool['closed'] := Closed;
if ArrowStartKind=akNone then AStorage.RemoveAttribute('arrow-start-kind')
else AStorage.RawString['arrow-start-kind'] := ArrowKindToStr[ArrowStartKind];
if ArrowEndKind=akNone then AStorage.RemoveAttribute('arrow-end-kind')
else AStorage.RawString['arrow-end-kind'] := ArrowKindToStr[ArrowEndKind];
if (ArrowStartKind=akNone) and (ArrowEndKind=akNone) then AStorage.RemoveAttribute('arrow-size')
else AStorage.PointF['arrow-size'] := FArrowSize;
AStorage.RawString['line-cap'] := LineCapToStr[Stroker.LineCap];
end;
procedure TCustomPolypointShape.ConfigureCustomEditor(AEditor: TBGRAOriginalEditor);
var
i, nbTotal: Integer;
begin
FViewMatrix := AEditor.Matrix;
if not IsAffineMatrixInversible(FViewMatrix) then exit;
FViewMatrixInverse := AffineMatrixInverse(FViewMatrix);
FGridMatrix := AEditor.GridMatrix;
AEditor.AddStartMoveHandler(@OnStartMove);
AEditor.AddClickPointHandler(@OnClickPoint);
AEditor.AddHoverPointHandler(@OnHoverPoint);
FCenterPoint := PointF(0,0);
nbTotal := 0;
for i:= 0 to PointCount-1 do
if isEmptyPointF(Points[i]) then
FPoints[i].editorIndex := -1
else if (FAddingPoint and (i = PointCount-1) and (GetLoopPointCount > 1)) then
begin
FPoints[i].editorIndex := -1;
FCenterPoint += Points[i];
inc(nbTotal);
end
else
begin
if CanMovePoints then
FPoints[i].editorIndex := AEditor.AddPoint(Points[i], @OnMovePoint, false)
else
FPoints[i].editorIndex := AEditor.AddFixedPoint(Points[i], false);
FCenterPoint += Points[i];
if i = HoverPoint then
AEditor.PointHighlighted[FPoints[i].editorIndex] := true;
inc(nbTotal);
end;
if nbTotal > 0 then
FCenterPoint *= 1/nbTotal
else FCenterPoint := EmptyPointF;
if (FAddingPoint and (nbTotal > 2)) or (not FAddingPoint and (nbTotal > 1)) then
begin
FCenterPointEditorIndex := AEditor.AddPoint(FCenterPoint, @OnMoveCenterPoint, true);
AEditor.PointHighlighted[FCenterPointEditorIndex] := HoverCenter;
end else
FCenterPointEditorIndex := -1;
end;
procedure TCustomPolypointShape.TransformFrame(const AMatrix: TAffineMatrix);
var
i: Integer;
m: TAffineMatrix;
begin
BeginUpdate(TCustomPolypointShapeDiff);
m := MatrixForPixelCentered(AMatrix);
for i := 0 to PointCount-1 do
FPoints[i].coord := m*FPoints[i].coord;
EndUpdate;
end;
{ TPolylineShape }
class function TPolylineShape.Fields: TVectorShapeFields;
begin
Result:= [vsfPenFill, vsfPenWidth, vsfPenStyle, vsfJoinStyle, vsfBackFill];
end;
procedure TPolylineShape.Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix;
ADraft: boolean);
var
pts: array of TPointF;
backScan, penScan: TBGRACustomScanner;
begin
if not GetBackVisible and not GetPenVisible then exit;
pts := GetCurve(AMatrix);
if GetBackVisible then
begin
if BackFill.FillType = vftSolid then backScan := nil
else backScan := BackFill.CreateScanner(AMatrix, ADraft);
if ADraft then
begin
if Assigned(backScan) then
ADest.FillPoly(pts, backScan, dmDrawWithTransparency) else
ADest.FillPoly(pts, BackFill.SolidColor, dmDrawWithTransparency);
end
else
begin
if Assigned(backScan) then
ADest.FillPolyAntialias(pts, backScan) else
ADest.FillPolyAntialias(pts, BackFill.SolidColor);
end;
backScan.Free;
end;
if GetPenVisible then
begin
if PenFill.FillType = vftSolid then penScan := nil
else penScan := PenFill.CreateScanner(AMatrix, ADraft);
pts := ComputeStroke(pts, Closed, AMatrix);
if ADraft and (PenWidth > 4) then
begin
if Assigned(penScan) then
ADest.FillPoly(pts, penScan, dmDrawWithTransparency) else
ADest.FillPoly(pts, PenColor, dmDrawWithTransparency);
end
else
begin
if Assigned(penScan) then
ADest.FillPolyAntialias(pts, penScan) else
ADest.FillPolyAntialias(pts, PenColor);
end;
penScan.Free;
end;
end;
function TPolylineShape.AppendToSVG(AContent: TSVGContent; ADefs: TSVGDefine): TSVGElement;
var
p: TBGRAPath;
begin
p := GetPath(AffineMatrixIdentity);
result := AContent.AppendPath(p.SvgString);
p.Free;
ApplyStrokeStyleToSVG(result, ADefs);
if PenVisible then
result.strokeLineCapLCL := LineCap;
ApplyFillStyleToSVG(result, ADefs);
end;
function TPolylineShape.GetRenderBounds(ADestRect: TRect; AMatrix: TAffineMatrix; AOptions: TRenderBoundsOptions): TRectF;
var
pts: ArrayOfTPointF;
xMargin, yMargin: single;
fillBounds, penBounds: TRectF;
begin
if not (GetBackVisible or (rboAssumeBackFill in AOptions)) and not GetPenVisible(rboAssumePenFill in AOptions) then
result:= EmptyRectF
else
begin
pts := GetCurve(AMatrix);
if GetPenVisible(rboAssumePenFill in AOptions) then
begin
if (JoinStyle = pjsRound) and (ArrowStartKind = akNone) and (ArrowEndKind = akNone) then
begin
xMargin := (abs(AMatrix[1,1])+abs(AMatrix[1,2]))*PenWidth*0.5;
yMargin := (abs(AMatrix[2,1])+abs(AMatrix[2,2]))*PenWidth*0.5;
if LineCap = pecSquare then
begin
xMargin *= sqrt(2);
yMargin *= sqrt(2);
end;
result := GetPointsBoundsF(pts);
result.Left -= xMargin;
result.Top -= yMargin;
result.Right += xMargin;
result.Bottom += yMargin;
end else
begin
if GetBackVisible or (rboAssumeBackFill in AOptions) then fillBounds := GetPointsBoundsF(pts)
else fillBounds := EmptyRectF;
pts := ComputeStroke(pts, Closed, AMatrix);
penBounds := GetPointsBoundsF(pts);
result := fillBounds.Union(penBounds, true);
end;
end
else
result := GetPointsBoundsF(pts);
end;
result.Offset(0.5,0.5);
end;
function TPolylineShape.PointInShape(APoint: TPointF): boolean;
var
pts: ArrayOfTPointF;
begin
if not GetBackVisible and not GetPenVisible then exit(false);
pts := GetCurve(AffineMatrixIdentity);
if GetBackVisible and IsPointInPolygon(pts, APoint, true) then exit(true);
if GetPenVisible then
begin
pts := ComputeStroke(pts, Closed, AffineMatrixIdentity);
if IsPointInPolygon(pts, APoint, true) then exit(true);
end;
result := false;
end;
function TPolylineShape.PointInShape(APoint: TPointF; ARadius: single): boolean;
var
pts: ArrayOfTPointF;
begin
if not GetBackVisible and not GetPenVisible then exit(false);
pts := GetCurve(AffineMatrixIdentity);
pts := ComputeStrokeEnvelope(pts, Closed, ARadius*2);
result := IsPointInPolygon(pts, APoint, true);
end;
function TPolylineShape.PointInBack(APoint: TPointF): boolean;
var
pts: ArrayOfTPointF;
scan: TBGRACustomScanner;
begin
if GetBackVisible then
begin
pts := GetCurve(AffineMatrixIdentity);
result := IsPointInPolygon(pts, APoint, true);
if result and (BackFill.FillType = vftTexture) then
begin
scan := BackFill.CreateScanner(AffineMatrixIdentity, false);
if scan.ScanAt(APoint.X,APoint.Y).alpha = 0 then result := false;
scan.Free;
end;
end else
result := false;
end;
function TPolylineShape.PointInPen(APoint: TPointF): boolean;
var
pts: ArrayOfTPointF;
begin
if GetBackVisible then
begin
pts := GetCurve(AffineMatrixIdentity);
pts := ComputeStroke(pts, Closed, AffineMatrixIdentity);
result := IsPointInPolygon(pts, APoint, true);
end else
result := false;
end;
function TPolylineShape.GetIsSlow(const AMatrix: TAffineMatrix): boolean;
var pts: ArrayOfTPointF;
i: Integer;
ptsBounds: TRectF;
backSurface: Single;
penLength, zoomFactor, penSurface, totalSurface: single;
begin
if not GetPenVisible and not GetBackVisible or (PointCount = 0) then exit(false);
setlength(pts, PointCount);
for i := 0 to high(pts) do
pts[i] := AMatrix * Points[i];
if GetPenVisible then
begin
penLength := 0;
zoomFactor := max(VectLen(AMatrix[1,1],AMatrix[2,1]), VectLen(AMatrix[1,2],AMatrix[2,2]));
for i := 0 to high(pts) do
if (i > 0) then
begin
if pts[i-1].IsEmpty then
begin
if not pts[i].IsEmpty and (LineCap <> pecFlat) then penLength += penWidth/2*zoomFactor;
end else
if pts[i].IsEmpty then
begin
if not pts[i-1].IsEmpty and (LineCap <> pecFlat) then penLength += penWidth/2*zoomFactor;
end else
penLength += VectLen(pts[i]-pts[i-1]);
end;
penSurface := penLength*PenWidth*zoomFactor;
end else penSurface := 0;
if GetBackVisible then
begin
ptsBounds := GetPointsBoundsF(pts);
backSurface := ptsBounds.Width*ptsBounds.Height;
end else
backSurface := 0;
if GetPenVisible and GetBackVisible then totalSurface := backSurface+penSurface/2
else totalSurface := backSurface+penSurface;
Result:= (PointCount > 40) or
((penSurface > 320*240) and PenFill.IsSlow(AMatrix)) or
((backSurface > 320*240) and BackFill.IsSlow(AMatrix)) or
(totalSurface > 640*480);
end;
class function TPolylineShape.StorageClassName: RawByteString;
begin
result := 'polyline';
end;
{ TCurveShape }
procedure TCurveShape.SetSplineStyle(AValue: TSplineStyle);
begin
if FSplineStyle=AValue then Exit;
BeginUpdate(TCurveShapeDiff);
FSplineStyle:=AValue;
EndUpdate;
end;
function TCurveShape.GetCurveMode(AIndex: integer): TEasyBezierCurveMode;
begin
if (AIndex < 0) or (AIndex >= PointCount) then exit(cmCurve);
result := TEasyBezierCurveMode(FPoints[AIndex].data);
end;
procedure TCurveShape.SetCosineAngle(AValue: single);
begin
if FCosineAngle=AValue then Exit;
BeginUpdate(TCurveShapeDiff);
FCosineAngle:=AValue;
EndUpdate;
end;
procedure TCurveShape.SetCurveMode(AIndex: integer; AValue: TEasyBezierCurveMode);
begin
if (AIndex < 0) or (AIndex >= PointCount) then exit;
if CurveMode[AIndex] = AValue then exit;
BeginUpdate(TCustomPolypointShapeDiff);
FPoints[AIndex].data := ord(AValue);
EndUpdate
end;
function TCurveShape.GetCurve(AMatrix: TAffineMatrix): ArrayOfTPointF;
var
pts: array of TPointF;
cm: array of TEasyBezierCurveMode;
i: Integer;
eb: TEasyBezierCurve;
begin
pts := inherited GetCurve(AMatrix);
if FSplineStyle = ssEasyBezier then
begin
setlength(cm, PointCount);
for i := 0 to PointCount-1 do
cm[i] := CurveMode[i];
eb := EasyBezierCurve(pts, Closed, cm, CosineAngle);
result := eb.ToPoints;
end else
begin
if Closed then result := ComputeClosedSpline(pts, FSplineStyle)
else result := ComputeOpenedSpline(pts, FSplineStyle);
end;
end;
function TCurveShape.GetPath(AMatrix: TAffineMatrix): TBGRAPath;
var
pts: array of TPointF;
cm: array of TEasyBezierCurveMode;
i: Integer;
eb: TEasyBezierCurve;
begin
pts := inherited GetCurve(AMatrix);
result := TBGRAPath.Create;
if FSplineStyle = ssEasyBezier then
begin
setlength(cm, PointCount);
for i := 0 to PointCount-1 do
cm[i] := CurveMode[i];
eb := EasyBezierCurve(pts, Closed, cm, CosineAngle);
eb.CopyToPath(result);
end else
begin
if Closed then result.closedSpline(pts, FSplineStyle)
else result.openedSpline(pts, FSplineStyle);
end;
end;
function TCurveShape.CanMovePoints: boolean;
begin
Result:= Usermode in [vsuCreate,vsuEdit];
end;
procedure TCurveShape.DoClickPoint(APointIndex: integer; AShift: TShiftState);
begin
case Usermode of
vsuCurveSetAuto: CurveMode[APointIndex] := cmAuto;
vsuCurveSetCurve: CurveMode[APointIndex] := cmCurve;
vsuCurveSetAngle: CurveMode[APointIndex] := cmAngle;
else
inherited DoClickPoint(APointIndex, AShift);
end;
end;
class function TCurveShape.Usermodes: TVectorShapeUsermodes;
begin
Result:=inherited Usermodes + [vsuCurveSetAuto, vsuCurveSetCurve, vsuCurveSetAngle];
end;
constructor TCurveShape.Create(AContainer: TVectorOriginal);
begin
inherited Create(AContainer);
FSplineStyle:= ssEasyBezier;
end;
constructor TCurveShape.CreateFrom(AContainer: TVectorOriginal;
AShape: TVectorShape);
var
r: TCustomRectShape;
u, v: TPointF;
p: TCustomPolypointShape;
i: Integer;
f: TVectorShapeFields;
sq2m1: single;
begin
Create(AContainer);
if AShape is TEllipseShape then
begin
r := AShape as TCustomRectShape;
u := r.XAxis-r.Origin;
v := r.YAxis-r.Origin;
sq2m1 := sqrt(2)-1;
AddPoint(r.Origin-v+u*sq2m1);
AddPoint(r.Origin-v*sq2m1+u);
AddPoint(r.Origin+v*sq2m1+u);
AddPoint(r.Origin+v+u*sq2m1);
AddPoint(r.Origin+v-u*sq2m1);
AddPoint(r.Origin+v*sq2m1-u);
AddPoint(r.Origin-v*sq2m1-u);
AddPoint(r.Origin-v-u*sq2m1);
Closed := true;
end else
if AShape is TRectShape then
begin
r := AShape as TCustomRectShape;
u := r.XAxis-r.Origin;
v := r.YAxis-r.Origin;
AddPoint(r.Origin-v-u, cmAngle);
AddPoint(r.Origin-v+u, cmAngle);
AddPoint(r.Origin+v+u, cmAngle);
AddPoint(r.Origin+v-u, cmAngle);
Closed := true;
end else
if (AShape is TPolylineShape) and not
(AShape is TCurveShape) then
begin
p := AShape as TCustomPolypointShape;
for i := 0 to p.PointCount-1 do
AddPoint(p.Points[i], cmAngle);
Closed := p.Closed;
end else
raise exception.Create(errShapeNotHandled);
f := AShape.Fields;
if vsfPenFill in f then PenFill.Assign(AShape.PenFill);
if vsfPenWidth in f then PenWidth := AShape.PenWidth;
if vsfPenStyle in f then PenStyle := AShape.PenStyle;
if vsfJoinStyle in f then JoinStyle := AShape.JoinStyle;
if vsfBackFill in f then BackFill.Assign(AShape.BackFill);
end;
class function TCurveShape.CanCreateFrom(AShape: TVectorShape): boolean;
begin
result := (AShape is TEllipseShape) or
(AShape is TRectShape) or
((AShape is TPolylineShape) and not
(AShape is TCurveShape));
end;
function TCurveShape.AddPoint(const APoint: TPointF): integer;
begin
if (PointCount > 1) and (APoint = Points[PointCount-1]) then
begin
BeginUpdate;
CurveMode[PointCount-1] := CurveMode[PointCount-2];
Result:=inherited AddPoint(APoint);
EndUpdate;
end
else Result:=inherited AddPoint(APoint);
end;
function TCurveShape.AddPoint(const APoint: TPointF; AMode: TEasyBezierCurveMode): integer;
begin
result := inherited AddPoint(APoint);
CurveMode[result] := AMode;
end;
procedure TCurveShape.KeyPress(UTF8Key: string; var AHandled: boolean);
var
targetPoint: Integer;
begin
if HoverPoint<>-1 then
targetPoint := HoverPoint
else if FAddingPoint and (PointCount > 1) then
targetPoint := PointCount-2
else
targetPoint := -1;
if (targetPoint >= 0) and (targetPoint < PointCount) then
begin
if (UTF8Key = 'A') or (UTF8Key = 'a') then
begin
CurveMode[targetPoint] := cmAuto;
AHandled := true;
end else
if (UTF8Key = 'S') or (UTF8Key = 's') then
begin
CurveMode[targetPoint] := cmCurve;
AHandled:= true;
end else
if (UTF8Key = 'X') or (UTF8Key = 'x') then
begin
CurveMode[targetPoint] := cmAngle;
AHandled:= true;
end;
end;
if not AHandled then
inherited KeyPress(UTF8Key, AHandled);
end;
procedure TCurveShape.LoadFromStorage(AStorage: TBGRACustomOriginalStorage);
var
i: Integer;
cm: array of Single;
begin
BeginUpdate;
inherited LoadFromStorage(AStorage);
case AStorage.RawString['spline-style'] of
'inside': SplineStyle := ssInside;
'inside+ends': SplineStyle := ssInsideWithEnds;
'crossing': SplineStyle := ssCrossing;
'crossing+ends': SplineStyle := ssCrossingWithEnds;
'outside': SplineStyle := ssOutside;
'round-outside': SplineStyle := ssRoundOutside;
'vertex-to-side': SplineStyle := ssVertexToSide;
else
{'easy-bezier'} SplineStyle := ssEasyBezier;
end;
if SplineStyle = ssEasyBezier then
begin
cm := AStorage.FloatArray['curve-mode'];
for i := 0 to min(high(cm),PointCount-1) do
case round(cm[i]) of
1: CurveMode[i] := cmCurve;
2: CurveMode[i] := cmAngle;
end;
if length(cm) < PointCount then
for i:= length(cm) to PointCount-1 do
CurveMode[i] := cmCurve;
end;
CosineAngle := AStorage.FloatDef['cosine-angle', EasyBezierDefaultMinimumDotProduct];
EndUpdate;
end;
procedure TCurveShape.SaveToStorage(AStorage: TBGRACustomOriginalStorage);
var s: string;
cm: array of single;
i: Integer;
begin
inherited SaveToStorage(AStorage);
case SplineStyle of
ssInside: s := 'inside';
ssInsideWithEnds: s := 'inside+ends';
ssCrossing: s := 'crossing';
ssCrossingWithEnds: s := 'crossing+ends';
ssOutside: s := 'outside';
ssRoundOutside: s := 'round-outside';
ssVertexToSide: s := 'vertex-to-side';
ssEasyBezier: s := 'easy-bezier';
else s := '';
end;
AStorage.RawString['spline-style'] := s;
if SplineStyle = ssEasyBezier then
begin
setlength(cm, PointCount);
for i := 0 to PointCount-1 do
cm[i] := ord(CurveMode[i]);
AStorage.FloatArray['curve-mode'] := cm;
end;
AStorage.Float['cosine-angle'] := CosineAngle;
end;
class function TCurveShape.StorageClassName: RawByteString;
begin
Result:= 'curve';
end;
initialization
RegisterVectorShape(TPolylineShape);
RegisterVectorShape(TCurveShape);
end.
./lazpaint-7.1.6/lazpaintcontrols/lcvectorialfillinterface.pas 0000664 0001750 0001750 00000134315 13761713342 025070 0 ustar circular circular // SPDX-License-Identifier: GPL-3.0-only
unit LCVectorialFillInterface;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Types,
Controls, ComCtrls, Menus, Dialogs, ExtDlgs, ExtCtrls,
BGRAImageList, BCTrackbarUpdown,
BGRABitmap, BGRABitmapTypes, LCVectorialFill, LCVectorOriginal,
BGRAGradientScanner, Graphics, BGRAGraphics;
function GradRepetitionToStr(AValue: TBGRAGradientRepetition): string;
function ColorInterpToStr(AValue: TBGRAColorInterpolation): string;
function TextureRepetitionToStr(AValue: TTextureRepetition): string;
type
TLCFillTarget = (ftPen, ftBack, ftOutline);
TChooseColorEvent = procedure(ASender: TObject; AButton: TMouseButton; AColorIndex: integer;
var AColorValue: TBGRAPixel; out AHandled: boolean) of object;
{ TVectorialFillInterface }
TVectorialFillInterface = class(TComponent)
private
FCanEditGradTexPoints: boolean;
FIsTarget: boolean;
FOnMouseDown: TMouseEvent;
FOnMouseEnter: TNotifyEvent;
FOnMouseLeave: TNotifyEvent;
FOnMouseMove: TMouseMoveEvent;
FOnMouseUp: TMouseEvent;
procedure EditGradTextPointsClick(Sender: TObject);
function GetEditingGradTexPoints: boolean;
procedure Preview_MouseUp(Sender: TObject; Button: TMouseButton;
{%H-}Shift: TShiftState; X, {%H-}Y: Integer);
procedure SetCanEditGradTexPoints(AValue: boolean);
procedure SetEditingGradTexPoints(AValue: boolean);
procedure SetIsTarget(AValue: boolean);
procedure SetVerticalPadding(AValue: integer);
procedure ToolbarMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure ToolbarMouseEnter(Sender: TObject);
procedure ToolbarMouseLeave(Sender: TObject);
procedure ToolbarMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure ToolbarMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure AnyButtonMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure AnyButtonMouseEnter(Sender: TObject);
procedure AnyButtonMouseLeave(Sender: TObject);
procedure AnyButtonMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure AnyButtonMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
protected
FFillType: TVectorialFillType;
FAllowedFillTypes: TVectorialFillTypes;
FSolidColor: TBGRAPixel;
FOnChooseColor: TChooseColorEvent;
FGradStartColor, FGradEndColor: TBGRAPixel;
FGradType: TGradientType;
FGradRepetition: TBGRAGradientRepetition;
FGradInterp: TBGRAColorInterpolation;
FTexRepetition: TTextureRepetition;
FTexture: TBGRABitmap;
FTexOpacity: byte;
FTextureAverageColor: TBGRAPixel;
FTextureAverageColorComputed: boolean;
//interface
FContainer: TWinControl;
FVerticalPadding: integer;
FPreview: TImage;
FButtonFillNone, FButtonFillSolid,
FButtonFillGradient, FButtonFillTexture: TToolButton;
FOnFillChange, FOnFillTypeChange: TNotifyEvent;
FButtonEditGradTexPoints, FButtonAdjustToShape: TToolButton;
FOnEditGradTexPoints, FOnAdjustToShape: TNotifyEvent;
FSolidColorInterfaceCreated: boolean;
FShapeSolidColor: TShape;
FUpDownSolidAlpha: TBCTrackbarUpdown;
FSolidColorChange: TNotifyEvent;
FTextureInterfaceCreated: boolean;
FCanAdjustToShape: boolean;
FButtonTexRepeat, FButtonLoadTexture: TToolButton;
FUpDownTexAlpha: TBCTrackbarUpdown;
FOnTextureClick: TNotifyEvent;
FOnTextureChange: TNotifyEvent;
FGradientInterfaceCreated: boolean;
//FShapeStartColor, FShapeEndColor: TShape;
FUpDownStartAlpha, FUpDownEndAlpha: TBCTrackbarUpdown;
FButtonSwapColor, FButtonGradRepetition, FButtonGradInterp: TToolButton;
FGradTypeMenu, FGradRepetitionMenu, FGradInterpMenu: TPopupMenu;
FColorDlg: TColorDialog;
FOpenPictureDlg: TOpenPictureDialog;
FTexRepetitionMenu: TPopupMenu;
FToolbar: TToolBar;
FImageList: TBGRAImageList;
FImageListLoaded: boolean;
FImageListSize: TSize;
procedure AdjustToShapeClick(Sender: TObject);
procedure ButtonFillChange(Sender: TObject);
procedure ButtonFillGradClick(Sender: TObject);
procedure ButtonFillTexClick(Sender: TObject);
procedure ButtonGradInterpClick(Sender: TObject);
procedure ButtonGradRepetitionClick(Sender: TObject);
procedure ButtonLoadTextureClick(Sender: TObject);
procedure ButtonSwapColorClick(Sender: TObject);
procedure ButtonTexRepeatClick(Sender: TObject);
procedure Changed(AUpdatePreview: boolean = True);
procedure OnClickBackGradType(ASender: TObject);
procedure OnClickBackTexRepeat(ASender: TObject);
procedure OnClickGradInterp(ASender: TObject);
procedure OnClickGradRepeat(ASender: TObject);
function GetPreferredSize: TSize;
function GetAverageColor: TBGRAPixel;
procedure SetCanAdjustToShape(AValue: boolean);
procedure SetContainer(AValue: TWinControl);
procedure SetFillType(AValue: TVectorialFillType);
procedure SetAllowedFillTypes(AValue: TVectorialFillTypes);
procedure SetSolidColor(AValue: TBGRAPixel);
procedure SetGradientType(AValue: TGradientType);
procedure SetGradEndColor(AValue: TBGRAPixel);
procedure SetGradStartColor(AValue: TBGRAPixel);
procedure SetGradRepetition(AValue: TBGRAGradientRepetition);
procedure SetGradInterpolation(AValue: TBGRAColorInterpolation);
procedure SetImageListSize(AValue: TSize);
procedure SetTexture(AValue: TBGRABitmap);
procedure SetTextureRepetition(AValue: TTextureRepetition);
procedure SetTextureOpacity(AValue: byte);
procedure SetOnTextureClick(AValue: TNotifyEvent);
// procedure ShapeEndColorMouseUp({%H-}Sender: TObject; {%H-}Button: TMouseButton;
// {%H-}Shift: TShiftState; {%H-}X, {%H-}Y: Integer);
procedure ShapeSolidColorMouseUp({%H-}Sender: TObject; {%H-}Button: TMouseButton;
{%H-}Shift: TShiftState; {%H-}X, {%H-}Y: Integer);
// procedure ShapeStartColorMouseUp({%H-}Sender: TObject; {%H-}Button: TMouseButton;
// {%H-}Shift: TShiftState; {%H-}X, {%H-}Y: Integer);
procedure UpdateAccordingToFillType;
procedure UpdateTopToolbar;
procedure UpdatePreview;
procedure UpdateShapeSolidColor;
procedure UpdateTextureParams;
procedure UpdateGradientParams;
procedure UpdateButtonAdjustToShape;
procedure UpDownEndAlphaChange(Sender: TObject; AByUser: boolean);
procedure UpDownSolidAlphaChange(Sender: TObject; AByUser: boolean);
procedure UpDownStartAlphaChange(Sender: TObject; AByUser: boolean);
procedure UpDownTexAlphaChange(Sender: TObject; AByUser: boolean);
procedure ChooseColor(AColorIndex: integer; AButton: TMouseButton);
procedure CreateSolidColorInterface;
procedure CreateGradientInterface;
procedure CreateTextureInterface;
procedure HideSolidColorInterface;
procedure HideGradientInterface;
procedure HideTextureInterface;
procedure Init(AImageListWidth,AImageListHeight: Integer);
procedure AttachMouseEvent(AControl: TToolBar); overload;
procedure AttachMouseEvent(AControl: TToolButton); overload;
procedure AttachMouseEvent(AControl: TBCTrackbarUpdown); overload;
procedure AttachMouseEvent(AControl: TImage); overload;
public
constructor Create(AOwner: TComponent); override;
constructor Create(AOwner: TComponent; AImageListWidth,AImageListHeight: Integer);
destructor Destroy; override;
procedure LoadTexture;
procedure LoadImageList;
procedure ContainerSizeChanged;
function GetTextureThumbnail(AWidth, AHeight: integer; ABackColor: TColor): TBitmap;
procedure AssignFill(AFill: TVectorialFill);
procedure UpdateFillExceptGeometry(ATargetFill: TVectorialFill);
function CreateShapeFill(AShape: TVectorShape): TVectorialFill;
procedure UpdateShapeFill(AShape: TVectorShape; ATarget: TLCFillTarget);
property FillType: TVectorialFillType read FFillType write SetFillType;
property IsTarget: boolean read FIsTarget write SetIsTarget;
property SolidColor: TBGRAPixel read FSolidColor write SetSolidColor;
property AverageColor: TBGRAPixel read GetAverageColor;
property GradientType: TGradientType read FGradType write SetGradientType;
property GradStartColor: TBGRAPixel read FGradStartColor write SetGradStartColor;
property GradEndColor: TBGRAPixel read FGradEndColor write SetGradEndColor;
property GradRepetition: TBGRAGradientRepetition read FGradRepetition write SetGradRepetition;
property GradInterpolation: TBGRAColorInterpolation read FGradInterp write SetGradInterpolation;
property Texture: TBGRABitmap read FTexture write SetTexture;
property TextureRepetition: TTextureRepetition read FTexRepetition write SetTextureRepetition;
property TextureOpacity: byte read FTexOpacity write SetTextureOpacity;
property CanAdjustToShape: boolean read FCanAdjustToShape write SetCanAdjustToShape;
property CanEditGradTexPoints: boolean read FCanEditGradTexPoints write SetCanEditGradTexPoints;
property EditingGradTexPoints: boolean read GetEditingGradTexPoints write SetEditingGradTexPoints;
property OnFillChange: TNotifyEvent read FOnFillChange write FOnFillChange;
property OnTextureChange: TNotifyEvent read FOnTextureChange write FOnTextureChange;
property OnTextureClick: TNotifyEvent read FOnTextureClick write SetOnTextureClick;
property OnAdjustToShape: TNotifyEvent read FOnAdjustToShape write FOnAdjustToShape;
property OnEditGradTexPoints: TNotifyEvent read FOnEditGradTexPoints write FOnEditGradTexPoints;
property OnFillTypeChange: TNotifyEvent read FOnFillTypeChange write FOnFillTypeChange;
property OnChooseColor: TChooseColorEvent read FOnChooseColor write FOnChooseColor;
property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
property Container: TWinControl read FContainer write SetContainer;
property ImageListSize: TSize read FImageListSize write SetImageListSize;
property VerticalPadding: integer read FVerticalPadding write SetVerticalPadding;
property PreferredSize: TSize read GetPreferredSize;
property AllowedFillTypes: TVectorialFillTypes read FAllowedFillTypes write SetAllowedFillTypes;
end;
implementation
uses LCToolbars, BGRAThumbnail, LResources,
LCVectorShapes, BGRAGradientOriginal, BGRATransform, math,
LCResourceString;
function GradRepetitionToStr(AValue: TBGRAGradientRepetition): string;
begin
case AValue of
grPad: result := rsGrPad;
grRepeat: result := rsGrRepeat;
grReflect: result := rsGrReflect;
grSine: result := rsGrSine;
else result := '';
end;
end;
function ColorInterpToStr(AValue: TBGRAColorInterpolation): string;
begin
case AValue of
ciStdRGB: result := rsCiStdRGB;
ciLinearRGB: result := rsCiLinearRGB;
ciLinearHSLPositive: result := rsCiLinearHSLPositive;
ciLinearHSLNegative: result := rsCiLinearHSLNegative;
ciGSBPositive: result := rsCiGSBPositive;
ciGSBNegative: result := rsCiGSBNegative;
else result := '';
end;
end;
function TextureRepetitionToStr(AValue: TTextureRepetition): string;
begin
case AValue of
trNone: result := rsTrNone;
trRepeatX: result := rsTrRepeatX;
trRepeatY: result := rsTrRepeatY;
trRepeatBoth: result := rsTrRepeatBoth;
else result := '';
end;
end;
{ TVectorialFillInterface }
procedure TVectorialFillInterface.LoadImageList;
var
i: Integer;
lst: TStringList;
begin
if FImageList = nil then FImageList := TBGRAImageList.Create(self);
if FImageListLoaded and (FImageList.Width=FImageListSize.cx) and (FImageList.Height=FImageListSize.cy) then exit;
FImageList.Clear;
FImageList.Width := FImageListSize.cx;
FImageList.Height := FImageListSize.cy;
{$IFDEF DARWIN}
FImageList.Scaled := true;
FImageList.RegisterResolutions([FImageListSize.cx, FImageListSize.cx*2]);
{$ENDIF}
lst := TStringList.Create;
lst.CommaText := GetResourceString('fillimages.lst');
for i := 0 to lst.Count-1 do
LoadToolbarImage(FImageList, i, lst[i]);
lst.Free;
FImageListLoaded := true;
if Assigned(FToolbar) then
begin
SetToolbarImages(FToolbar, FImageList, 5, VerticalPadding);
for i := 0 to FToolbar.ControlCount-1 do
if FToolbar.Controls[i] is TBCTrackbarUpdown then
FToolbar.Controls[i].Width := FToolbar.ButtonWidth*2
else if FToolbar.Controls[i] is TShape then
FToolbar.Controls[i].Width := FToolbar.ButtonWidth;
end;
UpdatePreview;
end;
procedure TVectorialFillInterface.Changed(AUpdatePreview: boolean);
begin
if AUpdatePreview then UpdatePreview;
if Assigned(FOnFillChange) then
FOnFillChange(self);
end;
procedure TVectorialFillInterface.OnClickBackGradType(ASender: TObject);
begin
GradientType:= TGradientType((ASender as TMenuItem).Tag);
FillType := vftGradient;
end;
procedure TVectorialFillInterface.OnClickBackTexRepeat(ASender: TObject);
begin
TextureRepetition := TTextureRepetition((ASender as TMenuItem).Tag);
end;
procedure TVectorialFillInterface.OnClickGradInterp(ASender: TObject);
begin
GradInterpolation:= TBGRAColorInterpolation((ASender as TMenuItem).Tag);
end;
procedure TVectorialFillInterface.OnClickGradRepeat(ASender: TObject);
begin
GradRepetition:= TBGRAGradientRepetition((ASender as TMenuItem).Tag);
end;
procedure TVectorialFillInterface.SetTexture(AValue: TBGRABitmap);
begin
if FTexture=AValue then Exit;
if Assigned(FTexture) then
begin
FTexture.FreeReference;
FTexture := nil;
end;
if Assigned(AValue) then
FTexture := AValue.NewReference as TBGRABitmap;
FTextureAverageColorComputed := false;
if Assigned(FOnTextureChange) then FOnTextureChange(self);
if FFillType = vftTexture then Changed;
end;
procedure TVectorialFillInterface.LoadTexture;
var
newTex: TBGRABitmap;
begin
if FOpenPictureDlg.Execute then
begin
try
newTex := TBGRABitmap.Create(FOpenPictureDlg.FileName, true);
Texture := newTex;
newTex.FreeReference;
FillType:= vftTexture;
except
on ex: exception do
ShowMessage(ex.Message);
end;
end;
end;
procedure TVectorialFillInterface.ContainerSizeChanged;
begin
FToolbar.Align:= alTop;
FToolbar.Height := FContainer.Height;
end;
procedure TVectorialFillInterface.SetFillType(AValue: TVectorialFillType);
begin
if FFillType=AValue then Exit;
FFillType:=AValue;
UpdateAccordingToFillType;
UpdatePreview;
if Assigned(FOnFillTypeChange) then FOnFillTypeChange(self);
Changed(False);
end;
procedure TVectorialFillInterface.ShapeSolidColorMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
ChooseColor(-1, Button);
end;
{procedure TVectorialFillInterface.ShapeStartColorMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
ChooseColor(0, Button);
end;}
procedure TVectorialFillInterface.UpdateAccordingToFillType;
begin
FButtonFillNone.Down := FillType = vftNone;
FButtonFillSolid.Down := FillType = vftSolid;
FButtonFillGradient.Down := FillType = vftGradient;
FButtonFillTexture.Down := FillType = vftTexture;
UpdateButtonAdjustToShape;
if FillType <> vftSolid then HideSolidColorInterface;
if FillType <> vftGradient then HideGradientInterface;
if FillType <> vftTexture then HideTextureInterface;
case FillType of
vftSolid: begin
CreateSolidColorInterface;
UpdateShapeSolidColor;
ShowAppendToolButtons([FShapeSolidColor,FUpDownSolidAlpha]);
end;
vftGradient: begin
CreateGradientInterface;
UpdateGradientParams;
ShowAppendToolButtons([FButtonGradRepetition,FButtonGradInterp,
{FShapeStartColor,}FUpDownStartAlpha,FButtonSwapColor,
{FShapeEndColor,}FUpDownEndAlpha]);
end;
vftTexture: begin
CreateTextureInterface;
UpdateTextureParams;
ShowAppendToolButtons([FButtonTexRepeat,FUpDownTexAlpha,FButtonLoadTexture]);
end;
end;
end;
procedure TVectorialFillInterface.UpdateTopToolbar;
var
x: Integer;
begin
FToolbar.BeginUpdate;
x := FToolbar.Indent;
FButtonFillNone.Left := x;
//FButtonFillNone.Wrap := [vftSolid,vftGradient,vftTexture]*FAllowedFillTypes = [];
FButtonFillNone.Visible:= vftNone in FAllowedFillTypes;
if vftNone in FAllowedFillTypes then inc(x, FButtonFillNone.Width);
FButtonFillSolid.Left := x;
//FButtonFillSolid.Wrap := [vftGradient,vftTexture]*FAllowedFillTypes = [];
FButtonFillSolid.Visible:= vftSolid in FAllowedFillTypes;
if vftSolid in FAllowedFillTypes then inc(x, FButtonFillSolid.Width);
FButtonFillGradient.Left := x;
//FButtonFillGradient.Wrap := [vftTexture]*FAllowedFillTypes = [];
FButtonFillGradient.Visible:= vftGradient in FAllowedFillTypes;
if vftGradient in FAllowedFillTypes then inc(x, FButtonFillGradient.Width);
FButtonFillTexture.Left := x;
FButtonFillTexture.Visible:= vftTexture in FAllowedFillTypes;
if vftTexture in FAllowedFillTypes then inc(x, FButtonFillTexture.Width);
FPreview.Left := x;
inc(x, FPreview.Width);
FButtonEditGradTexPoints.Left := x;
inc(x, FButtonEditGradTexPoints.Width);
FButtonAdjustToShape.Left := x;
FToolbar.EndUpdate;
end;
procedure TVectorialFillInterface.UpdatePreview;
var
bmp, thumb: TBGRABitmap;
grad: TBGRALayerGradientOriginal;
bmpCopy: TBitmap;
ratio: single;
previewWidth: Integer;
begin
if FillType = vftGradient then
previewWidth := round(FToolbar.ButtonWidth*1.5)
else previewWidth := FToolbar.ButtonWidth;
FPreview.Width:= previewWidth + round(FToolbar.ButtonWidth*0.2);
FPreview.Height:= FToolbar.ButtonHeight;
if not FImageListLoaded then exit;
bmp := TBGRABitmap.Create(previewWidth, FPreview.Height - VerticalPadding);
bmp.DrawCheckers(bmp.ClipRect, CSSWhite, CSSSilver);
case FillType of
vftSolid: bmp.Fill(SolidColor, dmDrawWithTransparency);
vftTexture:
if Assigned(FTexture) and (FTexture.Width > 0) and (FTexture.Height > 0) then
begin
ratio := min(bmp.Width/FTexture.Width, bmp.Height/FTexture.Height);
if ratio > 1 then ratio := 1;
thumb := TBGRABitmap.Create(max(round(FTexture.Width*ratio),1),
max(round(FTexture.Height*ratio),1));
thumb.StretchPutImage(thumb.ClipRect, FTexture, dmSet);
bmp.Fill(thumb, dmDrawWithTransparency, TextureOpacity*$0101);
thumb.Free;
end;
vftGradient:
begin
grad := TBGRALayerGradientOriginal.Create;
grad.StartColor := GradStartColor;
grad.EndColor := GradEndColor;
grad.Origin := PointF(0,0);
grad.XAxis := PointF(bmp.Width, 0);
grad.ColorInterpolation:= GradInterpolation;
grad.Render(bmp, AffineMatrixIdentity, false, dmDrawWithTransparency);
grad.Free;
end;
end;
if IsTarget then
begin
if bmp.GetPixel(bmp.Width/2,bmp.Height/2).Lightness > 20000 then
bmp.Rectangle(bmp.ClipRect, BGRABlack, dmDrawWithTransparency)
else bmp.Rectangle(bmp.ClipRect, CSSSilver, dmDrawWithTransparency);
end
else bmp.Rectangle(bmp.ClipRect, BGRA(0,0,0,128), dmDrawWithTransparency);
bmpCopy := bmp.MakeBitmapCopy(clBtnFace);
bmp.Free;
FPreview.Picture.Assign(bmpCopy);
bmpCopy.Free;
if (FillType = vftTexture) and Assigned(Texture) and Assigned(FOnTextureClick) then
FPreview.Cursor := crHandPoint
else
FPreview.Cursor := crDefault;
end;
procedure TVectorialFillInterface.UpdateShapeSolidColor;
var
c: TBGRAPixel;
begin
c := SolidColor;
c.alpha := 255;
if Assigned(FShapeSolidColor) then FShapeSolidColor.Brush.Color := c;
if Assigned(FUpDownSolidAlpha) then FUpDownSolidAlpha.Value := SolidColor.alpha;
end;
procedure TVectorialFillInterface.UpdateTextureParams;
begin
if Assigned(FButtonTexRepeat) then FButtonTexRepeat.ImageIndex := 17 + ord(TextureRepetition);
if Assigned(FUpDownTexAlpha) then FUpDownTexAlpha.Value := TextureOpacity;
end;
procedure TVectorialFillInterface.UpdateGradientParams;
{var
c: TBGRAPixel;}
begin
{ c := GradStartColor;
c.alpha := 255;
if Assigned(FShapeStartColor) then FShapeStartColor.Brush.Color := c;}
if Assigned(FUpDownStartAlpha) then FUpDownStartAlpha.Value := GradStartColor.alpha;
{ c := GradEndColor;
c.alpha := 255;
if Assigned(FShapeEndColor) then FShapeEndColor.Brush.Color := c;}
if Assigned(FUpDownEndAlpha) then FUpDownEndAlpha.Value := GradEndColor.alpha;
if Assigned(FButtonGradRepetition) then FButtonGradRepetition.ImageIndex := 7+ord(FGradRepetition);
if Assigned(FButtonGradInterp) then FButtonGradInterp.ImageIndex := 11+ord(FGradInterp);
end;
procedure TVectorialFillInterface.UpdateButtonAdjustToShape;
begin
if Assigned(FButtonAdjustToShape) then
begin
FButtonAdjustToShape.Enabled := FCanAdjustToShape and (FillType in[vftGradient,vftTexture]);
if FillType in[vftGradient,vftTexture] then
FButtonAdjustToShape.Style := tbsButton
else
FButtonAdjustToShape.Style := tbsDivider;
end;
if Assigned(FButtonEditGradTexPoints) then
begin
FButtonEditGradTexPoints.Enabled := FCanEditGradTexPoints and (FillType in [vftGradient,vftTexture]);
if FillType in [vftGradient,vftTexture] then
FButtonEditGradTexPoints.Style := tbsCheck
else
FButtonEditGradTexPoints.Style := tbsDivider;
end;
end;
procedure TVectorialFillInterface.UpDownEndAlphaChange(Sender: TObject;
AByUser: boolean);
var
c: TBGRAPixel;
begin
if AByUser then
begin
c := GradEndColor;
c.alpha := FUpDownEndAlpha.Value;
GradEndColor:= c;
end;
end;
procedure TVectorialFillInterface.UpDownSolidAlphaChange(Sender: TObject;
AByUser: boolean);
begin
if AByUser then
SolidColor:= ColorToBGRA(FShapeSolidColor.Brush.Color, FUpDownSolidAlpha.Value);
end;
procedure TVectorialFillInterface.UpDownStartAlphaChange(Sender: TObject;
AByUser: boolean);
var
c: TBGRAPixel;
begin
if AByUser then
begin
c := GradStartColor;
c.alpha := FUpDownStartAlpha.Value;
GradStartColor:= c;
end;
end;
procedure TVectorialFillInterface.UpDownTexAlphaChange(Sender: TObject;
AByUser: boolean);
begin
if AByUser then
begin
FTexOpacity:= FUpDownTexAlpha.Value;
if FillType = vftTexture then Changed;
end;
end;
procedure TVectorialFillInterface.ChooseColor(AColorIndex: integer; AButton: TMouseButton);
procedure AssignNewColor(AColor: TBGRAPixel);
begin
case AColorIndex of
-1: SolidColor := AColor;
0: GradStartColor := AColor;
1: GradEndColor := AColor;
end;
end;
var
curColorBGRA: TBGRAPixel;
curColor: TColor;
handled: boolean;
begin
case AColorIndex of
-1: curColorBGRA := SolidColor;
0: curColorBGRA := GradStartColor;
1: curColorBGRA := GradEndColor;
else exit;
end;
if Assigned(FOnChooseColor) then
begin
FOnChooseColor(self, AButton, AColorIndex, curColorBGRA, handled);
if handled then
begin
AssignNewColor( curColorBGRA );
exit;
end;
end;
curColor := RGBToColor(curColorBGRA.red, curColorBGRA.green, curColorBGRA.blue);
FColorDlg.Color := curColor;
if FColorDlg.Execute then
begin
if curColorBGRA.alpha = 0 then
AssignNewColor( ColorToBGRA(FColorDlg.Color) )
else
AssignNewColor( ColorToBGRA(FColorDlg.Color, curColorBGRA.alpha) );
end;
end;
procedure TVectorialFillInterface.CreateSolidColorInterface;
begin
if FSolidColorInterfaceCreated then exit;
FSolidColorInterfaceCreated := true;
//solid color interface
FShapeSolidColor := TShape.Create(FToolbar);
FShapeSolidColor.Width := FToolbar.ButtonWidth;
FShapeSolidColor.Height := FToolbar.ButtonHeight;
FShapeSolidColor.OnMouseUp:= @ShapeSolidColorMouseUp;
FShapeSolidColor.Hint := rsColor;
AddToolbarControl(FToolbar, FShapeSolidColor);
FUpDownSolidAlpha := TBCTrackbarUpdown.Create(FToolbar);
FUpDownSolidAlpha.Width := FToolbar.ButtonWidth*2;
FUpDownSolidAlpha.Height := FToolbar.ButtonHeight;
FUpDownSolidAlpha.MinValue := 0;
FUpDownSolidAlpha.MaxValue := 255;
FUpDownSolidAlpha.Increment:= 15;
FUpDownSolidAlpha.OnChange:=@UpDownSolidAlphaChange;
FUpDownSolidAlpha.Hint := rsOpacity;
AddToolbarControl(FToolbar, FUpDownSolidAlpha);
AttachMouseEvent(FUpDownSolidAlpha);
end;
procedure TVectorialFillInterface.CreateGradientInterface;
var
gr: TBGRAGradientRepetition;
ci: TBGRAColorInterpolation;
item: TMenuItem;
begin
if FGradientInterfaceCreated then exit;
FGradientInterfaceCreated := true;
FButtonGradRepetition := AddToolbarButton(FToolbar, rsGradientRepetition+'...', 7+ord(FGradRepetition), @ButtonGradRepetitionClick);
AttachMouseEvent(FButtonGradRepetition);
FButtonGradInterp := AddToolbarButton(FToolbar, rsColorInterpolation+'...', 11+ord(FGradInterp), @ButtonGradInterpClick);
AttachMouseEvent(FButtonGradInterp);
{ FShapeStartColor := TShape.Create(FToolbar);
FShapeStartColor.Width := FToolbar.ButtonWidth*3 div 4;
FShapeStartColor.Height := FToolbar.ButtonHeight;
FShapeStartColor.OnMouseUp:=@ShapeStartColorMouseUp;
FShapeStartColor.Hint := 'Start color';
AddToolbarControl(FToolbar, FShapeStartColor);}
FUpDownStartAlpha := TBCTrackbarUpdown.Create(FToolbar);
FUpDownStartAlpha.Width := FToolbar.ButtonWidth*2;
FUpDownStartAlpha.Height := FToolbar.ButtonHeight;
FUpDownStartAlpha.MinValue := 0;
FUpDownStartAlpha.MaxValue := 255;
FUpDownStartAlpha.Increment:= 15;
FUpDownStartAlpha.OnChange:=@UpDownStartAlphaChange;
FUpDownStartAlpha.Hint := rsStartOpacity;
AddToolbarControl(FToolbar, FUpDownStartAlpha);
AttachMouseEvent(FUpDownStartAlpha);
FButtonSwapColor := AddToolbarButton(FToolbar, rsSwapColors, 23, @ButtonSwapColorClick);
AttachMouseEvent(FButtonSwapColor);
{ FShapeEndColor := TShape.Create(FToolbar);
FShapeEndColor.Width := FToolbar.ButtonWidth*3 div 4;
FShapeEndColor.Height := FToolbar.ButtonHeight;
FShapeEndColor.OnMouseUp:=@ShapeEndColorMouseUp;
FShapeEndColor.Hint := 'End color';
AddToolbarControl(FToolbar, FShapeEndColor);}
FUpDownEndAlpha := TBCTrackbarUpdown.Create(FToolbar);
FUpDownEndAlpha.Width := FToolbar.ButtonWidth*2;
FUpDownEndAlpha.Height := FToolbar.ButtonHeight;
FUpDownEndAlpha.MinValue := 0;
FUpDownEndAlpha.MaxValue := 255;
FUpDownEndAlpha.Increment:= 15;
FUpDownEndAlpha.OnChange:=@UpDownEndAlphaChange;
FUpDownEndAlpha.Hint := rsEndOpacity;
AddToolbarControl(FToolbar, FUpDownEndAlpha);
AttachMouseEvent(FUpDownEndAlpha);
FGradRepetitionMenu := TPopupMenu.Create(self);
FGradRepetitionMenu.Images := FImageList;
for gr := low(TBGRAGradientRepetition) to high(TBGRAGradientRepetition) do
begin
item := TMenuItem.Create(FGradRepetitionMenu); item.Caption := GradRepetitionToStr(gr);
item.OnClick:=@OnClickGradRepeat; item.Tag := ord(gr);
item.ImageIndex:= 7+ord(gr);
FGradRepetitionMenu.Items.Add(item);
end;
FGradInterpMenu := TPopupMenu.Create(self);
FGradInterpMenu.Images := FImageList;
for ci := low(TBGRAColorInterpolation) to high(TBGRAColorInterpolation) do
begin
item := TMenuItem.Create(FGradInterpMenu); item.Caption := ColorInterpToStr(ci);
item.OnClick:=@OnClickGradInterp; item.Tag := ord(ci);
item.ImageIndex:= 11+ord(ci);
FGradInterpMenu.Items.Add(item);
end;
end;
procedure TVectorialFillInterface.CreateTextureInterface;
var
tr: TTextureRepetition;
item: TMenuItem;
begin
if FTextureInterfaceCreated then exit;
FTextureInterfaceCreated := true;
FButtonTexRepeat := AddToolbarButton(FToolbar, rsTextureRepetition+'...', -1, @ButtonTexRepeatClick);
AttachMouseEvent(FButtonTexRepeat);
FUpDownTexAlpha := TBCTrackbarUpdown.Create(FToolbar);
FUpDownTexAlpha.Width := FToolbar.ButtonWidth*2;
FUpDownTexAlpha.Height := FToolbar.ButtonHeight;
FUpDownTexAlpha.MinValue := 0;
FUpDownTexAlpha.MaxValue := 255;
FUpDownTexAlpha.Increment:= 15;
FUpDownTexAlpha.OnChange:=@UpDownTexAlphaChange;
FUpDownTexAlpha.Hint := rsOpacity;
AddToolbarControl(FToolbar, FUpDownTexAlpha);
AttachMouseEvent(FUpDownTexAlpha);
FButtonLoadTexture := AddToolbarButton(FToolbar, rsLoadTexture+'...', 22, @ButtonLoadTextureClick);
AttachMouseEvent(FButtonLoadTexture);
FTextureAverageColorComputed := false;
FTexRepetitionMenu := TPopupMenu.Create(self);
FTexRepetitionMenu.Images := FImageList;
for tr := low(TTextureRepetition) to high(TTextureRepetition) do
begin
item := TMenuItem.Create(FTexRepetitionMenu); item.Caption := TextureRepetitionToStr(tr);
item.OnClick:=@OnClickBackTexRepeat; item.Tag := ord(tr);
item.ImageIndex:= 17+ord(tr);
FTexRepetitionMenu.Items.Add(item);
end;
end;
procedure TVectorialFillInterface.HideSolidColorInterface;
begin
if not FSolidColorInterfaceCreated then exit;
FShapeSolidColor.Visible := false;
FUpDownSolidAlpha.Visible := false;
end;
procedure TVectorialFillInterface.HideGradientInterface;
begin
if not FGradientInterfaceCreated then exit;
FButtonGradRepetition.Visible := false;
FButtonGradInterp.Visible := false;
//FShapeStartColor.Visible := false;
FUpDownStartAlpha.Visible := false;
FButtonSwapColor.Visible := false;
//FShapeEndColor.Visible := false;
FUpDownEndAlpha.Visible := false;
end;
procedure TVectorialFillInterface.HideTextureInterface;
begin
if not FTextureInterfaceCreated then exit;
FButtonTexRepeat.Visible := false;
FUpDownTexAlpha.Visible := false;
FButtonLoadTexture.Visible := false;
end;
procedure TVectorialFillInterface.Init(AImageListWidth,
AImageListHeight: Integer);
var
gt: TGradientType;
item: TMenuItem;
begin
FContainer := nil;
FAllowedFillTypes := [vftNone, vftSolid, vftGradient, vftTexture];
FFillType:= vftSolid;
FSolidColor:= BGRAWhite;
FGradStartColor:= CSSRed;
FGradEndColor:= CSSYellow;
FGradType:= gtLinear;
FGradRepetition:= grPad;
FGradInterp:= ciLinearRGB;
FTexture:= nil;
FTexRepetition:= trRepeatBoth;
FTexOpacity:= 255;
FCanAdjustToShape:= true;
FVerticalPadding:= 4;
FImageList := TBGRAImageList.Create(self);
FImageListLoaded:= false;
FImageListSize := Size(AImageListWidth,AImageListHeight);
FOpenPictureDlg := TOpenPictureDialog.Create(self);
FColorDlg:= TColorDialog.Create(self);
FOnFillChange:= nil;
FOnTextureChange:= nil;
FToolbar := CreateToolBar(FImageList);
FToolbar.Wrapable := false;
AttachMouseEvent(FToolbar);
FButtonFillNone := AddToolbarCheckButton(FToolbar, rsNoFill, 0, @ButtonFillChange, False, False);
AttachMouseEvent(FButtonFillNone);
FButtonFillSolid := AddToolbarCheckButton(FToolbar, rsSolidColor, 1, @ButtonFillChange, False, False);
AttachMouseEvent(FButtonFillSolid);
FButtonFillGradient := AddToolbarButton(FToolbar, rsGradientFill, 2+ord(FGradType), @ButtonFillGradClick);
AttachMouseEvent(FButtonFillGradient);
FButtonFillTexture := AddToolbarButton(FToolbar, rsTextureFill, 24, @ButtonFillTexClick);
AttachMouseEvent(FButtonFillTexture);
FPreview := TImage.Create(FToolbar);
FPreview.Center:= true;
FPreview.OnMouseUp:=@Preview_MouseUp;
FPreview.Hint := rsPreview;
UpdatePreview;
AddToolbarControl(FToolbar, FPreview);
AttachMouseEvent(FPreview);
FButtonEditGradTexPoints := AddToolbarCheckButton(FToolbar, rsEditGradTexPoints, 25, @EditGradTextPointsClick, false, false);
AttachMouseEvent(FButtonEditGradTexPoints);
FButtonAdjustToShape := AddToolbarButton(FToolbar, rsAdjustToShape, 21, @AdjustToShapeClick);
AttachMouseEvent(FButtonAdjustToShape);
FButtonAdjustToShape.Wrap := true;
UpdateButtonAdjustToShape;
//menu to access gradient interface
FGradTypeMenu := TPopupMenu.Create(self);
FGradTypeMenu.Images := FImageList;
for gt := low(TGradientType) to high(TGradientType) do
begin
item := TMenuItem.Create(FGradTypeMenu); item.Caption := GradientTypeToTranslatedStr(gt);
item.OnClick:=@OnClickBackGradType; item.Tag := ord(gt);
item.ImageIndex:= 2+ord(gt);
FGradTypeMenu.Items.Add(item);
end;
FSolidColorInterfaceCreated := false;
FGradientInterfaceCreated:= false;
FTextureInterfaceCreated:= false;
UpdateAccordingToFillType;
end;
procedure TVectorialFillInterface.AttachMouseEvent(AControl: TToolBar);
begin
AControl.OnMouseMove:=@ToolbarMouseMove;
AControl.OnMouseDown:=@ToolbarMouseDown;
AControl.OnMouseUp:=@ToolbarMouseUp;
AControl.OnMouseEnter:=@ToolbarMouseEnter;
AControl.OnMouseLeave:=@ToolbarMouseLeave;
end;
procedure TVectorialFillInterface.AttachMouseEvent(AControl: TToolButton);
begin
AControl.OnMouseMove:=@AnyButtonMouseMove;
AControl.OnMouseDown:=@AnyButtonMouseDown;
AControl.OnMouseUp:=@AnyButtonMouseUp;
AControl.OnMouseEnter:=@AnyButtonMouseEnter;
AControl.OnMouseLeave:=@AnyButtonMouseLeave;
end;
procedure TVectorialFillInterface.AttachMouseEvent(AControl: TBCTrackbarUpdown);
begin
AControl.OnMouseMove:=@AnyButtonMouseMove;
AControl.OnMouseDown:=@AnyButtonMouseDown;
AControl.OnMouseUp:=@AnyButtonMouseUp;
AControl.OnMouseEnter:=@AnyButtonMouseEnter;
AControl.OnMouseLeave:=@AnyButtonMouseLeave;
end;
procedure TVectorialFillInterface.AttachMouseEvent(AControl: TImage);
begin
AControl.OnMouseMove:=@AnyButtonMouseMove;
AControl.OnMouseEnter:=@AnyButtonMouseEnter;
AControl.OnMouseLeave:=@AnyButtonMouseLeave;
end;
procedure TVectorialFillInterface.SetSolidColor(AValue: TBGRAPixel);
begin
if FSolidColor.EqualsExactly(AValue) then Exit;
FSolidColor:=AValue;
UpdateShapeSolidColor;
If FillType = vftSolid then Changed;
end;
procedure TVectorialFillInterface.ButtonFillChange(Sender: TObject);
begin
if Sender = FButtonFillNone then
begin
FillType:= vftNone;
FButtonFillNone.Down := true;
end
else if Sender = FButtonFillSolid then
begin
FillType:= vftSolid;
FButtonFillSolid.Down := true;
end;
end;
procedure TVectorialFillInterface.SetTextureRepetition(
AValue: TTextureRepetition);
begin
if FTexRepetition=AValue then Exit;
FTexRepetition:=AValue;
UpdateTextureParams;
If FillType = vftTexture then Changed;
end;
procedure TVectorialFillInterface.SetTextureOpacity(AValue: byte);
begin
if FTexOpacity=AValue then Exit;
FTexOpacity:=AValue;
FUpDownTexAlpha.Value := AValue;
If FillType = vftTexture then Changed;
end;
{procedure TVectorialFillInterface.ShapeEndColorMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
ChooseColor(1, Button);
end;}
procedure TVectorialFillInterface.SetGradientType(AValue: TGradientType);
begin
if FGradType=AValue then Exit;
FGradType:=AValue;
FButtonFillGradient.ImageIndex := 2+ord(GradientType);
if FillType = vftGradient then Changed;
end;
procedure TVectorialFillInterface.SetGradEndColor(AValue: TBGRAPixel);
begin
if FGradEndColor.EqualsExactly(AValue) then Exit;
FGradEndColor:=AValue;
UpdateGradientParams;
if FillType = vftGradient then Changed;
end;
procedure TVectorialFillInterface.SetGradStartColor(AValue: TBGRAPixel);
begin
if FGradStartColor.EqualsExactly(AValue) then Exit;
FGradStartColor:=AValue;
UpdateGradientParams;
if FillType = vftGradient then Changed;
end;
procedure TVectorialFillInterface.SetGradRepetition(AValue: TBGRAGradientRepetition);
begin
if FGradRepetition=AValue then Exit;
FGradRepetition:=AValue;
UpdateGradientParams;
if FillType = vftGradient then Changed;
end;
procedure TVectorialFillInterface.SetGradInterpolation(
AValue: TBGRAColorInterpolation);
begin
if FGradInterp=AValue then Exit;
FGradInterp:=AValue;
UpdateGradientParams;
if FillType = vftGradient then Changed;
end;
procedure TVectorialFillInterface.SetContainer(AValue: TWinControl);
begin
if FContainer=AValue then Exit;
if Assigned(FContainer) then FContainer.RemoveControl(FToolbar);
FContainer:=AValue;
if Assigned(FContainer) then
begin
FContainer.InsertControl(FToolBar);
ContainerSizeChanged;
end;
end;
function TVectorialFillInterface.GetPreferredSize: TSize;
begin
result := GetToolbarSize(FToolbar,0);
end;
procedure TVectorialFillInterface.SetCanAdjustToShape(AValue: boolean);
begin
if FCanAdjustToShape=AValue then Exit;
FCanAdjustToShape:=AValue;
UpdateButtonAdjustToShape;
end;
procedure TVectorialFillInterface.SetImageListSize(AValue: TSize);
begin
if (FImageListSize.cx=AValue.cx) and (FImageListSize.cy=AValue.cy) then Exit;
FImageListSize:=AValue;
if FImageListLoaded then LoadImageList;
end;
procedure TVectorialFillInterface.SetAllowedFillTypes(
AValue: TVectorialFillTypes);
begin
Include(AValue, FFillType); //cannot exclude current type
if FAllowedFillTypes=AValue then Exit;
FAllowedFillTypes:=AValue;
UpdateTopToolbar;
end;
procedure TVectorialFillInterface.SetOnTextureClick(AValue: TNotifyEvent);
begin
if FOnTextureClick=AValue then Exit;
FOnTextureClick:=AValue;
UpdatePreview;
end;
function TVectorialFillInterface.GetAverageColor: TBGRAPixel;
begin
case FillType of
vftNone: result := BGRAPixelTransparent;
vftGradient: result := MergeBGRAWithGammaCorrection(GradStartColor, 1, GradEndColor, 1);
vftTexture: begin
if not FTextureAverageColorComputed then
begin
if Assigned(FTexture) then
FTextureAverageColor := FTexture.AverageColor
else
FTextureAverageColor := BGRAPixelTransparent;
FTextureAverageColorComputed := true;
end;
result := FTextureAverageColor;
end
else {vftSolid} result := SolidColor;
end;
end;
procedure TVectorialFillInterface.ToolbarMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
begin
if Assigned(FOnMouseMove) then FOnMouseMove(self, Shift, X+FToolbar.Left,Y+FToolbar.Top);
end;
procedure TVectorialFillInterface.ToolbarMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Assigned(FOnMouseUp) then FOnMouseUp(self, Button, Shift, X+FToolbar.Left,Y+FToolbar.Top);
end;
procedure TVectorialFillInterface.AnyButtonMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Assigned(FOnMouseDown) then FOnMouseDown(self, Button, Shift,
X+FToolbar.Left+TControl(Sender).Left,Y+FToolbar.Top+TControl(Sender).Top);
end;
procedure TVectorialFillInterface.AnyButtonMouseEnter(Sender: TObject);
begin
If Assigned(FOnMouseEnter) then FOnMouseEnter(self);
end;
procedure TVectorialFillInterface.AnyButtonMouseLeave(Sender: TObject);
begin
If Assigned(FOnMouseLeave) then FOnMouseLeave(self);
end;
procedure TVectorialFillInterface.AnyButtonMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
begin
if Assigned(FOnMouseMove) then FOnMouseMove(self, Shift,
X+FToolbar.Left+TControl(Sender).Left,Y+FToolbar.Top+TControl(Sender).Top);
end;
procedure TVectorialFillInterface.AnyButtonMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Assigned(FOnMouseUp) then FOnMouseUp(self, Button, Shift,
X+FToolbar.Left+TControl(Sender).Left,Y+FToolbar.Top+TControl(Sender).Top);
end;
procedure TVectorialFillInterface.ToolbarMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Assigned(FOnMouseDown) then FOnMouseDown(self, Button, Shift, X+FToolbar.Left,Y+FToolbar.Top);
end;
procedure TVectorialFillInterface.SetVerticalPadding(AValue: integer);
begin
if FVerticalPadding=AValue then Exit;
FVerticalPadding:=AValue;
if Assigned(FToolbar) and Assigned(FImageList) then
begin
FToolbar.ButtonHeight:= FImageList.Height+AValue;
UpdatePreview;
end;
end;
procedure TVectorialFillInterface.Preview_MouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
case FillType of
vftSolid: ChooseColor(-1, Button);
vftGradient: if X < FPreview.Width div 2 then ChooseColor(0, Button) else ChooseColor(1, Button);
vftTexture: if Assigned(Texture) and Assigned(FOnTextureClick) then
FOnTextureClick(self);
end;
end;
procedure TVectorialFillInterface.EditGradTextPointsClick(Sender: TObject);
begin
if Assigned(FOnEditGradTexPoints) then FOnEditGradTexPoints(self);
end;
function TVectorialFillInterface.GetEditingGradTexPoints: boolean;
begin
if Assigned(FButtonEditGradTexPoints) then
result := FButtonEditGradTexPoints.Down
else result := false;
end;
procedure TVectorialFillInterface.SetCanEditGradTexPoints(AValue: boolean);
begin
if FCanEditGradTexPoints=AValue then Exit;
FCanEditGradTexPoints:=AValue;
UpdateButtonAdjustToShape;
end;
procedure TVectorialFillInterface.SetEditingGradTexPoints(AValue: boolean);
begin
if Assigned(FButtonEditGradTexPoints) then
FButtonEditGradTexPoints.Down := AValue;
end;
procedure TVectorialFillInterface.SetIsTarget(AValue: boolean);
begin
if FIsTarget=AValue then Exit;
FIsTarget:=AValue;
UpdatePreview;
end;
procedure TVectorialFillInterface.ToolbarMouseEnter(Sender: TObject);
begin
If Assigned(FOnMouseEnter) then FOnMouseEnter(self);
end;
procedure TVectorialFillInterface.ToolbarMouseLeave(Sender: TObject);
begin
If Assigned(FOnMouseLeave) then FOnMouseLeave(self);
end;
procedure TVectorialFillInterface.AdjustToShapeClick(Sender: TObject);
begin
if Assigned(FOnAdjustToShape) then FOnAdjustToShape(self);
end;
procedure TVectorialFillInterface.ButtonFillGradClick(Sender: TObject);
begin
if Assigned(FGradTypeMenu) then
with FButtonFillGradient.ClientToScreen(Point(0,FButtonFillGradient.Height)) do
FGradTypeMenu.PopUp(X,Y);
FButtonFillGradient.Down := (FillType = vftGradient);
end;
procedure TVectorialFillInterface.ButtonFillTexClick(Sender: TObject);
begin
if FFillType = vftTexture then
begin
FButtonFillTexture.Down := true;
exit;
end;
if Assigned(FTexture) then FillType := vftTexture
else LoadTexture;
end;
procedure TVectorialFillInterface.ButtonGradInterpClick(Sender: TObject);
begin
if Assigned(FGradInterpMenu) then
with FButtonGradInterp.ClientToScreen(Point(0,FButtonGradInterp.Height)) do
FGradInterpMenu.PopUp(X,Y);
end;
procedure TVectorialFillInterface.ButtonGradRepetitionClick(Sender: TObject);
begin
if Assigned(FGradRepetitionMenu) then
with FButtonGradRepetition.ClientToScreen(Point(0,FButtonGradRepetition.Height)) do
FGradRepetitionMenu.PopUp(X,Y);
end;
procedure TVectorialFillInterface.ButtonLoadTextureClick(Sender: TObject);
begin
LoadTexture;
end;
procedure TVectorialFillInterface.ButtonSwapColorClick(Sender: TObject);
var
temp: TBGRAPixel;
begin
temp := GradStartColor;
FGradStartColor := GradEndColor;
FGradEndColor := temp;
UpdateGradientParams;
if FillType = vftGradient then Changed;
end;
procedure TVectorialFillInterface.ButtonTexRepeatClick(Sender: TObject);
begin
if Assigned(FTexRepetitionMenu) then
with FButtonTexRepeat.ClientToScreen(Point(0,FButtonTexRepeat.Height)) do
FTexRepetitionMenu.PopUp(X,Y);
end;
constructor TVectorialFillInterface.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Init(16,16);
end;
constructor TVectorialFillInterface.Create(AOwner: TComponent; AImageListWidth,
AImageListHeight: Integer);
begin
inherited Create(AOwner);
Init(AImageListWidth,AImageListHeight);
end;
destructor TVectorialFillInterface.Destroy;
begin
FTexture.FreeReference;
if Assigned(FContainer) then
begin
FContainer.RemoveControl(FToolbar);
FContainer := nil;
end;
FToolbar.Free;
inherited Destroy;
end;
function TVectorialFillInterface.GetTextureThumbnail(AWidth, AHeight: integer; ABackColor: TColor): TBitmap;
var
thumb: TBGRABitmap;
begin
if FTexture = nil then exit(nil);
thumb := GetBitmapThumbnail(FTexture, AWidth,AHeight,BGRAPixelTransparent,true);
try
result := thumb.MakeBitmapCopy(ABackColor);
finally
thumb.Free;
end;
end;
procedure TVectorialFillInterface.AssignFill(AFill: TVectorialFill);
begin
FillType := AFill.FillType;
case FillType of
vftTexture:
begin
Texture := AFill.Texture;
TextureOpacity:= AFill.TextureOpacity;
TextureRepetition:= AFill.TextureRepetition;
end;
vftSolid: SolidColor := AFill.SolidColor;
vftGradient:
begin
GradStartColor := AFill.Gradient.StartColor;
GradEndColor := AFill.Gradient.EndColor;
GradientType:= AFill.Gradient.GradientType;
GradRepetition:= AFill.Gradient.Repetition;
GradInterpolation := AFill.Gradient.ColorInterpolation;
end;
end;
end;
procedure TVectorialFillInterface.UpdateFillExceptGeometry(ATargetFill: TVectorialFill);
var
f: TVectorialFill;
begin
f := CreateShapeFill(nil);
if Assigned(ATargetFill) then
ATargetFill.AssignExceptGeometry(f);
f.Free;
end;
function TVectorialFillInterface.CreateShapeFill(AShape: TVectorShape): TVectorialFill;
var
grad: TBGRALayerGradientOriginal;
begin
if FillType = vftSolid then
exit(TVectorialFill.CreateAsSolid(SolidColor))
else if (FillType = vftTexture) and Assigned(Texture) then
result := TVectorialFill.CreateAsTexture(Texture, AffineMatrixIdentity,
TextureOpacity, TextureRepetition)
else if FillType = vftGradient then
begin
grad := TBGRALayerGradientOriginal.Create;
grad.StartColor := GradStartColor;
grad.EndColor := GradEndColor;
grad.GradientType:= GradientType;
grad.Repetition := GradRepetition;
grad.ColorInterpolation:= GradInterpolation;
result := TVectorialFill.CreateAsGradient(grad, true);
end
else exit(nil); //none
if Assigned(AShape) then
result.FitGeometry(AShape.SuggestGradientBox(AffineMatrixIdentity));
end;
procedure TVectorialFillInterface.UpdateShapeFill(AShape: TVectorShape;
ATarget: TLCFillTarget);
var
vectorFill: TVectorialFill;
curFill: TVectorialFill;
begin
case ATarget of
ftPen: curFill:= AShape.PenFill;
ftBack: curFill := AShape.BackFill;
ftOutline: curFill := AShape.OutlineFill;
else exit;
end;
if (FillType = vftTexture) and (TextureOpacity = 0) then
vectorFill := nil else
if (FillType = vftTexture) and (curFill.FillType = vftTexture) then
begin
vectorFill := TVectorialFill.CreateAsTexture(Texture, curFill.TextureMatrix,
TextureOpacity, TextureRepetition);
end
else if (FillType = vftGradient) and (curFill.FillType = vftGradient) then
begin
vectorFill := curFill.Duplicate;
vectorFill.Gradient.StartColor := GradStartColor;
vectorFill.Gradient.EndColor := GradEndColor;
vectorFill.Gradient.GradientType := GradientType;
vectorFill.Gradient.Repetition := GradRepetition;
vectorFill.Gradient.ColorInterpolation:= GradInterpolation;
end else
vectorFill := CreateShapeFill(AShape);
case ATarget of
ftPen: AShape.PenFill:= vectorFill;
ftBack: AShape.BackFill:= vectorFill;
ftOutline: AShape.OutlineFill:= vectorFill;
end;
vectorFill.Free;
end;
begin
{$i fillimages.lrs}
end.
./lazpaint-7.1.6/lazpaintcontrols/lazpaintcontrols.lpk 0000664 0001750 0001750 00000005613 13761713342 023440 0 ustar circular circular
./lazpaint-7.1.6/lazpaintcontrols/lcvectormultishape.pas 0000664 0001750 0001750 00000070327 13761713342 023750 0 ustar circular circular // SPDX-License-Identifier: GPL-3.0-only
unit LCVectorMultishape;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LCVectorRectShapes, LCVectorOriginal, BGRALayerOriginal,
BGRATransform, BGRABitmap, BGRABitmapTypes, BGRAPen, fgl, LCVectorialFill;
type
TShapeChangeHandlerMap = specialize TFPGMap;
TShapeDiffMap = specialize TFPGMap;
TIntegerList = specialize TFPGList;
{ TMultiSelectionShapesDiff }
TMultiSelectionShapesDiff = class(TCustomMultiSelectionDiff)
protected
FDiffs: TShapeDiffMap;
FSelectedIds: TIntegerList;
function GetShapeById(AContainer: TVectorShape; AId: integer): TVectorShape;
function GetShapeCount: integer; override;
function GetShapeId(AIndex: integer): integer; override;
public
constructor Create(AStartShape: TVectorShape); override;
procedure ComputeDiff(AEndShape: TVectorShape); override;
procedure Apply(AStartShape: TVectorShape); override;
procedure Unapply(AEndShape: TVectorShape); override;
function CanAppend(ADiff: TVectorShapeDiff): boolean; override;
procedure Append(ADiff: TVectorShapeDiff); override; //does not preserve ADiff
procedure AppendForShape(AShape: TVectorShape; var ADiff: TVectorShapeDiff); //does not preserve ADiff
function IsIdentity: boolean; override;
destructor Destroy; override;
property ShapeCount: integer read GetShapeCount;
property ShapeId[AIndex: integer]: integer read GetShapeId;
end;
{ TVectorMultiselection }
TVectorMultiselection = class(TCustomRectShape, IVectorMultishape)
protected
function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
function _AddRef: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
function _Release: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
protected
FShapes: TVectorShapes;
FOldChangeHandler: TShapeChangeHandlerMap;
FOnSelectionChange: TNotifyEvent;
FUpdatingFromShape, FInMultiTranformFill: Boolean;
function GetCornerPositition: single; override;
procedure RestoreChangeHandler(AShape: TVectorShape);
procedure AttachChangeHandler(AShape: TVectorShape);
procedure ContainedShape_Change(ASender: TObject; ABounds: TRectF; ADiff: TVectorShapeDiff);
procedure UpdateFromShapes;
procedure UpdateFrameFromShapes;
procedure FillChange({%H-}ASender: TObject; var ADiff: TCustomVectorialFillDiff); override;
procedure FillBeforeChange({%H-}ASender: TObject); override;
procedure SetPenStyle(AValue: TBGRAPenStyle); override;
procedure SetPenWidth(AValue: single); override;
procedure SetJoinStyle(AValue: TPenJoinStyle); override;
procedure SetOutlineWidth(AValue: single); override;
function GetIsFront: boolean; override;
function GetIsBack: boolean; override;
function GetPenVisible(AAssumePenFill: boolean = False): boolean; override;
function GetBackVisible: boolean; override;
function GetOutlineVisible: boolean; override;
procedure NotifySelectionChanged;
procedure InternalMoveToIndex(AFirst: integer);
public
constructor Create(AContainer: TVectorOriginal); override;
class function StorageClassName: RawByteString; override;
destructor Destroy; override;
procedure BeginUpdate(ADiffHandler: TVectorShapeDiffAny=nil); override;
procedure EndUpdate; override;
procedure BringToFront; override;
procedure SendToBack; override;
procedure MoveUp(APassNonIntersectingShapes: boolean); override;
procedure MoveDown(APassNonIntersectingShapes: boolean); override;
procedure ClearShapes;
procedure AddShape(AShape: TVectorShape);
procedure RemoveShape(AShape: TVectorShape);
function ContainsShape(AShape: TVectorShape): boolean;
function ShapeCount: integer;
function GetShape(AIndex: integer): TVectorShape;
function SetShapes(AShapes: TVectorShapes): boolean;
function FrontShape: TVectorShape;
function BackShape: TVectorShape;
function GetShapeById(AId: integer): TVectorShape;
function MultiFields: TVectorShapeFields; override;
procedure TransformFrame(const AMatrix: TAffineMatrix); override;
procedure TransformFill(const AMatrix: TAffineMatrix; ABackOnly: boolean); override;
function AllowShearTransform: boolean; override;
procedure LoadFromStorage(AStorage: TBGRACustomOriginalStorage); override;
procedure SaveToStorage(AStorage: TBGRACustomOriginalStorage); override;
procedure Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix; ADraft: boolean); overload; override;
procedure Render(ADest: TBGRABitmap; ARenderOffset: TPoint; AMatrix: TAffineMatrix; ADraft: boolean); overload; override;
function GetRenderBounds({%H-}ADestRect: TRect; AMatrix: TAffineMatrix; {%H-}AOptions: TRenderBoundsOptions = []): TRectF; override;
function GetAlignBounds(const ALayoutRect: TRect; const AMatrix: TAffineMatrix): TRectF; override;
function SuggestGradientBox(AMatrix: TAffineMatrix): TAffineBox; override;
procedure ConfigureCustomEditor(AEditor: TBGRAOriginalEditor); override;
function PointInShape(APoint: TPointF): boolean; overload; override;
function PointInShape(APoint: TPointF; ARadius: single): boolean; overload; override;
function PointInBack(APoint: TPointF): boolean; overload; override;
function PointInPen(APoint: TPointF): boolean; overload; override;
function GetIsSlow(const AMatrix: TAffineMatrix): boolean; override;
function GetAsMultishape: IVectorMultishape; override;
procedure SetOnSelectionChange(AHandler: TNotifyEvent);
function GetOnSelectionChange: TNotifyEvent;
property OnSelectionChange: TNotifyEvent read GetOnSelectionChange write SetOnSelectionChange;
end;
implementation
function Shapes_CompareDepth(const Item1, Item2: TVectorShape): Integer;
var
idx1, idx2: Integer;
begin
if Assigned(Item1.Container) and Assigned(Item2.Container) then
begin
idx1 := Item1.Container.IndexOfShape(Item1);
idx2 := Item2.Container.IndexOfShape(Item2);
result := idx1 - idx2;
end;
end;
{ TMultiSelectionShapesDiff }
function TMultiSelectionShapesDiff.GetShapeCount: integer;
begin
result := FSelectedIds.Count;
end;
function TMultiSelectionShapesDiff.GetShapeId(AIndex: integer): integer;
begin
result := FSelectedIds.Items[AIndex];
end;
function TMultiSelectionShapesDiff.GetShapeById(AContainer: TVectorShape; AId: integer): TVectorShape;
begin
result := AContainer.Container.FindShapeById(AId);
end;
constructor TMultiSelectionShapesDiff.Create(AStartShape: TVectorShape);
var
i: Integer;
begin
if not (AStartShape is TVectorMultiselection) then
raise exception.Create('Expecting TVectorMultishape');
FDiffs := TShapeDiffMap.Create;
FSelectedIds := TIntegerList.Create;
with AStartShape.GetAsMultishape do
begin
for i := 0 to ShapeCount-1 do
FSelectedIds.Add(GetShape(i).Id);
end;
end;
procedure TMultiSelectionShapesDiff.ComputeDiff(AEndShape: TVectorShape);
begin
//nothing
end;
procedure TMultiSelectionShapesDiff.Apply(AStartShape: TVectorShape);
var
s: TVectorShape;
i: Integer;
begin
for i := 0 to FDiffs.Count-1 do
begin
s := GetShapeById(AStartShape, FDiffs.Keys[i]);
if Assigned(s) then
FDiffs.Data[i].Apply(s);
end;
end;
procedure TMultiSelectionShapesDiff.Unapply(AEndShape: TVectorShape);
var
s: TVectorShape;
i: Integer;
begin
for i := FDiffs.Count-1 downto 0 do
begin
s := GetShapeById(AEndShape, FDiffs.Keys[i]);
if Assigned(s) then
FDiffs.Data[i].Unapply(s);
end;
end;
function TMultiSelectionShapesDiff.CanAppend(ADiff: TVectorShapeDiff): boolean;
var
other: TMultiSelectionShapesDiff;
i, j: Integer;
begin
if not (ADiff is TMultiSelectionShapesDiff) then exit(false);
other := TMultiSelectionShapesDiff(ADiff);
for i := 0 to other.FDiffs.Count-1 do
for j := 0 to FDiffs.Count-1 do
if FDiffs.Keys[j] = other.FDiffs.Keys[i] then
begin
if not FDiffs.Data[j].CanAppend(other.FDiffs.Data[i]) then
exit(false);
end;
result := true;
end;
procedure TMultiSelectionShapesDiff.Append(ADiff: TVectorShapeDiff);
var found: boolean;
other: TMultiSelectionShapesDiff;
otherKey, i, j: integer;
otherData: TVectorShapeDiff;
toCopy: TShapeDiffMap;
begin
if not (ADiff is TMultiSelectionShapesDiff) then raise exception.Create('Unexpected diff type');
other := TMultiSelectionShapesDiff(ADiff);
toCopy := TShapeDiffMap.Create;
for i := 0 to other.FDiffs.Count-1 do
begin
found := false;
otherKey := other.FDiffs.Keys[i];
otherData := other.FDiffs.Data[i];
for j := 0 to FDiffs.Count-1 do
if FDiffs.Keys[j] = otherKey then
begin
FDiffs.Data[j].Append(otherData);
found := true;
break;
end;
if not found then toCopy.Add(otherKey, otherData);
end;
for i := 0 to toCopy.Count-1 do
begin
FDiffs.Add(toCopy.Keys[i], toCopy.Data[i]);
other.FDiffs.Remove(toCopy.Keys[i]);
end;
toCopy.Free;
end;
procedure TMultiSelectionShapesDiff.AppendForShape(AShape: TVectorShape;
var ADiff: TVectorShapeDiff);
var
idx: Integer;
begin
idx := FDiffs.IndexOf(AShape.Id);
if idx <> -1 then
FDiffs.Data[idx].Append(ADiff)
else
begin
FDiffs.Add(AShape.Id, ADiff);
ADiff := nil;
end;
end;
function TMultiSelectionShapesDiff.IsIdentity: boolean;
var
i: Integer;
begin
for i := 0 to FDiffs.Count-1 do
if not FDiffs.Data[i].IsIdentity then exit(false);
result := true;
end;
destructor TMultiSelectionShapesDiff.Destroy;
var
i: Integer;
begin
for i := 0 to FDiffs.Count-1 do
FDiffs.Data[i].Free;
FDiffs.Free;
FSelectedIds.Free;
inherited Destroy;
end;
{ TVectorMultiselection }
function TVectorMultiselection.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
begin
if GetInterface(iid, obj) then
Result := S_OK
else
Result := longint(E_NOINTERFACE);
end;
function TVectorMultiselection._AddRef: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
begin
result := 0;
end;
function TVectorMultiselection._Release: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND};
begin
result := 0;
end;
procedure TVectorMultiselection.TransformFill(const AMatrix: TAffineMatrix;
ABackOnly: boolean);
var
i: Integer;
begin
FInMultiTranformFill := true;
BeginUpdate(TMultiSelectionShapesDiff);
for i := 0 to FShapes.Count-1 do
begin
FShapes[i].BeginUpdate;
FShapes[i].TransformFrame(AMatrix);
FShapes[i].TransformFill(AMatrix, ABackOnly);
FShapes[i].EndUpdate;
end;
inherited TransformFill(AMatrix, ABackOnly);
EndUpdate;
FInMultiTranformFill := false;
end;
procedure TVectorMultiselection.ContainedShape_Change(ASender: TObject;
ABounds: TRectF; ADiff: TVectorShapeDiff);
var
contained: TMultiSelectionShapesDiff;
begin
if Assigned(ADiff) then
begin
contained := TMultiSelectionShapesDiff(AddDiffHandler(TMultiSelectionShapesDiff));
contained.AppendForShape(ASender as TVectorShape, ADiff);
ADiff.Free;
end else
begin
if not IsUpdating and Assigned(OnChange) then
OnChange(self, ABounds, nil);
end;
end;
procedure TVectorMultiselection.UpdateFromShapes;
var
i: Integer;
found: boolean;
begin
if FShapes.Count > 0 then
begin
FUpdatingFromShape := true;
BeginEditingUpdate;
UpdateFrameFromShapes;
found := false;
for i := 0 to FShapes.Count-1 do
if (vsfPenFill in FShapes[i].Fields) and
FShapes[i].PenVisible then
begin
PenFill.Assign(FShapes[i].PenFill);
found := true;
break;
end;
if not found then PenFill.Clear;
found := false;
for i := 0 to FShapes.Count-1 do
if (vsfPenStyle in FShapes[i].Fields) and
FShapes[i].PenVisible then
begin
Stroker.CustomPenStyle := FShapes[i].PenStyle;
found := true;
break;
end;
if not found then Stroker.CustomPenStyle := ClearPenStyle;
for i := 0 to FShapes.Count-1 do
if (vsfPenWidth in FShapes[i].Fields) and
FShapes[i].PenVisible then
begin
FPenWidth := FShapes[i].PenWidth;
break;
end;
for i := 0 to FShapes.Count-1 do
if vsfJoinStyle in FShapes[i].Fields then
begin
Stroker.JoinStyle := FShapes[i].JoinStyle;
break;
end;
found := false;
for i := 0 to FShapes.Count-1 do
if (vsfBackFill in FShapes[i].Fields) and
FShapes[i].BackVisible then
begin
BackFill.Assign(FShapes[i].BackFill);
found := true;
break;
end;
if not found then BackFill.Clear;
found := false;
for i := 0 to FShapes.Count-1 do
if (vsfOutlineFill in FShapes[i].Fields) and
FShapes[i].OutlineVisible then
begin
OutlineFill.Assign(FShapes[i].OutlineFill);
found := true;
break;
end;
if not found then OutlineFill.Clear;
for i := 0 to FShapes.Count-1 do
if (vsfOutlineWidth in FShapes[i].Fields) and
FShapes[i].OutlineVisible then
begin
FOutlineWidth:= FShapes[i].OutlineWidth;
break;
end;
EndEditingUpdate;
FUpdatingFromShape := false;
end;
end;
procedure TVectorMultiselection.UpdateFrameFromShapes;
var
rF: TRectF;
i: Integer;
begin
BeginEditingUpdate;
rF := EmptyRectF;
for i := 0 to FShapes.Count-1 do
rF := rF.Union(FShapes[i].GetAlignBounds(InfiniteRect, AffineMatrixIdentity), true);
FOrigin := (rF.TopLeft + rf.BottomRight)*0.5;
FXAxis := FOrigin + PointF(rF.Width/2, 0);
FYAxis := FOrigin + PointF(0, rF.Height/2);
EndEditingUpdate;
end;
procedure TVectorMultiselection.FillChange(ASender: TObject;
var ADiff: TCustomVectorialFillDiff);
var
i: Integer;
begin
if FUpdatingFromShape or FInMultiTranformFill then exit;
if FFillChangeWithoutUpdate then exit;
BeginUpdate;
AddFillDiffHandler(ASender as TVectorialFill, ADiff);
if ASender = PenFill then
begin
for i := 0 to FShapes.Count-1 do
if vsfPenFill in FShapes[i].Fields then
begin
if not PenFill.IsFullyTransparent or FShapes[i].BackVisible or FShapes[i].OutlineVisible then
FShapes[i].PenFill.Assign(PenFill);
end;
end else
if ASender = BackFill then
begin
for i := 0 to FShapes.Count-1 do
if vsfBackFill in FShapes[i].Fields then
begin
if not BackFill.IsFullyTransparent or FShapes[i].PenVisible or FShapes[i].OutlineVisible then
FShapes[i].BackFill.Assign(BackFill);
end;
end else
if ASender = OutlineFill then
begin
for i := 0 to FShapes.Count-1 do
if vsfOutlineFill in FShapes[i].Fields then
begin
if not OutlineFill.IsFullyTransparent or FShapes[i].PenVisible or FShapes[i].BackVisible then
FShapes[i].OutlineFill.Assign(OutlineFill);
end;
end;
EndUpdate;
end;
procedure TVectorMultiselection.FillBeforeChange(ASender: TObject);
begin
//nothing
end;
procedure TVectorMultiselection.SetPenStyle(AValue: TBGRAPenStyle);
var
i: Integer;
begin
if PenStyleEqual(AValue, PenStyle) then exit;
BeginUpdate;
inherited SetPenStyle(AValue);
for i := 0 to FShapes.Count-1 do
if vsfPenStyle in FShapes[i].Fields then
begin
if not IsClearPenStyle(AValue) or FShapes[i].BackVisible then
FShapes[i].PenStyle := AValue;
end;
EndUpdate;
end;
procedure TVectorMultiselection.SetPenWidth(AValue: single);
var
i: Integer;
begin
if AValue < 0 then AValue := 0;
if AValue = PenWidth then exit;
BeginUpdate;
inherited SetPenWidth(AValue);
for i := 0 to FShapes.Count-1 do
if vsfPenWidth in FShapes[i].Fields then
begin
if (AValue > 0) or FShapes[i].BackVisible then
FShapes[i].PenWidth := AValue;
end;
EndUpdate;
end;
procedure TVectorMultiselection.SetJoinStyle(AValue: TPenJoinStyle);
var
i: Integer;
begin
if AValue = JoinStyle then exit;
BeginUpdate;
inherited SetJoinStyle(AValue);
for i := 0 to FShapes.Count-1 do
if vsfJoinStyle in FShapes[i].Fields then
FShapes[i].JoinStyle := AValue;
EndUpdate;
end;
procedure TVectorMultiselection.SetOutlineWidth(AValue: single);
var
i: Integer;
begin
if AValue < 0 then AValue := 0;
if AValue = OutlineWidth then exit;
BeginUpdate;
inherited SetOutlineWidth(AValue);
for i := 0 to FShapes.Count-1 do
if vsfOutlineWidth in FShapes[i].Fields then
FShapes[i].OutlineWidth := AValue;
EndUpdate;
end;
function TVectorMultiselection.GetIsFront: boolean;
var
i, containerIdx: Integer;
s: TVectorShape;
begin
s := FrontShape;
if not Assigned(s) or not s.IsFront then exit(false);
containerIdx := Container.IndexOfShape(s);
for i := FShapes.Count-2 downto 0 do
begin
dec(containerIdx);
if Container.IndexOfShape(FShapes[i]) <> containerIdx then
exit(false);
end;
result := true;
end;
function TVectorMultiselection.GetIsBack: boolean;
var
i, containerIdx: Integer;
s: TVectorShape;
begin
s := BackShape;
if not Assigned(s) or not s.IsBack then exit(false);
containerIdx := Container.IndexOfShape(s);
for i := 1 to FShapes.Count-1 do
begin
inc(containerIdx);
if Container.IndexOfShape(FShapes[i]) <> containerIdx then
exit(false);
end;
result := true;
end;
function TVectorMultiselection.GetPenVisible(AAssumePenFill: boolean): boolean;
var
i: Integer;
begin
for i := 0 to ShapeCount-1 do
if FShapes[i].PenVisible then exit(true);
result := false;
end;
function TVectorMultiselection.GetBackVisible: boolean;
var
i: Integer;
begin
for i := 0 to ShapeCount-1 do
if FShapes[i].BackVisible then exit(true);
result := false;
end;
function TVectorMultiselection.GetOutlineVisible: boolean;
var
i: Integer;
begin
for i := 0 to ShapeCount-1 do
if FShapes[i].OutlineVisible then exit(true);
Result:= false;
end;
procedure TVectorMultiselection.NotifySelectionChanged;
begin
if OnSelectionChange <> nil then
OnSelectionChange(self);
end;
procedure TVectorMultiselection.InternalMoveToIndex(AFirst: integer);
var fromIndex, toIndex: array of integer;
i: Integer;
begin
if Container = nil then exit;
setlength(fromIndex, ShapeCount);
setlength(toIndex, ShapeCount);
for i := 0 to ShapeCount-1 do
begin
fromIndex[i] := Container.IndexOfShape(FShapes[i]);
toIndex[i] := AFirst + i;
end;
Container.MoveShapeToIndex(fromIndex, toIndex);
end;
function TVectorMultiselection.GetCornerPositition: single;
begin
result := 1;
end;
procedure TVectorMultiselection.RestoreChangeHandler(AShape: TVectorShape);
var
handlerIndex: Integer;
begin
if AShape.OnChange <> @ContainedShape_Change then exit;
handlerIndex := FOldChangeHandler.IndexOf(AShape);
if handlerIndex <> -1 then
begin
AShape.OnChange:= FOldChangeHandler.Data[handlerIndex];
FOldChangeHandler.Delete(handlerIndex);
end
else
AShape.OnChange:= nil;
end;
procedure TVectorMultiselection.AttachChangeHandler(AShape: TVectorShape);
begin
if AShape.OnChange <> @ContainedShape_Change then
begin
FOldChangeHandler.Add(AShape, AShape.OnChange);
AShape.OnChange:= @ContainedShape_Change;
end;
end;
function TVectorMultiselection.AllowShearTransform: boolean;
var
i: Integer;
begin
for i := 0 to FShapes.Count-1 do
if not FShapes[i].AllowShearTransform then exit(false);
result := true;
end;
procedure TVectorMultiselection.LoadFromStorage(AStorage: TBGRACustomOriginalStorage);
begin
raise exception.Create('Cannot be deserialized');
end;
procedure TVectorMultiselection.SaveToStorage(AStorage: TBGRACustomOriginalStorage);
begin
raise exception.Create('Cannot be serialized');
end;
procedure TVectorMultiselection.Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix;
ADraft: boolean);
var
i: Integer;
begin
for i := 0 to FShapes.Count-1 do
FShapes[i].Render(ADest, AMatrix, ADraft);
end;
procedure TVectorMultiselection.Render(ADest: TBGRABitmap; ARenderOffset: TPoint;
AMatrix: TAffineMatrix; ADraft: boolean);
var
i: Integer;
begin
for i := 0 to FShapes.Count-1 do
FShapes[i].Render(ADest, ARenderOffset, AMatrix, ADraft);
end;
function TVectorMultiselection.GetRenderBounds(ADestRect: TRect;
AMatrix: TAffineMatrix; AOptions: TRenderBoundsOptions): TRectF;
var
i: Integer;
begin
result := EmptyRectF;
for i := 0 to FShapes.Count-1 do
result := result.Union(FShapes[i].GetRenderBounds(ADestRect, AMatrix, AOptions), true);
end;
function TVectorMultiselection.GetAlignBounds(const ALayoutRect: TRect;
const AMatrix: TAffineMatrix): TRectF;
var
i: Integer;
begin
result := EmptyRectF;
for i := 0 to FShapes.Count-1 do
result := result.Union(FShapes[i].GetAlignBounds(ALayoutRect, AMatrix), true);
end;
function TVectorMultiselection.SuggestGradientBox(AMatrix: TAffineMatrix): TAffineBox;
var
i: Integer;
r: TRectF;
begin
if FShapes.Count = 1 then
result := FShapes[0].SuggestGradientBox(AMatrix)
else
begin
r := EmptyRectF;
for i := 0 to FShapes.Count-1 do
r := r.Union(FShapes[i].SuggestGradientBox(AMatrix).RectBoundsF, true);
result := TAffineBox.AffineBox(r);
end;
end;
procedure TVectorMultiselection.ConfigureCustomEditor(AEditor: TBGRAOriginalEditor);
var
i: Integer;
ab: TAffineBox;
begin
for i := 0 to FShapes.Count-1 do
begin
ab := FShapes[i].SuggestGradientBox(AffineMatrixIdentity);
AEditor.AddPolyline(ab.AsPolygon, true, opsDash);
end;
inherited ConfigureCustomEditor(AEditor);
end;
function TVectorMultiselection.PointInShape(APoint: TPointF): boolean;
var
i: LongInt;
begin
for i := FShapes.Count-1 downto 0 do
if FShapes[i].PointInShape(APoint) then exit(true);
result := false;
end;
function TVectorMultiselection.PointInShape(APoint: TPointF; ARadius: single): boolean;
var
i: LongInt;
begin
for i := FShapes.Count-1 downto 0 do
if FShapes[i].PointInShape(APoint, ARadius) then exit(true);
result := false;
end;
function TVectorMultiselection.PointInBack(APoint: TPointF): boolean;
var
i: LongInt;
begin
for i := FShapes.Count-1 downto 0 do
if FShapes[i].PointInBack(APoint) then exit(true);
result := false;
end;
function TVectorMultiselection.PointInPen(APoint: TPointF): boolean;
var
i: LongInt;
begin
for i := FShapes.Count-1 downto 0 do
if FShapes[i].PointInPen(APoint) then exit(true);
result := false;
end;
function TVectorMultiselection.GetIsSlow(const AMatrix: TAffineMatrix): boolean;
var
i: LongInt;
begin
if FShapes.Count >= 5 then exit(true);
for i := 0 to FShapes.Count-1 do
if FShapes[i].GetIsSlow(AMatrix) then exit(true);
result := false;
end;
function TVectorMultiselection.GetAsMultishape: IVectorMultishape;
begin
Result:= self;
end;
procedure TVectorMultiselection.SetOnSelectionChange(AHandler: TNotifyEvent);
begin
FOnSelectionChange := AHandler;
end;
function TVectorMultiselection.GetOnSelectionChange: TNotifyEvent;
begin
result := FOnSelectionChange;
end;
class function TVectorMultiselection.StorageClassName: RawByteString;
begin
result := 'multishape';
end;
procedure TVectorMultiselection.ClearShapes;
var
i: Integer;
begin
if FShapes.Count = 0 then exit;
for i := 0 to FShapes.Count-1 do
RestoreChangeHandler(FShapes[i]);
FShapes.Clear;
UpdateFromShapes;
NotifySelectionChanged;
end;
procedure TVectorMultiselection.AddShape(AShape: TVectorShape);
begin
if ContainsShape(AShape) then exit;
FShapes.Add(AShape);
FShapes.Sort(@Shapes_CompareDepth);
AttachChangeHandler(AShape);
UpdateFromShapes;
NotifySelectionChanged;
end;
procedure TVectorMultiselection.RemoveShape(AShape: TVectorShape);
begin
RestoreChangeHandler(AShape);
FShapes.Remove(AShape);
UpdateFromShapes;
NotifySelectionChanged;
end;
function TVectorMultiselection.ContainsShape(AShape: TVectorShape): boolean;
begin
result := FShapes.IndexOf(AShape) <> -1;
end;
function TVectorMultiselection.ShapeCount: integer;
begin
result := FShapes.Count;
end;
function TVectorMultiselection.GetShape(AIndex: integer): TVectorShape;
begin
if (AIndex < 0) or (AIndex >= FShapes.Count) then
raise exception.Create('Index out of bounds');
result := FShapes[AIndex];
end;
function TVectorMultiselection.SetShapes(AShapes: TVectorShapes): boolean;
var
i: Integer;
different: Boolean;
begin
different := false;
for i := 0 to FShapes.Count-1 do
if AShapes.IndexOf(FShapes[i]) = -1 then
begin
different := true;
break;
end;
for i := 0 to AShapes.Count-1 do
if FShapes.IndexOf(AShapes[i]) = -1 then
begin
different := true;
break;
end;
if not different then exit(false);
for i := 0 to FShapes.Count-1 do
RestoreChangeHandler(FShapes[i]);
FShapes.Clear;
for i := 0 to AShapes.Count-1 do
begin
FShapes.Add(AShapes[i]);
AttachChangeHandler(AShapes[i]);
end;
FShapes.Sort(@Shapes_CompareDepth);
UpdateFromShapes;
NotifySelectionChanged;
exit(true);
end;
function TVectorMultiselection.FrontShape: TVectorShape;
begin
if FShapes.Count > 0 then
result := FShapes[FShapes.Count-1]
else result := nil;
end;
function TVectorMultiselection.BackShape: TVectorShape;
begin
if FShapes.Count > 0 then
result := FShapes[0]
else result := nil;
end;
function TVectorMultiselection.GetShapeById(AId: integer): TVectorShape;
var
i: Integer;
begin
for i := 0 to FShapes.Count-1 do
if FShapes[i].Id = AId then exit(FShapes[i]);
result := nil;
end;
function TVectorMultiselection.MultiFields: TVectorShapeFields;
var
i: Integer;
begin
result := [];
for i := 0 to FShapes.Count-1 do
result += FShapes[i].Fields;
end;
constructor TVectorMultiselection.Create(AContainer: TVectorOriginal);
begin
inherited Create(AContainer);
FShapes := TVectorShapes.Create;
FOldChangeHandler := TShapeChangeHandlerMap.Create;
FDisableHitBox:= true;
end;
procedure TVectorMultiselection.TransformFrame(const AMatrix: TAffineMatrix);
var
i: Integer;
begin
BeginUpdate(TMultiSelectionShapesDiff);
for i := 0 to FShapes.Count-1 do
FShapes[i].TransformFrame(AMatrix);
inherited TransformFrame(AMatrix);
EndUpdate;
end;
destructor TVectorMultiselection.Destroy;
begin
ClearShapes;
FShapes.Free;
FOldChangeHandler.Free;
inherited Destroy;
end;
procedure TVectorMultiselection.BeginUpdate(ADiffHandler: TVectorShapeDiffAny);
var
i: Integer;
begin
inherited BeginUpdate(ADiffHandler);
for i := 0 to FShapes.Count-1 do
FShapes[i].BeginUpdate;
end;
procedure TVectorMultiselection.EndUpdate;
var
i: Integer;
begin
for i := 0 to FShapes.Count-1 do
FShapes[i].EndUpdate;
inherited EndUpdate;
end;
procedure TVectorMultiselection.BringToFront;
begin
if Assigned(Container) then
InternalMoveToIndex(Container.ShapeCount - ShapeCount);
end;
procedure TVectorMultiselection.SendToBack;
begin
InternalMoveToIndex(0);
end;
procedure TVectorMultiselection.MoveUp(APassNonIntersectingShapes: boolean);
var
topIndex, i: Integer;
curBounds: TRectF;
touch: Boolean;
begin
if Container = nil then exit;
topIndex := Container.IndexOfShape(FrontShape);
while topIndex < Container.ShapeCount-1 do
begin
inc(topIndex);
curBounds := Container.Shape[topIndex].GetAlignBounds(InfiniteRect, AffineMatrixIdentity);
if not APassNonIntersectingShapes then break;
touch := false;
for i := 0 to ShapeCount-1 do
if FShapes[i].GetAlignBounds(InfiniteRect, AffineMatrixIdentity).IntersectsWith(curBounds) then
begin
touch := true;
break;
end;
if touch then break;
end;
InternalMoveToIndex(topIndex + 1 - ShapeCount);
end;
procedure TVectorMultiselection.MoveDown(APassNonIntersectingShapes: boolean);
var
bottomIndex, i: Integer;
curBounds: TRectF;
touch: Boolean;
begin
if Container = nil then exit;
bottomIndex := Container.IndexOfShape(FrontShape);
while bottomIndex > 0 do
begin
dec(bottomIndex);
curBounds := Container.Shape[bottomIndex].GetAlignBounds(InfiniteRect, AffineMatrixIdentity);
if not APassNonIntersectingShapes then break;
touch := false;
for i := 0 to ShapeCount-1 do
if FShapes[i].GetAlignBounds(InfiniteRect, AffineMatrixIdentity).IntersectsWith(curBounds) then
begin
touch := true;
break;
end;
if touch then break;
end;
InternalMoveToIndex(bottomIndex);
end;
initialization
VectorMultiselectionFactory := TVectorMultiselection;
end.
./lazpaint-7.1.6/lazpaintcontrols/lazpaintcontrols.pas 0000664 0001750 0001750 00000001257 13761713342 023435 0 ustar circular circular { This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit lazpaintcontrols;
{$warn 5023 off : no warning about unused units}
interface
uses
LCToolbars, LCVectorialFill, LCVectorialFillInterface, LCVectorOriginal,
LCVectorPolyShapes, LCVectorRectShapes, LCVectorialFillControl,
LCVectorShapes, LCVectorTextShapes, LCScaleDPI, LCVectorClipboard,
LCResourceString, LCVectorMultishape, LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('LCVectorialFillControl', @LCVectorialFillControl.Register);
end;
initialization
RegisterPackage('lazpaintcontrols', @Register);
end.
./lazpaint-7.1.6/lazpaintcontrols/lcvectortextshapes.pas 0000664 0001750 0001750 00000230342 13762265102 023755 0 ustar circular circular // SPDX-License-Identifier: GPL-3.0-only
unit LCVectorTextShapes;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LCVectorRectShapes, BGRATextBidi, BGRABitmapTypes, LCVectorOriginal,
BGRAGraphics, BGRABitmap, BGRALayerOriginal, BGRACanvas2D, LCVectorialFill,
BGRASVGShapes, BGRASVGType, BGRAUnits;
type
TTextShape = class;
{ TTextShapeFontDiff }
TTextShapeFontDiff = class(TVectorShapeDiff)
protected
FFontBidiModeBefore: TFontBidiMode;
FFontEmHeightBefore: single;
FFontNameBefore: string;
FFontStyleBefore: TFontStyles;
FAliasedBefore: boolean;
FFontBidiModeAfter: TFontBidiMode;
FFontEmHeightAfter: single;
FFontNameAfter: string;
FFontStyleAfter: TFontStyles;
FAliasedAfter: boolean;
public
constructor Create(AStartShape: TVectorShape); override;
procedure ComputeDiff(AEndShape: TVectorShape); override;
procedure Apply(AStartShape: TVectorShape); override;
procedure Unapply(AEndShape: TVectorShape); override;
procedure Append(ADiff: TVectorShapeDiff); override;
function IsIdentity: boolean; override;
end;
{ TTextShapePhongDiff }
TTextShapePhongDiff = class(TVectorShapeDiff)
protected
FAltitudePercentBefore: single;
FPenPhongBefore: boolean;
FLightPositionBefore: TPointF;
FAltitudePercentAfter: single;
FPenPhongAfter: boolean;
FLightPositionAfter: TPointF;
public
constructor Create(AStartShape: TVectorShape); override;
procedure ComputeDiff(AEndShape: TVectorShape); override;
procedure Apply(AStartShape: TVectorShape); override;
procedure Unapply(AEndShape: TVectorShape); override;
procedure Append(ADiff: TVectorShapeDiff); override;
function IsIdentity: boolean; override;
end;
{ TTextShapeTextDiff }
TTextShapeTextDiff = class(TVectorShapeDiff)
protected
FTextBefore: string;
FSelStartBefore,FSelEndBefore: integer;
FVertAlignBefore: TTextLayout;
FParaAlignBefore: array of TBidiTextAlignment;
FTextAfter: string;
FSelStartAfter,FSelEndAfter: integer;
FVertAlignAfter: TTextLayout;
FParaAlignAfter: array of TBidiTextAlignment;
public
constructor Create(AStartShape: TVectorShape); override;
procedure ComputeDiff(AEndShape: TVectorShape); override;
procedure Apply(AStartShape: TVectorShape); override;
procedure Unapply(AEndShape: TVectorShape); override;
procedure Append(ADiff: TVectorShapeDiff); override;
function IsIdentity: boolean; override;
end;
{ TTextShape }
TTextShape = class(TCustomRectShape)
private
FAliased: boolean;
FAltitudePercent: single;
FPenPhong: boolean;
FPenFillIteration: integer;
FLightPosition: TPointF;
FFontBidiMode: TFontBidiMode;
FFontEmHeight: single;
FFontName: string;
FFontStyle: TFontStyles;
FText: string;
FSelStart,FSelEnd: integer;
FVertAlign: TTextLayout;
FEnteringUnicode: boolean;
FUnicodeValue: cardinal;
FUnicodeDigitCount: integer;
FMouseSelecting: boolean;
function GetBidiParagraphAlignment: TBidiTextAlignment;
function GetCanPasteSelection: boolean;
function GetHasSelection: boolean;
function GetParagraphAlignment: TAlignment;
procedure InvalidateParagraphLayout(AFrom, ATo: integer);
procedure LayoutBrokenLinesChanged(ASender: TObject;
AParagraphIndex: integer; ASubBrokenStart, ASubBrokenChangedCountBefore,
ASubBrokenChangedCountAfter: integer; ASubBrokenTotalCountBefore,
ASubBrokenTotalCountAfter: integer);
procedure LayoutParagraphDeleted(ASender: TObject; AParagraphIndex: integer);
procedure LayoutParagraphMergedWithNext(ASender: TObject;
AParagraphIndex: integer);
procedure LayoutParagraphSplit(ASender: TObject; AParagraphIndex: integer;
ASubBrokenIndex, ACharIndex: integer);
procedure OnMoveLightPos({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF;
{%H-}AShift: TShiftState);
procedure SetAliased(AValue: boolean);
procedure SetAltitudePercent(AValue: single);
procedure SetPenPhong(AValue: boolean);
procedure SetFontBidiMode(AValue: TFontBidiMode);
procedure SetFontEmHeight(AValue: single);
procedure SetFontName(AValue: string);
procedure SetFontStyle(AValue: TFontStyles);
procedure SetBidiParagraphAlignment(AValue: TBidiTextAlignment);
procedure SetLightPosition(AValue: TPointF);
procedure SetParagraphAlignment(AValue: TAlignment);
procedure SetText(AValue: string);
procedure SetVertAlign(AValue: TTextLayout);
protected
FTextLayout: TBidiTextLayout;
FFontRenderer: TBGRACustomFontRenderer;
FGlobalMatrix: TAffineMatrix;
FCurBrokenLineImageId: int64;
FParagraphLayout: array of record
brokenLines: array of record
penImageId, penMaskId,
outlineMaskId: int64;
end;
end;
procedure SetGlobalMatrix(AMatrix: TAffineMatrix);
function ShowArrows: boolean; override;
function GetTextLayout: TBidiTextLayout;
function GetFontRenderer: TBGRACustomFontRenderer;
function UpdateFontRenderer: boolean;
function GetTextRenderZoom: single;
function GetUntransformedMatrix: TAffineMatrix; //matrix before render transform
function IsTextMirrored(ABox: TAffineBox): boolean;
procedure SetDefaultFont;
function GetCornerPositition: single; override;
procedure DeleteTextBefore(ACount: integer);
procedure DeleteTextAfter(ACount: integer);
procedure InsertText(ATextUTF8: string);
procedure SelectWithMouse(X,Y: single; AExtend: boolean);
function HasOutline: boolean;
procedure InsertUnicodeValue;
procedure FillChange(ASender: TObject; var ADiff: TCustomVectorialFillDiff); override;
procedure InvalidateAll;
public
constructor Create(AContainer: TVectorOriginal); override;
procedure QuickDefine(constref APoint1,APoint2: TPointF); override;
procedure LoadFromStorage(AStorage: TBGRACustomOriginalStorage); override;
procedure SaveToStorage(AStorage: TBGRACustomOriginalStorage); override;
destructor Destroy; override;
class function Fields: TVectorShapeFields; override;
class function PreferPixelCentered: boolean; override;
class function DefaultFontName: string;
class function DefaultFontEmHeight: single;
class function DefaultAltitudePercent: single;
class function CreateEmpty: boolean; override;
class function StorageClassName: RawByteString; override;
class function Usermodes: TVectorShapeUsermodes; override;
function AppendToSVG(AContent: TSVGContent; ADefs: TSVGDefine): TSVGElement; override;
procedure ConfigureCustomEditor(AEditor: TBGRAOriginalEditor); override;
procedure Render(ADest: TBGRABitmap; ARenderOffset: TPoint; AMatrix: TAffineMatrix; ADraft: boolean); overload; override;
function GetRenderBounds({%H-}ADestRect: TRect; AMatrix: TAffineMatrix; AOptions: TRenderBoundsOptions = []): TRectF; override;
function PointInShape(APoint: TPointF): boolean; overload; override;
function PointInShape({%H-}APoint: TPointF; {%H-}ARadius: single): boolean; overload; override;
function PointInPen(APoint: TPointF): boolean; overload; override;
function GetIsSlow(const {%H-}AMatrix: TAffineMatrix): boolean; override;
function GetGenericCost: integer; override;
procedure MouseMove({%H-}Shift: TShiftState; {%H-}X, {%H-}Y: single; var {%H-}ACursor: TOriginalEditorCursor; var {%H-}AHandled: boolean); override;
procedure MouseDown({%H-}RightButton: boolean; {%H-}Shift: TShiftState; {%H-}X, {%H-}Y: single; var {%H-}ACursor: TOriginalEditorCursor; var {%H-}AHandled: boolean); override;
procedure MouseUp({%H-}RightButton: boolean; {%H-}Shift: TShiftState; {%H-}X, {%H-}Y: single; var {%H-}ACursor: TOriginalEditorCursor; var {%H-}AHandled: boolean); override;
procedure KeyDown({%H-}Shift: TShiftState; {%H-}Key: TSpecialKey; var {%H-}AHandled: boolean); override;
procedure KeyPress({%H-}UTF8Key: string; var {%H-}AHandled: boolean); override;
procedure KeyUp({%H-}Shift: TShiftState; {%H-}Key: TSpecialKey; var {%H-}AHandled: boolean); override;
procedure SetFontNameAndStyle(AFontName: string; AFontStyle: TFontStyles);
function CopySelection: boolean;
function CutSelection: boolean;
function PasteSelection: boolean;
function DeleteSelection: boolean;
function GetAlignBounds(const {%H-}ALayoutRect: TRect; const AMatrix: TAffineMatrix): TRectF; override;
procedure Transform(const AMatrix: TAffineMatrix); override;
function AllowShearTransform: boolean; override;
property HasSelection: boolean read GetHasSelection;
property CanPasteSelection: boolean read GetCanPasteSelection;
property Text: string read FText write SetText;
property FontName: string read FFontName write SetFontName;
property FontStyle: TFontStyles read FFontStyle write SetFontStyle;
property FontEmHeight: single read FFontEmHeight write SetFontEmHeight;
property FontBidiMode: TFontBidiMode read FFontBidiMode write SetFontBidiMode;
property BidiParagraphAlignment: TBidiTextAlignment read GetBidiParagraphAlignment write SetBidiParagraphAlignment;
property ParagraphAlignment: TAlignment read GetParagraphAlignment write SetParagraphAlignment;
property VerticalAlignment: TTextLayout read FVertAlign write SetVertAlign;
property PenPhong: boolean read FPenPhong write SetPenPhong;
property LightPosition: TPointF read FLightPosition write SetLightPosition;
property AltitudePercent: single read FAltitudePercent write SetAltitudePercent;
property Aliased: boolean read FAliased write SetAliased;
end;
function FontStyleToStr(AStyle: TFontStyles): string;
function StrToFontStyle(AText: string): TFontStyles;
function FontBidiModeToStr(AMode: TFontBidiMode): string;
function StrToFontBidiMode(AText: string): TFontBidiMode;
implementation
uses BGRATransform, BGRAText, BGRAVectorize, math,
BGRAUTF8, BGRAUnicode, Graphics, Clipbrd, LCLType, LCLIntf,
BGRAGradients, BGRACustomTextFX, LCResourceString, BGRAFillInfo,
BGRAGrayscaleMask, BGRAPath, BGRALzpCommon, BGRADefaultBitmap;
function FontStyleToStr(AStyle: TFontStyles): string;
begin
result := '';
if fsBold in AStyle then result += 'b';
if fsItalic in AStyle then result += 'i';
if fsStrikeOut in AStyle then result += 's';
if fsUnderline in AStyle then result += 'u';
end;
function StrToFontStyle(AText: string): TFontStyles;
var
i: Integer;
begin
result := [];
for i := 1 to length(AText) do
case AText[i] of
'b': Include(result, fsBold);
'i': Include(result, fsItalic);
's': Include(result, fsStrikeOut);
'u': Include(result, fsUnderline);
end;
end;
function FontBidiModeToStr(AMode: TFontBidiMode): string;
begin
case AMode of
fbmLeftToRight: result := 'ltr';
fbmRightToLeft: result := 'rtl';
else {fbmAuto} result := 'auto';
end;
end;
function StrToFontBidiMode(AText: string): TFontBidiMode;
begin
if CompareText(AText,'ltr')=0 then result := fbmLeftToRight else
if CompareText(AText,'rtl')=0 then result := fbmRightToLeft
else result := fbmAuto;
end;
function GetPointBoundsF(APoints: ArrayOfTPointF): TRectF;
var
i: Integer;
begin
result := EmptyRectF;
i := length(APoints);
while i > 0 do
begin
dec(i);
if not isEmptyPointF(APoints[i]) then
begin
result.TopLeft := APoints[i];
result.BottomRight := APoints[i];
break;
end;
end;
while i > 0 do
begin
dec(i);
result.Include(APoints[i]);
end;
end;
{ TTextShapeTextDiff }
constructor TTextShapeTextDiff.Create(AStartShape: TVectorShape);
var
tl: TBidiTextLayout;
i: Integer;
begin
with (AStartShape as TTextShape) do
begin
FTextBefore:= FText;
FVertAlignBefore:= FVertAlign;
tl := GetTextLayout;
FSelStartBefore := FSelStart;
FSelEndBefore:= FSelEnd;
setlength(FParaAlignBefore, tl.ParagraphCount);
for i := 0 to high(FParaAlignBefore) do
FParaAlignBefore[i] := tl.ParagraphAlignment[i];
end;
end;
procedure TTextShapeTextDiff.ComputeDiff(AEndShape: TVectorShape);
var
tl: TBidiTextLayout;
i: Integer;
begin
with (AEndShape as TTextShape) do
begin
FTextAfter:= FText;
FVertAlignAfter:= FVertAlign;
FSelStartAfter := FSelStart;
FSelEndAfter:= FSelEnd;
tl := GetTextLayout;
setlength(FParaAlignAfter, tl.ParagraphCount);
for i := 0 to high(FParaAlignAfter) do
FParaAlignAfter[i] := tl.ParagraphAlignment[i];
end;
end;
procedure TTextShapeTextDiff.Apply(AStartShape: TVectorShape);
var
tl: TBidiTextLayout;
i: Integer;
begin
with (AStartShape as TTextShape) do
begin
BeginUpdate;
FreeAndNil(FTextLayout);
FText := FTextAfter;
FVertAlign := FVertAlignAfter;
FSelStart := FSelStartAfter;
FSelEnd := FSelEndAfter;
tl := GetTextLayout;
for i := 0 to min(length(FParaAlignAfter),tl.ParagraphCount)-1 do
tl.ParagraphAlignment[i] := FParaAlignAfter[i];
EndUpdate;
end;
end;
procedure TTextShapeTextDiff.Unapply(AEndShape: TVectorShape);
var
tl: TBidiTextLayout;
i: Integer;
begin
with (AEndShape as TTextShape) do
begin
BeginUpdate;
FreeAndNil(FTextLayout);
FText := FTextBefore;
FVertAlign := FVertAlignBefore;
FSelStart := FSelStartBefore;
FSelEnd := FSelEndBefore;
tl := GetTextLayout;
for i := 0 to min(length(FParaAlignBefore),tl.ParagraphCount)-1 do
tl.ParagraphAlignment[i] := FParaAlignBefore[i];
EndUpdate;
end;
end;
procedure TTextShapeTextDiff.Append(ADiff: TVectorShapeDiff);
var
next: TTextShapeTextDiff;
i: Integer;
begin
next := ADiff as TTextShapeTextDiff;
FTextAfter := next.FTextAfter;
FVertAlignAfter := next.FVertAlignAfter;
FSelStartAfter := next.FSelStartAfter;
FSelEndAfter := next.FSelEndAfter;
setlength(FParaAlignAfter, length(next.FParaAlignAfter));
for i := 0 to high(FParaAlignAfter) do
FParaAlignAfter[i] := next.FParaAlignAfter[i];
end;
function TTextShapeTextDiff.IsIdentity: boolean;
var
i: Integer;
begin
result := (FTextBefore = FTextAfter) and
(FSelStartBefore = FSelStartAfter) and
(FSelEndBefore = FSelEndAfter) and
(FVertAlignBefore = FVertAlignAfter) and
(length(FParaAlignBefore) = length(FParaAlignAfter));
if result then
begin
for i := 0 to high(FParaAlignBefore) do
if FParaAlignBefore[i] <> FParaAlignAfter[i] then
begin
result := false;
break;
end;
end;
end;
{ TTextShapePhongDiff }
constructor TTextShapePhongDiff.Create(AStartShape: TVectorShape);
begin
with (AStartShape as TTextShape) do
begin
FAltitudePercentBefore := FAltitudePercent;
FPenPhongBefore := FPenPhong;
FLightPositionBefore := FLightPosition;
end;
end;
procedure TTextShapePhongDiff.ComputeDiff(AEndShape: TVectorShape);
begin
with (AEndShape as TTextShape) do
begin
FAltitudePercentAfter := FAltitudePercent;
FPenPhongAfter := FPenPhong;
FLightPositionAfter := FLightPosition;
end;
end;
procedure TTextShapePhongDiff.Apply(AStartShape: TVectorShape);
begin
with (AStartShape as TTextShape) do
begin
BeginUpdate;
FAltitudePercent := FAltitudePercentAfter;
FPenPhong := FPenPhongAfter;
FLightPosition := FLightPositionAfter;
EndUpdate;
end;
end;
procedure TTextShapePhongDiff.Unapply(AEndShape: TVectorShape);
begin
with (AEndShape as TTextShape) do
begin
BeginUpdate;
FAltitudePercent := FAltitudePercentBefore;
FPenPhong := FPenPhongBefore;
FLightPosition := FLightPositionBefore;
EndUpdate;
end;
end;
procedure TTextShapePhongDiff.Append(ADiff: TVectorShapeDiff);
var
next: TTextShapePhongDiff;
begin
next := ADiff as TTextShapePhongDiff;
FAltitudePercentAfter:= next.FAltitudePercentAfter;
FPenPhongAfter:= next.FPenPhongAfter;
FLightPositionAfter:= next.FLightPositionAfter;
end;
function TTextShapePhongDiff.IsIdentity: boolean;
begin
result := (FAltitudePercentBefore = FAltitudePercentAfter) and
(FPenPhongBefore = FPenPhongAfter) and
(FLightPositionBefore = FLightPositionAfter);
end;
{ TTextShapeFontDiff }
constructor TTextShapeFontDiff.Create(AStartShape: TVectorShape);
begin
with (AStartShape as TTextShape) do
begin
FFontBidiModeBefore:= FFontBidiMode;
FFontEmHeightBefore:= FFontEmHeight;
FFontNameBefore:= FFontName;
FFontStyleBefore:= FFontStyle;
FAliasedBefore := FAliased;
end;
end;
procedure TTextShapeFontDiff.ComputeDiff(AEndShape: TVectorShape);
begin
with (AEndShape as TTextShape) do
begin
FFontBidiModeAfter:= FFontBidiMode;
FFontEmHeightAfter:= FFontEmHeight;
FFontNameAfter:= FFontName;
FFontStyleAfter:= FFontStyle;
FAliasedAfter := FAliased;
end;
end;
procedure TTextShapeFontDiff.Apply(AStartShape: TVectorShape);
begin
with (AStartShape as TTextShape) do
begin
BeginUpdate;
FFontBidiMode := FFontBidiModeAfter;
FFontEmHeight := FFontEmHeightAfter;
FFontName := FFontNameAfter;
FFontStyle := FFontStyleAfter;
FAliased := FAliasedAfter;
if Assigned(FTextLayout) then FTextLayout.InvalidateLayout;
EndUpdate;
end;
end;
procedure TTextShapeFontDiff.Unapply(AEndShape: TVectorShape);
begin
with (AEndShape as TTextShape) do
begin
BeginUpdate;
FFontBidiMode := FFontBidiModeBefore;
FFontEmHeight := FFontEmHeightBefore;
FFontName := FFontNameBefore;
FFontStyle := FFontStyleBefore;
FAliased := FAliasedBefore;
if Assigned(FTextLayout) then FTextLayout.InvalidateLayout;
EndUpdate;
end;
end;
procedure TTextShapeFontDiff.Append(ADiff: TVectorShapeDiff);
var
next: TTextShapeFontDiff;
begin
next := ADiff as TTextShapeFontDiff;
FFontBidiModeAfter := next.FFontBidiModeAfter;
FFontEmHeightAfter := next.FFontEmHeightAfter;
FFontNameAfter := next.FFontNameAfter;
FFontStyleAfter := next.FFontStyleAfter;
FAliasedAfter := next.FAliasedAfter;
end;
function TTextShapeFontDiff.IsIdentity: boolean;
begin
result := (FFontBidiModeBefore = FFontBidiModeAfter) and
(FFontEmHeightBefore = FFontEmHeightAfter) and
(FFontNameBefore = FFontNameAfter) and
(FFontStyleBefore = FFontStyleAfter) and
(FAliasedBefore = FAliasedAfter);
end;
{ TTextShape }
procedure TTextShape.SetText(AValue: string);
begin
if FText=AValue then Exit;
BeginUpdate(TTextShapeTextDiff);
FText:=AValue;
FSelStart:=0;
FSelEnd :=0;
FreeAndNil(FTextLayout);
EndUpdate;
end;
procedure TTextShape.SetFontBidiMode(AValue: TFontBidiMode);
begin
if FFontBidiMode=AValue then Exit;
BeginUpdate(TTextShapeFontDiff);
FFontBidiMode:=AValue;
InvalidateAll;
EndUpdate;
end;
function TTextShape.GetBidiParagraphAlignment: TBidiTextAlignment;
var
tl: TBidiTextLayout;
paraIndex: Integer;
begin
tl := GetTextLayout;
paraIndex := tl.GetParagraphAt(FSelEnd);
result := tl.ParagraphAlignment[paraIndex];
end;
function TTextShape.GetCanPasteSelection: boolean;
begin
result := Clipboard.HasFormat(PredefinedClipboardFormat(pcfText));
end;
function TTextShape.GetHasSelection: boolean;
begin
result := FSelEnd <> FSelStart;
end;
function TTextShape.GetParagraphAlignment: TAlignment;
var
tl: TBidiTextLayout;
paraIndex: Integer;
rtl: Boolean;
begin
tl := GetTextLayout;
paraIndex := tl.GetParagraphAt(FSelEnd);
rtl := tl.ParagraphRightToLeft[paraIndex];
case tl.ParagraphAlignment[paraIndex] of
btaCenter: result := taCenter;
btaRightJustify: result := taRightJustify;
btaNatural: if rtl then result := taRightJustify else result := taLeftJustify;
btaOpposite: if rtl then result := taLeftJustify else result := taRightJustify;
else {btaLeftJustify}
result := taLeftJustify;
end;
end;
procedure TTextShape.InvalidateParagraphLayout(AFrom, ATo: integer);
var
i, j: Integer;
begin
for i := AFrom to ATo do
with FParagraphLayout[i] do
begin
for j := 0 to high(brokenLines) do
begin
brokenLines[j].penImageId := 0;
brokenLines[j].penMaskId:= 0;
brokenLines[j].outlineMaskId := 0;
end;
end;
end;
procedure TTextShape.LayoutBrokenLinesChanged(ASender: TObject;
AParagraphIndex: integer; ASubBrokenStart, ASubBrokenChangedCountBefore,
ASubBrokenChangedCountAfter: integer; ASubBrokenTotalCountBefore,
ASubBrokenTotalCountAfter: integer);
var
i: Integer;
begin
if AParagraphIndex >= length(FParagraphLayout) then exit;
if (ASubBrokenTotalCountBefore <> length(FParagraphLayout[AParagraphIndex].brokenLines)) then
begin
InvalidateParagraphLayout(AParagraphIndex,high(FParagraphLayout));
FParagraphLayout[AParagraphIndex].brokenLines := nil;
exit;
end;
with FParagraphLayout[AParagraphIndex] do
begin
if (ASubBrokenChangedCountBefore <> ASubBrokenChangedCountAfter) then
begin
for i := ASubBrokenStart to high(brokenLines) do
begin
brokenLines[i].penImageId := 0;
brokenLines[i].penMaskId := 0;
brokenLines[i].outlineMaskId := 0;
end;
setlength(brokenLines, ASubBrokenTotalCountAfter);
if ASubBrokenChangedCountAfter > ASubBrokenChangedCountBefore then
begin
for i := ASubBrokenTotalCountBefore to high(brokenLines) do
begin
brokenLines[i].penImageId := 0;
brokenLines[i].penMaskId := 0;
brokenLines[i].outlineMaskId := 0;
end;
end;
InvalidateParagraphLayout(AParagraphIndex+1,high(FParagraphLayout));
end else
for i := ASubBrokenStart to ASubBrokenStart+ASubBrokenChangedCountBefore-1 do
begin
brokenLines[i].penImageId := 0;
brokenLines[i].penMaskId := 0;
brokenLines[i].outlineMaskId := 0;
end;
end;
end;
procedure TTextShape.LayoutParagraphDeleted(ASender: TObject;
AParagraphIndex: integer);
begin
InvalidateParagraphLayout(AParagraphIndex, high(FParagraphLayout));
end;
procedure TTextShape.LayoutParagraphMergedWithNext(ASender: TObject;
AParagraphIndex: integer);
begin
InvalidateParagraphLayout(AParagraphIndex, high(FParagraphLayout));
end;
procedure TTextShape.LayoutParagraphSplit(ASender: TObject;
AParagraphIndex: integer; ASubBrokenIndex, ACharIndex: integer);
begin
InvalidateParagraphLayout(AParagraphIndex, high(FParagraphLayout));
end;
procedure TTextShape.OnMoveLightPos(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
LightPosition := ANewCoord;
end;
procedure TTextShape.SetAliased(AValue: boolean);
begin
if FAliased=AValue then Exit;
BeginUpdate(TTextShapeFontDiff);
FAliased:=AValue;
EndUpdate;
end;
procedure TTextShape.SetAltitudePercent(AValue: single);
begin
if AValue < 0 then AValue := 0;
if AValue > 100 then AValue := 100;
if FAltitudePercent=AValue then Exit;
BeginUpdate(TTextShapePhongDiff);
FAltitudePercent:=AValue;
EndUpdate;
end;
procedure TTextShape.SetPenPhong(AValue: boolean);
begin
if FPenPhong=AValue then Exit;
BeginUpdate(TTextShapePhongDiff);
FPenPhong:=AValue;
EndUpdate;
end;
procedure TTextShape.SetFontEmHeight(AValue: single);
begin
if FFontEmHeight=AValue then Exit;
BeginUpdate(TTextShapeFontDiff);
FFontEmHeight:=AValue;
if Assigned(FTextLayout) then FTextLayout.InvalidateLayout;
EndUpdate;
end;
procedure TTextShape.SetFontName(AValue: string);
begin
if FFontName=AValue then Exit;
BeginUpdate(TTextShapeFontDiff);
FFontName:=AValue;
InvalidateAll;
EndUpdate;
end;
procedure TTextShape.SetFontStyle(AValue: TFontStyles);
begin
if FFontStyle=AValue then Exit;
BeginUpdate(TTextShapeFontDiff);
FFontStyle:=AValue;
InvalidateAll;
EndUpdate;
end;
procedure TTextShape.SetBidiParagraphAlignment(AValue: TBidiTextAlignment);
var
tl: TBidiTextLayout;
paraIndex, paraIndex2, i: Integer;
needUpdate: boolean;
begin
tl := GetTextLayout;
if Usermode <> vsuEditText then
begin
if tl.ParagraphCount = 0 then exit;
paraIndex := 0;
paraIndex2:= tl.ParagraphCount-1;
end else
begin
paraIndex := tl.GetParagraphAt(FSelStart);
paraIndex2 := tl.GetParagraphAt(FSelEnd);
end;
needUpdate := false;
for i := min(paraIndex,paraIndex2) to max(paraIndex,paraIndex2) do
if tl.ParagraphAlignment[i] <> AValue then
begin
if not needUpdate then
begin
BeginUpdate(TTextShapeTextDiff);
needUpdate := true;
end;
tl.ParagraphAlignment[i] := AValue;
end;
if needUpdate then EndUpdate;
end;
procedure TTextShape.SetLightPosition(AValue: TPointF);
begin
if FLightPosition=AValue then Exit;
BeginUpdate(TTextShapePhongDiff);
FLightPosition:=AValue;
EndUpdate;
end;
procedure TTextShape.SetParagraphAlignment(AValue: TAlignment);
var
tl: TBidiTextLayout;
paraIndex, paraIndex2, i: Integer;
bidiAlign: TBidiTextAlignment;
rtl, needUpdate: Boolean;
begin
tl := GetTextLayout;
if UserMode <> vsuEditText then
begin
if tl.ParagraphCount = 0 then exit;
paraIndex := 0;
paraIndex2:= tl.ParagraphCount-1;
end else
begin
paraIndex := tl.GetParagraphAt(FSelStart);
paraIndex2 := tl.GetParagraphAt(FSelEnd);
end;
needUpdate := false;
for i := min(paraIndex,paraIndex2) to max(paraIndex,paraIndex2) do
begin
rtl := tl.ParagraphRightToLeft[i];
case AValue of
taCenter: bidiAlign:= btaCenter;
taRightJustify: if rtl then bidiAlign := btaNatural else bidiAlign := btaOpposite;
else {taLeftJustify}
if rtl then bidiAlign := btaOpposite else bidiAlign := btaNatural;
end;
if tl.ParagraphAlignment[i] <> bidiAlign then
begin
if not needUpdate then
begin
BeginUpdate(TTextShapeTextDiff);
needUpdate := true;
end;
tl.ParagraphAlignment[i] := bidiAlign;
end;
end;
if needUpdate then EndUpdate;
end;
procedure TTextShape.SetVertAlign(AValue: TTextLayout);
begin
if FVertAlign=AValue then Exit;
BeginUpdate(TTextShapeTextDiff);
FVertAlign:=AValue;
EndUpdate;
end;
procedure TTextShape.SetGlobalMatrix(AMatrix: TAffineMatrix);
begin
if AMatrix = FGlobalMatrix then exit;
FGlobalMatrix := AMatrix;
end;
function TTextShape.AllowShearTransform: boolean;
begin
Result:= true;
end;
function TTextShape.ShowArrows: boolean;
begin
Result:= false;
end;
function TTextShape.GetTextLayout: TBidiTextLayout;
var
box: TAffineBox;
begin
if FTextLayout = nil then
begin
FTextLayout := TBidiTextLayout.Create(GetFontRenderer, FText);
FTextLayout.OnParagraphDeleted:=@LayoutParagraphDeleted;
FTextLayout.OnParagraphMergedWithNext:=@LayoutParagraphMergedWithNext;
FTextLayout.OnParagraphSplit:=@LayoutParagraphSplit;
FTextLayout.OnBrokenLinesChanged:=@LayoutBrokenLinesChanged;
end
else
if UpdateFontRenderer then FTextLayout.InvalidateLayout;
box := GetAffineBox(FGlobalMatrix,false);
FTextLayout.FontBidiMode:= FontBidiMode;
FTextLayout.TopLeft := PointF(0,0);
FTextLayout.AvailableWidth:= box.Width;
FTextLayout.AvailableHeight:= box.Height;
FTextLayout.ParagraphSpacingBelow:= 0.5;
result:= FTextLayout;
end;
function TTextShape.GetFontRenderer: TBGRACustomFontRenderer;
begin
UpdateFontRenderer;
result := FFontRenderer;
end;
function TTextShape.UpdateFontRenderer: boolean;
var
newEmHeight: single;
begin
if FFontRenderer = nil then
begin
FFontRenderer := TBGRAVectorizedFontRenderer.Create;
TBGRAVectorizedFontRenderer(FFontRenderer).QuadraticCurves := true;
TBGRAVectorizedFontRenderer(FFontRenderer).MinFontResolution := 300;
TBGRAVectorizedFontRenderer(FFontRenderer).MaxFontResolution := 300;
end;
newEmHeight := FontEmHeight*GetTextRenderZoom;
if (newEmHeight <> FFontRenderer.FontEmHeight) or
(FFontRenderer.FontName <> FontName) or
(FFontRenderer.FontStyle <> FontStyle) or
(FFontRenderer.FontQuality <> fqFineAntialiasing) then
begin
FFontRenderer.FontEmHeightF := newEmHeight;
FFontRenderer.FontName:= FontName;
FFontRenderer.FontStyle:= FontStyle;
FFontRenderer.FontQuality:= fqFineAntialiasing;
exit(true);
end
else exit(false);
end;
function TTextShape.GetTextRenderZoom: single;
begin
//font to be rendered at a sufficient size to avoid stretching
result := max(VectLen(FGlobalMatrix[1,1],FGlobalMatrix[2,1]),
VectLen(FGlobalMatrix[1,2],FGlobalMatrix[2,2]));
end;
function TTextShape.GetUntransformedMatrix: TAffineMatrix;
var
ab: TAffineBox;
u, v: TPointF;
lenU, lenV: Single;
begin
ab := GetAffineBox(AffineMatrixIdentity, false);
u := ab.TopRight-ab.TopLeft;
lenU := VectLen(u);
if lenU<>0 then u *= (1/lenU);
v := ab.BottomLeft-ab.TopLeft;
lenV := VectLen(v);
if lenV<>0 then v *= (1/lenV);
result := AffineMatrix(u,v,ab.TopLeft);
end;
function TTextShape.IsTextMirrored(ABox: TAffineBox): boolean;
var
u,v: TPointF;
begin
u := ABox.TopRight-ABox.TopLeft;
v := ABox.BottomLeft-ABox.TopLeft;
result := u.x*v.y - u.y*v.x < 0;
end;
procedure TTextShape.SetDefaultFont;
begin
FontName := DefaultFontName;
FontEmHeight := DefaultFontEmHeight;
FontBidiMode:= fbmAuto;
FontStyle := [];
end;
function TTextShape.GetCornerPositition: single;
begin
result := 1;
end;
procedure TTextShape.DeleteTextBefore(ACount: integer);
var
delCount, selLeft: Integer;
begin
if UserMode <> vsuEditText then exit;
BeginUpdate(TTextShapeTextDiff);
selLeft := Min(FSelStart,FSelEnd);
if selLeft > 0 then
begin
delCount := GetTextLayout.DeleteTextBefore(selLeft, ACount);
FText := GetTextLayout.TextUTF8;
dec(selLeft,delCount);
end;
inc(selLeft, GetTextLayout.IncludeNonSpacingChars(selLeft, 0));
FSelStart := selLeft;
FSelEnd := selLeft;
EndUpdate;
end;
procedure TTextShape.DeleteTextAfter(ACount: integer);
var
selRight: Integer;
tl: TBidiTextLayout;
begin
if UserMode <> vsuEditText then exit;
BeginUpdate(TTextShapeTextDiff);
selRight := Max(FSelStart,FSelEnd);
tl := GetTextLayout;
if selRight+ACount <= tl.CharCount then
begin
tl.DeleteText(selRight, ACount);
FText := tl.TextUTF8;
end;
inc(selRight, GetTextLayout.IncludeNonSpacingChars(selRight, 0));
FSelStart := selRight;
FSelEnd := selRight;
EndUpdate;
end;
function TTextShape.DeleteSelection: boolean;
var
selLeft: Integer;
begin
if FSelStart <> FSelEnd then
begin
BeginUpdate(TTextShapeTextDiff);
selLeft := Min(FSelStart,FSelEnd);
GetTextLayout.DeleteText(selLeft, Abs(FSelEnd-FSelStart));
FText := GetTextLayout.TextUTF8;
inc(selLeft, GetTextLayout.IncludeNonSpacingChars(selLeft, 0));
FSelStart := selLeft;
FSelEnd := selLeft;
EndUpdate;
result := true;
end else
result := false;
end;
function TTextShape.GetAlignBounds(const ALayoutRect: TRect;
const AMatrix: TAffineMatrix): TRectF;
var
ab: TAffineBox;
begin
ab := GetAffineBox(AMatrix, false);
Result:= ab.RectBoundsF;
end;
procedure TTextShape.InsertText(ATextUTF8: string);
var
insertCount: Integer;
begin
if UserMode <> vsuEditText then exit;
BeginUpdate(TTextShapeTextDiff);
DeleteSelection;
insertCount := GetTextLayout.InsertText(ATextUTF8, FSelStart);
FText := GetTextLayout.TextUTF8;
Inc(FSelStart, insertCount);
inc(FSelStart, GetTextLayout.IncludeNonSpacingChars(FSelStart, 0));
FSelEnd := FSelStart;
EndUpdate;
end;
procedure TTextShape.SelectWithMouse(X, Y: single; AExtend: boolean);
var
newPos: Integer;
tl: TBidiTextLayout;
zoom: Single;
untransformed: TAffineMatrix;
begin
tl := GetTextLayout;
zoom := GetTextRenderZoom;
untransformed := GetUntransformedMatrix;
if not IsAffineMatrixInversible(untransformed) then exit;
newPos := tl.GetCharIndexAt(AffineMatrixScale(zoom,zoom)*AffineMatrixInverse(untransformed)*PointF(X,Y));
if newPos<>-1 then
begin
if (newPos <> FSelEnd) or (not AExtend and (FSelStart <> FSelEnd)) or (UserMode <> vsuEditText) then
begin
BeginEditingUpdate;
FSelEnd:= newPos;
if not AExtend or (UserMode <> vsuEditText) then FSelStart:= FSelEnd;
UserMode := vsuEditText;
EndEditingUpdate;
end;
end;
end;
function TTextShape.HasOutline: boolean;
begin
result := not OutlineFill.IsFullyTransparent and (OutlineWidth > 0);
end;
procedure TTextShape.InsertUnicodeValue;
begin
if FEnteringUnicode then
begin
if FUnicodeValue <= $10FFFF then
InsertText(UnicodeCharToUTF8(FUnicodeValue));
FEnteringUnicode:= false;
end;
end;
procedure TTextShape.FillChange(ASender: TObject;
var ADiff: TCustomVectorialFillDiff);
begin
if ASender = PenFill then inc(FPenFillIteration);
inherited FillChange(ASender, ADiff);
end;
procedure TTextShape.InvalidateAll;
begin
if Assigned(FTextLayout) then FTextLayout.InvalidateLayout;
FParagraphLayout := nil;
end;
constructor TTextShape.Create(AContainer: TVectorOriginal);
begin
inherited Create(AContainer);
SetDefaultFont;
FVertAlign:= tlTop;
FText := '';
FSelStart := 0;
FSelEnd := 0;
FGlobalMatrix := AffineMatrixIdentity;
FPenPhong:= false;
FPenFillIteration := 0;
FAltitudePercent:= DefaultAltitudePercent;
FLightPosition := PointF(0,0);
FAliased := false;
FCurBrokenLineImageId := 0;
end;
procedure TTextShape.QuickDefine(constref APoint1, APoint2: TPointF);
var minSize: single;
p2: TPointF;
begin
minSize := GetFontRenderer.TextSize('Hg').cy/GetTextRenderZoom;
p2 := APoint2;
if abs(APoint1.x-p2.x) < minSize then
begin
if p2.x < APoint1.x then p2.x := APoint1.x - minSize else
p2.x := APoint1.x + minSize;
end;
if abs(APoint1.y-p2.y) < minSize then
begin
if p2.y < APoint1.y then p2.y := APoint1.y - minSize else
p2.y := APoint1.y + minSize;
end;
inherited QuickDefine(APoint1, p2);
end;
procedure TTextShape.LoadFromStorage(AStorage: TBGRACustomOriginalStorage);
var
font, phongObj: TBGRACustomOriginalStorage;
tl: TBidiTextLayout;
paraAlignList: TStringList;
i: Integer;
alignment: TAlignment;
begin
BeginUpdate;
inherited LoadFromStorage(AStorage);
Text := AStorage.RawString['text'];
font := AStorage.OpenObject('font');
if Assigned(font) then
begin
if font.HasAttribute('name') then
FontName:= font.RawString['name']
else
FontName:= AStorage.RawString['name']; //compatibility
if fontName = '' then fontName := DefaultFontName;
if font.HasAttribute('em-height') then
FontEmHeight:= font.FloatDef['em-height', DefaultFontEmHeight]
else
FontEmHeight:= AStorage.FloatDef['em-height', DefaultFontEmHeight]; //compatibility
if Font.HasAttribute('bidi') then
FontBidiMode:= StrToFontBidiMode(font.RawString['bidi'])
else
FontBidiMode:= StrToFontBidiMode(AStorage.RawString['bidi']); //compatibility
if font.HasAttribute('style') then
FontStyle:= StrToFontStyle(font.RawString['style'])
else
FontStyle:= StrToFontStyle(AStorage.RawString['style']); //compatibility
font.Free;
end else
SetDefaultFont;
Aliased := AStorage.Bool['aliased'];
phongObj := AStorage.OpenObject('pen-phong');
PenPhong := Assigned(phongObj);
if PenPhong then
begin
LightPosition := phongObj.PointF['light-pos'];
AltitudePercent:= phongObj.FloatDef['altitude-percent', DefaultAltitudePercent];
phongObj.Free;
end else
begin
LightPosition := PointF(0,0);
AltitudePercent:= DefaultAltitudePercent;
end;
tl := GetTextLayout;
paraAlignList := TStringList.Create;
paraAlignList.DelimitedText:= AStorage.RawString['paragraph-align'];
for i := 0 to min(paraAlignList.Count, tl.ParagraphCount)-1 do
begin
case paraAlignList[i] of
'center': alignment := taCenter;
'right': alignment := taRightJustify;
else {'left'} alignment := taLeftJustify;
end;
tl.ParagraphAlignment[i] := AlignmentToBidiTextAlignment(alignment, tl.ParagraphRightToLeft[i]);
end;
paraAlignList.Free;
EndUpdate;
end;
procedure TTextShape.SaveToStorage(AStorage: TBGRACustomOriginalStorage);
var
font, phongObj: TBGRACustomOriginalStorage;
tl: TBidiTextLayout;
paraAlignList: TStringList;
i: Integer;
begin
inherited SaveToStorage(AStorage);
AStorage.RawString['text'] := Text;
font := AStorage.OpenObject('font');
if font = nil then font := AStorage.CreateObject('font');
font.RawString['name'] := FontName;
font.Float['em-height'] := FontEmHeight;
font.RawString['bidi'] := FontBidiModeToStr(FontBidiMode);
font.RawString['style'] := FontStyleToStr(FontStyle);
font.Free;
AStorage.Bool['aliased'] := Aliased;
if PenPhong then
begin
phongObj := AStorage.OpenObject('pen-phong');
if phongObj=nil then phongObj := AStorage.CreateObject('pen-phong');
phongObj.PointF['light-pos'] := LightPosition;
phongObj.Float['altitude-percent'] := AltitudePercent;
phongObj.Free;
end else
AStorage.RemoveObject('pen-phong');
tl := GetTextLayout;
paraAlignList := TStringList.Create;
for i := 0 to tl.ParagraphCount-1 do
case tl.ParagraphAlignment[i] of
btaRightJustify: paraAlignList.Add('right');
btaCenter: paraAlignList.Add('center');
btaNatural: if tl.ParagraphRightToLeft[i] then paraAlignList.Add('right') else paraAlignList.Add('left');
btaOpposite: if tl.ParagraphRightToLeft[i] then paraAlignList.Add('left') else paraAlignList.Add('right');
else {btaLeftJustify}
paraAlignList.Add('left');
end;
AStorage.RawString['paragraph-align'] := paraAlignList.DelimitedText;
paraAlignList.Free;
end;
destructor TTextShape.Destroy;
begin
FreeAndNil(FTextLayout);
FreeAndNil(FFontRenderer);
inherited Destroy;
end;
class function TTextShape.Fields: TVectorShapeFields;
begin
Result:= [vsfPenFill,vsfOutlineFill,vsfOutlineWidth];
end;
class function TTextShape.PreferPixelCentered: boolean;
begin
Result:= false;
end;
class function TTextShape.DefaultFontName: string;
begin
result := {$IFDEF WINDOWS}'Arial'{$ELSE}{$IFDEF DARWIN}'Helvetica'{$ELSE}'Liberation Sans'{$ENDIF}{$ENDIF};
end;
class function TTextShape.DefaultFontEmHeight: single;
begin
result := 20;
end;
class function TTextShape.DefaultAltitudePercent: single;
begin
result := 30;
end;
class function TTextShape.CreateEmpty: boolean;
begin
Result:= true;
end;
procedure TTextShape.ConfigureCustomEditor(AEditor: TBGRAOriginalEditor);
var
caret: TBidiCaretPos;
orientation: TPointF;
m: TAffineMatrix;
tl: TBidiTextLayout;
pts: Array Of TPointF;
i, idxLight: Integer;
c: TBGRAPixel;
zoom: Single;
begin
inherited ConfigureCustomEditor(AEditor);
AEditor.AddPolyline(GetAffineBox(AffineMatrixIdentity,true).AsPolygon, true, opsDashWithShadow);
if AEditor.Focused and (Usermode = vsuEditText) then
begin
tl := GetTextLayout;
caret:= tl.GetCaret(FSelEnd);
zoom := GetTextRenderZoom;
m := AffineMatrixTranslation(-0.5,-0.5)*GetUntransformedMatrix*AffineMatrixScale(1/zoom,1/zoom);
if FSelStart<>FSelEnd then
begin
pts := tl.GetTextEnveloppe(FSelStart, FSelEnd, false, true, true);
for i := 0 to high(pts) do
pts[i] := m*pts[i];
c:= clHighlight;
c.alpha := 96;
AEditor.AddPolyline(pts, true, opsDash, c);
end;
if (tl.AvailableHeight = EmptySingle) or (caret.Top.y < tl.AvailableHeight) then
begin
orientation := (caret.Bottom-caret.Top)*(1/10);
orientation := PointF(-orientation.y,orientation.x);
if (tl.AvailableHeight <> EmptySingle) and (caret.Bottom.y <> EmptySingle) and (caret.Bottom.y > tl.AvailableHeight) then caret.Bottom.y := tl.AvailableHeight;
if (tl.AvailableHeight <> EmptySingle) and (caret.PreviousBottom.y <> EmptySingle) and (caret.PreviousBottom.y > tl.AvailableHeight) then caret.PreviousBottom.y := tl.AvailableHeight;
if not isEmptyPointF(caret.PreviousTop) and (caret.PreviousRightToLeft<>caret.RightToLeft) then
begin
if caret.RightToLeft then orientation := -orientation;
AEditor.AddPolyline([m*caret.Bottom,m*caret.Top,m*(caret.Top+orientation)],false, opsSolid);
end else
AEditor.AddPolyline([m*caret.Bottom,m*caret.Top],false, opsSolid);
end;
end;
if PenPhong then
begin
idxLight := AEditor.AddPoint(FLightPosition, @OnMoveLightPos, true);
if AEditor is TVectorOriginalEditor then
TVectorOriginalEditor(AEditor).AddLabel(idxLight, rsLightPosition, taCenter, tlTop);
end;
end;
procedure TTextShape.Render(ADest: TBGRABitmap; ARenderOffset: TPoint; AMatrix: TAffineMatrix;
ADraft: boolean);
function GetTextPhongHeight: integer;
begin
result := round(AltitudePercent/100 * FontEmHeight*0.15);
end;
function CreateShader(AOfsX,AOfsY: integer): TPhongShading;
var
lightPosF: TPointF;
lightPosZ: Single;
begin
result := TPhongShading.Create;
result.AmbientFactor := 0.6;
result.NegativeDiffusionFactor := 0.15;
lightPosF := FGlobalMatrix*LightPosition+PointF(AOfsX,AOfsY);
lightPosZ := max(AltitudePercent, 1.2*GetTextPhongHeight);
result.LightPosition3D := Point3D(lightPosF.x,lightPosF.y,lightPosZ);
end;
var
hasPen: boolean;
zoom, outlineRenderWidth: Single;
m: TAffineMatrix;
tl: TBidiTextLayout;
fr: TBGRACustomFontRenderer;
pad, paraIndex, fileIdx: Integer;
sourceRectF,transfRectF,sourceInvRect,destF: TRectF;
transfRect, tmpRenderRect, brokenLineRectBounds: TRect;
tmpTransf: TBGRABitmap;
tmpBroken: TBGRAMemoryStreamBitmap;
tmpTransfOutline, tmpBrokenMask: TGrayscaleMask;
storeImage, useBrokenLinesRender, redrawPen, redrawOutline,
outlineWidthChange, penPhongChange: Boolean;
storage: TShapeRenderStorage;
startBrokenIndex, endBrokenIndex, brokenIndex: LongInt;
tempRenderNewList, tempRenderCurList: TStringList;
phongObj, tempStorage: TBGRACustomOriginalStorage;
brokenRenderOfs: TPoint;
brokenLinePoints: Array of TPointF;
brokenLineBoundsF: TRectF;
procedure ComputeBrokenLinesPath(AStartBroken, AEndBroken: integer);
var
p: TBGRAPath;
begin
p := TBGRAPath.Create;
tl.PathBrokenLines(p, AStartBroken, AEndBroken);
brokenLinePoints := p.ToPoints(m);
brokenLineBoundsF := GetPointBoundsF(brokenLinePoints);
p.Free;
end;
procedure FillPen(ADestination: TCustomUniversalBitmap; AOffset: TPoint; ABrush: TUniversalBrush);
var
pts: ArrayOfTPointF;
i: Integer;
begin
if not hasPen then exit;
pts := PointsF(brokenLinePoints);
for i := high(pts) downto 0 do
pts[i].Offset(AOffset.x, AOffset.Y);
ADestination.FillMode:= fmWinding;
if (ADraft and PenPhong) or Aliased then
ADestination.FillPoly(pts, ABrush, false)
else
ADestination.FillPolyAntialias(pts, ABrush, false);
end;
procedure RenderPen(ADestination: TBGRACustomBitmap; AOffset: TPoint);
var
rF: TRectF;
r: TRect;
textMask: TGrayscaleMask;
textFx: TBGRACustomTextEffect;
scan: TBGRACustomScanner;
shader: TPhongShading;
maskOfs: TPoint;
b: TUniversalBrush;
begin
if not hasPen then exit;
if PenPhong then
begin
rF := brokenLineBoundsF;
rF.Offset(AOffset.X, AOffset.Y);
rF := TRectF.Intersect(rF, rectF(0,0,ADestination.Width,ADestination.Height));
r := Rect(floor(rF.Left), floor(rF.Top), ceil(rF.Right), ceil(rF.Bottom));
r.Inflate(1, 1);
maskOfs := Point(AOffset.x - r.Left, AOffset.y - r.Top);
textMask := TGrayscaleMask.Create(r.Width, r.Height, 0);
textMask.SolidBrush(b, ByteMaskWhite, dmDrawWithTransparency);
FillPen(textMask, maskOfs, b);
textFx := TBGRACustomTextEffect.Create(textMask, true, textMask.Width,textMask.Height, Point(0, 0));
shader:= CreateShader(AOffset.X, AOffset.Y);
if PenFill.FillType = vftSolid then
textFx.DrawShaded(ADestination, r.Left, r.Top, shader, GetTextPhongHeight, PenFill.SolidColor)
else
begin
scan := PenFill.CreateScanner(AffineMatrixTranslation(AOffset.X, AOffset.Y)*FGlobalMatrix, ADraft);
textFx.DrawShaded(ADestination, r.Left, r.Top, shader, GetTextPhongHeight, scan);
scan.Free;
end;
shader.Free;
textFx.Free;
end else
begin
if PenFill.FillType = vftSolid then
begin
ADestination.SolidBrush(b, PenFill.SolidColor, dmDrawWithTransparency);
FillPen(ADestination, AOffset, b);
end else
begin
scan := PenFill.CreateScanner(AffineMatrixTranslation(AOffset.X, AOffset.Y)*FGlobalMatrix, ADraft);
ADestination.ScannerBrush(b, scan, dmDrawWithTransparency);
FillPen(ADestination, AOffset, b);
scan.Free;
end;
end;
end;
procedure RenderPenMask(ADestination: TGrayscaleMask; AOffset: TPoint);
var
b: TUniversalBrush;
begin
ADestination.SolidBrush(b, ByteMaskWhite, dmDrawWithTransparency);
FillPen(ADestination, AOffset, b);
end;
procedure RenderFromMask(ADestination: TBGRABitmap; AX, AY: Integer; AMask: TGrayscaleMask;
AFillOffset: TPoint; AFill: TVectorialFill);
var
scan: TBGRACustomScanner;
begin
if AFill.FillType = vftSolid then
begin
ADestination.FillMask(AX, AY, AMask, AFill.SolidColor, dmDrawWithTransparency);
end else
if AFill.FillType <> vftNone then
begin
scan := AFill.CreateScanner(AffineMatrixTranslation(AFillOffset.X, AFillOffset.Y)*FGlobalMatrix, ADraft);
ADestination.FillMask(AX, AY, AMask, scan, dmDrawWithTransparency);
scan.Free;
end;
end;
procedure RenderFromMask(ADestination: TGrayscaleMask; AX, AY: Integer; AMask: TGrayscaleMask);
begin
ADestination.FillMask(AX, AY, AMask, ByteMaskWhite);
end;
procedure FillOutline(ADestination: TCustomUniversalBitmap; AOffset: TPoint; ABrush: TUniversalBrush);
var
pts: ArrayOfTPointF;
i: Integer;
begin
if not HasOutline then exit;
ADestination.Pen.JoinStyle:= pjsRound;
ADestination.Pen.Style:= psSolid;
ADestination.FillMode:= fmWinding;
pts := ADestination.Pen.ComputePolygon(brokenLinePoints, outlineRenderWidth);
for i := high(pts) downto 0 do
pts[i].Offset(AOffset.x, AOffset.Y);
if ADraft or Aliased then
ADestination.FillPoly(pts, ABrush, false)
else
ADestination.FillPolyAntialias(pts, ABrush, false);
end;
procedure RenderOutlineMask(ADestination: TGrayscaleMask; AOffset: TPoint);
var
b: TUniversalBrush;
begin
ADestination.SolidBrush(b, ByteMaskWhite, dmDrawWithTransparency);
FillOutline(ADestination, AOffset, b);
end;
procedure RenderOutline(ADestination: TBGRABitmap; AOffset: TPoint);
var
scan: TBGRACustomScanner;
b: TUniversalBrush;
begin
if OutlineFill.FillType = vftSolid then
begin
ADestination.SolidBrush(b, OutlineFill.SolidColor, dmDrawWithTransparency);
FillOutline(ADestination, AOffset, b);
end else
if OutlineFill.FillType <> vftNone then
begin
scan := OutlineFill.CreateScanner(AffineMatrixTranslation(AOffset.X, AOffset.Y)*FGlobalMatrix, ADraft);
ADestination.ScannerBrush(b, scan, dmDrawWithTransparency);
FillOutline(ADestination, AOffset, b);
scan.Free;
end;
end;
procedure RenderBrokenLines(ADestination: TBGRABitmap; AStartBroken, AEndBroken: integer; AOffset: TPoint);
begin
ComputeBrokenLinesPath(AStartBroken, AEndBroken);
RenderOutline(ADestination, AOffset);
RenderPen(ADestination, AOffset);
end;
procedure StoreRGBAImage(var AImageId: int64; AImage: TBGRAMemoryStreamBitmap; AImageOffset: TPoint);
var
renderObj: TBGRACustomOriginalStorage;
begin
if AImageId = 0 then
begin
inc(FCurBrokenLineImageId);
AImageId := FCurBrokenLineImageId;
end;
renderObj := tempStorage.CreateObject(inttostr(AImageId));
renderObj.PointF['size'] := PointF(AImage.Width, AImage.Height);
renderObj.PointF['offset'] := PointF(AImageOffset) - PointF(ARenderOffset);
renderObj.WriteFile('image.data', AImage.Stream, false, AImage.OwnStream);
AImage.OwnStream := false;
renderObj.Free;
tempRenderNewList.Add(inttostr(AImageId));
end;
procedure EncodeSimpleRLE(AData: PByte; ASize: integer; AStream: TStream);
var
repCount, val: Byte;
repeating: boolean;
begin
repeating := true;
while ASize > 0 do
begin
val := AData^; inc(AData); repCount := 1; dec(ASize);
while (ASize > 0) and (AData^ = val) and (repCount < 254) do
begin
inc(AData);
dec(ASize);
inc(repCount);
end;
if (repCount > 2) or (ASize = 0) then
begin
if not repeating then AStream.WriteByte(0);
AStream.WriteByte(repCount);
AStream.WriteByte(val);
repeating := false;
end else
begin
while (ASize > 1) and (repCount < 253) and ((AData^ <> (AData-1)^) or ((AData+1)^ <> (AData-1)^)) do
begin
inc(AData, 2);
dec(ASize, 2);
inc(repCount, 2);
end;
if (ASize = 1) and (repCount < 254) then
begin
inc(AData);
dec(ASize);
inc(repCount);
end;
if repeating then AStream.WriteByte(0);
AStream.WriteByte(repCount);
AStream.WriteBuffer((AData-repCount)^, repCount);
repeating := true;
end;
end;
AStream.WriteByte(255);
end;
procedure DecodeSimpleRLE(AData: PByte; ASize: integer; AStream: TStream);
var
repCount, val: Byte;
begin
while ASize > 0 do
begin
repCount := AStream.ReadByte;
if repCount = 255 then break;
if repCount > 0 then
begin
val := AStream.ReadByte;
if repCount > ASize then repCount := ASize;
fillchar(AData^, repCount, val);
inc(AData, repCount);
dec(ASize, repCount);
end;
repCount := AStream.ReadByte;
if repCount = 255 then break;
if repCount > 0 then
begin
if repCount > ASize then repCount := ASize;
AStream.ReadBuffer(AData^, repCount);
inc(AData, repCount);
dec(ASize, repCount);
end;
end;
while ASize > 0 do
begin
AData^ := 0;
inc(AData);
dec(ASize);
end;
end;
procedure StoreMask(var AMaskId: int64; AMask: TGrayscaleMask; AMaskOffset: TPoint);
var
imgStream: TMemoryStream;
renderObj: TBGRACustomOriginalStorage;
begin
imgStream := TMemoryStream.Create;
EncodeSimpleRLE(AMask.Data, AMask.NbPixels, imgStream);
if AMaskId = 0 then
begin
inc(FCurBrokenLineImageId);
AMaskId := FCurBrokenLineImageId;
end;
renderObj := tempStorage.CreateObject(inttostr(AMaskId));
renderObj.PointF['size'] := PointF(AMask.Width, AMask.Height);
renderObj.PointF['offset'] := PointF(AMaskOffset) - PointF(ARenderOffset);
renderObj.WriteFile('mask.data', imgStream, false, true);
renderObj.Free;
tempRenderNewList.Add(inttostr(AMaskId));
end;
function LoadStoredMask(AMaskId: integer; out AMask: TGrayscaleMask; out AOffset: TPoint): boolean;
var
imgStream: TStream;
renderObj: TBGRACustomOriginalStorage;
size: TPoint;
begin
AMask := nil;
AOffset := Point(0,0);
result := false;
renderObj := tempStorage.OpenObject(inttostr(AMaskId));
if Assigned(renderObj) then
begin
size := renderObj.PointF['size'].Round;
AOffset := (renderObj.PointF['offset'] + PointF(ARenderOffset)).Round;
imgStream := renderObj.GetFileStream('mask.data');
if not Assigned(imgStream) or (imgStream.Size = 0) then
begin
renderObj.Free;
exit;
end;
tempRenderNewList.Add(inttostr(AMaskId));
AMask := TGrayscaleMask.Create;
AMask.SetSize(size.x, size.y);
imgStream.Position := 0;
DecodeSimpleRLE(AMask.Data, AMask.NbPixels, imgStream);
renderObj.Free;
result := true;
end;
end;
procedure RenderFromStoredMask(ADestination: TBGRABitmap; AMaskId: integer; AFill: TVectorialFill);
var
brokenRenderOfs: TPoint;
tmpBrokenMask: TGrayscaleMask;
begin
if LoadStoredMask(AMaskId, tmpBrokenMask, brokenRenderOfs) then
begin
RenderFromMask(ADestination, brokenRenderOfs.X - transfRect.Left,
brokenRenderOfs.Y - transfRect.Top, tmpBrokenMask,
Point(- transfRect.Left, - transfRect.Top), AFill);
tmpBrokenMask.Free;
end;
end;
procedure RenderFromStoredMask(ADestination: TGrayscaleMask; AMaskId: integer);
var
brokenRenderOfs: TPoint;
tmpBrokenMask: TGrayscaleMask;
begin
if LoadStoredMask(AMaskId, tmpBrokenMask, brokenRenderOfs) then
begin
RenderFromMask(ADestination, brokenRenderOfs.X - transfRect.Left,
brokenRenderOfs.Y - transfRect.Top, tmpBrokenMask);
tmpBrokenMask.Free;
end;
end;
procedure RenderFromStoredImage(ADestination: TBGRABitmap; AImageId: integer);
var
renderObj: TBGRACustomOriginalStorage;
brokenRenderOfs, size: TPoint;
imgStream: TStream;
tmpBroken: TBGRAMemoryStreamBitmap;
begin
renderObj := tempStorage.OpenObject(inttostr(AImageId));
if Assigned(renderObj) then
begin
size := renderObj.PointF['size'].Round;
brokenRenderOfs := (renderObj.PointF['offset'] + PointF(ARenderOffset)).Round;
imgStream := renderObj.GetFileStream('image.data');
if (imgStream = nil) or (imgStream.Size = 0) then
begin
renderObj.Free;
exit;
end;
tempRenderNewList.Add(inttostr(AImageId));
tmpBroken := TBGRAMemoryStreamBitmap.Create(size.x, size.y,
imgStream as TMemoryStream, 0, false);
ADestination.PutImage(brokenRenderOfs.X - transfRect.Left,
brokenRenderOfs.Y - transfRect.Top,
tmpBroken, dmDrawWithTransparency);
tmpBroken.Free;
renderObj.Free;
end;
end;
procedure ApplyClipBox(ADest: TCustomUniversalBitmap);
var
maskBox: TAffineBox;
wholeImage: TAffineBox;
begin
maskBox := AffineMatrixTranslation(-transfRect.Left,-transfRect.Top) * m *
TAffineBox.AffineBox(sourceRectF);
wholeImage := TAffineBox.AffineBox(PointF(-1,-1), PointF(-1,ADest.Height+1),
PointF(ADest.Width+1,-1));
ADest.FillMode := fmWinding;
ADest.ErasePolyAntialias( ConcatPointsF([wholeImage.AsPolygon, maskBox.AsPolygon], true),
255, false);
end;
begin
RetrieveRenderStorage(AMatrix, transfRect, tmpTransf);
if Assigned(tmpTransf) then
begin
ADest.PutImage(transfRect.Left + ARenderOffset.X, transfRect.Top + ARenderOffset.Y,
tmpTransf, dmDrawWithTransparency);
tmpTransf.Free;
exit;
end;
hasPen := not PenFill.IsFullyTransparent;
if not hasPen and not HasOutline then exit;
SetGlobalMatrix(AffineMatrixTranslation(ARenderOffset.X,ARenderOffset.Y)*AMatrix);
zoom := GetTextRenderZoom;
if zoom = 0 then exit;
fr := GetFontRenderer;
if fr.FontEmHeight = 0 then exit;
pad := fr.FontEmHeight;
m := FGlobalMatrix* //global transform
GetUntransformedMatrix* //transform according to shape rectangle
AffineMatrixScale(1/zoom,1/zoom); //shrink zoomed text if necessary
tl := GetTextLayout;
sourceRectF := RectF(-pad,0,tl.AvailableWidth+pad,min(tl.TotalTextHeight,tl.AvailableHeight));
if CanHaveRenderStorage then
begin
storage := OpenRenderStorage(true);
tempStorage := storage.temporary;
end else
begin
storage := TShapeRenderStorage.None;
tempStorage := TemporaryStorage;
end;
if Assigned(tempStorage) then
begin
tempRenderNewList := TStringList.Create;
useBrokenLinesRender := not ADraft and (Usermode = vsuEditText);
if not tempStorage.AffineMatrixEquals('last-matrix', AMatrix) or
not tempStorage.PointFEquals('origin', Origin) or
not tempStorage.PointFEquals('x-axis', XAxis) or
not tempStorage.PointFEquals('y-axis', YAxis) or
not tempStorage.FloatEquals('em-height', FontEmHeight) or
not useBrokenLinesRender then
begin
//all temp files that are obsolete
tempRenderCurList := TStringList.Create;
tempStorage.EnumerateObjects(tempRenderCurList);
for fileIdx := 0 to tempRenderCurList.Count-1 do
tempStorage.RemoveObject(tempRenderCurList[fileIdx]);
tempRenderCurList.Free;
tempStorage.RemoveAttribute('last-matrix');
tempStorage.RemoveAttribute('origin');
tempStorage.RemoveAttribute('x-axis');
tempStorage.RemoveAttribute('y-axis');
tempStorage.RemoveAttribute('em-height');
tempStorage.RemoveAttribute('outline-width');
tempStorage.RemoveObject('pen-phong');
end;
end else
begin
tempRenderNewList := nil;
useBrokenLinesRender := false;
end;
storeImage := CanHaveRenderStorage and not ADraft; // and not useBrokenLinesRender;
if storeImage or useBrokenLinesRender then
destF := rectF(0,0,ADest.Width,ADest.Height)
else
destF := RectF(ADest.ClipRect.Left,ADest.ClipRect.Top,ADest.ClipRect.Right,ADest.ClipRect.Bottom);
transfRectF := (m*TAffineBox.AffineBox(sourceRectF)).RectBoundsF;
transfRectF := TRectF.Intersect(transfRectF, destF);
if not IsAffineMatrixInversible(m) then
begin
tempRenderNewList.Free;
exit;
end;
sourceInvRect := (AffineMatrixInverse(m)*TAffineBox.AffineBox(transfRectF)).RectBoundsF;
sourceInvRect.Top := floor(sourceInvRect.Top);
sourceInvRect.Bottom := ceil(sourceInvRect.Bottom);
sourceRectF := TRectF.Intersect(sourceRectF,sourceInvRect);
if IsEmptyRectF(sourceRectF) then
begin
tempRenderNewList.Free;
exit;
end;
sourceRectF.Left := floor(sourceRectF.Left);
sourceRectF.Top := floor(sourceRectF.Top);
sourceRectF.Right := floor(sourceRectF.Right);
sourceRectF.Bottom := sourceRectF.Bottom;
if tl.TotalTextHeight < tl.AvailableHeight then
case VerticalAlignment of
tlBottom: m *= AffineMatrixTranslation(0, tl.AvailableHeight-tl.TotalTextHeight);
tlCenter: m *= AffineMatrixTranslation(0, (tl.AvailableHeight-tl.TotalTextHeight)/2);
end;
with transfRectF do
transfRect := Rect(floor(Left),floor(Top),ceil(Right),ceil(Bottom));
if PenPhong and Assigned(tempStorage) then
begin
phongObj := tempStorage.OpenObject('pen-phong');
penPhongChange := not Assigned(phongObj) or
not phongObj.PointFEquals('light-pos', LightPosition) or
not phongObj.FloatEquals('altitude-percent', AltitudePercent) or
(phongObj.Int['fill-iteration'] <> FPenFillIteration);
phongObj.Free;
end else
penPhongChange := false;
if HasOutline then
begin
outlineRenderWidth := zoom*OutlineWidth;
outlineWidthChange := Assigned(tempStorage) and
(tempStorage.Float['outline-width'] <> OutlineWidth);
end else
begin
outlineRenderWidth := 0;
outlineWidthChange := false;
end;
if useBrokenLinesRender then
begin
brokenLineBoundsF := EmptyRectF;
if HasOutline then
tmpTransfOutline := TGrayscaleMask.Create(transfRect.Width, transfRect.Height)
else tmpTransfOutline := nil;
//render each broken line independently
setlength(FParagraphLayout, tl.ParagraphCount);
for paraIndex := 0 to tl.ParagraphCount-1 do
with FParagraphLayout[paraIndex] do
begin
startBrokenIndex := tl.ParagraphStartBrokenLine[paraIndex];
endBrokenIndex := tl.ParagraphEndBrokenLine[paraIndex];
setlength(FParagraphLayout[paraIndex].brokenLines, endBrokenIndex - startBrokenIndex);
for brokenIndex := startBrokenIndex to endBrokenIndex-1 do
with brokenLines[brokenIndex - startBrokenIndex] do
begin
redrawPen := hasPen and
(
(PenPhong and (penPhongChange or (penImageId = 0) or
not tempStorage.ObjectExists(inttostr(penImageId))) ) or
(not PenPhong and ((penMaskId = 0) or
not tempStorage.ObjectExists(inttostr(penMaskId))) )
);
redrawOutline := HasOutline and ((outlineMaskId = 0) or outlineWidthChange or
not tempStorage.ObjectExists(inttostr(outlineMaskId)) );
if redrawPen or redrawOutline then
ComputeBrokenLinesPath(brokenIndex, brokenIndex+1);
if redrawOutline then
begin
with brokenLineBoundsF do
brokenLineRectBounds := Rect(floor(Left - outlineRenderWidth/2),
floor(Top - outlineRenderWidth/2), ceil(Right + outlineRenderWidth/2),
ceil(Bottom + outlineRenderWidth/2));
tmpRenderRect := TRect.Intersect(brokenLineRectBounds, transfRect);
brokenRenderOfs := tmpRenderRect.TopLeft;
tmpBrokenMask := TGrayscaleMask.Create(tmpRenderRect.Width, tmpRenderRect.Height);
RenderOutlineMask(tmpBrokenMask, Point(-brokenRenderOfs.X, -brokenRenderOfs.Y));
RenderFromMask(tmpTransfOutline, brokenRenderOfs.X - transfRect.Left,
brokenRenderOfs.Y - transfRect.Top, tmpBrokenMask);
StoreMask(outlineMaskId, tmpBrokenMask, brokenRenderOfs);
tmpBrokenMask.Free;
end else
if HasOutline then
RenderFromStoredMask(tmpTransfOutline, outlineMaskId);
if redrawPen then
begin
if PenPhong then
begin
with brokenLineBoundsF do
brokenLineRectBounds := Rect(floor(Left), floor(Top), ceil(Right), ceil(Bottom));
tmpRenderRect := TRect.Intersect(brokenLineRectBounds, transfRect);
brokenRenderOfs := tmpRenderRect.TopLeft;
tmpBroken := TBGRAMemoryStreamBitmap.Create(tmpRenderRect.Width, tmpRenderRect.Height);
RenderPen(tmpBroken, Point(- brokenRenderOfs.X,
- brokenRenderOfs.Y));
StoreRGBAImage(penImageId, tmpBroken, brokenRenderOfs);
tmpBroken.Free;
end else
begin
with brokenLineBoundsF do
brokenLineRectBounds := Rect(floor(Left), floor(Top), ceil(Right), ceil(Bottom));
tmpRenderRect := TRect.Intersect(brokenLineRectBounds, transfRect);
brokenRenderOfs := tmpRenderRect.TopLeft;
tmpBrokenMask := TGrayscaleMask.Create(tmpRenderRect.Width, tmpRenderRect.Height);
RenderPenMask(tmpBrokenMask, Point(-brokenRenderOfs.X, -brokenRenderOfs.Y));
StoreMask(penMaskId, tmpBrokenMask, brokenRenderOfs);
tmpBrokenMask.Free;
end;
end;
end;
end;
tmpTransf := TBGRABitmap.Create(transfRect.Width, transfRect.Height);
if Assigned(tmpTransfOutline) then
begin
ApplyClipBox(tmpTransfOutline);
RenderFromMask(tmpTransf, 0, 0, tmpTransfOutline,
Point(-transfRect.Left, -transfRect.Top), OutlineFill);
tmpTransfOutline.Free;
end;
if hasPen then
for paraIndex := 0 to tl.ParagraphCount-1 do
with FParagraphLayout[paraIndex] do
begin
for brokenIndex := 0 to high(brokenLines) do
with brokenLines[brokenIndex] do
begin
if PenPhong then RenderFromStoredImage(tmpTransf, penImageId)
else RenderFromStoredMask(tmpTransf, penMaskId, PenFill);
end;
end;
end else
begin
tmpTransf := TBGRABitmap.Create(transfRect.Width, transfRect.Height);
RenderBrokenLines(tmpTransf, 0, tl.BrokenLineCount, Point(-transfRect.Left, -transfRect.Top));
//make list of temp files to keep
if Assigned(tempStorage) and Assigned(tempRenderNewList) then
for paraIndex := 0 to high(FParagraphLayout) do
with FParagraphLayout[paraIndex] do
for brokenIndex := 0 to high(brokenLines) do
with brokenLines[brokenIndex] do
begin
if hasPen then
begin
if not PenPhong and (penImageId <> 0) then
tempRenderNewList.Add(inttostr(penImageId));
if PenPhong and not penPhongChange and (penMaskId <> 0) then
tempRenderNewList.Add(inttostr(penMaskId));
end;
if HasOutline and (outlineMaskId <> 0) and not outlineWidthChange then
tempRenderNewList.Add(inttostr(outlineMaskId));
end;
end;
if Assigned(tempStorage) then
begin
//remove temp files that are obsolete
tempRenderCurList := TStringList.Create;
tempStorage.EnumerateObjects(tempRenderCurList);
for fileIdx := 0 to tempRenderCurList.Count-1 do
if tempRenderNewList.IndexOf(tempRenderCurList[fileIdx]) = -1 then
tempStorage.RemoveObject(tempRenderCurList[fileIdx]);
tempRenderCurList.Free;
tempStorage.AffineMatrix['last-matrix'] := AMatrix;
tempStorage.PointF['origin'] := Origin;
tempStorage.PointF['x-axis'] := XAxis;
tempStorage.PointF['y-axis'] := YAxis;
tempStorage.Float['em-height'] := FontEmHeight;
if HasOutline then
tempStorage.Float['outline-width'] := OutlineWidth
else tempStorage.RemoveAttribute('outline-width');
if PenPhong then
begin
phongObj := tempStorage.CreateObject('pen-phong');
phongObj.PointF['light-pos'] := LightPosition;
phongObj.Float['altitude-percent'] := AltitudePercent;
phongObj.Int['fill-iteration'] := FPenFillIteration;
phongObj.Free;
end else
tempStorage.RemoveObject('pen-phong');
end;
storage.Close;
tempRenderNewList.Free;
ApplyClipBox(tmpTransf);
ADest.PutImage(transfRect.Left, transfRect.Top, tmpTransf, dmDrawWithTransparency);
transfRect.Offset(-ARenderOffset.X,-ARenderOffset.Y);
if storeImage then UpdateRenderStorage(transfRect, tmpTransf)
else UpdateRenderStorage(transfRect);
tmpTransf.Free;
end;
function TTextShape.GetRenderBounds(ADestRect: TRect; AMatrix: TAffineMatrix;
AOptions: TRenderBoundsOptions): TRectF;
var
ab: TAffineBox;
u: TPointF;
lenU, margin: Single;
begin
if (GetPenVisible(rboAssumePenFill in AOptions) or HasOutline) and
(Text <> '') then
begin
ab := GetAffineBox(AMatrix, false);
//add margin for text that would be out of bound (for example italic j)
u := ab.TopRight-ab.TopLeft;
lenU := VectLen(u);
if lenU<>0 then u *= (1/lenU);
margin := FontEmHeight;
u *= margin;
ab.TopLeft -= u;
ab.TopRight += u;
ab.BottomLeft -= u;
result := ab.RectBoundsF;
end
else
result:= EmptyRectF;
end;
function TTextShape.PointInShape(APoint: TPointF): boolean;
begin
result := GetAffineBox(AffineMatrixIdentity,true).Contains(APoint);
end;
function TTextShape.PointInShape(APoint: TPointF; ARadius: single): boolean;
begin
result := false;
end;
function TTextShape.PointInPen(APoint: TPointF): boolean;
var
tl: TBidiTextLayout;
pt: TPointF;
i: Integer;
untransformed: TAffineMatrix;
begin
if not GetAffineBox(AffineMatrixIdentity,true).Contains(APoint) then
exit(false);
SetGlobalMatrix(AffineMatrixIdentity);
tl := GetTextLayout;
untransformed := GetUntransformedMatrix;
if not IsAffineMatrixInversible(untransformed) then exit(false);
pt := AffineMatrixInverse(untransformed)*APoint;
for i := 0 to tl.PartCount-1 do
if tl.PartAffineBox[i].Contains(pt) then exit(true);
result := false;
end;
function TTextShape.GetIsSlow(const AMatrix: TAffineMatrix): boolean;
begin
Result:= true;
end;
function TTextShape.GetGenericCost: integer;
begin
Result:= 10;
end;
procedure TTextShape.MouseMove(Shift: TShiftState; X, Y: single;
var ACursor: TOriginalEditorCursor; var AHandled: boolean);
begin
if FMouseSelecting then
begin
SelectWithMouse(X,Y, true);
ACursor := oecText;
AHandled:= true;
end else
begin
inherited MouseMove(Shift, X, Y, ACursor, AHandled);
if (ACursor = oecDefault) and PointInShape(PointF(X,Y)) then ACursor := oecText;
end;
end;
procedure TTextShape.MouseDown(RightButton: boolean; Shift: TShiftState; X,
Y: single; var ACursor: TOriginalEditorCursor; var AHandled: boolean);
begin
inherited MouseDown(RightButton, Shift, X, Y, ACursor, AHandled);
if not AHandled and not RightButton and PointInShape(PointF(X,Y)) then
begin
FMouseSelecting:= true;
SelectWithMouse(X,Y, ssShift in Shift);
AHandled:= true;
end;
if (ACursor = oecDefault) and PointInShape(PointF(X,Y)) then ACursor := oecText;
end;
procedure TTextShape.MouseUp(RightButton: boolean; Shift: TShiftState; X,
Y: single; var ACursor: TOriginalEditorCursor; var AHandled: boolean);
begin
if FMouseSelecting and not RightButton then
begin
FMouseSelecting:= false;
ACursor := oecText;
AHandled:= true;
end else
begin
inherited MouseUp(RightButton, Shift, X, Y, ACursor, AHandled);
if (ACursor = oecDefault) and PointInShape(PointF(X,Y)) then ACursor := oecText;
end;
end;
procedure TTextShape.KeyDown(Shift: TShiftState; Key: TSpecialKey;
var AHandled: boolean);
var
idxPara, newPos: Integer;
tl: TBidiTextLayout;
begin
if (FTextLayout = nil) or (Usermode <> vsuEditText) then exit;
if Key = skDelete then
begin
if FSelStart <> FSelEnd then DeleteSelection
else DeleteTextAfter(1);
AHandled:= true;
end else
if Key in [skLeft,skRight] then
begin
tl := GetTextLayout;
if (Key = skLeft) xor tl.ParagraphRightToLeft[tl.GetParagraphAt(FSelEnd)] then
begin
BeginEditingUpdate;
if FSelEnd > 0 then
Dec(FSelEnd, tl.IncludeNonSpacingCharsBefore(FSelEnd,1) );
if not (ssShift in Shift) then FSelStart := FSelEnd;
EndEditingUpdate;
end else
begin
BeginEditingUpdate;
if FSelEnd < tl.CharCount then
Inc(FSelEnd, tl.IncludeNonSpacingChars(FSelEnd,1) );
if not (ssShift in Shift) then FSelStart := FSelEnd;
EndEditingUpdate;
end;
AHandled := true;
end else
if Key in [skUp,skDown] then
begin
tl := GetTextLayout;
if Key = skUp then
newPos := tl.FindTextAbove(FSelEnd)
else
newPos := tl.FindTextBelow(FSelEnd);
if (newPos <> -1) or (not (ssShift in Shift) and (FSelStart <> FSelEnd)) then
begin
BeginEditingUpdate;
FSelEnd := newPos;
if not (ssShift in Shift) then FSelStart := FSelEnd;
EndEditingUpdate;
end;
AHandled:= true;
end else
if Key = skHome then
begin
tl := GetTextLayout;
BeginEditingUpdate;
if ssCtrl in Shift then
FSelEnd := 0
else
begin
idxPara := tl.GetParagraphAt(FSelEnd);
FSelEnd := tl.ParagraphStartIndex[idxPara];
end;
if not (ssShift in Shift) then FSelStart := FSelEnd;
EndEditingUpdate;
AHandled := true;
end else
if Key = skEnd then
begin
tl := GetTextLayout;
BeginEditingUpdate;
if ssCtrl in Shift then
FSelEnd := tl.CharCount
else
begin
idxPara := tl.GetParagraphAt(FSelEnd);
FSelEnd := tl.ParagraphEndIndexBeforeParagraphSeparator[idxPara];
end;
if not (ssShift in Shift) then FSelStart := FSelEnd;
EndEditingUpdate;
AHandled := true;
end else
if (Key = skReturn) and ([ssCtrl,ssShift] <= Shift) and FEnteringUnicode then
begin
InsertUnicodeValue;
AHandled:= true;
end else
if Key = skReturn then
begin
if ssShift in Shift then
InsertText(UnicodeCharToUTF8(UNICODE_LINE_SEPARATOR))
else
InsertText(#10);
AHandled := true;
end else
if Key = skTab then
begin
InsertText(#9);
AHandled := true;
end else
if (Key = skU) and ([ssCtrl,ssShift] <= Shift) then
begin
if FEnteringUnicode then InsertUnicodeValue;
FEnteringUnicode:= true;
FUnicodeValue:= 0;
FUnicodeDigitCount:= 0;
AHandled := true;
end else
if (Key in[sk0..sk9,skNum0..skNum9,skA..skF]) and ([ssCtrl,ssShift] <= Shift) and FEnteringUnicode then
begin
if FUnicodeDigitCount >= 8 then FEnteringUnicode:= false else
begin
FUnicodeValue := (FUnicodeValue shl 4);
case Key of
sk0..sk9: inc(FUnicodeValue, ord(Key)-ord(sk0));
skNum0..skNum9: inc(FUnicodeValue, ord(Key)-ord(sk0));
skA..skF: inc(FUnicodeValue, ord(Key)-ord(skA)+10);
end;
end;
end else
if (Key = skC) and (ssCtrl in Shift) then
begin
if CopySelection then AHandled:= true;
end else
if (Key = skX) and (ssCtrl in Shift) then
begin
if CutSelection then AHandled:= true;
end else
if (Key = skV) and (ssCtrl in Shift) then
begin
if PasteSelection then AHandled := true;
end else
if (Key = skA) and (ssCtrl in Shift) then
begin
BeginEditingUpdate;
FSelStart:= 0;
FSelEnd:= GetTextLayout.CharCount;
EndEditingUpdate;
AHandled := true;
end;
end;
procedure TTextShape.KeyPress(UTF8Key: string; var AHandled: boolean);
begin
if (Usermode = vsuEditText) and (UTF8Key = #8) then
begin
if FSelEnd <> FSelStart then DeleteSelection
else DeleteTextBefore(1);
AHandled := true;
end else
if UTF8Key >= ' ' then
begin
if Usermode <> vsuEditText then
begin
if Text = '' then
begin
Usermode := vsuEditText;
InsertText(UTF8Key);
end;
end else
InsertText(UTF8Key);
AHandled := true;
end;
end;
procedure TTextShape.KeyUp(Shift: TShiftState; Key: TSpecialKey;
var AHandled: boolean);
begin
if (Key in[skCtrl,skShift]) and FEnteringUnicode then
begin
InsertUnicodeValue;
AHandled := true;
end;
end;
procedure TTextShape.SetFontNameAndStyle(AFontName: string;
AFontStyle: TFontStyles);
begin
if (AFontName <> FFontName) or (AFontStyle <> FFontStyle) then
begin
BeginUpdate(TTextShapeFontDiff);
FFontName := AFontName;
FFontStyle:= AFontStyle;
EndUpdate;
end;
end;
function TTextShape.CopySelection: boolean;
var
stream: TStringStream;
begin
if HasSelection then
begin
stream := nil;
try
Clipboard.Clear;
stream := TStringStream.Create(GetTextLayout.CopyText(min(FSelStart,FSelEnd),abs(FSelEnd-FSelStart)));
Clipboard.SetFormat(PredefinedClipboardFormat(pcfText), stream);
finally
stream.Free;
end;
result := true;
end
else result := false;
end;
function TTextShape.CutSelection: boolean;
begin
result := CopySelection;
if result then DeleteSelection;
end;
function TTextShape.PasteSelection: boolean;
var
txt: String;
begin
if CanPasteSelection then
begin
txt := Clipboard.AsText;
txt := StringReplace(txt, #13#10, #10, [rfReplaceAll]);
txt := StringReplace(txt, #10#13, #10, [rfReplaceAll]);
txt := StringReplace(txt, #13, #10, [rfReplaceAll]);
txt := StringReplace(txt, UnicodeCharToUTF8(UNICODE_PARAGRAPH_SEPARATOR), #10, [rfReplaceAll]);
txt := StringReplace(txt, UnicodeCharToUTF8(UNICODE_NEXT_LINE), #10, [rfReplaceAll]);
InsertText(txt);
result := true;
end else
result := false;
end;
procedure TTextShape.Transform(const AMatrix: TAffineMatrix);
var
zoom: Single;
begin
BeginUpdate;
AddDiffHandler(TTextShapeFontDiff);
AddDiffHandler(TTextShapePhongDiff);
zoom := (VectLen(AMatrix[1,1],AMatrix[2,1])+VectLen(AMatrix[1,2],AMatrix[2,2]))/2;
FontEmHeight:= zoom*FontEmHeight;
LightPosition := AMatrix*LightPosition;
inherited Transform(AMatrix);
EndUpdate;
end;
class function TTextShape.StorageClassName: RawByteString;
begin
result := 'text';
end;
class function TTextShape.Usermodes: TVectorShapeUsermodes;
begin
Result:=inherited Usermodes + [vsuEditText];
end;
function TTextShape.AppendToSVG(AContent: TSVGContent; ADefs: TSVGDefine): TSVGElement;
var
topLeft, u, v: TPointF;
w, h, zoom: Single;
t: TSVGText;
tl: TBidiTextLayout;
i: Integer;
span: TSVGTSpan;
fm: TFontPixelMetric;
rF: TRectF;
penFillId, outlineFillId: String;
a: ArrayOfTFloatWithCSSUnit;
begin
topLeft := Origin - (XAxis - Origin) - (YAxis - Origin);
w := Width*2; h := Height*2;
result := AContent.AppendText(topLeft, '');
if (XAxis.y <> 0) or (YAxis.x <> 0) then
begin
u := XAxis - Origin;
if w > 0 then u *= (2/w);
v := YAxis - Origin;
if h > 0 then v *= (2/h);
result.matrix[cuPixel] := AffineMatrixTranslation(topLeft.X, topLeft.Y) *
AffineMatrix(u, v, PointF(0, 0)) *
AffineMatrixTranslation(-topLeft.X, -topLeft.Y);
end;
if PenVisible then
begin
if IsAffineMatrixInversible(result.Matrix[cuPixel]) then
penFillId := AppendVectorialFillToSVGDefs(PenFill,
AffineMatrixInverse(result.Matrix[cuPixel]), ADefs, 'fill')
else penFillId := '';
if penFillId <> '' then
result.fill := 'url(#' + penFillId + ')'
else result.fillColor := PenColor;
end
else result.fillNone;
if OutlineVisible then
begin
if IsAffineMatrixInversible(result.Matrix[cuPixel]) then
outlineFillId := AppendVectorialFillToSVGDefs(OutlineFill,
AffineMatrixInverse(result.Matrix[cuPixel]), ADefs, 'stroke')
else outlineFillId:= '';
if outlineFillId <> '' then
result.stroke := 'url(#' + outlineFillId + ')'
else result.strokeColor := OutlineFill.AverageColor;
result.strokeWidth := FloatWithCSSUnit(OutlineWidth, cuCustom);
result.strokeLineJoinLCL:= pjsRound;
result.paintOrder:= spoStrokeFillMarkers;
end else
result.strokeNone;
t := TSVGText(result);
t.fontStyleLCL:= FontStyle;
t.fontSize := FloatWithCSSUnit(FontEmHeight, cuPixel);
t.fontFamily:= FontName;
SetGlobalMatrix(AffineMatrixIdentity);
zoom := GetTextRenderZoom;
tl := GetTextLayout;
fm := tl.FontRenderer.GetFontPixelMetric;
for i := 0 to tl.PartCount-1 do
begin
rF := tl.PartRectF[i];
if rF.IsEmpty then continue;
rF.OffseT(topLeft.x, topLeft.y);
span := t.Content.AppendTextSpan(tl.GetTextPart(i, true));
if tl.PartRightToLeft[i] then
span.textDirection:= stdRtl
else span.textDirection:= stdLtr;
with rF do
begin
setlength(a, 1);
a[0] := FloatWithCSSUnit(Left/zoom, cuCustom);
span.x := a;
a[0] := FloatWithCSSUnit((Top + fm.Baseline)/zoom, cuCustom);
span.y := a;
span.textLength := FloatWithCSSUnit(Width/zoom, cuCustom);
end;
end;
end;
initialization
RegisterVectorShape(TTextShape);
end.
./lazpaint-7.1.6/lazpaintcontrols/lcvectororiginal.pas 0000664 0001750 0001750 00000351611 13761713342 023377 0 ustar circular circular // SPDX-License-Identifier: GPL-3.0-only
unit LCVectorOriginal;
{$mode objfpc}{$H+}
{$modeswitch advancedrecords}
interface
uses
Classes, SysUtils, BGRABitmap, BGRALayerOriginal, fgl, BGRAGradientOriginal, BGRABitmapTypes,
BGRAPen, LCVectorialFill, LCResourceString, BGRASVGShapes, BGRASVGType,
BGRASVG, BGRAUnits;
const
InfiniteRect : TRect = (Left: -MaxLongInt; Top: -MaxLongInt; Right: MaxLongInt; Bottom: MaxLongInt);
EmptyTextureId = 0;
DefaultShapeOutlineWidth = 2;
MediumShapeCost = 100;
//not translated because unexpected internal errors are not useful for users
errDuplicateVectorClass = 'Duplicate class name "%1" for vector shape';
errMergeNotAllowed = 'Merge not allowed';
errCannotBeComputedFromShape = 'Cannot be computed from shape';
errFillFieldMismatch = 'Fill field mismatch';
errInvalidStoredPointer = 'Invalid stored pointer';
errUndefinedContainer = 'Undefined container';
errContainerAlreadyAssigned = 'Container already assigned';
errDiffHandlerOnlyDuringUpdate = 'Diff handler expected only between BeginUpdate and EndUpdate';
errUnexpectedNil = 'Unexpected nil value';
errContainerMismatch = 'Container mismatch';
errAlreadyRemovingShape = 'Already removing shape';
errUnableToFindTexture = 'Unable to find texture';
errErrorLoadingShape = 'Error loading shape';
type
TVectorOriginal = class;
ArrayOfBGRABitmap = array of TBGRABitmap;
TVectorShapeDiff = class;
TShapeChangeEvent = procedure(ASender: TObject; ABounds: TRectF; ADiff: TVectorShapeDiff) of object;
TShapeEditingChangeEvent = procedure(ASender: TObject) of object;
TShapeRemoveQuery = procedure(ASender: TObject; var AHandled: boolean) of object;
TRenderBoundsOption = (rboAssumePenFill, rboAssumeBackFill);
TRenderBoundsOptions = set of TRenderBoundsOption;
TVectorShapeField = (vsfPenFill, vsfPenWidth, vsfPenStyle, vsfJoinStyle, vsfBackFill, vsfOutlineFill, vsfOutlineWidth);
TVectorShapeFields = set of TVectorShapeField;
TVectorShapeUsermode = (vsuEdit, vsuCreate, vsuEditPenFill, vsuEditBackFill, vsuEditOutlineFill,
vsuCurveSetAuto, vsuCurveSetCurve, vsuCurveSetAngle,
vsuEditText);
TVectorShapeUsermodes = set of TVectorShapeUsermode;
TVectorShape = class;
TVectorShapes = specialize TFPGList;
{ TVectorShapeDiff }
TVectorShapeDiff = class
constructor Create(AStartShape: TVectorShape); virtual; abstract;
procedure ComputeDiff(AEndShape: TVectorShape); virtual; abstract;
procedure Apply(AStartShape: TVectorShape); virtual; abstract;
procedure Unapply(AEndShape: TVectorShape); virtual; abstract;
function CanAppend(ADiff: TVectorShapeDiff): boolean; virtual;
procedure Append(ADiff: TVectorShapeDiff); virtual; abstract;
function IsIdentity: boolean; virtual; abstract;
end;
TCustomMultiSelectionDiff = class(TVectorShapeDiff)
protected
function GetShapeCount: integer; virtual; abstract;
function GetShapeId(AIndex: integer): integer; virtual; abstract;
public
property ShapeCount: integer read GetShapeCount;
property ShapeId[AIndex: integer]: integer read GetShapeId;
end;
TVectorShapeDiffList = specialize TFPGList;
TVectorShapeDiffAny = class of TVectorShapeDiff;
{ TVectorShapeComposedDiff }
TVectorShapeComposedDiff = class(TVectorShapeDiff)
protected
FDiffs: array of TVectorShapeDiff;
public
constructor Create(ADiffs: TVectorShapeDiffList);
constructor Create(ADiffs: array of TVectorShapeDiff);
constructor Create({%H-}AStartShape: TVectorShape); override;
destructor Destroy; override;
procedure ComputeDiff({%H-}AEndShape: TVectorShape); override;
procedure Apply(AStartShape: TVectorShape); override;
procedure Unapply(AEndShape: TVectorShape); override;
function CanAppend(ADiff: TVectorShapeDiff): boolean; override;
procedure Append(ADiff: TVectorShapeDiff); override;
function IsIdentity: boolean; override;
function GetMultiselection: TCustomMultiSelectionDiff;
end;
{ TVectorShapeEmbeddedFillDiff }
TVectorShapeEmbeddedFillDiff = class(TVectorShapeDiff)
protected
FField: TVectorShapeField;
FFillDiff: TCustomVectorialFillDiff;
public
constructor Create(AField: TVectorShapeField; AFillDiff: TCustomVectorialFillDiff);
constructor Create({%H-}AStartShape: TVectorShape); override;
destructor Destroy; override;
procedure ComputeDiff({%H-}AEndShape: TVectorShape); override;
procedure Apply(AStartShape: TVectorShape); override;
procedure Unapply(AEndShape: TVectorShape); override;
function CanAppend(ADiff: TVectorShapeDiff): boolean; override;
procedure Append(ADiff: TVectorShapeDiff); override;
function IsIdentity: boolean; override;
end;
{ TVectorShapeCommonDiff }
TVectorShapeCommonDiff = class(TVectorShapeDiff)
protected
FStartPenWidth: single;
FStartPenStyle: TBGRAPenStyle;
FStartOutlineWidth: single;
FStartJoinStyle: TPenJoinStyle;
FEndPenWidth: single;
FEndPenStyle: TBGRAPenStyle;
FEndOutlineWidth: single;
FEndJoinStyle: TPenJoinStyle;
public
constructor Create(AStartShape: TVectorShape); override;
procedure ComputeDiff(AEndShape: TVectorShape); override;
procedure Apply(AStartShape: TVectorShape); override;
procedure Unapply(AEndShape: TVectorShape); override;
procedure Append(ADiff: TVectorShapeDiff); override;
function IsIdentity: boolean; override;
end;
{ TVectorShapeCommonFillDiff }
TVectorShapeCommonFillDiff = class(TVectorShapeDiff)
protected
FStartPenFill: TVectorialFill;
FStartBackFill: TVectorialFill;
FStartOutlineFill: TVectorialFill;
FEndPenFill: TVectorialFill;
FEndBackFill: TVectorialFill;
FEndOutlineFill: TVectorialFill;
public
constructor Create(AStartShape: TVectorShape); override;
destructor Destroy; override;
procedure ComputeDiff(AEndShape: TVectorShape); override;
procedure Apply(AStartShape: TVectorShape); override;
procedure Unapply(AEndShape: TVectorShape); override;
procedure Append(ADiff: TVectorShapeDiff); override;
function IsIdentity: boolean; override;
end;
IVectorMultishape = interface
procedure ClearShapes;
procedure AddShape(AShape: TVectorShape);
procedure RemoveShape(AShape: TVectorShape);
function ContainsShape(AShape: TVectorShape): boolean;
function ShapeCount: integer;
function GetShape(AIndex: integer): TVectorShape;
function SetShapes(AShapes: TVectorShapes): boolean;
function FrontShape: TVectorShape;
function BackShape: TVectorShape;
procedure SetOnSelectionChange(AHandler: TNotifyEvent);
function GetOnSelectionChange: TNotifyEvent;
end;
{ TShapeRenderStorage }
TShapeRenderStorage = object
persistent, temporary: TBGRACustomOriginalStorage;
class function OpenOrCreate(ARenderStorage: TBGRACustomOriginalStorage; AShapeId: integer): TShapeRenderStorage; static;
class function Open(ARenderStorage: TBGRACustomOriginalStorage; AShapeId: integer): TShapeRenderStorage; static;
class procedure Discard(ARenderStorage: TBGRACustomOriginalStorage; AShapeId: integer); static;
class function None: TShapeRenderStorage; static;
function IsOpened: boolean;
procedure Close;
end;
{ TVectorShape }
TVectorShape = class
private
FId: integer;
FOnRemoveQuery: TShapeRemoveQuery;
FRenderIteration: integer; // increased at each BeginUpdate
FOnChange: TShapeChangeEvent;
FOnEditingChange: TShapeEditingChangeEvent;
FTemporaryStorage: TBGRACustomOriginalStorage;
FUpdateCount, FUpdateEditingCount: integer;
FBoundsBeforeUpdate: TRectF;
FPenFill, FBackFill, FOutlineFill: TVectorialFill;
FStoreTexturePointer: boolean;
FStroker: TBGRAPenStroker;
FUsermode: TVectorShapeUsermode;
FContainer: TVectorOriginal;
FRemoving: boolean;
FDiffs: TVectorShapeDiffList;
FFillBeforeChangeBounds: TRectF;
function GetIsUpdating: boolean;
procedure SetContainer(AValue: TVectorOriginal);
function GetFill(var AFillVariable: TVectorialFill): TVectorialFill;
procedure SetFill(var AFillVariable: TVectorialFill; AValue: TVectorialFill; AUpdate: boolean);
procedure SetId(AValue: integer);
protected
FPenWidth: single;
FOutlineWidth: single;
FFillChangeWithoutUpdate: boolean;
procedure BeginEditingUpdate;
procedure EndEditingUpdate;
procedure DoOnChange(ABoundsBefore: TRectF; ADiff: TVectorShapeDiff); virtual;
function GetIsBack: boolean; virtual;
function GetIsFront: boolean; virtual;
function GetPenColor: TBGRAPixel; virtual;
function GetPenWidth: single; virtual;
function GetPenStyle: TBGRAPenStyle; virtual;
function GetJoinStyle: TPenJoinStyle;
function GetBackFill: TVectorialFill; virtual;
function GetPenFill: TVectorialFill; virtual;
function GetOutlineFill: TVectorialFill; virtual;
function GetOutlineWidth: single; virtual;
procedure SetPenColor(AValue: TBGRAPixel); virtual;
procedure SetPenWidth(AValue: single); virtual;
procedure SetPenStyle({%H-}AValue: TBGRAPenStyle); virtual;
procedure SetJoinStyle(AValue: TPenJoinStyle); virtual;
procedure SetBackFill(AValue: TVectorialFill); virtual;
procedure SetPenFill(AValue: TVectorialFill); virtual;
procedure SetOutlineFill(AValue: TVectorialFill); virtual;
procedure SetOutlineWidth(AValue: single); virtual;
procedure SetUsermode(AValue: TVectorShapeUsermode); virtual;
function LoadTexture(AStorage: TBGRACustomOriginalStorage; AName: string): TBGRABitmap;
procedure SaveTexture(AStorage: TBGRACustomOriginalStorage; AName: string; AValue: TBGRABitmap);
procedure LoadFill(AStorage: TBGRACustomOriginalStorage; AObjectName: string; var AValue: TVectorialFill);
procedure SaveFill(AStorage: TBGRACustomOriginalStorage; AObjectName: string; AValue: TVectorialFill);
function ComputeStroke(APoints: ArrayOfTPointF; AClosed: boolean; AStrokeMatrix: TAffineMatrix): ArrayOfTPointF; virtual;
function ComputeStrokeEnvelope(APoints: ArrayOfTPointF; AClosed: boolean; AWidth: single): ArrayOfTPointF; virtual;
function GetStroker: TBGRAPenStroker;
procedure FillChange({%H-}ASender: TObject; var ADiff: TCustomVectorialFillDiff); virtual;
procedure FillBeforeChange({%H-}ASender: TObject); virtual;
function OpenRenderStorage(ACreateIfNecessary: boolean): TShapeRenderStorage;
procedure UpdateRenderStorage(ARenderBounds: TRect; AImage: TBGRACustomBitmap = nil);
procedure DiscardRenderStorage;
procedure RetrieveRenderStorage(AMatrix: TAffineMatrix; out ARenderBounds: TRect; out AImage: TBGRABitmap);
function CanHaveRenderStorage: boolean;
function AddDiffHandler(AClass: TVectorShapeDiffAny): TVectorShapeDiff;
procedure AddFillDiffHandler(AFill: TVectorialFill; ADiff: TCustomVectorialFillDiff);
function GetDiffHandler(AClass: TVectorShapeDiffAny): TVectorShapeDiff;
function GetIsFollowingMouse: boolean; virtual;
function GetPenVisible(AAssumePenFill: boolean = False): boolean; virtual;
function GetPenVisibleNow: boolean;
function GetBackVisible: boolean; virtual;
function GetOutlineVisible: boolean; virtual;
function AppendVectorialFillToSVGDefs(AFill: TVectorialFill; const AMatrix: TAffineMatrix;
ADefs: TSVGDefine; ANamePrefix: string): string;
procedure ApplyStrokeStyleToSVG(AElement: TSVGElement; ADefs: TSVGDefine);
procedure ApplyFillStyleToSVG(AElement: TSVGElement; ADefs: TSVGDefine);
property Stroker: TBGRAPenStroker read GetStroker;
public
constructor Create(AContainer: TVectorOriginal); virtual;
class function CreateFromStorage(AStorage: TBGRACustomOriginalStorage; AContainer: TVectorOriginal): TVectorShape;
destructor Destroy; override;
function AppendToSVG(AContent: TSVGContent; ADefs: TSVGDefine): TSVGElement; virtual; abstract;
procedure BeginUpdate(ADiffHandler: TVectorShapeDiffAny=nil); virtual;
procedure EndUpdate; virtual;
procedure FillFit;
procedure QuickDefine(constref APoint1,APoint2: TPointF); virtual; abstract;
//one of the two Render functions must be overriden
procedure Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix; ADraft: boolean); overload; virtual;
procedure Render(ADest: TBGRABitmap; ARenderOffset: TPoint; AMatrix: TAffineMatrix; ADraft: boolean); overload; virtual;
function GetRenderBounds(ADestRect: TRect; AMatrix: TAffineMatrix; AOptions: TRenderBoundsOptions = []): TRectF; virtual; abstract;
function SuggestGradientBox(AMatrix: TAffineMatrix): TAffineBox; virtual;
function PointInShape(APoint: TPointF): boolean; overload; virtual; abstract;
function PointInShape(APoint: TPointF; ARadius: single): boolean; overload; virtual; abstract;
function PointInBack(APoint: TPointF): boolean; overload; virtual;
function PointInPen(APoint: TPointF): boolean; overload; virtual;
procedure ConfigureCustomEditor(AEditor: TBGRAOriginalEditor); virtual; abstract;
procedure ConfigureEditor(AEditor: TBGRAOriginalEditor); virtual;
procedure LoadFromStorage(AStorage: TBGRACustomOriginalStorage); virtual;
procedure SaveToStorage(AStorage: TBGRACustomOriginalStorage); virtual;
procedure MouseMove({%H-}Shift: TShiftState; {%H-}X, {%H-}Y: single; var {%H-}ACursor: TOriginalEditorCursor; var {%H-}AHandled: boolean); virtual;
procedure MouseDown({%H-}RightButton: boolean; {%H-}Shift: TShiftState; {%H-}X, {%H-}Y: single; var {%H-}ACursor: TOriginalEditorCursor; var {%H-}AHandled: boolean); virtual;
procedure MouseUp({%H-}RightButton: boolean; {%H-}Shift: TShiftState; {%H-}X, {%H-}Y: single; var {%H-}ACursor: TOriginalEditorCursor; var {%H-}AHandled: boolean); virtual;
procedure KeyDown({%H-}Shift: TShiftState; {%H-}Key: TSpecialKey; var {%H-}AHandled: boolean); virtual;
procedure KeyUp({%H-}Shift: TShiftState; {%H-}Key: TSpecialKey; var {%H-}AHandled: boolean); virtual;
procedure KeyPress({%H-}UTF8Key: string; var {%H-}AHandled: boolean); virtual;
procedure BringToFront; virtual;
procedure SendToBack; virtual;
procedure MoveUp(APassNonIntersectingShapes: boolean); virtual;
procedure MoveDown(APassNonIntersectingShapes: boolean); virtual;
procedure Remove;
procedure AlignHorizontally(AAlign: TAlignment; const AMatrix: TAffineMatrix; const ABounds: TRect); virtual;
procedure AlignVertically(AAlign: TTextLayout; const AMatrix: TAffineMatrix; const ABounds: TRect); virtual;
function GetAlignBounds(const ALayoutRect: TRect; const AMatrix: TAffineMatrix): TRectF; virtual;
procedure AlignTransform(const AMatrix: TAffineMatrix); virtual;
function Duplicate: TVectorShape;
class function StorageClassName: RawByteString; virtual; abstract;
function GetIsSlow(const {%H-}AMatrix: TAffineMatrix): boolean; virtual;
function GetGenericCost: integer; virtual;
function GetUsedTextures: ArrayOfBGRABitmap; virtual;
function GetAsMultishape: IVectorMultishape; virtual;
procedure Transform(const AMatrix: TAffineMatrix); virtual;
procedure TransformFrame(const AMatrix: TAffineMatrix); virtual; abstract;
procedure TransformFill(const AMatrix: TAffineMatrix; ABackOnly: boolean); virtual;
function AllowShearTransform: boolean; virtual;
function MultiFields: TVectorShapeFields; virtual;
class function Fields: TVectorShapeFields; virtual;
class function Usermodes: TVectorShapeUsermodes; virtual;
function MultiUsermodes: TVectorShapeUsermodes; virtual;
class function PreferPixelCentered: boolean; virtual;
class function CreateEmpty: boolean; virtual; //create shape even if empty?
property OnChange: TShapeChangeEvent read FOnChange write FOnChange;
property OnEditingChange: TShapeEditingChangeEvent read FOnEditingChange write FOnEditingChange;
property OnRemoveQuery: TShapeRemoveQuery read FOnRemoveQuery write FOnRemoveQuery;
property PenColor: TBGRAPixel read GetPenColor write SetPenColor;
property PenFill: TVectorialFill read GetPenFill write SetPenFill;
property BackFill: TVectorialFill read GetBackFill write SetBackFill;
property OutlineFill: TVectorialFill read GetOutlineFill write SetOutlineFill;
property PenWidth: single read GetPenWidth write SetPenWidth;
property PenStyle: TBGRAPenStyle read GetPenStyle write SetPenStyle;
property OutlineWidth: single read GetOutlineWidth write SetOutlineWidth;
property JoinStyle: TPenJoinStyle read GetJoinStyle write SetJoinStyle;
property Usermode: TVectorShapeUsermode read FUsermode write SetUsermode;
property Container: TVectorOriginal read FContainer write SetContainer;
property TemporaryStorage: TBGRACustomOriginalStorage read FTemporaryStorage write FTemporaryStorage;
property IsFront: boolean read GetIsFront;
property IsBack: boolean read GetIsBack;
property IsRemoving: boolean read FRemoving;
property Id: integer read FId write SetId;
property IsFollowingMouse: boolean read GetIsFollowingMouse;
property IsUpdating: boolean read GetIsUpdating;
property BackVisible: boolean read GetBackVisible;
property PenVisible: boolean read GetPenVisibleNow;
property OutlineVisible: boolean read GetOutlineVisible;
end;
TVectorShapeAny = class of TVectorShape;
TVectorOriginalSelectShapeEvent = procedure(ASender: TObject; AShape: TVectorShape; APreviousShape: TVectorShape) of object;
{ TVectorOriginalShapeDiff }
TVectorOriginalShapeDiff = class(TBGRAOriginalDiff)
protected
FShapeIndex: integer;
FShapeDiff: TVectorShapeDiff;
function GetShape(AOriginal: TBGRALayerCustomOriginal): TVectorShape;
public
constructor Create(AShapeIndex: integer; AShapeDiff: TVectorShapeDiff);
destructor Destroy; override;
procedure Apply(AOriginal: TBGRALayerCustomOriginal); override;
procedure Unapply(AOriginal: TBGRALayerCustomOriginal); override;
function CanAppend(ADiff: TBGRAOriginalDiff): boolean; override;
procedure Append(ADiff: TBGRAOriginalDiff); override;
function IsIdentity: boolean; override;
end;
{ TVectorOriginalShapeRangeDiff }
TVectorOriginalShapeRangeDiff = class(TBGRAOriginalDiff)
protected
FRangeStart: integer;
FShapesBefore, FShapesAfter: TVectorShapes;
FSelectedShapeBefore, FSelectedShapeAfter: integer;
public
constructor Create(ARangeStart: integer; AShapesBefore, AShapesAfter: TVectorShapes;
ASelectedShapeBefore, ASelectedShapeAfter: integer);
destructor Destroy; override;
procedure Apply(AOriginal: TBGRALayerCustomOriginal); override;
procedure Unapply(AOriginal: TBGRALayerCustomOriginal); override;
function CanAppend({%H-}ADiff: TBGRAOriginalDiff): boolean; override;
procedure Append({%H-}ADiff: TBGRAOriginalDiff); override;
function IsIdentity: boolean; override;
end;
{ TVectorOriginalMoveShapeToIndexDiff }
TVectorOriginalMoveShapeToIndexDiff = class(TBGRAOriginalDiff)
protected
FFromIndex,FToIndex: array of integer;
FShapeCount: integer;
procedure InternalMove(AOriginal: TBGRALayerCustomOriginal; AFromIndex,AToIndex: array of integer; ASendDiff: boolean);
public
constructor Create(AFromIndex,AToIndex: array of integer);
procedure Apply(AOriginal: TBGRALayerCustomOriginal); overload; override;
procedure Apply(AOriginal: TBGRALayerCustomOriginal; ASendDiff: boolean); overload;
procedure Unapply(AOriginal: TBGRALayerCustomOriginal); override;
function CanAppend(ADiff: TBGRAOriginalDiff): boolean; override;
procedure Append(ADiff: TBGRAOriginalDiff); override;
function IsIdentity: boolean; override;
end;
TVectorOriginalEditor = class;
{ TVectorOriginal }
TVectorOriginal = class(TBGRALayerCustomOriginal)
private
procedure MultiSelection_SelectionChange(Sender: TObject);
protected
FShapes: TVectorShapes;
FDeletedShapes: TVectorShapes;
FSelectedShape: TVectorShape;
FMultiselection: TVectorShape;
FFrozenShapesUnderSelection,
FFrozenShapesOverSelection: TBGRABitmap;
FFrozenShapesUnderBounds,
FFrozenShapesOverBounds: TRect;
FFrozenShapesRenderOffset: TPoint;
FFrozenShapesComputed: boolean;
FFrozenShapeMatrix: TAffineMatrix;
FUnfrozenRangeStart, FUnfrozenRangeEnd: integer;
FOnSelectShape: TVectorOriginalSelectShapeEvent;
FTextures: array of record
Bitmap: TBGRABitmap;
Id, Counter: integer;
end;
FTextureCount: integer;
FLastTextureId: integer;
FLastShapeId: integer;
procedure FreeDeletedShapes;
procedure OnShapeChange(ASender: TObject; ABounds: TRectF; ADiff: TVectorShapeDiff);
procedure OnShapeEditingChange({%H-}ASender: TObject);
procedure DiscardFrozenShapes;
function GetShape(AIndex: integer): TVectorShape;
function GetTextureId(ABitmap: TBGRABitmap): integer;
function IndexOfTexture(AId: integer): integer;
procedure AddTextureWithId(ATexture: TBGRABitmap; AId: integer);
procedure ClearTextures;
function GetShapeCount: integer;
function OpenShapeRenderStorage(AShapeIndex: integer; ACreate: boolean): TBGRACustomOriginalStorage;
procedure DiscardUnusedRenderStorage;
function InternalInsertShape(AShape: TVectorShape; AIndex: integer): TRectF;
function InternalInsertShapeRange(AShapes: TVectorShapes; AIndex: integer): TRectF;
function InternalDeleteShapeRange(AStartIndex,ACount: integer): TRectF;
function GetNewShapeId: integer;
public
constructor Create; override;
destructor Destroy; override;
procedure Clear;
function ConvertToSVG(const AMatrix: TAffineMatrix; out AOffset: TPoint): TObject; override;
function AddTexture(ATexture: TBGRABitmap): integer;
function GetTexture(AId: integer): TBGRABitmap;
procedure DiscardUnusedTextures;
function AddShape(AShape: TVectorShape): integer; overload;
function AddShape(AShape: TVectorShape; AUsermode: TVectorShapeUsermode): integer; overload;
function AddShapes(AShapes: TVectorShapes): integer;
procedure InsertShape(AShape: TVectorShape; AIndex: integer);
procedure InsertShapes(AShapes: TVectorShapes; AIndex: integer);
function RemoveShape(AShape: TVectorShape): boolean;
procedure DeleteShape(AIndex: integer);
procedure DeleteShapeRange(AStartIndex,ACount: integer);
procedure ReplaceShape(AIndex: integer; ANewShape: TVectorShape);
procedure ReplaceShapeRange(AStartIndex: integer; ACountBefore: integer; ANewShapes: TVectorShapes);
function SelectShapes(AShapes: TVectorShapes): boolean;
function SelectShape(AIndex: integer; AToggle: boolean = false): boolean; overload;
function SelectShape(AShape: TVectorShape; AToggle: boolean = false): boolean; overload;
function DeselectShapes: boolean;
procedure DeselectShape(AIndex: integer); overload;
procedure DeselectShape(AShape: TVectorShape); overload;
function GetShapesCost: integer;
function PreferDraftMode(AEditor: TBGRAOriginalEditor; const AMatrix: TAffineMatrix): boolean;
function MouseClick(APoint: TPointF; ARadius: single; AToggle: boolean): boolean;
procedure Render(ADest: TBGRABitmap; ARenderOffset: TPoint; AMatrix: TAffineMatrix; ADraft: boolean); override;
procedure ConfigureEditor(AEditor: TBGRAOriginalEditor); override;
function CreateEditor: TBGRAOriginalEditor; override;
function GetRenderBounds(ADestRect: TRect; {%H-}AMatrix: TAffineMatrix): TRect; overload; override;
function GetRenderBounds(ADestRect: TRect; {%H-}AMatrix: TAffineMatrix; AStartIndex, AEndIndex: integer): TRect; overload;
function GetAlignBounds(ADestRect: TRect; {%H-}AMatrix: TAffineMatrix): TRect;
procedure LoadFromStorage(AStorage: TBGRACustomOriginalStorage); override;
procedure SaveToStorage(AStorage: TBGRACustomOriginalStorage); override;
function IndexOfShape(AShape: TVectorShape): integer;
function FindShapeById(AId: integer): TVectorShape;
procedure MoveShapeToIndex(AFromIndex, AToIndex: integer); overload;
procedure MoveShapeToIndex(AFromIndex, AToIndex: array of integer); overload;
class function StorageClassName: RawByteString; override;
class function CanConvertToSVG: boolean; override;
property OnSelectShape: TVectorOriginalSelectShapeEvent read FOnSelectShape write FOnSelectShape;
property SelectedShape: TVectorShape read FSelectedShape;
property ShapeCount: integer read GetShapeCount;
property Shape[AIndex: integer]: TVectorShape read GetShape;
end;
{ TVectorOriginalEditor }
TVectorOriginalEditor = class(TBGRAOriginalEditor)
protected
FOriginal: TVectorOriginal;
FLabels: array of record
Coord: TPointF;
Text: string;
HorizAlign: TAlignment;
VertAlign: TTextLayout;
Padding: integer;
end;
function NiceText(ADest: TBGRABitmap; x, y: integer; const ALayoutRect: TRect;
AText: string; AHorizAlign: TAlignment; AVertAlign: TTextLayout;
APadding: integer): TRect;
public
constructor Create(AOriginal: TVectorOriginal);
procedure Clear; override;
function Render(ADest: TBGRABitmap; const ALayoutRect: TRect): TRect; override;
function GetRenderBounds(const ALayoutRect: TRect): TRect; override;
procedure AddLabel(const ACoord: TPointF; AText: string; AHorizAlign: TAlignment; AVertAlign: TTextLayout);
procedure AddLabel(APointIndex: integer; AText: string; AHorizAlign: TAlignment; AVertAlign: TTextLayout);
procedure MouseMove(Shift: TShiftState; ViewX, ViewY: single; out ACursor: TOriginalEditorCursor; out AHandled: boolean); override;
procedure MouseDown(RightButton: boolean; Shift: TShiftState; ViewX, ViewY: single; out ACursor: TOriginalEditorCursor; out AHandled: boolean); override;
procedure MouseUp(RightButton: boolean; {%H-}Shift: TShiftState; {%H-}ViewX, {%H-}ViewY: single; out ACursor: TOriginalEditorCursor; out AHandled: boolean); override;
procedure KeyDown(Shift: TShiftState; Key: TSpecialKey; out AHandled: boolean); override;
procedure KeyUp(Shift: TShiftState; Key: TSpecialKey; out AHandled: boolean); override;
procedure KeyPress(UTF8Key: string; out AHandled: boolean); override;
end;
function MatrixForPixelCentered(const AMatrix: TAffineMatrix): TAffineMatrix;
procedure RegisterVectorShape(AClass: TVectorShapeAny);
function GetVectorShapeByStorageClassName(AName: string): TVectorShapeAny;
var
VectorMultiselectionFactory: TVectorShapeAny;
implementation
uses math, BGRATransform, BGRAFillInfo, BGRAGraphics, BGRAPath, Types,
BGRAText, BGRATextFX, BGRALayers;
function MatrixForPixelCentered(const AMatrix: TAffineMatrix): TAffineMatrix;
begin
result := AffineMatrixTranslation(-0.5,-0.5) * AMatrix * AffineMatrixTranslation(0.5,0.5);
end;
var
VectorShapeClasses: array of TVectorShapeAny;
function GetVectorShapeByStorageClassName(AName: string): TVectorShapeAny;
var
i: Integer;
begin
for i := 0 to high(VectorShapeClasses) do
if VectorShapeClasses[i].StorageClassName = AName then exit(VectorShapeClasses[i]);
exit(nil);
end;
procedure RegisterVectorShape(AClass: TVectorShapeAny);
var
i: Integer;
begin
for i := 0 to high(VectorShapeClasses) do
if VectorShapeClasses[i]=AClass then exit;
if Assigned(GetVectorShapeByStorageClassName(AClass.StorageClassName)) then
raise exception.Create(StringReplace(errDuplicateVectorClass, '%1', AClass.StorageClassName, []));
setlength(VectorShapeClasses, length(VectorShapeClasses)+1);
VectorShapeClasses[high(VectorShapeClasses)] := AClass;
end;
{ TVectorOriginalMoveShapeToIndexDiff }
type
TMovedShape = record
shape: TVectorShape;
targetIndex: integer;
class operator =(const ms1, ms2: TMovedShape): boolean;
end;
{ TShapeRenderStorage }
class function TShapeRenderStorage.OpenOrCreate(ARenderStorage: TBGRACustomOriginalStorage; AShapeId: integer): TShapeRenderStorage;
begin
result.persistent := ARenderStorage.OpenObject(inttostr(AShapeId));
if result.persistent = nil then
result.persistent := ARenderStorage.CreateObject(inttostr(AShapeId));
result.temporary := result.persistent.OpenObject(RenderTempSubDirectory);
if result.temporary = nil then
result.temporary := result.persistent.CreateObject(RenderTempSubDirectory);
end;
class function TShapeRenderStorage.Open(
ARenderStorage: TBGRACustomOriginalStorage; AShapeId: integer): TShapeRenderStorage;
begin
result.persistent := ARenderStorage.OpenObject(inttostr(AShapeId));
if Assigned(result.persistent) then
result.temporary := result.persistent.OpenObject(RenderTempSubDirectory)
else
result.temporary := nil;
end;
class procedure TShapeRenderStorage.Discard(
ARenderStorage: TBGRACustomOriginalStorage; AShapeId: integer);
begin
ARenderStorage.RemoveObject(inttostr(AShapeId));
end;
class function TShapeRenderStorage.None: TShapeRenderStorage;
begin
result.persistent := nil;
result.temporary := nil;
end;
function TShapeRenderStorage.IsOpened: boolean;
begin
result := (persistent <> nil) or (temporary <> nil);
end;
procedure TShapeRenderStorage.Close;
var
freeTemp: Boolean;
begin
if Assigned(temporary) then
begin
freeTemp := temporary.Empty;
FreeAndNil(temporary);
if freeTemp and Assigned(persistent) then persistent.RemoveObject(RenderTempSubDirectory);
end;
FreeAndNil(persistent);
end;
class operator TMovedShape.=(const ms1, ms2: TMovedShape): boolean;
begin
result := (ms1.shape = ms2.shape) and (ms1.targetIndex = ms2.targetIndex);
end;
function CompareMovedShapeTargetIndex(const ms1, ms2: TMovedShape): integer;
begin
result := ms1.targetIndex - ms2.targetIndex;
end;
procedure TVectorOriginalMoveShapeToIndexDiff.InternalMove(AOriginal: TBGRALayerCustomOriginal; AFromIndex,
AToIndex: array of integer; ASendDiff: boolean);
type
TMovedShapeList = specialize TFPGList;
var
movedShapes: TMovedShapeList;
ms: TMovedShape;
r: TRectF;
i: Integer;
orig: TVectorOriginal;
begin
if FShapeCount = 0 then exit;
orig := AOriginal as TVectorOriginal;
movedShapes := TMovedShapeList.Create;
for i := 0 to FShapeCount-1 do
begin
ms.shape := orig.Shape[AFromIndex[i]];
ms.targetIndex:= AToIndex[i];
movedShapes.Add(ms);
end;
movedShapes.Sort(@CompareMovedShapeTargetIndex);
if movedShapes[0].targetIndex > orig.IndexOfShape(movedShapes[0].shape) then
begin
for i := movedShapes.Count-1 downto 0 do
orig.FShapes.Move(orig.IndexOfShape(movedShapes[i].shape), movedShapes[i].targetIndex);
end else
for i := 0 to movedShapes.Count-1 do
orig.FShapes.Move(orig.IndexOfShape(movedShapes[i].shape), movedShapes[i].targetIndex);
orig.DiscardFrozenShapes;
r := EmptyRectF;
for i := 0 to movedShapes.Count-1 do
r := r.Union(movedShapes[i].shape.GetRenderBounds(InfiniteRect, AffineMatrixIdentity), true);
movedShapes.Free;
if ASendDiff then orig.NotifyChange(r,self)
else orig.NotifyChange(r);
end;
constructor TVectorOriginalMoveShapeToIndexDiff.Create(AFromIndex,
AToIndex: array of integer);
var
i: Integer;
begin
if length(AFromIndex) <> length(AToIndex) then
raise exception.Create('Dimension mismatch');
FShapeCount:= length(AFromIndex);
setlength(FFromIndex, FShapeCount);
setlength(FToIndex, FShapeCount);
for i := 0 to FShapeCount-1 do
begin
FFromIndex[i] := AFromIndex[i];
FToIndex[i] := AToIndex[i];
end;
end;
procedure TVectorOriginalMoveShapeToIndexDiff.Apply(
AOriginal: TBGRALayerCustomOriginal);
begin
Apply(AOriginal, False);
end;
procedure TVectorOriginalMoveShapeToIndexDiff.Apply(
AOriginal: TBGRALayerCustomOriginal; ASendDiff: boolean);
begin
InternalMove(AOriginal, FFromIndex, FToIndex, ASendDiff);
end;
procedure TVectorOriginalMoveShapeToIndexDiff.Unapply(
AOriginal: TBGRALayerCustomOriginal);
begin
InternalMove(AOriginal, FToIndex, FFromIndex, False);
end;
function TVectorOriginalMoveShapeToIndexDiff.CanAppend(ADiff: TBGRAOriginalDiff): boolean;
var
other: TVectorOriginalMoveShapeToIndexDiff;
i: Integer;
begin
if ADiff is TVectorOriginalMoveShapeToIndexDiff then
begin
other := TVectorOriginalMoveShapeToIndexDiff(ADiff);
if other.FShapeCount <> FShapeCount then exit(false);
for i := 0 to FShapeCount-1 do
if other.FFromIndex[i] <> FToIndex[i] then exit(false);
result := true;
end else
result := false;
end;
procedure TVectorOriginalMoveShapeToIndexDiff.Append(ADiff: TBGRAOriginalDiff);
var
other: TVectorOriginalMoveShapeToIndexDiff;
i: Integer;
begin
if CanAppend(ADiff) then
begin
other := ADiff as TVectorOriginalMoveShapeToIndexDiff;
for i := 0 to FShapeCount-1 do
FToIndex[i] := other.FToIndex[i];
end;
end;
function TVectorOriginalMoveShapeToIndexDiff.IsIdentity: boolean;
var
i: Integer;
begin
for i := 0 to FShapeCount-1 do
if FFromIndex[i] <> FToIndex[i] then
exit(false);
result := true;
end;
{ TVectorShapeDiff }
function TVectorShapeDiff.CanAppend(ADiff: TVectorShapeDiff): boolean;
begin
result := (ADiff.ClassType = self.ClassType);
end;
{ TVectorShapeCommonFillDiff }
constructor TVectorShapeCommonFillDiff.Create(AStartShape: TVectorShape);
begin
with AStartShape do
begin
if Assigned(FPenFill) and (FPenFill.FillType <> vftNone) then
FStartPenFill := FPenFill.Duplicate;
if Assigned(FBackFill) and (FBackFill.FillType <> vftNone) then
FStartBackFill := FBackFill.Duplicate;
if Assigned(FOutlineFill) and (FOutlineFill.FillType <> vftNone) then
FStartOutlineFill := FOutlineFill.Duplicate;
end;
end;
destructor TVectorShapeCommonFillDiff.Destroy;
begin
FStartPenFill.Free;
FStartBackFill.Free;
FStartOutlineFill.Free;
FEndPenFill.Free;
FEndBackFill.Free;
FEndOutlineFill.Free;
inherited Destroy;
end;
procedure TVectorShapeCommonFillDiff.ComputeDiff(AEndShape: TVectorShape);
begin
with AEndShape do
begin
if Assigned(FPenFill) and (FPenFill.FillType <> vftNone) then
FEndPenFill := FPenFill.Duplicate;
if Assigned(FBackFill) and (FBackFill.FillType <> vftNone) then
FEndBackFill := FBackFill.Duplicate;
if Assigned(FOutlineFill) and (FOutlineFill.FillType <> vftNone) then
FEndOutlineFill := FOutlineFill.Duplicate;
end;
end;
procedure TVectorShapeCommonFillDiff.Apply(AStartShape: TVectorShape);
begin
with AStartShape do
begin
BeginUpdate;
SetFill(FPenFill, FEndPenFill, False);
SetFill(FBackFill, FEndBackFill, False);
SetFill(FOutlineFill, FEndOutlineFill, False);
EndUpdate;
end;
end;
procedure TVectorShapeCommonFillDiff.Unapply(AEndShape: TVectorShape);
begin
with AEndShape do
begin
BeginUpdate;
SetFill(FPenFill, FStartPenFill, False);
SetFill(FBackFill, FStartBackFill, False);
SetFill(FOutlineFill, FStartOutlineFill, False);
EndUpdate;
end;
end;
procedure TVectorShapeCommonFillDiff.Append(ADiff: TVectorShapeDiff);
var
next: TVectorShapeCommonFillDiff;
begin
next := ADiff as TVectorShapeCommonFillDiff;
if Assigned(next.FEndPenFill) then
begin
if FEndPenFill = nil then FEndPenFill := TVectorialFill.Create;
FEndPenFill.Assign(next.FEndPenFill);
end else FreeAndNil(FEndPenFill);
if Assigned(next.FEndBackFill) then
begin
if FEndBackFill = nil then FEndBackFill := TVectorialFill.Create;
FEndBackFill.Assign(next.FEndBackFill);
end else FreeAndNil(FEndBackFill);
if Assigned(next.FEndOutlineFill) then
begin
if FEndOutlineFill = nil then FEndOutlineFill := TVectorialFill.Create;
FEndOutlineFill.Assign(next.FEndOutlineFill);
end else FreeAndNil(FEndOutlineFill);
end;
function TVectorShapeCommonFillDiff.IsIdentity: boolean;
begin
result := TVectorialFill.Equal(FStartPenFill, FEndPenFill) and
TVectorialFill.Equal(FStartBackFill, FEndBackFill) and
TVectorialFill.Equal(FStartOutlineFill, FEndOutlineFill);
end;
{ TVectorOriginalShapeRangeDiff }
constructor TVectorOriginalShapeRangeDiff.Create(ARangeStart: integer;
AShapesBefore, AShapesAfter: TVectorShapes;
ASelectedShapeBefore, ASelectedShapeAfter: integer);
var
i: Integer;
begin
FRangeStart := ARangeStart;
FShapesBefore := TVectorShapes.Create;
if Assigned(AShapesBefore) then
for i := 0 to AShapesBefore.Count-1 do
FShapesBefore.Add(AShapesBefore[i].Duplicate);
FSelectedShapeBefore:= ASelectedShapeBefore;
FShapesAfter := TVectorShapes.Create;
if Assigned(AShapesAfter) then
for i := 0 to AShapesAfter.Count-1 do
FShapesAfter.Add(AShapesAfter[i].Duplicate);
FSelectedShapeAfter:= ASelectedShapeAfter;
end;
destructor TVectorOriginalShapeRangeDiff.Destroy;
var
i: Integer;
begin
for i := 0 to FShapesBefore.Count-1 do FShapesBefore[i].Free;
FShapesBefore.Free;
for i := 0 to FShapesAfter.Count-1 do FShapesAfter[i].Free;
FShapesAfter.Free;
inherited Destroy;
end;
procedure TVectorOriginalShapeRangeDiff.Apply(
AOriginal: TBGRALayerCustomOriginal);
var
i: Integer;
rRemove, rInsert: TRectF;
insCopy: TVectorShapes;
begin
with (AOriginal as TVectorOriginal) do
begin
rRemove := InternalDeleteShapeRange(FRangeStart, FShapesBefore.Count);
insCopy := TVectorShapes.Create;
for i := 0 to FShapesAfter.Count-1 do insCopy.Add(FShapesAfter[i].Duplicate);
rInsert := InternalInsertShapeRange(insCopy, FRangeStart);
insCopy.Free;
NotifyChange(TRectF.Union(rRemove,rInsert,True));
SelectShape(FSelectedShapeAfter);
end;
end;
procedure TVectorOriginalShapeRangeDiff.Unapply(
AOriginal: TBGRALayerCustomOriginal);
var
i: Integer;
rRemove, rInsert: TRectF;
insCopy: TVectorShapes;
begin
with (AOriginal as TVectorOriginal) do
begin
rRemove := InternalDeleteShapeRange(FRangeStart, FShapesAfter.Count);
insCopy := TVectorShapes.Create;
for i := 0 to FShapesBefore.Count-1 do insCopy.Add(FShapesBefore[i].Duplicate);
rInsert := InternalInsertShapeRange(insCopy, FRangeStart);
insCopy.Free;
NotifyChange(TRectF.Union(rRemove,rInsert,True));
SelectShape(FSelectedShapeBefore);
end;
end;
function TVectorOriginalShapeRangeDiff.CanAppend(ADiff: TBGRAOriginalDiff): boolean;
begin
result := false;
end;
procedure TVectorOriginalShapeRangeDiff.Append(ADiff: TBGRAOriginalDiff);
begin
raise exception.Create(errMergeNotAllowed);
end;
function TVectorOriginalShapeRangeDiff.IsIdentity: boolean;
begin
result := false;
end;
{ TVectorOriginalShapeDiff }
function TVectorOriginalShapeDiff.GetShape(AOriginal: TBGRALayerCustomOriginal): TVectorShape;
procedure UpdateMultiSelection(AOriginal: TVectorOriginal; AMultiDiff: TCustomMultiSelectionDiff);
var
i: Integer;
containedShapes: TVectorShapes;
s, s2: TVectorShape;
begin
containedShapes := TVectorShapes.Create;
for i := 0 to AMultiDiff.ShapeCount-1 do
begin
s2 := AOriginal.FindShapeById(AMultiDiff.ShapeId[i]);
if Assigned(s2) then containedShapes.Add(s2);
end;
AOriginal.SelectShapes(containedShapes);
containedShapes.Free;
end;
var
multiDiff: TCustomMultiSelectionDiff;
orig: TVectorOriginal;
begin
orig := (AOriginal as TVectorOriginal);
if FShapeIndex = -2 then
begin
result := orig.FMultiselection;
if FShapeDiff is TCustomMultiSelectionDiff then
UpdateMultiSelection(orig, TCustomMultiSelectionDiff(FShapeDiff)) else
if FShapeDiff is TVectorShapeComposedDiff then
begin
multiDiff := TVectorShapeComposedDiff(FShapeDiff).GetMultiselection;
if Assigned(multiDiff) then UpdateMultiSelection(orig, multiDiff);
end;
end else
result := orig.Shape[FShapeIndex];
end;
constructor TVectorOriginalShapeDiff.Create(AShapeIndex: integer;
AShapeDiff: TVectorShapeDiff);
begin
FShapeIndex := AShapeIndex;
FShapeDiff := AShapeDiff;
end;
destructor TVectorOriginalShapeDiff.Destroy;
begin
FShapeDiff.Free;
inherited Destroy;
end;
procedure TVectorOriginalShapeDiff.Apply(AOriginal: TBGRALayerCustomOriginal);
begin
FShapeDiff.Apply(GetShape(AOriginal));
end;
procedure TVectorOriginalShapeDiff.Unapply(AOriginal: TBGRALayerCustomOriginal);
begin
FShapeDiff.Unapply(GetShape(AOriginal));
end;
function TVectorOriginalShapeDiff.CanAppend(ADiff: TBGRAOriginalDiff): boolean;
begin
result := (ADiff is TVectorOriginalShapeDiff) and
(TVectorOriginalShapeDiff(ADiff).FShapeIndex = FShapeIndex) and
(FShapeDiff.CanAppend(TVectorOriginalShapeDiff(ADiff).FShapeDiff));
end;
procedure TVectorOriginalShapeDiff.Append(ADiff: TBGRAOriginalDiff);
begin
if CanAppend(ADiff) then
FShapeDiff.Append(TVectorOriginalShapeDiff(ADiff).FShapeDiff)
else
raise exception.Create(errMergeNotAllowed);
end;
function TVectorOriginalShapeDiff.IsIdentity: boolean;
begin
result := FShapeDiff.IsIdentity;
end;
{ TVectorShapeCommonDiff }
constructor TVectorShapeCommonDiff.Create(AStartShape: TVectorShape);
begin
with AStartShape do
begin
FStartPenWidth:= PenWidth;
FStartPenStyle:= DuplicatePenStyle(PenStyle);
FStartOutlineWidth:= OutlineWidth;
FStartJoinStyle:= JoinStyle;
end;
end;
procedure TVectorShapeCommonDiff.ComputeDiff(AEndShape: TVectorShape);
begin
with AEndShape do
begin
FEndPenWidth:= PenWidth;
FEndPenStyle:= DuplicatePenStyle(PenStyle);
FEndOutlineWidth:= OutlineWidth;
FEndJoinStyle:= JoinStyle;
end;
end;
procedure TVectorShapeCommonDiff.Apply(AStartShape: TVectorShape);
begin
with AStartShape do
begin
BeginUpdate;
FPenWidth := FEndPenWidth;
Stroker.CustomPenStyle := DuplicatePenStyle(FEndPenStyle);
FOutlineWidth := FEndOutlineWidth;
Stroker.JoinStyle := FEndJoinStyle;
EndUpdate;
end;
end;
procedure TVectorShapeCommonDiff.Unapply(AEndShape: TVectorShape);
begin
with AEndShape do
begin
BeginUpdate;
FPenWidth := FStartPenWidth;
Stroker.CustomPenStyle := DuplicatePenStyle(FStartPenStyle);
FOutlineWidth := FStartOutlineWidth;
Stroker.JoinStyle := FStartJoinStyle;
EndUpdate;
end;
end;
procedure TVectorShapeCommonDiff.Append(ADiff: TVectorShapeDiff);
var
next: TVectorShapeCommonDiff;
begin
next := ADiff as TVectorShapeCommonDiff;
FEndPenWidth:= next.FEndPenWidth;
FEndPenStyle:= DuplicatePenStyle(next.FEndPenStyle);
FEndOutlineWidth:= next.FEndOutlineWidth;
FEndJoinStyle:= next.FEndJoinStyle;
end;
function TVectorShapeCommonDiff.IsIdentity: boolean;
begin
result := (FStartPenWidth = FEndPenWidth) and
PenStyleEqual(FStartPenStyle, FEndPenStyle) and
(FStartOutlineWidth = FEndOutlineWidth) and
(FStartJoinStyle = FEndJoinStyle);
end;
{ TVectorShapeEmbeddedFillDiff }
constructor TVectorShapeEmbeddedFillDiff.Create(AField: TVectorShapeField;
AFillDiff: TCustomVectorialFillDiff);
begin
FField := AField;
FFillDiff := AFillDiff;
end;
constructor TVectorShapeEmbeddedFillDiff.Create(AStartShape: TVectorShape);
begin
raise exception.Create(errCannotBeComputedFromShape);
end;
destructor TVectorShapeEmbeddedFillDiff.Destroy;
begin
FFillDiff.Free;
inherited Destroy;
end;
procedure TVectorShapeEmbeddedFillDiff.ComputeDiff(AEndShape: TVectorShape);
begin
raise exception.Create(errCannotBeComputedFromShape);
end;
procedure TVectorShapeEmbeddedFillDiff.Apply(AStartShape: TVectorShape);
begin
case FField of
vsfPenFill: FFillDiff.Apply(AStartShape.PenFill);
vsfBackFill: FFillDiff.Apply(AStartShape.BackFill);
vsfOutlineFill: FFillDiff.Apply(AStartShape.OutlineFill);
end;
end;
procedure TVectorShapeEmbeddedFillDiff.Unapply(AEndShape: TVectorShape);
begin
case FField of
vsfPenFill: FFillDiff.Unapply(AEndShape.PenFill);
vsfBackFill: FFillDiff.Unapply(AEndShape.BackFill);
vsfOutlineFill: FFillDiff.Unapply(AEndShape.OutlineFill);
end;
end;
function TVectorShapeEmbeddedFillDiff.CanAppend(ADiff: TVectorShapeDiff): boolean;
begin
result := (ADiff is TVectorShapeEmbeddedFillDiff) and
(TVectorShapeEmbeddedFillDiff(ADiff).FField = FField) and
FFillDiff.CanAppend(TVectorShapeEmbeddedFillDiff(ADiff).FFillDiff);
end;
procedure TVectorShapeEmbeddedFillDiff.Append(ADiff: TVectorShapeDiff);
var
next: TVectorShapeEmbeddedFillDiff;
begin
next := ADiff as TVectorShapeEmbeddedFillDiff;
if next.FField <> FField then raise exception.Create(errFillFieldMismatch);
FFillDiff.Append(next.FFillDiff);
end;
function TVectorShapeEmbeddedFillDiff.IsIdentity: boolean;
begin
result := FFillDiff.IsIdentity;
end;
{ TVectorShapeComposedDiff }
constructor TVectorShapeComposedDiff.Create(ADiffs: TVectorShapeDiffList);
var
i: Integer;
begin
setlength(FDiffs, ADiffs.Count);
for i := 0 to high(FDiffs) do
FDiffs[i] := ADiffs[i];
end;
constructor TVectorShapeComposedDiff.Create(ADiffs: array of TVectorShapeDiff);
var
i: Integer;
begin
setlength(FDiffs, length(ADiffs));
for i := 0 to high(FDiffs) do
FDiffs[i] := ADiffs[i];
end;
constructor TVectorShapeComposedDiff.Create(AStartShape: TVectorShape);
begin
raise exception.Create(errCannotBeComputedFromShape);
end;
destructor TVectorShapeComposedDiff.Destroy;
var
i: Integer;
begin
for i := 0 to high(FDiffs) do
FDiffs[i].Free;
FDiffs := nil;
inherited Destroy;
end;
procedure TVectorShapeComposedDiff.ComputeDiff(AEndShape: TVectorShape);
begin
raise exception.Create(errCannotBeComputedFromShape);
end;
procedure TVectorShapeComposedDiff.Apply(AStartShape: TVectorShape);
var
i: Integer;
begin
AStartShape.BeginUpdate;
for i := 0 to high(FDiffs) do
FDiffs[i].Apply(AStartShape);
AStartShape.EndUpdate;
end;
procedure TVectorShapeComposedDiff.Unapply(AEndShape: TVectorShape);
var
i: Integer;
begin
AEndShape.BeginUpdate;
for i := high(FDiffs) downto 0 do
FDiffs[i].Unapply(AEndShape);
AEndShape.EndUpdate;
end;
function TVectorShapeComposedDiff.CanAppend(ADiff: TVectorShapeDiff): boolean;
var
next: TVectorShapeComposedDiff;
i: Integer;
begin
if ADiff is TVectorShapeComposedDiff then
begin
next := TVectorShapeComposedDiff(ADiff);
for i := 0 to high(next.FDiffs) do
if not CanAppend(next.FDiffs[i]) then exit(false);
result := true;
end else
begin
for i := high(FDiffs) downto 0 do
if FDiffs[i].CanAppend(ADiff) then exit(true);
exit(false);
end;
end;
procedure TVectorShapeComposedDiff.Append(ADiff: TVectorShapeDiff);
var
next: TVectorShapeComposedDiff;
i: Integer;
begin
if ADiff is TVectorShapeComposedDiff then
begin
next := TVectorShapeComposedDiff(ADiff);
for i := 0 to high(next.FDiffs) do
Append(next.FDiffs[i]);
end else
begin
for i := high(FDiffs) downto 0 do
if FDiffs[i].CanAppend(ADiff) then
begin
FDiffs[i].Append(ADiff);
exit;
end;
end;
end;
function TVectorShapeComposedDiff.IsIdentity: boolean;
var
i: Integer;
begin
for i := 0 to high(FDiffs) do
if not FDiffs[i].IsIdentity then exit(false);
result := true;
end;
function TVectorShapeComposedDiff.GetMultiselection: TCustomMultiSelectionDiff;
var
i: Integer;
begin
for i := 0 to high(FDiffs) do
if FDiffs[i] is TCustomMultiSelectionDiff then
exit(TCustomMultiSelectionDiff(FDiffs[i]));
result := nil;
end;
{ TVectorOriginalEditor }
constructor TVectorOriginalEditor.Create(AOriginal: TVectorOriginal);
begin
inherited Create;
FOriginal := AOriginal;
end;
procedure TVectorOriginalEditor.Clear;
begin
inherited Clear;
FLabels:= nil;
end;
function TVectorOriginalEditor.Render(ADest: TBGRABitmap;
const ALayoutRect: TRect): TRect;
var
i: Integer;
ptF: TPointF;
r: Classes.TRect;
begin
Result:=inherited Render(ADest, ALayoutRect);
for i := 0 to high(FLabels) do
if not isEmptyPointF(FLabels[i].Coord) then
begin
ptF := OriginalCoordToView(FLabels[i].Coord);
r := NiceText(ADest, round(ptF.x),round(ptF.y), ALayoutRect, FLabels[i].Text, FLabels[i].HorizAlign, FLabels[i].VertAlign, FLabels[i].Padding);
if not IsRectEmpty(r) then
begin
if IsRectEmpty(result) then result:= r
else UnionRect(result, result, r);
end;
end;
end;
function TVectorOriginalEditor.GetRenderBounds(const ALayoutRect: TRect): TRect;
var
i: Integer;
ptF: TPointF;
r: Classes.TRect;
begin
Result:=inherited GetRenderBounds(ALayoutRect);
for i := 0 to high(FLabels) do
if not isEmptyPointF(FLabels[i].Coord) then
begin
ptF := OriginalCoordToView(FLabels[i].Coord);
r := NiceText(nil, round(ptF.x),round(ptF.y), ALayoutRect, FLabels[i].Text, FLabels[i].HorizAlign, FLabels[i].VertAlign, FLabels[i].Padding);
if not IsRectEmpty(r) then
begin
if IsRectEmpty(result) then result:= r
else UnionRect(result, result, r);
end;
end;
end;
procedure TVectorOriginalEditor.AddLabel(const ACoord: TPointF; AText: string;
AHorizAlign: TAlignment; AVertAlign: TTextLayout);
begin
setlength(FLabels, length(FLabels)+1);
with FLabels[high(FLabels)] do
begin
Coord := ACoord;
Text:= AText;
HorizAlign:= AHorizAlign;
VertAlign:= AVertAlign;
Padding := 0;
end;
end;
procedure TVectorOriginalEditor.AddLabel(APointIndex: integer; AText: string;
AHorizAlign: TAlignment; AVertAlign: TTextLayout);
begin
setlength(FLabels, length(FLabels)+1);
with FLabels[high(FLabels)] do
begin
Coord := PointCoord[APointIndex];
Text:= AText;
HorizAlign:= AHorizAlign;
VertAlign:= AVertAlign;
Padding := round(PointSize);
end;
end;
function TVectorOriginalEditor.NiceText(ADest: TBGRABitmap; x, y: integer;
const ALayoutRect: TRect; AText: string; AHorizAlign: TAlignment;
AVertAlign: TTextLayout; APadding: integer): TRect;
var fx: TBGRATextEffect;
f: TFont;
previousClip: TRect;
shadowRadius: integer;
begin
f := TFont.Create;
f.Name := 'default';
f.Height := round(PointSize*2.5);
fx := TBGRATextEffect.Create(AText,f,true);
if (AVertAlign = tlTop) and (AHorizAlign = taCenter) and (y+APadding+fx.TextSize.cy > ALayoutRect.Bottom) then AVertAlign:= tlBottom;
if (AVertAlign = tlBottom) and (AHorizAlign = taCenter) and (y-APadding-fx.TextSize.cy < ALayoutRect.Top) then AVertAlign:= tlTop;
if (AHorizAlign = taLeftJustify) and (AVertAlign = tlCenter) and (x+APadding+fx.TextSize.cx > ALayoutRect.Right) then AHorizAlign:= taRightJustify;
if (AHorizAlign = taRightJustify) and (AVertAlign = tlCenter) and (x-APadding-fx.TextSize.cx < ALayoutRect.Left) then AHorizAlign:= taLeftJustify;
if AVertAlign = tlBottom then y := y-APadding-fx.TextSize.cy else
if AVertAlign = tlCenter then y := y-fx.TextSize.cy div 2 else inc(y,APadding);
if y+fx.TextSize.cy > ALayoutRect.Bottom then y := ALayoutRect.Bottom-fx.TextSize.cy;
if y < ALayoutRect.Top then y := ALayoutRect.Top;
if AHorizAlign = taRightJustify then x := x-APadding-fx.TextSize.cx else
if AHorizAlign = taCenter then x := x-fx.TextSize.cx div 2 else inc(x,APadding);
if x+fx.TextSize.cx > ALayoutRect.Right then x := ALayoutRect.Right-fx.TextSize.cx;
if x < ALayoutRect.Left then x := ALayoutRect.Left;
shadowRadius:= round(PointSize*0.5);
result := rect(x,y,x+fx.TextWidth+2*shadowRadius,y+fx.TextHeight+2*shadowRadius);
if Assigned(ADest) then
begin
previousClip := ADest.ClipRect;
ADest.ClipRect := result;
if shadowRadius <> 0 then
fx.DrawShadow(ADest,x+shadowRadius,y+shadowRadius,shadowRadius,BGRABlack);
fx.DrawOutline(ADest,x,y,BGRABlack);
fx.Draw(ADest,x,y,BGRAWhite);
ADest.ClipRect := previousClip;
end;
fx.Free;
f.Free;
end;
procedure TVectorOriginalEditor.MouseMove(Shift: TShiftState; ViewX, ViewY: single; out
ACursor: TOriginalEditorCursor; out AHandled: boolean);
var
ptF: TPointF;
begin
inherited MouseMove(Shift, ViewX, ViewY, ACursor, AHandled);
if not AHandled and Assigned(FOriginal) and Assigned(FOriginal.SelectedShape) then
begin
ptF := ViewCoordToOriginal(PointF(ViewX,ViewY));
if GridActive then ptF := SnapToGrid(ptF, False);
with ptF do FOriginal.SelectedShape.MouseMove(Shift, X,Y, ACursor, AHandled);
end;
end;
procedure TVectorOriginalEditor.MouseDown(RightButton: boolean;
Shift: TShiftState; ViewX, ViewY: single; out ACursor: TOriginalEditorCursor; out
AHandled: boolean);
var
ptF: TPointF;
begin
inherited MouseDown(RightButton, Shift, ViewX, ViewY, ACursor, AHandled);
if not AHandled and Assigned(FOriginal) and Assigned(FOriginal.SelectedShape) then
begin
ptF := ViewCoordToOriginal(PointF(ViewX,ViewY));
if GridActive then ptF := SnapToGrid(ptF, False);
with ptF do FOriginal.SelectedShape.MouseDown(RightButton, Shift, X,Y, ACursor, AHandled);
end;
end;
procedure TVectorOriginalEditor.MouseUp(RightButton: boolean;
Shift: TShiftState; ViewX, ViewY: single; out ACursor: TOriginalEditorCursor; out
AHandled: boolean);
var
ptF: TPointF;
begin
inherited MouseUp(RightButton, Shift, ViewX, ViewY, ACursor, AHandled);
if not AHandled and Assigned(FOriginal) and Assigned(FOriginal.SelectedShape) then
begin
ptF := ViewCoordToOriginal(PointF(ViewX,ViewY));
if GridActive then ptF := SnapToGrid(ptF, False);
with ptF do FOriginal.SelectedShape.MouseUp(RightButton, Shift, X,Y, ACursor, AHandled);
end;
end;
procedure TVectorOriginalEditor.KeyDown(Shift: TShiftState; Key: TSpecialKey; out
AHandled: boolean);
begin
if Assigned(FOriginal) and Assigned(FOriginal.SelectedShape) then
begin
AHandled := false;
FOriginal.SelectedShape.KeyDown(Shift, Key, AHandled);
if AHandled then exit;
if (Key = skReturn) and ([ssShift,ssCtrl,ssAlt]*Shift = []) then
begin
FOriginal.DeselectShapes;
AHandled := true;
exit;
end else
if (Key = skEscape) and ([ssShift,ssCtrl,ssAlt]*Shift = []) and (FOriginal.SelectedShape.Usermode = vsuCreate) then
begin
FOriginal.SelectedShape.Remove;
AHandled:= true;
end;
end;
inherited KeyDown(Shift, Key, AHandled);
end;
procedure TVectorOriginalEditor.KeyUp(Shift: TShiftState; Key: TSpecialKey; out
AHandled: boolean);
begin
if Assigned(FOriginal) and Assigned(FOriginal.SelectedShape) then
begin
AHandled := false;
FOriginal.SelectedShape.KeyUp(Shift, Key, AHandled);
if AHandled then exit;
end;
inherited KeyUp(Shift, Key, AHandled);
end;
procedure TVectorOriginalEditor.KeyPress(UTF8Key: string; out
AHandled: boolean);
begin
if Assigned(FOriginal) and Assigned(FOriginal.SelectedShape) then
begin
AHandled := false;
FOriginal.SelectedShape.KeyPress(UTF8Key, AHandled);
if AHandled then exit;
end;
inherited KeyPress(UTF8Key, AHandled);
end;
{ TVectorShape }
function TVectorShape.GetIsSlow(const AMatrix: TAffineMatrix): boolean;
begin
result := false;
end;
function TVectorShape.GetGenericCost: integer;
begin
if vsfBackFill in Fields then
begin
case BackFill.FillType of
vftGradient: result := 25;
vftTexture: result := 10;
vftSolid: result := 4;
else {vftNone} result := 1;
end
end else
if vsfPenStyle in Fields then
begin
if PenStyleEqual(PenStyle, SolidPenStyle) or
PenStyleEqual(PenStyle, ClearPenStyle) then
result := 1
else
result := 2;
end else
result := 1;
end;
function TVectorShape.GetUsedTextures: ArrayOfBGRABitmap;
var
f: TVectorShapeFields;
nb: integer;
begin
f := Fields;
setlength(result, 3);
nb := 0;
if (vsfBackFill in f) and (BackFill.FillType = vftTexture) then
begin
result[nb] := BackFill.Texture;
inc(nb);
end;
if (vsfPenFill in f) and (PenFill.FillType = vftTexture) then
begin
result[nb] := PenFill.Texture;
inc(nb);
end;
if (vsfOutlineFill in f) and (OutlineFill.FillType = vftTexture) then
begin
result[nb] := OutlineFill.Texture;
inc(nb);
end;
setlength(result, nb);
end;
function TVectorShape.GetAsMultishape: IVectorMultishape;
begin
result := nil;
end;
procedure TVectorShape.Transform(const AMatrix: TAffineMatrix);
var
zoom: Single;
begin
if IsAffineMatrixIdentity(AMatrix) then exit;
BeginUpdate;
TransformFrame(AMatrix);
TransformFill(AMatrix, False);
zoom := (VectLen(AMatrix[1,1],AMatrix[2,1])+VectLen(AMatrix[1,2],AMatrix[2,2]))/2;
if vsfPenWidth in Fields then PenWidth := zoom*PenWidth;
if vsfOutlineWidth in Fields then OutlineWidth := zoom*OutlineWidth;
EndUpdate;
end;
class function TVectorShape.Fields: TVectorShapeFields;
begin
result := [];
end;
function TVectorShape.GetJoinStyle: TPenJoinStyle;
begin
result := Stroker.JoinStyle;
end;
procedure TVectorShape.SetJoinStyle(AValue: TPenJoinStyle);
begin
if Stroker.JoinStyle = AValue then exit;
BeginUpdate(TVectorShapeCommonDiff);
Stroker.JoinStyle := AValue;
EndUpdate;
end;
procedure TVectorShape.SetUsermode(AValue: TVectorShapeUsermode);
begin
if FUsermode=AValue then Exit;
BeginEditingUpdate;
FUsermode:=AValue;
EndEditingUpdate;
end;
function TVectorShape.LoadTexture(AStorage: TBGRACustomOriginalStorage;
AName: string): TBGRABitmap;
var
texId: Integer;
pointerData: RawByteString;
begin
if FStoreTexturePointer then
begin
result := nil;
pointerData := AStorage.RawString[AName+'-ptr'];
if length(pointerData)<>sizeof(result) then
raise exception.Create(errInvalidStoredPointer);
move(pointerData[1],result,sizeof(result));
end else
if Assigned(Container) then
begin
texId := AStorage.Int[AName+'-id'];
result := Container.GetTexture(texId);
end else
raise exception.Create(errUndefinedContainer);
end;
procedure TVectorShape.SaveTexture(AStorage: TBGRACustomOriginalStorage;
AName: string; AValue: TBGRABitmap);
var
texId: Integer;
pointerData: RawByteString;
begin
if FStoreTexturePointer then
begin
setlength(pointerData, sizeof(AValue));
move(AValue, pointerData[1], length(pointerData));
AStorage.RawString[AName+'-ptr'] := pointerData;
end else
if Assigned(Container) then
begin
texId := Container.GetTextureId(AValue);
AStorage.Int[AName+'-id'] := texId;
end else
raise exception.Create(errUndefinedContainer);
end;
procedure TVectorShape.LoadFill(AStorage: TBGRACustomOriginalStorage;
AObjectName: string; var AValue: TVectorialFill);
var
obj: TBGRACustomOriginalStorage;
tex: TBGRABitmap;
texOpacity: integer;
origin, xAxis, yAxis: TPointF;
grad: TBGRALayerGradientOriginal;
repetition: TTextureRepetition;
c: TBGRAPixel;
begin
if AValue = nil then
begin
AValue := TVectorialFill.Create;
AValue.OnChange := @FillChange;
end;
obj := AStorage.OpenObject(AObjectName+'-fill');
if obj = nil then
begin
c := AStorage.Color[AObjectName+'-color'];
if c.alpha <> 0 then
AValue.SetSolid(c);
exit;
end;
try
case obj.RawString['class'] of
'solid': AValue.SetSolid(obj.Color['color']);
'texture': begin
tex := LoadTexture(obj, 'tex');
origin := obj.PointF['origin'];
xAxis := obj.PointF['x-axis'];
yAxis := obj.PointF['y-axis'];
texOpacity := obj.IntDef['opacity',255];
if texOpacity < 0 then texOpacity:= 0;
if texOpacity > 255 then texOpacity:= 255;
case obj.RawString['repetition'] of
'none': repetition := trNone;
'repeat-x': repetition := trRepeatX;
'repeat-y': repetition := trRepeatY;
else repetition := trRepeatBoth;
end;
AValue.SetTexture(tex, AffineMatrix(xAxis,yAxis,origin), texOpacity, repetition)
end;
'gradient': begin
grad := TBGRALayerGradientOriginal.Create;
grad.LoadFromStorage(obj);
AValue.SetGradient(grad,true);
end;
else AValue.Clear;
end;
finally
obj.Free;
end;
end;
procedure TVectorShape.SaveFill(AStorage: TBGRACustomOriginalStorage;
AObjectName: string; AValue: TVectorialFill);
var
obj: TBGRACustomOriginalStorage;
m: TAffineMatrix;
ft: TVectorialFillType;
begin
AStorage.RemoveObject(AObjectName+'-fill');
AStorage.RemoveAttribute(AObjectName+'-color');
if Assigned(AValue) then
begin
ft := AValue.FillType;
if ft = vftSolid then
begin
AStorage.Color[AObjectName+'-color'] := AValue.SolidColor;
exit;
end else
if not (ft in [vftTexture,vftGradient]) then exit;
obj := AStorage.CreateObject(AObjectName+'-fill');
try
if ft = vftSolid then
begin
obj.RawString['class'] := 'solid';
obj.Color['color'] := AValue.SolidColor;
end
else
if ft = vftTexture then
begin
obj.RawString['class'] := 'texture';
SaveTexture(obj, 'tex', AValue.Texture);
m := AValue.TextureMatrix;
obj.PointF['origin'] := PointF(m[1,3],m[2,3]);
obj.PointF['x-axis'] := PointF(m[1,1],m[2,1]);
obj.PointF['y-axis'] := PointF(m[1,2],m[2,2]);
if AValue.TextureOpacity<>255 then
obj.Int['opacity'] := AValue.TextureOpacity;
case AValue.TextureRepetition of
trNone: obj.RawString['repetition'] := 'none';
trRepeatX: obj.RawString['repetition'] := 'repeat-x';
trRepeatY: obj.RawString['repetition'] := 'repeat-y';
trRepeatBoth: obj.RemoveAttribute('repetition');
end;
end else
if ft = vftGradient then
begin
obj.RawString['class'] := 'gradient';
AValue.Gradient.SaveToStorage(obj);
end else
obj.RawString['class'] := 'none';
finally
obj.Free;
end;
end;
end;
class function TVectorShape.Usermodes: TVectorShapeUsermodes;
begin
result := [vsuEdit];
if vsfBackFill in Fields then result += [vsuEditBackFill];
if vsfPenFill in Fields then result += [vsuEditPenFill];
if vsfOutlineFill in Fields then result += [vsuEditOutlineFill];
end;
function TVectorShape.MultiUsermodes: TVectorShapeUsermodes;
var
f: TVectorShapeFields;
begin
result := [vsuEdit];
f := MultiFields;
if vsfBackFill in f then result += [vsuEditBackFill];
if vsfPenFill in f then result += [vsuEditPenFill];
if vsfOutlineFill in f then result += [vsuEditOutlineFill];
end;
class function TVectorShape.PreferPixelCentered: boolean;
begin
result := true;
end;
class function TVectorShape.CreateEmpty: boolean;
begin
result := false;
end;
procedure TVectorShape.SetContainer(AValue: TVectorOriginal);
begin
if FContainer=AValue then Exit;
if Assigned(FContainer) then raise exception.Create(errContainerAlreadyAssigned);
FContainer:=AValue;
end;
function TVectorShape.GetIsUpdating: boolean;
begin
result := FUpdateCount > 0;
end;
function TVectorShape.GetOutlineWidth: single;
begin
result := FOutlineWidth;
end;
function TVectorShape.GetFill(var AFillVariable: TVectorialFill): TVectorialFill;
begin
if AFillVariable = nil then
begin
AFillVariable := TVectorialFill.Create;
AFillVariable.OnChange := @FillChange;
AFillVariable.OnBeforeChange := @FillBeforeChange;
end;
result := AFillVariable;
end;
procedure TVectorShape.SetFill(var AFillVariable: TVectorialFill;
AValue: TVectorialFill; AUpdate: boolean);
var
sharedTex: TBGRABitmap;
freeTex: Boolean;
begin
if Assigned(AFillVariable) then
begin
if AFillVariable.Equals(AValue) then exit;
end else
if AValue=nil then exit;
if not AUpdate then FFillChangeWithoutUpdate := true;
freeTex := Assigned(AFillVariable) and Assigned(AFillVariable.Texture) and
not (Assigned(AValue) and (AValue.FillType = vftTexture) and (AValue.Texture = AFillVariable.Texture));
if AValue = nil then
begin
AFillVariable.Clear; //trigger event
FreeAndNil(AFillVariable);
end else
if AValue.FillType = vftTexture then
begin
if Assigned(Container) then
sharedTex := Container.GetTexture(Container.AddTexture(AValue.Texture))
else
sharedTex := AValue.Texture;
GetFill(AFillVariable).SetTexture(sharedTex, AValue.TextureMatrix, AValue.TextureOpacity, AValue.TextureRepetition);
end else
GetFill(AFillVariable).Assign(AValue);
if Assigned(Container) and freeTex then Container.DiscardUnusedTextures;
if not AUpdate then FFillChangeWithoutUpdate := false;
end;
procedure TVectorShape.SetId(AValue: integer);
begin
if FId=AValue then Exit;
FId:=AValue;
end;
procedure TVectorShape.SetOutlineWidth(AValue: single);
begin
if AValue < 0 then AValue := 0;
if FOutlineWidth=AValue then Exit;
BeginUpdate(TVectorShapeCommonDiff);
FOutlineWidth:=AValue;
EndUpdate;
end;
procedure TVectorShape.SetOutlineFill(AValue: TVectorialFill);
begin
SetFill(FOutlineFill, AValue, True);
end;
function TVectorShape.GetIsBack: boolean;
begin
result := Assigned(Container) and (Container.IndexOfShape(self)=0);
end;
function TVectorShape.GetIsFollowingMouse: boolean;
begin
result := false;
end;
function TVectorShape.GetPenVisible(AAssumePenFill: boolean): boolean;
var
f: TVectorShapeFields;
begin
f := Fields;
result := (vsfPenFill in f) and (not PenFill.IsFullyTransparent or AAssumePenFill);
if result and (vsfPenWidth in f) then result := result and (PenWidth>0);
if result and (vsfPenStyle in f) then result := result and not IsClearPenStyle(PenStyle);
end;
function TVectorShape.GetPenVisibleNow: boolean;
begin
result := GetPenVisible(False);
end;
function TVectorShape.GetBackVisible: boolean;
begin
result := (vsfBackFill in Fields) and not BackFill.IsFullyTransparent;
end;
function TVectorShape.GetOutlineVisible: boolean;
begin
result := (vsfOutlineFill in Fields) and not OutlineFill.IsFullyTransparent and
(not (vsfOutlineWidth in Fields) or (OutlineWidth > 0));
end;
function TVectorShape.AppendVectorialFillToSVGDefs(AFill: TVectorialFill; const AMatrix: TAffineMatrix;
ADefs: TSVGDefine; ANamePrefix: string): string;
var
grad: TSVGGradient;
begin
if AFill.FillType = vftGradient then
begin
grad := AFill.Gradient.AddToSVGDefs(AMatrix, ADefs) as TSVGGradient;
if grad = nil then exit('');
grad.ID := ANamePrefix + 'grad' + inttostr(Id);
result := grad.ID;
end else
result := '';
end;
procedure TVectorShape.ApplyStrokeStyleToSVG(AElement: TSVGElement; ADefs: TSVGDefine);
var ps: array of single;
i: Integer;
fillId: String;
begin
if PenVisible then
begin
if IsAffineMatrixInversible(AElement.matrix[cuPixel]) then
fillId := AppendVectorialFillToSVGDefs(PenFill,
AffineMatrixInverse(AElement.matrix[cuPixel]), ADefs, 'stroke')
else fillId := '';
if fillId <> '' then
AElement.stroke:= 'url(#'+fillId+')'
else AElement.strokeColor := PenColor;
if IsSolidPenStyle(PenStyle) then
AElement.strokeDashArrayNone else
begin
setlength(ps, length(PenStyle));
for i := 0 to high(ps) do
ps[i] := PenStyle[i] * PenWidth;
AElement.strokeDashArrayF := ps;
end;
AElement.strokeLineJoinLCL := JoinStyle;
AElement.strokeWidth := FloatWithCSSUnit(PenWidth, cuCustom);
end else
AElement.strokeNone;
end;
procedure TVectorShape.ApplyFillStyleToSVG(AElement: TSVGElement; ADefs: TSVGDefine);
var
fillId: String;
begin
if BackVisible then
begin
if IsAffineMatrixInversible(AElement.matrix[cuPixel]) then
fillId := AppendVectorialFillToSVGDefs(BackFill,
AffineMatrixInverse(AElement.matrix[cuPixel]), ADefs, 'fill')
else fillId := '';
if fillId <> '' then
AElement.fill:= 'url(#'+fillId+')'
else AElement.fillColor := BackFill.AverageColor;
end
else AElement.fillNone;
end;
procedure TVectorShape.TransformFill(const AMatrix: TAffineMatrix; ABackOnly: boolean);
begin
BeginUpdate;
if vsfBackFill in Fields then BackFill.Transform(AMatrix);
if not ABackOnly then
begin
if vsfPenFill in Fields then PenFill.Transform(AMatrix);
if vsfOutlineFill in Fields then OutlineFill.Transform(AMatrix);
end;
EndUpdate;
end;
function TVectorShape.AllowShearTransform: boolean;
begin
result := true;
end;
function TVectorShape.MultiFields: TVectorShapeFields;
begin
result := Fields;
end;
function TVectorShape.GetIsFront: boolean;
begin
result := Assigned(Container) and (Container.IndexOfShape(self)=Container.ShapeCount-1);
end;
function TVectorShape.GetOutlineFill: TVectorialFill;
begin
result := GetFill(FOutlineFill);
end;
procedure TVectorShape.BeginUpdate(ADiffHandler: TVectorShapeDiffAny);
begin
if FUpdateCount = 0 then
begin
FBoundsBeforeUpdate := GetRenderBounds(InfiniteRect, AffineMatrixIdentity);
Inc(FRenderIteration);
end;
inc(FUpdateCount);
if ADiffHandler<>nil then AddDiffHandler(ADiffHandler);
end;
procedure TVectorShape.EndUpdate;
var
i: Integer;
comp: TVectorShapeComposedDiff;
begin
if FUpdateCount > 0 then
begin
dec(FUpdateCount);
if FUpdateCount = 0 then
begin
if Assigned(FDiffs) and (FDiffs.Count > 0) then
begin
for i := 0 to FDiffs.Count-1 do
FDiffs[i].ComputeDiff(self);
if FDiffs.Count = 1 then
DoOnChange(FBoundsBeforeUpdate, FDiffs[0])
else
begin
comp := TVectorShapeComposedDiff.Create(FDiffs);
DoOnChange(FBoundsBeforeUpdate, comp);
end;
FDiffs.Clear;
end else
DoOnChange(FBoundsBeforeUpdate, nil);
end;
end;
end;
procedure TVectorShape.FillFit;
var
box: TAffineBox;
begin
BeginUpdate;
box := SuggestGradientBox(AffineMatrixIdentity);
if vsfPenFill in Fields then PenFill.FitGeometry(box);
if vsfBackFill in Fields then BackFill.FitGeometry(box);
if vsfOutlineFill in Fields then OutlineFill.FitGeometry(box);
EndUpdate;
end;
procedure TVectorShape.BeginEditingUpdate;
begin
inc(FUpdateEditingCount);
end;
procedure TVectorShape.EndEditingUpdate;
begin
if FUpdateEditingCount > 0 then
begin
dec(FUpdateEditingCount);
if FUpdateEditingCount = 0 then
begin
if Assigned(FOnEditingChange) then
FOnEditingChange(self);
end;
end;
end;
procedure TVectorShape.DoOnChange(ABoundsBefore: TRectF; ADiff: TVectorShapeDiff);
var
boundsAfter: TRectF;
begin
if Assigned(FOnChange) then
begin
boundsAfter := GetRenderBounds(InfiniteRect, AffineMatrixIdentity);
FOnChange(self, boundsAfter.Union(ABoundsBefore, true), ADiff);
end else
ADiff.Free;
end;
function TVectorShape.GetPenColor: TBGRAPixel;
begin
if Assigned(FPenFill) then
result := FPenFill.SolidColor
else
result := BGRAPixelTransparent;
end;
function TVectorShape.GetPenWidth: single;
begin
result := FPenWidth;
end;
function TVectorShape.GetPenStyle: TBGRAPenStyle;
begin
result := Stroker.CustomPenStyle;
end;
function TVectorShape.GetBackFill: TVectorialFill;
begin
result := GetFill(FBackFill);
end;
function TVectorShape.GetPenFill: TVectorialFill;
begin
result := GetFill(FPenFill);
end;
function TVectorShape.ComputeStroke(APoints: ArrayOfTPointF; AClosed: boolean; AStrokeMatrix: TAffineMatrix): ArrayOfTPointF;
begin
Stroker.StrokeMatrix := AStrokeMatrix;
if AClosed then
result := Stroker.ComputePolygon(APoints, PenWidth)
else
result := Stroker.ComputePolyline(APoints, PenWidth, PenColor);
end;
function TVectorShape.ComputeStrokeEnvelope(APoints: ArrayOfTPointF;
AClosed: boolean; AWidth: single): ArrayOfTPointF;
var
opt: TBGRAPolyLineOptions;
begin
opt := [];
if AClosed then include(opt, plCycle);
result := ComputeWidePolyPolylinePoints(APoints, AWidth, BGRABlack, pecRound, pjsMiter, SolidPenStyle, opt);
end;
function TVectorShape.GetStroker: TBGRAPenStroker;
begin
if FStroker = nil then
begin
FStroker := TBGRAPenStroker.Create;
FStroker.MiterLimit:= 2;
end;
result := FStroker;
end;
procedure TVectorShape.FillChange(ASender: TObject; var ADiff: TCustomVectorialFillDiff);
var
field: TVectorShapeField;
r: TRectF;
begin
r := FFillBeforeChangeBounds;
FFillBeforeChangeBounds := EmptyRectF;
if FFillChangeWithoutUpdate then exit;
//if shape is not being updated, send the fill diff as such
if not IsUpdating then
begin
inc(FRenderIteration);
if ASender = FPenFill then field := vsfPenFill
else if ASender = FBackFill then field := vsfBackFill
else if ASender = FOutlineFill then field := vsfOutlineFill
else
begin
ADiff.Free;
DoOnChange(r, nil);
exit;
end;
if Assigned(ADiff) then
begin
DoOnChange(r, TVectorShapeEmbeddedFillDiff.Create(field, ADiff));
ADiff := nil;
end else
DoOnChange(r, nil);
end else
AddFillDiffHandler(ASender as TVectorialFill, ADiff);
end;
procedure TVectorShape.FillBeforeChange(ASender: TObject);
begin
FFillBeforeChangeBounds := GetRenderBounds(InfiniteRect, AffineMatrixIdentity);
end;
function TVectorShape.OpenRenderStorage(ACreateIfNecessary: boolean): TShapeRenderStorage;
begin
if ACreateIfNecessary then
result := TShapeRenderStorage.OpenOrCreate(Container.RenderStorage, Id)
else
result := TShapeRenderStorage.Open(Container.RenderStorage, Id);
end;
procedure TVectorShape.UpdateRenderStorage(ARenderBounds: TRect; AImage: TBGRACustomBitmap);
var
imgStream: TMemoryStream;
shapeStorage: TShapeRenderStorage;
begin
if CanHaveRenderStorage then
begin
shapeStorage := OpenRenderStorage(true);
shapeStorage.persistent.Int['iteration'] := FRenderIteration;
shapeStorage.persistent.Rectangle['bounds'] := ARenderBounds;
if Assigned(AImage) then
begin
imgStream := TMemoryStream.Create;
AImage.Serialize(imgStream);
shapeStorage.persistent.WriteFile('image.data', imgStream, false, true);
//will be compressed when saving
end else
shapeStorage.persistent.RemoveFile('image.data');
shapeStorage.Close;
end;
end;
procedure TVectorShape.DiscardRenderStorage;
begin
if CanHaveRenderStorage then
TShapeRenderStorage.Discard(Container.RenderStorage, Id);
end;
procedure TVectorShape.RetrieveRenderStorage(AMatrix: TAffineMatrix; out
ARenderBounds: TRect; out AImage: TBGRABitmap);
var
stream: TStream;
shapeStorage: TShapeRenderStorage;
begin
ARenderBounds := EmptyRect;
AImage := nil;
if Assigned(Container) and Assigned(Container.RenderStorage) and (Container.RenderStorage.AffineMatrix['last-matrix']=AMatrix) then
begin
shapeStorage := TShapeRenderStorage.Open(Container.RenderStorage, Id);
if Assigned(shapeStorage.persistent) then
begin
if shapeStorage.persistent.Int['iteration'] = FRenderIteration then
begin
ARenderBounds := shapeStorage.persistent.Rectangle['bounds'];
stream := shapeStorage.persistent.GetFileStream('image.data') ;
if Assigned(stream) and (stream.Size > 0) then
begin
stream.Position:= 0;
AImage := TBGRABitmap.Create;
AImage.Deserialize(stream);
end;
end;
end;
shapeStorage.Close;
end;
end;
function TVectorShape.CanHaveRenderStorage: boolean;
begin
result := (Id <> 0) and Assigned(Container) and Assigned(Container.RenderStorage);
end;
function TVectorShape.AddDiffHandler(AClass: TVectorShapeDiffAny): TVectorShapeDiff;
var
i: Integer;
begin
result := nil;
if not IsUpdating then
raise exception.Create(errDiffHandlerOnlyDuringUpdate);
if Assigned(FOnChange) then
begin
if FDiffs = nil then FDiffs := TVectorShapeDiffList.Create;
for i := 0 to FDiffs.Count-1 do
if FDiffs[i] is AClass then exit(FDiffs[i]);
result := AClass.Create(self);
FDiffs.Add(result);
end;
end;
procedure TVectorShape.AddFillDiffHandler(AFill: TVectorialFill; ADiff: TCustomVectorialFillDiff);
var
h: TVectorShapeCommonFillDiff;
begin
if Assigned(AFill) and Assigned(ADiff) then
begin
//make sure there is a handler for fill diff
if GetDiffHandler(TVectorShapeCommonFillDiff)=nil then
begin
h := AddDiffHandler(TVectorShapeCommonFillDiff) as TVectorShapeCommonFillDiff;
if Assigned(h) then
begin
//handler is initialized with current fill that is already changed
//so we need to fix the start value using diff
if AFill = FPenFill then
begin
if h.FStartPenFill=nil then h.FStartPenFill := TVectorialFill.Create;
ADiff.Unapply(h.FStartPenFill)
end
else if AFill = FBackFill then
begin
if h.FStartBackFill=nil then h.FStartBackFill := TVectorialFill.Create;
ADiff.Unapply(h.FStartBackFill);
end
else if AFill = FOutlineFill then
begin
if h.FStartOutlineFill=nil then h.FStartOutlineFill := TVectorialFill.Create;
ADiff.Unapply(h.FStartOutlineFill);
end;
end;
end;
end;
end;
function TVectorShape.GetDiffHandler(AClass: TVectorShapeDiffAny): TVectorShapeDiff;
var
i: Integer;
begin
if Assigned(FDiffs) then
begin
for i := 0 to FDiffs.Count-1 do
if FDiffs[i] is AClass then exit(FDiffs[i]);
end;
result := nil;
end;
procedure TVectorShape.SetPenColor(AValue: TBGRAPixel);
var
vf: TVectorialFill;
begin
vf := TVectorialFill.CreateAsSolid(AValue);
PenFill := vf;
vf.Free;
end;
procedure TVectorShape.SetPenWidth(AValue: single);
begin
if AValue < 0 then AValue := 0;
if FPenWidth = AValue then exit;
BeginUpdate(TVectorShapeCommonDiff);
FPenWidth := AValue;
EndUpdate;
end;
procedure TVectorShape.SetPenStyle(AValue: TBGRAPenStyle);
begin
if PenStyleEqual(AValue, PenStyle) then exit;
BeginUpdate(TVectorShapeCommonDiff);
Stroker.CustomPenStyle := AValue;
EndUpdate;
end;
procedure TVectorShape.SetBackFill(AValue: TVectorialFill);
begin
SetFill(FBackFill, AValue, True);
end;
procedure TVectorShape.SetPenFill(AValue: TVectorialFill);
begin
SetFill(FPenFill, AValue, True);
end;
constructor TVectorShape.Create(AContainer: TVectorOriginal);
begin
FContainer := AContainer;
FPenFill := nil;
FPenWidth := 1;
FOutlineWidth := DefaultShapeOutlineWidth;
FStroker := nil;
FOnChange := nil;
FOnEditingChange := nil;
FBackFill := nil;
FOutlineFill := nil;
FUsermode:= vsuEdit;
FRemoving:= false;
FId := 0;
FRenderIteration:= 0;
FFillBeforeChangeBounds := EmptyRectF;
end;
class function TVectorShape.CreateFromStorage(
AStorage: TBGRACustomOriginalStorage; AContainer: TVectorOriginal): TVectorShape;
var
objClassName: RawByteString;
shapeClass: TVectorShapeAny;
begin
objClassName := AStorage.RawString['class'];
if objClassName = '' then raise exception.Create(rsShapeClassNotSpecified);
shapeClass:= GetVectorShapeByStorageClassName(objClassName);
if shapeClass = nil then raise exception.Create(StringReplace(rsUnknownShapeClass, '%1', objClassName, []));
result := shapeClass.Create(AContainer);
result.LoadFromStorage(AStorage);
end;
destructor TVectorShape.Destroy;
var
i: Integer;
begin
FreeAndNil(FStroker);
FreeAndNil(FPenFill);
FreeAndNil(FBackFill);
FreeAndNil(FOutlineFill);
if Assigned(FDiffs) then
for i := 0 to FDiffs.Count-1 do
FDiffs[i].Free;
FreeAndNil(FDiffs);
inherited Destroy;
end;
procedure TVectorShape.Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix;
ADraft: boolean);
begin
Render(ADest, Point(0,0), AMatrix, ADraft);
end;
procedure TVectorShape.Render(ADest: TBGRABitmap; ARenderOffset: TPoint;
AMatrix: TAffineMatrix; ADraft: boolean);
begin
Render(ADest, AffineMatrixTranslation(ARenderOffset.X,ARenderOffset.Y)*AMatrix, ADraft);
end;
function TVectorShape.SuggestGradientBox(AMatrix: TAffineMatrix): TAffineBox;
var
rF: TRectF;
begin
rF := GetRenderBounds(InfiniteRect, AMatrix, [rboAssumeBackFill]);
result := TAffineBox.AffineBox(rF);
end;
function TVectorShape.PointInBack(APoint: TPointF): boolean;
begin
result := false;
end;
function TVectorShape.PointInPen(APoint: TPointF): boolean;
begin
result := false;
end;
procedure TVectorShape.ConfigureEditor(AEditor: TBGRAOriginalEditor);
begin
if (Usermode = vsuEditBackFill) and BackFill.IsEditable then
BackFill.ConfigureEditor(AEditor)
else
if (Usermode = vsuEditPenFill) and PenFill.IsEditable then
PenFill.ConfigureEditor(AEditor)
else
if (Usermode = vsuEditOutlineFill) and OutlineFill.IsEditable then
OutlineFill.ConfigureEditor(AEditor)
else
ConfigureCustomEditor(AEditor);
end;
procedure TVectorShape.LoadFromStorage(AStorage: TBGRACustomOriginalStorage);
var
f: TVectorShapeFields;
begin
f := Fields;
if f <> [] then
begin
BeginUpdate;
Id := AStorage.Int['id'];
FRenderIteration := AStorage.Int['iteration'];
if vsfPenFill in f then LoadFill(AStorage, 'pen', FPenFill);
if vsfPenWidth in f then PenWidth := AStorage.FloatDef['pen-width', 0];
if vsfPenStyle in f then PenStyle := AStorage.FloatArray['pen-style'];
if vsfJoinStyle in f then
case AStorage.RawString['join-style'] of
'round': JoinStyle := pjsRound;
'bevel': JoinStyle := pjsBevel;
else JoinStyle := pjsMiter;
end;
if vsfBackFill in f then LoadFill(AStorage, 'back', FBackFill);
if vsfOutlineFill in f then LoadFill(AStorage, 'outline', FOutlineFill);
if vsfOutlineWidth in f then OutlineWidth := AStorage.FloatDef['outline-width', DefaultShapeOutlineWidth];
EndUpdate;
end;
end;
procedure TVectorShape.SaveToStorage(AStorage: TBGRACustomOriginalStorage);
var
f: TVectorShapeFields;
begin
AStorage.Int['id'] := Id;
AStorage.Int['iteration'] := FRenderIteration;
f := Fields;
if vsfPenFill in f then SaveFill(AStorage, 'pen', FPenFill);
if vsfPenWidth in f then AStorage.Float['pen-width'] := PenWidth;
if vsfPenStyle in f then AStorage.FloatArray['pen-style'] := PenStyle;
if vsfJoinStyle in f then
case JoinStyle of
pjsRound: AStorage.RawString['join-style'] := 'round';
pjsBevel: AStorage.RawString['join-style'] := 'bevel';
else AStorage.RawString['join-style'] := 'miter';
end;
if vsfBackFill in f then SaveFill(AStorage, 'back', FBackFill);
if OutlineVisible then
begin
if vsfOutlineFill in f then SaveFill(AStorage, 'outline', FOutlineFill);
if vsfOutlineWidth in f then AStorage.Float['outline-width'] := FOutlineWidth
else AStorage.RemoveAttribute('outline-width');
end else
begin
AStorage.RemoveObject('outline-fill');
AStorage.RemoveAttribute('outline-color');
AStorage.RemoveAttribute('outline-width');
end;
end;
procedure TVectorShape.MouseMove(Shift: TShiftState; X, Y: single; var
ACursor: TOriginalEditorCursor; var AHandled: boolean);
begin
//nothing
end;
procedure TVectorShape.MouseDown(RightButton: boolean; Shift: TShiftState; X,
Y: single; var ACursor: TOriginalEditorCursor; var AHandled: boolean);
begin
//nothing
end;
procedure TVectorShape.MouseUp(RightButton: boolean; Shift: TShiftState; X,
Y: single; var ACursor: TOriginalEditorCursor; var AHandled: boolean);
begin
//nothing
end;
procedure TVectorShape.KeyDown(Shift: TShiftState; Key: TSpecialKey;
var AHandled: boolean);
begin
//nothing
end;
procedure TVectorShape.KeyUp(Shift: TShiftState; Key: TSpecialKey;
var AHandled: boolean);
begin
//nothing
end;
procedure TVectorShape.KeyPress(UTF8Key: string; var AHandled: boolean);
begin
//nothing
end;
procedure TVectorShape.BringToFront;
begin
if Assigned(Container) then
Container.MoveShapeToIndex(Container.IndexOfShape(self),Container.ShapeCount-1);
end;
procedure TVectorShape.SendToBack;
begin
if Assigned(Container) then
Container.MoveShapeToIndex(Container.IndexOfShape(self),0);
end;
procedure TVectorShape.MoveUp(APassNonIntersectingShapes: boolean);
var
movedShapeBounds, otherShapeBounds: TRectF;
sourceIdx,idx: integer;
begin
if not Assigned(Container) then exit;
sourceIdx := Container.IndexOfShape(self);
if sourceIdx = Container.ShapeCount-1 then exit;
idx := sourceIdx;
if APassNonIntersectingShapes then
begin
movedShapeBounds := self.GetAlignBounds(InfiniteRect, AffineMatrixIdentity);
while idx < Container.ShapeCount-2 do
begin
otherShapeBounds := Container.Shape[idx+1].GetAlignBounds(InfiniteRect, AffineMatrixIdentity);
if movedShapeBounds.IntersectsWith(otherShapeBounds) then break;
inc(idx);
end;
end;
inc(idx);
Container.MoveShapeToIndex(sourceIdx, idx);
end;
procedure TVectorShape.MoveDown(APassNonIntersectingShapes: boolean);
var
movedShapeBounds, otherShapeBounds: TRectF;
sourceIdx,idx: integer;
begin
if not Assigned(Container) then exit;
sourceIdx := Container.IndexOfShape(self);
if sourceIdx = 0 then exit;
idx := sourceIdx;
if APassNonIntersectingShapes then
begin
movedShapeBounds := self.GetAlignBounds(InfiniteRect, AffineMatrixIdentity);
while idx > 1 do
begin
otherShapeBounds := Container.Shape[idx-1].GetAlignBounds(InfiniteRect, AffineMatrixIdentity);
if movedShapeBounds.IntersectsWith(otherShapeBounds) then break;
dec(idx);
end;
end;
dec(idx);
Container.MoveShapeToIndex(sourceIdx, idx);
end;
procedure TVectorShape.Remove;
var handled: boolean;
begin
if Assigned(OnRemoveQuery) then
begin
handled := false;
OnRemoveQuery(self, handled);
if handled then exit;
end;
if Assigned(Container) then Container.RemoveShape(self)
else raise exception.Create(errUndefinedContainer);
end;
procedure TVectorShape.AlignHorizontally(AAlign: TAlignment;
const AMatrix: TAffineMatrix; const ABounds: TRect);
var
sb: TRectF;
m: TAffineMatrix;
begin
if not IsAffineMatrixInversible(AMatrix) then exit;
sb := GetAlignBounds(ABounds, AMatrix);
case AAlign of
taRightJustify: m := AffineMatrixTranslation(ABounds.Right-sb.Right,0);
taCenter: m := AffineMatrixTranslation((ABounds.Left+ABounds.Right-sb.Left-sb.Right)/2,0);
else m := AffineMatrixTranslation(ABounds.Left-sb.Left,0);
end;
AlignTransform(AffineMatrixInverse(AMatrix)*m*AMatrix);
end;
procedure TVectorShape.AlignVertically(AAlign: TTextLayout;
const AMatrix: TAffineMatrix; const ABounds: TRect);
var
sb: TRectF;
m: TAffineMatrix;
begin
if not IsAffineMatrixInversible(AMatrix) then exit;
sb := GetAlignBounds(ABounds, AMatrix);
case AAlign of
tlBottom: m := AffineMatrixTranslation(0,ABounds.Bottom-sb.Bottom);
tlCenter: m := AffineMatrixTranslation(0,(ABounds.Top+ABounds.Bottom-sb.Top-sb.Bottom)/2);
else m := AffineMatrixTranslation(0,ABounds.Top-sb.Top);
end;
AlignTransform(AffineMatrixInverse(AMatrix)*m*AMatrix);
end;
function TVectorShape.GetAlignBounds(const ALayoutRect: TRect;
const AMatrix: TAffineMatrix): TRectF;
begin
result := GetRenderBounds(ALayoutRect, AMatrix, []);
end;
procedure TVectorShape.AlignTransform(const AMatrix: TAffineMatrix);
begin
Transform(AMatrix);
end;
function TVectorShape.Duplicate: TVectorShape;
var temp: TBGRAMemOriginalStorage;
shapeClass: TVectorShapeAny;
begin
shapeClass:= GetVectorShapeByStorageClassName(StorageClassName);
if shapeClass = nil then raise exception.Create(StringReplace(rsUnknownShapeClass, '%1', StorageClassName, []));
result := nil;
temp := TBGRAMemOriginalStorage.Create;
FStoreTexturePointer:= true;
try
SaveToStorage(temp);
result := shapeClass.Create(nil);
result.FStoreTexturePointer := true;
result.LoadFromStorage(temp);
finally
temp.Free;
FStoreTexturePointer:= false;
if assigned(result) then
result.FStoreTexturePointer := false;
end;
end;
{ TVectorOriginal }
function TVectorOriginal.GetShapeCount: integer;
begin
result := FShapes.Count;
end;
function TVectorOriginal.OpenShapeRenderStorage(AShapeIndex: integer; ACreate: boolean): TBGRACustomOriginalStorage;
var
shapeId: Integer;
begin
if Assigned(RenderStorage) then
begin
shapeId := Shape[AShapeIndex].Id;
if ACreate then
result := RenderStorage.CreateObject(inttostr(shapeId))
else
result := RenderStorage.OpenObject(inttostr(shapeId));
end
else
result := nil;
end;
function TVectorOriginal.FindShapeById(AId: integer): TVectorShape;
var
i: Integer;
begin
for i := 0 to FShapes.Count-1 do
if FShapes[i].Id = AId then exit(FShapes[i]);
exit(nil);
end;
procedure TVectorOriginal.DiscardUnusedRenderStorage;
var
objs: TStringList;
shapeId, errPos, i: integer;
begin
if Assigned(RenderStorage) then
begin
objs := TStringList.Create;
RenderStorage.EnumerateObjects(objs);
for i := 0 to objs.Count-1 do
begin
val(objs[i], shapeId, errPos);
if errPos = 0 then
begin
if FindShapeById(shapeId) = nil then
RenderStorage.RemoveObject(objs[i]);
end;
end;
objs.Free;
end;
end;
function TVectorOriginal.InternalInsertShape(AShape: TVectorShape;
AIndex: integer): TRectF;
var
texs: ArrayOfBGRABitmap;
i: Integer;
begin
if AShape = nil then raise exception.Create(errUnexpectedNil);
if AShape.Container <> self then
begin
if AShape.Container = nil then
AShape.Container := self
else
raise exception.Create(errContainerMismatch);
end;
if (AIndex < 0) or (AIndex > FShapes.Count) then
raise exception.Create(rsIndexOutOfBounds);
FShapes.Insert(AIndex, AShape);
texs := AShape.GetUsedTextures;
for i := 0 to high(texs) do AddTexture(texs[i]);
AShape.OnChange := @OnShapeChange;
AShape.OnEditingChange := @OnShapeEditingChange;
DiscardFrozenShapes;
result := AShape.GetRenderBounds(InfiniteRect, AffineMatrixIdentity);
end;
function TVectorOriginal.InternalInsertShapeRange(AShapes: TVectorShapes;
AIndex: integer): TRectF;
var
i: Integer;
r: TRectF;
begin
result := EmptyRectF;
if Assigned(AShapes) then
for i := 0 to AShapes.Count-1 do
begin
r := InternalInsertShape(AShapes[i], AIndex+i);
if not r.IsEmpty then
begin
if result.IsEmpty then result := r
else result := result.Union(r);
end;
end;
end;
function TVectorOriginal.InternalDeleteShapeRange(AStartIndex, ACount: integer): TRectF;
var
r: TRectF;
s: TVectorShape;
i: Integer;
begin
result := EmptyRectF;
if (AStartIndex < 0) or (AStartIndex+ACount > ShapeCount) then
raise exception.Create(rsIndexOutOfBounds);
for i := AStartIndex to AStartIndex+ACount-1 do
if Shape[i].FRemoving then
raise exception.Create(errAlreadyRemovingShape);
for i := AStartIndex to AStartIndex+ACount-1 do Shape[i].FRemoving := true;
for i := AStartIndex to AStartIndex+ACount-1 do DeselectShape(i);
for i := AStartIndex+ACount-1 downto AStartIndex do
begin
s := Shape[i];
s.OnChange := nil;
s.OnEditingChange := nil;
r := s.GetRenderBounds(InfiniteRect, AffineMatrixIdentity);
result := TRectF.Union(result,r,True);
FShapes.Delete(i);
FDeletedShapes.Add(s);
s.FRemoving:= false;
end;
DiscardFrozenShapes;
end;
function TVectorOriginal.GetNewShapeId: integer;
begin
inc(FLastShapeId);
result := FLastShapeId;
end;
function TVectorOriginal.GetShape(AIndex: integer): TVectorShape;
begin
result := FShapes[AIndex];
end;
procedure TVectorOriginal.MultiSelection_SelectionChange(Sender: TObject);
begin
if FMultiselection = FSelectedShape then
begin
DiscardFrozenShapes;
NotifyEditorChange;
end;
end;
procedure TVectorOriginal.FreeDeletedShapes;
var
i: Integer;
begin
for i := 0 to FDeletedShapes.Count-1 do
FDeletedShapes[i].Free;
FDeletedShapes.Clear
end;
procedure TVectorOriginal.OnShapeChange(ASender: TObject; ABounds: TRectF; ADiff: TVectorShapeDiff);
var
embed: TVectorOriginalShapeDiff;
idxShape: Integer;
begin
if ASender <> FSelectedShape then DiscardFrozenShapes;
if DiffExpected and Assigned(ADiff) then
begin
if ASender = FMultiselection then
idxShape := -2
else idxShape := IndexOfShape(ASender as TVectorShape);
embed := TVectorOriginalShapeDiff.Create(idxShape, ADiff);
ADiff := nil;
NotifyChange(ABounds, embed);
end else
NotifyChange(ABounds);
ADiff.Free;
end;
procedure TVectorOriginal.OnShapeEditingChange(ASender: TObject);
begin
if ASender = FSelectedShape then
NotifyEditorChange;
end;
procedure TVectorOriginal.DiscardFrozenShapes;
begin
FFrozenShapesComputed:= false;
FreeAndNil(FFrozenShapesUnderSelection);
FreeAndNil(FFrozenShapesOverSelection);
end;
function TVectorOriginal.GetTextureId(ABitmap: TBGRABitmap): integer;
var
i: Integer;
begin
if (ABitmap = nil) or (ABitmap.NbPixels = 0) then exit(EmptyTextureId);
for i := 0 to FTextureCount-1 do
if FTextures[i].Bitmap = ABitmap then exit(FTextures[i].Id);
for i := 0 to FTextureCount-1 do
if FTextures[i].Bitmap.Equals(ABitmap) then exit(FTextures[i].Id);
exit(-1);
end;
function TVectorOriginal.IndexOfTexture(AId: integer): integer;
var
i: Integer;
begin
if AId = EmptyTextureId then exit(-1);
for i := 0 to FTextureCount-1 do
if FTextures[i].Id = AId then exit(i);
exit(-1);
end;
procedure TVectorOriginal.AddTextureWithId(ATexture: TBGRABitmap; AId: integer);
begin
if FTextureCount >= length(FTextures) then
setlength(FTextures, FTextureCount*2+2);
if AId > FLastTextureId then FLastTextureId:= AId;
FTextures[FTextureCount].Bitmap := ATexture.NewReference as TBGRABitmap;
FTextures[FTextureCount].Id := AId;
inc(FTextureCount);
end;
procedure TVectorOriginal.ClearTextures;
var
i: Integer;
begin
//note that there are still shapes that could use textures
for i := 0 to FTextureCount-1 do
begin
FTextures[i].Bitmap.FreeReference;
FTextures[i].Bitmap := nil;
end;
FTextureCount := 0;
FTextures := nil;
FLastTextureId:= EmptyTextureId;
end;
constructor TVectorOriginal.Create;
begin
inherited Create;
FShapes := TVectorShapes.Create;
FDeletedShapes := TVectorShapes.Create;
FSelectedShape := nil;
FFrozenShapesUnderSelection := nil;
FFrozenShapesOverSelection := nil;
FFrozenShapesComputed:= false;
FLastTextureId:= EmptyTextureId;
FLastShapeId:= 0;
if VectorMultiselectionFactory <> nil then
begin
FMultiselection := VectorMultiselectionFactory.Create(self);
FMultiselection.Id := -2;
FMultiselection.OnChange := @OnShapeChange;
FMultiselection.OnEditingChange := @OnShapeEditingChange;
FMultiselection.GetAsMultishape.SetOnSelectionChange(@MultiSelection_SelectionChange);
end
else FMultiselection := nil;
end;
destructor TVectorOriginal.Destroy;
var
i: Integer;
begin
FMultiselection.Free;
FSelectedShape := nil;
for i := 0 to FShapes.Count-1 do
FShapes[i].Free;
FreeAndNil(FShapes);
FreeDeletedShapes;
FreeAndNil(FDeletedShapes);
FreeAndNil(FFrozenShapesUnderSelection);
FreeAndNil(FFrozenShapesOverSelection);
ClearTextures;
inherited Destroy;
end;
procedure TVectorOriginal.Clear;
var
i: Integer;
begin
if FShapes.Count > 0 then
begin
DeselectShapes;
for i := 0 to FShapes.Count-1 do
FDeletedShapes.Add(FShapes[i]);
FShapes.Clear;
FLastShapeId:= 0;
ClearTextures;
NotifyChange;
end;
end;
function TVectorOriginal.ConvertToSVG(const AMatrix: TAffineMatrix; out AOffset: TPoint): TObject;
var
svg: TBGRASVG;
rb: TRect;
vb: TSVGViewBox;
i: Integer;
sCopy: TVectorShape;
m: TAffineMatrix;
defs: TSVGDefine;
begin
m := AffineMatrixTranslation(0.5, 0.5) * AMatrix;
svg := TBGRASVG.Create;
defs := svg.Content.AppendDefine;
result := svg;
rb := GetRenderBounds(InfiniteRect, AffineMatrixIdentity);
svg.WidthAsPixel:= rb.Width;
svg.HeightAsPixel := rb.Height;
AOffset := rb.TopLeft;
vb.min := PointF(rb.Left, rb.Top);
vb.size := PointF(rb.Width, rb.Height);
svg.ViewBox := vb;
for i := 0 to ShapeCount-1 do
begin
if not IsAffineMatrixIdentity(m) then
begin
sCopy := Shape[i].Duplicate;
try
sCopy.Transform(m);
sCopy.AppendToSVG(svg.Content, defs);
finally
sCopy.Free;
end;
end else
Shape[i].AppendToSVG(svg.Content, defs);
end;
if defs.Content.ElementCount = 0 then
svg.Content.RemoveElement(defs);
end;
function TVectorOriginal.AddTexture(ATexture: TBGRABitmap): integer;
begin
result := GetTextureId(ATexture);
if result <> -1 then exit;
result:= FLastTextureId+1;
AddTextureWithId(ATexture, result);
end;
function TVectorOriginal.GetTexture(AId: integer): TBGRABitmap;
var
index: Integer;
begin
index := IndexOfTexture(AId);
if index = -1 then
result := nil
else
result := FTextures[index].Bitmap;
end;
procedure TVectorOriginal.DiscardUnusedTextures;
var
i, j: Integer;
texs: array Of TBGRABitmap;
begin
for i := 0 to FTextureCount-1 do
FTextures[i].Counter:= 0;
for i := 0 to FShapes.Count-1 do
begin
texs := FShapes[i].GetUsedTextures;
for j := 0 to high(texs) do
inc(FTextures[IndexOfTexture(GetTextureId(texs[j]))].Counter);
end;
for i := FTextureCount-1 downto 0 do
if FTextures[i].Counter = 0 then
begin
FTextures[i].Bitmap.FreeReference;
FTextures[i].Bitmap := nil;
for j := i to FTextureCount-2 do
FTextures[j] := FTextures[j+1];
dec(FTextureCount);
end;
if FTextureCount < length(FTextures) div 2 then
setlength(FTextures, FTextureCount);
end;
function TVectorOriginal.AddShape(AShape: TVectorShape): integer;
begin
result := ShapeCount;
InsertShape(AShape, result);
end;
function TVectorOriginal.AddShape(AShape: TVectorShape;
AUsermode: TVectorShapeUsermode): integer;
begin
result := AddShape(AShape);
AShape.Usermode:= AUsermode;
SelectShape(result);
end;
function TVectorOriginal.AddShapes(AShapes: TVectorShapes): integer;
begin
result := ShapeCount;
InsertShapes(AShapes, result);
end;
procedure TVectorOriginal.InsertShape(AShape: TVectorShape; AIndex: integer);
var
newShapes: TVectorShapes;
begin
newShapes := TVectorShapes.Create;
newShapes.Add(AShape);
ReplaceShapeRange(AIndex,0,newShapes);
newShapes.Free;
end;
procedure TVectorOriginal.InsertShapes(AShapes: TVectorShapes;
AIndex: integer);
begin
ReplaceShapeRange(AIndex, 0, AShapes);
end;
function TVectorOriginal.RemoveShape(AShape: TVectorShape): boolean;
var
idx: LongInt;
multiSel: IVectorMultishape;
startIndex, endIndex, nextIndex, i, selCount: Integer;
begin
if AShape.FRemoving then exit(false);
if (AShape = FMultiselection) and Assigned(FMultiselection) then
begin
multiSel := FMultiselection.GetAsMultishape;
selCount := multiSel.ShapeCount;
if selCount = 0 then exit;
endIndex := IndexOfShape(multiSel.GetShape(selCount-1));
startIndex := endIndex;
i := selCount-2;
while i >= 0 do
begin
nextIndex := IndexOfShape(multiSel.GetShape(i));
if nextIndex < startIndex-1 then
begin
DeleteShapeRange(startIndex, endIndex-startIndex+1);
endIndex := nextIndex;
startIndex := endIndex;
end else
startIndex := nextIndex;
dec(i);
end;
DeleteShapeRange(startIndex, endIndex-startIndex+1);
end else
begin
idx := FShapes.IndexOf(AShape);
if idx = -1 then exit(false);
DeleteShapeRange(idx, 1);
result := true;
end;
end;
procedure TVectorOriginal.DeleteShape(AIndex: integer);
begin
DeleteShapeRange(AIndex, 1);
end;
procedure TVectorOriginal.DeleteShapeRange(AStartIndex, ACount: integer);
begin
ReplaceShapeRange(AStartIndex, ACount, nil);
end;
procedure TVectorOriginal.ReplaceShape(AIndex: integer; ANewShape: TVectorShape);
var newShapes: TVectorShapes;
begin
if ANewShape = nil then raise exception.Create(errUnexpectedNil);
newShapes:= TVectorShapes.Create;
newShapes.Add(ANewShape);
ReplaceShapeRange(AIndex, 1, newShapes);
newShapes.Free;
end;
procedure TVectorOriginal.ReplaceShapeRange(AStartIndex: integer;
ACountBefore: integer; ANewShapes: TVectorShapes);
var
rDelete, rInsert: TRectF;
removed: TVectorShapes;
diff: TVectorOriginalShapeRangeDiff;
i: Integer;
begin
if (AStartIndex < 0) or (AStartIndex+ACountBefore > ShapeCount) then
raise exception.Create(rsIndexOutOfBounds);
if Assigned(ANewShapes) then
for i := 0 to ANewShapes.Count-1 do
if ANewShapes[i] is VectorMultiselectionFactory then
raise exception.Create('Cannot add a multiselection as a shape');
if Assigned(ANewShapes) then
for i := 0 to ANewShapes.Count-1 do
ANewShapes[i].Id := GetNewShapeId;
if DiffExpected then
begin
if ACountBefore > 0 then
begin
removed := TVectorShapes.Create;
for i := 0 to ACountBefore-1 do removed.Add(Shape[AStartIndex+i]);
end else removed := nil;
diff := TVectorOriginalShapeRangeDiff.Create(AStartIndex, removed, ANewShapes,
-1,-1);
removed.Free;
end else diff := nil;
rDelete := InternalDeleteShapeRange(AStartIndex, ACountBefore);
rInsert := InternalInsertShapeRange(ANewShapes, AStartIndex);
NotifyChange(TRectF.Union(rDelete,rInsert,True), diff);
end;
function TVectorOriginal.SelectShapes(AShapes: TVectorShapes): boolean;
begin
if AShapes.Count = 0 then result := DeselectShapes
else if AShapes.Count = 1 then result := SelectShape(AShapes[0])
else
begin
FSelectedShape := FMultiselection;
if FMultiselection.GetAsMultishape.SetShapes(AShapes) then
NotifyEditorChange;
end;
end;
function TVectorOriginal.SelectShape(AIndex: integer; AToggle: boolean): boolean;
begin
if AIndex=-1 then result := SelectShape(nil, AToggle)
else
begin
if (AIndex < 0) or (AIndex >= FShapes.Count) then
raise ERangeError.Create(rsIndexOutOfBounds);
result := SelectShape(FShapes[AIndex], AToggle);
end;
end;
function TVectorOriginal.SelectShape(AShape: TVectorShape; AToggle: boolean): boolean;
var
prevSel, newSel: TVectorShape;
prevMode: TVectorShapeUsermode;
multiSel: IVectorMultishape;
begin
result := false;
//when selecting nothing
if AShape = nil then
begin
if not AToggle then
result := DeselectShapes;
exit;
end;
//selecting current selection
if AShape = FSelectedShape then
begin
if AToggle then
result := DeselectShapes;
exit;
end;
//check selected shape exists
if AShape <> nil then
if FShapes.IndexOf(AShape)=-1 then
raise exception.Create(rsShapeNotFound);
//case of modifying multiselection
if (FSelectedShape = FMultiselection) and Assigned(FMultiselection) and AToggle then
begin
multiSel := FSelectedShape.GetAsMultishape;
if multiSel.ContainsShape(AShape) then
begin
multiSel.RemoveShape(AShape);
if multiSel.ShapeCount = 0 then
begin
FSelectedShape := nil;
exit(true);
end else
if multiSel.ShapeCount > 1 then
exit(true) else
begin
SelectShape(multiSel.GetShape(0));
exit(true);
end;
end else
begin
multiSel.AddShape(AShape);
exit(true);
end;
end;
//changing selection completely
prevSel := FSelectedShape;
if Assigned(prevSel) then
begin
prevMode := prevSel.Usermode;
prevSel.Usermode := vsuEdit;
end else
prevMode := vsuEdit;
//becomes a multiselection
if AToggle and (prevSel <> nil) and Assigned(FMultiselection) then
begin
multiSel := FMultiselection.GetAsMultishape;
multiSel.ClearShapes;
multiSel.AddShape(prevSel);
multiSel.AddShape(AShape);
newSel := FMultiselection;
end else
begin
//otherwise simple selection
newSel := AShape;
end;
//transfering user mode
if (prevMode = vsuEditBackFill) and (prevMode in newSel.Usermodes) and
newSel.BackFill.IsEditable then newSel.Usermode:= prevMode;
if (prevMode = vsuEditPenFill) and (prevMode in newSel.Usermodes) and
newSel.PenFill.IsEditable then newSel.Usermode:= prevMode;
if (prevMode = vsuEditOutlineFill) and (prevMode in newSel.Usermodes) and
newSel.OutlineFill.IsEditable then newSel.Usermode:= prevMode;
if (prevMode = vsuEditText) and (prevMode in newSel.Usermodes) then
newSel.Usermode := prevMode;
FSelectedShape := newSel;
DiscardFrozenShapes;
NotifyEditorChange;
if Assigned(FOnSelectShape) then
FOnSelectShape(self, FSelectedShape, prevSel);
if (prevSel = FMultiselection) and Assigned(FMultiselection) then
FMultiselection.GetAsMultishape.ClearShapes;
end;
function TVectorOriginal.DeselectShapes: boolean;
var
prev: TVectorShape;
begin
if SelectedShape = nil then exit(false);
prev := SelectedShape;
SelectedShape.Usermode := vsuEdit;
FSelectedShape := nil;
if (prev = FMultiselection) and Assigned(FMultiselection) then
FMultiselection.GetAsMultishape.ClearShapes;
DiscardFrozenShapes;
NotifyEditorChange;
if Assigned(FOnSelectShape) then
FOnSelectShape(self, nil, prev);
result := true;
end;
procedure TVectorOriginal.DeselectShape(AIndex: integer);
begin
if (AIndex >= 0) and (AIndex < ShapeCount) then
DeselectShape(Shape[AIndex]);
end;
procedure TVectorOriginal.DeselectShape(AShape: TVectorShape);
var
multiSel: IVectorMultishape;
begin
if AShape = SelectedShape then DeselectShapes else
begin
if (SelectedShape = FMultiselection) and Assigned(FMultiselection) then
begin
multiSel := SelectedShape.GetAsMultishape;
if multiSel.ContainsShape(AShape) then
multiSel.RemoveShape(AShape);
if multiSel.ShapeCount = 1 then
SelectShape(multiSel.GetShape(0));
end;
end;
end;
function TVectorOriginal.GetShapesCost: integer;
var
i: Integer;
begin
result := 0;
for i := 0 to ShapeCount-1 do
inc(result, Shape[i].GetGenericCost);
end;
function TVectorOriginal.PreferDraftMode(AEditor: TBGRAOriginalEditor; const AMatrix: TAffineMatrix): boolean;
begin
if Assigned(SelectedShape) and Assigned(AEditor) then
begin
result := (AEditor.IsMovingPoint or SelectedShape.IsFollowingMouse) and
SelectedShape.GetIsSlow(AMatrix);
end else
result := false;
end;
function TVectorOriginal.MouseClick(APoint: TPointF; ARadius: single; AToggle: boolean): boolean;
var
i: LongInt;
begin
for i:= FShapes.Count-1 downto 0 do
if FShapes[i].PointInShape(APoint) then
begin
if SelectedShape <> FShapes[i] then
begin
SelectShape(i, AToggle);
exit(true);
end else
exit(false);
end;
for i:= FShapes.Count-1 downto 0 do
if FShapes[i].PointInShape(APoint, ARadius) then
begin
if SelectedShape <> FShapes[i] then
begin
SelectShape(i, AToggle);
exit(true);
end else
exit(false);
end;
if (SelectedShape <> nil) and not AToggle then
begin
DeselectShapes;
exit(true);
end else
exit(false);
end;
procedure TVectorOriginal.Render(ADest: TBGRABitmap; ARenderOffset: TPoint; AMatrix: TAffineMatrix;
ADraft: boolean);
var
i: Integer;
idxSelected, newUnfrozenRangeStart, newUnfrozenRangeEnd: LongInt;
shapeRectF, clipRectF, allRectF: TRectF;
mOfs: TAffineMatrix;
multiSel: IVectorMultishape;
ofsRange: TPoint;
oldClip: TRect;
begin
if FSelectedShape <> FMultiselection then
begin
idxSelected := FShapes.IndexOf(FSelectedShape);
if idxSelected = -1 then
begin
FSelectedShape := nil;
newUnfrozenRangeStart := 0;
newUnfrozenRangeEnd := ShapeCount;
end else
begin
newUnfrozenRangeStart := idxSelected;
newUnfrozenRangeEnd := idxSelected+1;
end;
end else
if FMultiselection = nil then
begin
newUnfrozenRangeStart := 0;
newUnfrozenRangeEnd := ShapeCount;
end else
begin
multiSel := FMultiselection.GetAsMultishape;
if multiSel.ShapeCount = 0 then
begin
FSelectedShape := nil;
newUnfrozenRangeStart := 0;
newUnfrozenRangeEnd := ShapeCount;
end;
newUnfrozenRangeStart := IndexOfShape(multiSel.BackShape);
newUnfrozenRangeEnd := IndexOfShape(multiSel.FrontShape)+1;
end;
if (newUnfrozenRangeStart <> FUnfrozenRangeStart) or
(newUnfrozenRangeEnd <> FUnfrozenRangeEnd) or
(AMatrix <> FFrozenShapeMatrix) then
DiscardFrozenShapes;
with ADest.ClipRect do
clipRectF := RectF(Left,Top,Right,Bottom);
mOfs := AffineMatrixTranslation(ARenderOffset.X,ARenderOffset.Y)*AMatrix;
if FFrozenShapesComputed then
begin
if Assigned(FFrozenShapesUnderSelection) then
ADest.PutImage(ARenderOffset.X-FFrozenShapesRenderOffset.X+FFrozenShapesUnderBounds.Left,
ARenderOffset.Y-FFrozenShapesRenderOffset.Y+FFrozenShapesUnderBounds.Top,
FFrozenShapesUnderSelection, dmSet);
for i := FUnfrozenRangeStart to FUnfrozenRangeEnd-1 do
begin
shapeRectF := FShapes[i].GetRenderBounds(ADest.ClipRect, mOfs, []);
if shapeRectF.IntersectsWith(clipRectF) then
begin
with shapeRectF do
oldClip := ADest.IntersectClip(rect(floor(Left), floor(Top), ceil(Right), ceil(Bottom)));
FShapes[i].Render(ADest, ARenderOffset, AMatrix, ADraft);
ADest.ClipRect := oldClip;
end;
end;
if Assigned(FFrozenShapesOverSelection) then
ADest.PutImage(ARenderOffset.X-FFrozenShapesRenderOffset.X+FFrozenShapesOverBounds.Left,
ARenderOffset.Y-FFrozenShapesRenderOffset.Y+FFrozenShapesOverBounds.Top,
FFrozenShapesOverSelection, dmDrawWithTransparency);
end else
begin
if (newUnfrozenRangeStart > 0) or (newUnfrozenRangeEnd < ShapeCount) then
begin
allRectF := rectF(0,0,ADest.Width,ADest.Height);
FUnfrozenRangeStart := newUnfrozenRangeStart;
FUnfrozenRangeEnd := newUnfrozenRangeEnd;
FreeAndNil(FFrozenShapesUnderSelection);
if FUnfrozenRangeStart > 0 then
begin
FFrozenShapesUnderBounds := GetRenderBounds(rect(0,0,ADest.Width,ADest.Height), mOfs,
0, FUnfrozenRangeStart-1);
FFrozenShapesUnderBounds.Intersect(rect(0,0,ADest.Width,ADest.Height));
FFrozenShapesUnderSelection := TBGRABitmap.Create(FFrozenShapesUnderBounds.Width, FFrozenShapesUnderBounds.Height);
ofsRange := Point(ARenderOffset.X - FFrozenShapesUnderBounds.Left,
ARenderOffset.Y - FFrozenShapesUnderBounds.Top);
for i:= 0 to FUnfrozenRangeStart-1 do
begin
shapeRectF := FShapes[i].GetRenderBounds(rect(0,0,ADest.Width,ADest.Height), mOfs, []);
if shapeRectF.IntersectsWith(allRectF) then
begin
shapeRectF.Offset(-FFrozenShapesUnderBounds.Left, -FFrozenShapesUnderBounds.Top);
with shapeRectF do
oldClip := FFrozenShapesUnderSelection.IntersectClip(rect(floor(Left), floor(Top), ceil(Right), ceil(Bottom)));
FShapes[i].Render(FFrozenShapesUnderSelection, ofsRange, AMatrix, false);
FFrozenShapesUnderSelection.ClipRect := oldClip;
end;
end;
ADest.PutImage(FFrozenShapesUnderBounds.Left, FFrozenShapesUnderBounds.Top,
FFrozenShapesUnderSelection, dmSet);
end;
for i := FUnfrozenRangeStart to FUnfrozenRangeEnd-1 do
if FShapes[i].GetRenderBounds(ADest.ClipRect, mOfs, []).IntersectsWith(clipRectF) then
FShapes[i].Render(ADest, ARenderOffset, AMatrix, ADraft);
FreeAndNil(FFrozenShapesOverSelection);
if FUnfrozenRangeEnd < FShapes.Count then
begin
FFrozenShapesOverBounds := GetRenderBounds(rect(0,0,ADest.Width,ADest.Height), mOfs,
FUnfrozenRangeEnd, FShapes.Count-1);
FFrozenShapesOverBounds.Intersect(rect(0,0,ADest.Width,ADest.Height));
FFrozenShapesOverSelection := TBGRABitmap.Create(FFrozenShapesOverBounds.Width, FFrozenShapesOverBounds.Height);
ofsRange := Point(ARenderOffset.X - FFrozenShapesOverBounds.Left,
ARenderOffset.Y - FFrozenShapesOverBounds.Top);
for i:= FUnfrozenRangeEnd to FShapes.Count-1 do
begin
shapeRectF := FShapes[i].GetRenderBounds(rect(0,0,ADest.Width,ADest.Height), mOfs, []);
if shapeRectF.IntersectsWith(allRectF) then
begin
shapeRectF.Offset(-FFrozenShapesOverBounds.Left, -FFrozenShapesOverBounds.Top);
with shapeRectF do
oldClip := FFrozenShapesOverSelection.IntersectClip(rect(floor(Left), floor(Top), ceil(Right), ceil(Bottom)));
FShapes[i].Render(FFrozenShapesOverSelection, ofsRange, AMatrix, false);
FFrozenShapesOverSelection.ClipRect := oldClip;
end;
end;
ADest.PutImage(FFrozenShapesOverBounds.Left, FFrozenShapesOverBounds.Top,
FFrozenShapesOverSelection, dmDrawWithTransparency);
end;
FFrozenShapesRenderOffset := ARenderOffset;
FFrozenShapesComputed := true;
FFrozenShapeMatrix := AMatrix;
end else
begin
for i:= 0 to FShapes.Count-1 do
if FShapes[i].GetRenderBounds(ADest.ClipRect, mOfs, []).IntersectsWith(clipRectF) then
FShapes[i].Render(ADest, ARenderOffset, AMatrix, ADraft);
end;
end;
DiscardUnusedRenderStorage;
end;
procedure TVectorOriginal.ConfigureEditor(AEditor: TBGRAOriginalEditor);
begin
inherited ConfigureEditor(AEditor);
if Assigned(FSelectedShape) then
begin
if (FShapes.IndexOf(FSelectedShape)=-1) and
(FSelectedShape <> FMultiselection) then
begin
FSelectedShape := nil;
DiscardFrozenShapes;
end
else
FSelectedShape.ConfigureEditor(AEditor);
end;
//no more reference to event handlers
FreeDeletedShapes;
end;
function TVectorOriginal.CreateEditor: TBGRAOriginalEditor;
begin
Result:= TVectorOriginalEditor.Create(self);
end;
function TVectorOriginal.GetRenderBounds(ADestRect: TRect;
AMatrix: TAffineMatrix): TRect;
begin
result := GetRenderBounds(ADestRect, AMatrix, 0, ShapeCount-1);
end;
function TVectorOriginal.GetRenderBounds(ADestRect: TRect;
AMatrix: TAffineMatrix; AStartIndex, AEndIndex: integer): TRect;
var
area, shapeArea: TRectF;
i: Integer;
shapeDir: TBGRACustomOriginalStorage;
useStorage: Boolean;
iteration: LongInt;
begin
area:= EmptyRectF;
useStorage := Assigned(RenderStorage) and (RenderStorage.AffineMatrix['last-matrix']=AMatrix);
for i:= AStartIndex to AEndIndex do
begin
if useStorage then
begin
shapeDir := OpenShapeRenderStorage(i, false);
if Assigned(shapeDir) then
begin
iteration := shapeDir.Int['iteration'];
if iteration = FShapes[i].FRenderIteration then
begin
shapeArea := shapeDir.RectangleF['bounds'];
area := area.Union(shapeArea, true);
shapeDir.Free;
continue;
end;
end;
end;
shapeArea := FShapes[i].GetRenderBounds(ADestRect, AMatrix);
area := area.Union(shapeArea, true);
end;
if IsEmptyRectF(area) then
result := EmptyRect
else
result := rect(floor(area.Left),floor(area.Top),ceil(area.Right),ceil(area.Bottom));
end;
function TVectorOriginal.GetAlignBounds(ADestRect: TRect; AMatrix: TAffineMatrix): TRect;
var
area, shapeArea: TRectF;
i: Integer;
begin
area:= EmptyRectF;
for i:= 0 to FShapes.Count-1 do
begin
shapeArea := FShapes[i].GetAlignBounds(ADestRect, AMatrix);
area := area.Union(shapeArea, true);
end;
if IsEmptyRectF(area) then
result := EmptyRect
else
result := rect(floor(area.Left),floor(area.Top),ceil(area.Right),ceil(area.Bottom));
end;
procedure TVectorOriginal.LoadFromStorage(AStorage: TBGRACustomOriginalStorage);
var
nb: LongInt;
i: Integer;
shapeObj, texObj: TBGRACustomOriginalStorage;
texName: String;
loadedShape: TVectorShape;
idList: array of single;
texId: integer;
bmp: TBGRABitmap;
strErrors: string;
begin
Clear;
texObj := AStorage.OpenObject('textures');
if Assigned(texObj) then
begin
try
idList := texObj.FloatArray['id'];
for i := 0 to high(idList) do
begin
texId:= round(idList[i]);
texName:= 'tex'+inttostr(texId);
try
bmp := TBGRABitmap.Create;
if not texObj.ReadBitmap(texName+'.png', bmp) and
not texObj.ReadBitmap(texName+'.jpg', bmp) then
raise exception.Create(errUnableToFindTexture);
AddTextureWithId(bmp, texId);
finally
bmp.FreeReference;
end;
end;
finally
texObj.Free;
end;
end;
strErrors := '';
nb := AStorage.Int['count'];
for i:= 0 to nb-1 do
begin
shapeObj := AStorage.OpenObject('shape'+inttostr(i+1));
if shapeObj <> nil then
try
loadedShape := TVectorShape.CreateFromStorage(shapeObj, self);
loadedShape.OnChange := @OnShapeChange;
loadedShape.OnEditingChange := @OnShapeEditingChange;
if loadedShape.Id > FLastShapeId then FLastShapeId := loadedShape.Id;
FShapes.Add(loadedShape);
except
on ex: exception do
AppendStr(strErrors, ex.Message + ' ');
end;
shapeObj.Free;
end;
for i := 0 to ShapeCount-1 do
if Shape[i].Id = 0 then
Shape[i].Id := GetNewShapeId;
NotifyChange;
if strErrors <> '' then
raise exception.Create(errErrorLoadingShape + ': ' + Trim(strErrors));
end;
procedure TVectorOriginal.SaveToStorage(AStorage: TBGRACustomOriginalStorage);
var
nb: LongInt;
i, texIndex: Integer;
shapeObj, texObj: TBGRACustomOriginalStorage;
idList: array of single;
texName: String;
mem: TMemoryStream;
texId: integer;
begin
nb := AStorage.Int['count'];
for i := 0 to nb-1 do AStorage.RemoveObject('shape'+inttostr(i+1));
AStorage.Int['count'] := 0;
for i := 0 to FShapes.Count-1 do
begin
shapeObj := AStorage.CreateObject('shape'+inttostr(i+1));
shapeObj.RawString['class'] := FShapes[i].StorageClassName;
try
FShapes[i].SaveToStorage(shapeObj);
AStorage.Int['count'] := i+1;
finally
shapeObj.Free;
end;
end;
if FTextureCount = 0 then
AStorage.RemoveObject('textures')
else
begin
texObj := nil;
try
texObj := AStorage.OpenObject('textures');
if texObj = nil then
texObj := AStorage.CreateObject('textures');
for i := 0 to FTextureCount-1 do
FTextures[i].Counter:= 0;
idList := texObj.FloatArray['id'];
for i := 0 to high(idList) do
begin
texId := round(idList[i]);
texIndex:= IndexOfTexture(texId);
if texIndex=-1 then
begin
texName := 'tex'+inttostr(texId);
texObj.RemoveFile(texName+'.png');
texObj.RemoveFile(texName+'.jpg');
end else
inc(FTextures[texIndex].Counter);
end;
setlength(idList, FTextureCount);
for i := 0 to FTextureCount-1 do
begin
if FTextures[i].Counter = 0 then
begin
texName := 'tex'+inttostr(FTextures[i].Id);
mem := TMemoryStream.Create;
try
FTextures[i].Bitmap.SaveToStreamAsPng(mem);
texObj.WriteFile(texName+'.png', mem, false);
finally
mem.Free;
end;
end;
idList[i] := FTextures[i].Id;
end;
texObj.FloatArray['id'] := idList;
finally
texObj.Free;
end;
end;
end;
function TVectorOriginal.IndexOfShape(AShape: TVectorShape): integer;
begin
result := FShapes.IndexOf(AShape);
end;
procedure TVectorOriginal.MoveShapeToIndex(AFromIndex, AToIndex: integer);
begin
MoveShapeToIndex([AFromIndex], [AToIndex]);
end;
procedure TVectorOriginal.MoveShapeToIndex(AFromIndex,
AToIndex: array of integer);
var
diff: TVectorOriginalMoveShapeToIndexDiff;
begin
diff := TVectorOriginalMoveShapeToIndexDiff.Create(AFromIndex, AToIndex);
if diff.IsIdentity then
begin
diff.Free;
exit;
end;
diff.Apply(self, true);
end;
class function TVectorOriginal.StorageClassName: RawByteString;
begin
result := 'vector';
end;
class function TVectorOriginal.CanConvertToSVG: boolean;
begin
result := true;
end;
initialization
RegisterLayerOriginal(TVectorOriginal);
end.
./lazpaint-7.1.6/lazpaintcontrols/lcvectorshapes.pas 0000664 0001750 0001750 00000000431 13761713342 023045 0 ustar circular circular // SPDX-License-Identifier: GPL-3.0-only
unit LCVectorShapes;
{$mode objfpc}{$H+}
interface
uses
LCVectorRectShapes, LCVectorPolyShapes, LCVectorTextShapes;
implementation
procedure RegisterShapes;
begin
//done in used units
end;
initialization
RegisterShapes;
end.
./lazpaint-7.1.6/lazpaintcontrols/lcresourcestring.pas 0000664 0001750 0001750 00000004015 13761713342 023417 0 ustar circular circular // SPDX-License-Identifier: GPL-3.0-only
unit LCResourceString;
{$mode objfpc}{$H+}
interface
uses BGRABitmapTypes;
function GradientTypeToTranslatedStr(AGradientType: TGradientType): string;
resourcestring
rsPreview = 'Preview';
rsNoFill = 'No fill';
rsSolidColor = 'Solid color';
rsColor = 'Color';
rsOpacity = 'Opacity';
rsGradientFill = 'Gradient fill';
rsSwapColors = 'Swap colors';
rsStartOpacity = 'Start opacity';
rsEndOpacity = 'End opacity';
rsGradientLinear = 'Linear';
rsGradientReflected = 'Reflected';
rsGradientDiamond = 'Diamond';
rsGradientRadial = 'Radial';
rsGradientAngular = 'Angular';
rsGradientRepetition = 'Gradient repetition';
rsGrPad = 'Pad';
rsGrRepeat = 'Repeat';
rsGrReflect = 'Reflect';
rsGrSine = 'Sine';
rsColorInterpolation = 'Color interpolation';
rsCiStdRGB = 'sRGB';
rsCiLinearRGB = 'RGB';
rsCiLinearHSLPositive = 'HSL CW';
rsCiLinearHSLNegative = 'HSL CCW';
rsCiGSBPositive = 'Corr. HSL CW';
rsCiGSBNegative = 'Corr. HSL CCW';
rsTextureFill = 'Texture fill';
rsTextureRepetition = 'Texture repetition';
rsLoadTexture = 'Load texture';
rsTrNone = 'No repetition';
rsTrRepeatX = 'Repeat X';
rsTrRepeatY = 'Repeat Y';
rsTrRepeatBoth = 'Repeat both';
rsEditGradTexPoints = 'Edit gradient/texture points';
rsAdjustToShape = 'Adjust to shape';
rsNotTextureFill = 'It is not a texture fill';
rsIncompatibleType = 'Incompatible type';
rsLightPosition = 'Light position';
rsShapeClassNotSpecified = 'Shape class not specified';
rsUnknownShapeClass = 'Unknown shape class "%1"';
rsShapeNotFound = 'Shape not found';
rsIndexOutOfBounds = 'Index out of bounds';
implementation
function GradientTypeToTranslatedStr(AGradientType: TGradientType): string;
begin
case AGradientType of
gtLinear: result := rsGradientLinear;
gtReflected: result := rsGradientReflected;
gtDiamond: result := rsGradientDiamond;
gtRadial: result := rsGradientRadial;
gtAngular: result := rsGradientAngular;
else result := '?';
end;
end;
end.
./lazpaint-7.1.6/lazpaintcontrols/lcvectorrectshapes.pas 0000664 0001750 0001750 00000177335 13761713342 023745 0 ustar circular circular // SPDX-License-Identifier: GPL-3.0-only
unit LCVectorRectShapes;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Types, LCVectorOriginal, BGRABitmapTypes, BGRALayerOriginal,
BGRABitmap, BGRATransform, BGRAGradients, BGRASVGShapes, BGRASVGType, BGRAUnits;
type
TCustomRectShape = class;
{ TCustomRectShapeDiff }
TCustomRectShapeDiff = class(TVectorShapeDiff)
protected
FStartOrigin, FStartXAxis, FStartYAxis: TPointF;
FStartFixedRatio: Single;
FEndOrigin, FEndXAxis, FEndYAxis: TPointF;
FEndFixedRatio: Single;
public
constructor Create(AStartShape: TVectorShape); override;
procedure ComputeDiff(AEndShape: TVectorShape); override;
procedure Apply(AStartShape: TVectorShape); override;
procedure Unapply(AEndShape: TVectorShape); override;
procedure Append(ADiff: TVectorShapeDiff); override;
function IsIdentity: boolean; override;
end;
{ TCustomRectShape }
TCustomRectShape = class(TVectorShape)
private
procedure SetXAxis(AValue: TPointF);
procedure SetYAxis(AValue: TPointF);
protected
FOrigin, FXAxis, FYAxis: TPointF;
FOriginBackup,FXUnitBackup,FYUnitBackup,
FXAxisBackup,FYAxisBackup: TPointF;
FXSizeBackup,FYSizeBackup: single;
FMatrixBackup: TAffineMatrix;
FFixedRatio: single;
FDisableHitBox: boolean;
procedure DoMoveXAxis(ANewCoord: TPointF; AShift: TShiftState; AFactor: single);
procedure DoMoveYAxis(ANewCoord: TPointF; AShift: TShiftState; AFactor: single);
procedure DoMoveXYCorner(ANewCoord: TPointF; AShift: TShiftState; AFactorX, AFactorY: single);
procedure OnMoveOrigin({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; {%H-}AShift: TShiftState);
procedure OnMoveXAxis({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
procedure OnMoveYAxis({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
procedure OnMoveXAxisNeg({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
procedure OnMoveYAxisNeg({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
procedure OnMoveXAxisAlt({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
procedure OnMoveYAxisAlt({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
procedure OnMoveXAxisNegAlt({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
procedure OnMoveYAxisNegAlt({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
procedure OnMoveXYCorner({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
procedure OnMoveXNegYCorner({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
procedure OnMoveXYNegCorner({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
procedure OnMoveXNegYNegCorner({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
procedure OnMoveXYCornerAlt({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
procedure OnMoveXNegYCornerAlt({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
procedure OnMoveXYNegCornerAlt({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
procedure OnMoveXNegYNegCornerAlt({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
procedure OnStartMove({%H-}ASender: TObject; {%H-}APointIndex: integer; {%H-}AShift: TShiftState);
procedure UpdateFillFromRectDiff;
function GetCornerPositition: single; virtual; abstract;
function GetOrthoRect(AMatrix: TAffineMatrix; out ARect: TRectF): boolean;
function ShowArrows: boolean; virtual;
procedure SetOrigin(AValue: TPointF);
function GetHeight: single;
function GetWidth: single;
procedure SetHeight(AValue: single);
procedure SetWidth(AValue: single);
procedure SetFixedRatio(AValue: single);
procedure EnsureRatio(ACenterX,ACenterY: single);
public
procedure QuickDefine(constref APoint1,APoint2: TPointF); override;
function SuggestGradientBox(AMatrix: TAffineMatrix): TAffineBox; override;
procedure LoadFromStorage(AStorage: TBGRACustomOriginalStorage); override;
procedure SaveToStorage(AStorage: TBGRACustomOriginalStorage); override;
function GetRenderBounds({%H-}ADestRect: TRect; AMatrix: TAffineMatrix; {%H-}AOptions: TRenderBoundsOptions = []): TRectF; override;
procedure ConfigureCustomEditor(AEditor: TBGRAOriginalEditor); override;
function GetAffineBox(const AMatrix: TAffineMatrix; APixelCentered: boolean): TAffineBox;
procedure TransformFrame(const AMatrix: TAffineMatrix); override;
procedure AlignTransform(const AMatrix: TAffineMatrix); override;
property Origin: TPointF read FOrigin write SetOrigin;
property XAxis: TPointF read FXAxis write SetXAxis;
property YAxis: TPointF read FYAxis write SetYAxis;
property Width: single read GetWidth write SetWidth;
property Height: single read GetHeight write SetHeight;
property FixedRatio: single read FFixedRatio write SetFixedRatio;
end;
{ TRectShape }
TRectShape = class(TCustomRectShape)
protected
function GetCornerPositition: single; override;
public
class function Fields: TVectorShapeFields; override;
function AppendToSVG(AContent: TSVGContent; ADefs: TSVGDefine): TSVGElement; override;
procedure Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix; ADraft: boolean); overload; override;
function GetRenderBounds({%H-}ADestRect: TRect; AMatrix: TAffineMatrix; AOptions: TRenderBoundsOptions = []): TRectF; override;
function PointInShape(APoint: TPointF): boolean; overload; override;
function PointInShape(APoint: TPointF; ARadius: single): boolean; overload; override;
function PointInBack(APoint: TPointF): boolean; overload; override;
function PointInPen(APoint: TPointF): boolean; overload; override;
function GetIsSlow(const AMatrix: TAffineMatrix): boolean; override;
class function StorageClassName: RawByteString; override;
end;
{ TEllipseShape }
TEllipseShape = class(TCustomRectShape)
protected
function GetCornerPositition: single; override;
public
constructor Create(AContainer: TVectorOriginal); override;
class function Fields: TVectorShapeFields; override;
function AppendToSVG(AContent: TSVGContent; ADefs: TSVGDefine): TSVGElement; override;
function GetAlignBounds(const {%H-}ALayoutRect: TRect; const AMatrix: TAffineMatrix): TRectF; override;
procedure Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix; ADraft: boolean); overload; override;
function GetRenderBounds({%H-}ADestRect: TRect; AMatrix: TAffineMatrix; AOptions: TRenderBoundsOptions = []): TRectF; override;
function PointInShape(APoint: TPointF): boolean; overload; override;
function PointInShape(APoint: TPointF; ARadius: single): boolean; overload; override;
function PointInBack(APoint: TPointF): boolean; overload; override;
function PointInPen(APoint: TPointF): boolean; overload; override;
function GetIsSlow(const AMatrix: TAffineMatrix): boolean; override;
class function StorageClassName: RawByteString; override;
end;
TPhongShapeKind = (pskRectangle, pskRoundRectangle, pskHalfSphere, pskConeTop, pskConeSide,
pskHorizCylinder, pskVertCylinder);
const
DefaultPhongShapeAltitudePercent = 20;
DefaultPhongBorderSizePercent = 20;
type
TPhongShape = class;
{ TPhongShapeDiff }
TPhongShapeDiff = class(TVectorShapeDiff)
protected
FStartShapeKind: TPhongShapeKind;
FStartLightPosition: TPointF;
FStartShapeAltitudePercent,FStartBorderSizePercent: single;
FEndShapeKind: TPhongShapeKind;
FEndLightPosition: TPointF;
FEndShapeAltitudePercent,FEndBorderSizePercent: single;
public
constructor Create(AStartShape: TVectorShape); override;
procedure ComputeDiff(AEndShape: TVectorShape); override;
procedure Apply(AStartShape: TVectorShape); override;
procedure Unapply(AEndShape: TVectorShape); override;
procedure Append(ADiff: TVectorShapeDiff); override;
function IsIdentity: boolean; override;
end;
{ TPhongShape }
TPhongShape = class(TCustomRectShape)
private
FShapeKind: TPhongShapeKind;
FLightPosition: TPointF;
FShapeAltitudePercent: single;
FBorderSizePercent: single;
procedure OnMoveLightPos({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF;
{%H-}AShift: TShiftState);
procedure SetBorderSizePercent(AValue: single);
procedure SetLightPosition(AValue: TPointF);
procedure SetShapeAltitudePercent(AValue: single);
procedure SetShapeKind(AValue: TPhongShapeKind);
function GetEnvelope: ArrayOfTPointF;
public
constructor Create(AContainer: TVectorOriginal); override;
destructor Destroy; override;
function GetCornerPositition: single; override;
class function Fields: TVectorShapeFields; override;
class function PreferPixelCentered: boolean; override;
function AppendToSVG(AContent: TSVGContent; ADefs: TSVGDefine): TSVGElement; override;
function GetAlignBounds(const ALayoutRect: TRect; const AMatrix: TAffineMatrix): TRectF; override;
procedure ConfigureCustomEditor(AEditor: TBGRAOriginalEditor); override;
procedure MouseDown(RightButton: boolean; Shift: TShiftState; X, Y: single; var ACursor: TOriginalEditorCursor; var AHandled: boolean); override;
procedure LoadFromStorage(AStorage: TBGRACustomOriginalStorage); override;
procedure SaveToStorage(AStorage: TBGRACustomOriginalStorage); override;
procedure Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix; ADraft: boolean); overload; override;
function GetRenderBounds({%H-}ADestRect: TRect; AMatrix: TAffineMatrix; AOptions: TRenderBoundsOptions = []): TRectF; override;
function PointInShape(APoint: TPointF): boolean; overload; override;
function PointInShape(APoint: TPointF; ARadius: single): boolean; overload; override;
function PointInBack(APoint: TPointF): boolean; overload; override;
function GetIsSlow(const AMatrix: TAffineMatrix): boolean; override;
function GetGenericCost: integer; override;
procedure Transform(const AMatrix: TAffineMatrix); override;
function AllowShearTransform: boolean; override;
class function StorageClassName: RawByteString; override;
property ShapeKind: TPhongShapeKind read FShapeKind write SetShapeKind;
property LightPosition: TPointF read FLightPosition write SetLightPosition;
property ShapeAltitudePercent: single read FShapeAltitudePercent write SetShapeAltitudePercent;
property BorderSizePercent: single read FBorderSizePercent write SetBorderSizePercent;
end;
implementation
uses BGRAPen, BGRAGraphics, BGRAFillInfo, BGRAPath, math, LCVectorialFill, LCResourceString;
{ TPhongShapeDiff }
constructor TPhongShapeDiff.Create(AStartShape: TVectorShape);
begin
with (AStartShape as TPhongShape) do
begin
FStartShapeKind:= ShapeKind;
FStartLightPosition:= LightPosition;
FStartShapeAltitudePercent:= ShapeAltitudePercent;
FStartBorderSizePercent:= BorderSizePercent;
end;
end;
procedure TPhongShapeDiff.ComputeDiff(AEndShape: TVectorShape);
begin
with (AEndShape as TPhongShape) do
begin
FEndShapeKind:= ShapeKind;
FEndLightPosition:= LightPosition;
FEndShapeAltitudePercent:= ShapeAltitudePercent;
FEndBorderSizePercent:= BorderSizePercent;
end;
end;
procedure TPhongShapeDiff.Apply(AStartShape: TVectorShape);
begin
with (AStartShape as TPhongShape) do
begin
BeginUpdate;
FShapeKind := FEndShapeKind;
FLightPosition := FEndLightPosition;
FShapeAltitudePercent := FEndShapeAltitudePercent;
FBorderSizePercent := FEndBorderSizePercent;
EndUpdate;
end;
end;
procedure TPhongShapeDiff.Unapply(AEndShape: TVectorShape);
begin
with (AEndShape as TPhongShape) do
begin
BeginUpdate;
FShapeKind := FStartShapeKind;
FLightPosition := FStartLightPosition;
FShapeAltitudePercent := FStartShapeAltitudePercent;
FBorderSizePercent := FStartBorderSizePercent;
EndUpdate;
end;
end;
procedure TPhongShapeDiff.Append(ADiff: TVectorShapeDiff);
var
next: TPhongShapeDiff;
begin
next := ADiff as TPhongShapeDiff;
FEndShapeKind := next.FEndShapeKind;
FEndLightPosition := next.FEndLightPosition;
FEndShapeAltitudePercent := next.FEndShapeAltitudePercent;
FEndBorderSizePercent := next.FEndBorderSizePercent;
end;
function TPhongShapeDiff.IsIdentity: boolean;
begin
result := (FStartShapeKind = FEndShapeKind) and
(FStartLightPosition = FEndLightPosition) and
(FStartShapeAltitudePercent = FEndShapeAltitudePercent) and
(FStartBorderSizePercent = FEndBorderSizePercent);
end;
{ TCustomRectShapeDiff }
constructor TCustomRectShapeDiff.Create(AStartShape: TVectorShape);
begin
with (AStartShape as TCustomRectShape) do
begin
FStartOrigin := Origin;
FStartXAxis := XAxis;
FStartYAxis := YAxis;
FStartFixedRatio := FixedRatio;
end;
end;
procedure TCustomRectShapeDiff.ComputeDiff(AEndShape: TVectorShape);
begin
with (AEndShape as TCustomRectShape) do
begin
FEndOrigin := Origin;
FEndXAxis := XAxis;
FEndYAxis := YAxis;
FEndFixedRatio := FixedRatio;
end;
end;
procedure TCustomRectShapeDiff.Apply(AStartShape: TVectorShape);
begin
with (AStartShape as TCustomRectShape) do
begin
BeginUpdate;
FOrigin := FEndOrigin;
FXAxis := FEndXAxis;
FYAxis := FEndYAxis;
FFixedRatio := FEndFixedRatio;
EndUpdate;
end;
end;
procedure TCustomRectShapeDiff.Unapply(AEndShape: TVectorShape);
begin
with (AEndShape as TCustomRectShape) do
begin
BeginUpdate;
FOrigin := FStartOrigin;
FXAxis := FStartXAxis;
FYAxis := FStartYAxis;
FFixedRatio := FStartFixedRatio;
EndUpdate;
end;
end;
procedure TCustomRectShapeDiff.Append(ADiff: TVectorShapeDiff);
var
next: TCustomRectShapeDiff;
begin
next := ADiff as TCustomRectShapeDiff;
FEndOrigin := next.FEndOrigin;
FEndXAxis := next.FEndXAxis;
FEndYAxis := next.FEndYAxis;
FEndFixedRatio := next.FEndFixedRatio;
end;
function TCustomRectShapeDiff.IsIdentity: boolean;
begin
result := (FStartOrigin = FEndOrigin) and
(FStartXAxis = FEndXAxis) and
(FStartYAxis = FEndYAxis) and
(FStartFixedRatio = FEndFixedRatio);
end;
{ TCustomRectShape }
procedure TCustomRectShape.SetOrigin(AValue: TPointF);
var
delta: TPointF;
t: TAffineMatrix;
begin
if FOrigin=AValue then Exit;
BeginUpdate(TCustomRectShapeDiff);
delta := AValue - FOrigin;
t := AffineMatrixTranslation(delta.x, delta.y);
FOrigin := AValue;
FXAxis := t*FXAxis;
FYAxis := t*FYAxis;
TransformFill(t, False);
EndUpdate;
end;
function TCustomRectShape.GetHeight: single;
begin
result := VectLen(YAxis-Origin);
end;
function TCustomRectShape.GetWidth: single;
begin
result := VectLen(XAxis-Origin);
end;
procedure TCustomRectShape.SetHeight(AValue: single);
var u,v: TPointF;
h,w: single;
begin
h := GetHeight;
if h <> 0 then v := (YAxis-Origin)*(1/h)
else
begin
w := GetWidth;
if w <> 0 then
begin
u := (XAxis-Origin)*(1/w);
v := PointF(-u.y,u.x);
end else
v := PointF(0,1/2);
end;
FYAxis := Origin + v*AValue;
end;
procedure TCustomRectShape.SetWidth(AValue: single);
var u,v: TPointF;
h,w: single;
begin
w := GetWidth;
if w <> 0 then u := (XAxis-Origin)*(1/w)
else
begin
h := GetHeight;
if h <> 0 then
begin
v := (YAxis-Origin)*(1/h);
u := PointF(v.y,-v.x);
end else
u := PointF(1/2,0);
end;
FXAxis := Origin + u*AValue;
end;
procedure TCustomRectShape.EnsureRatio(ACenterX,ACenterY: single);
var
h, w, curRatio,ratioFactor,fracPower: Single;
refPoint, newRefPoint: TPointF;
begin
if (FFixedRatio<>EmptySingle) and (FFixedRatio<>0) then
begin
h := Height;
w := Width;
if h = 0 then
Height := w/FFixedRatio
else if w = 0 then
Width := h*FFixedRatio
else
begin
curRatio := Width/Height;
if FFixedRatio <> curRatio then
begin
ratioFactor := FFixedRatio/curRatio;
BeginUpdate(TCustomRectShapeDiff);
refPoint := Origin + (XAxis-Origin)*ACenterX + (YAxis-Origin)*ACenterY;
if (ACenterX=0) and (ACenterY=0) then fracPower := 1/2
else fracPower := abs(ACenterY)/(abs(ACenterX)+abs(ACenterY));
Width := Width*Power(ratioFactor, fracPower);
if (ACenterX=0) and (ACenterY=0) then fracPower := 1/2
else fracPower := abs(ACenterX)/(abs(ACenterX)+abs(ACenterY));
Height := Height/Power(ratioFactor, fracPower);
newRefPoint := Origin + (XAxis-Origin)*ACenterX + (YAxis-Origin)*ACenterY;
Origin := Origin + (refPoint-newRefPoint);
EndUpdate;
end;
end;
end;
end;
procedure TCustomRectShape.SetFixedRatio(AValue: single);
begin
if FFixedRatio=AValue then Exit;
FFixedRatio:=AValue;
EnsureRatio(0,0);
end;
procedure TCustomRectShape.SetXAxis(AValue: TPointF);
begin
if FXAxis=AValue then Exit;
BeginUpdate(TCustomRectShapeDiff);
FXAxis:=AValue;
EndUpdate;
end;
procedure TCustomRectShape.SetYAxis(AValue: TPointF);
begin
if FYAxis=AValue then Exit;
BeginUpdate(TCustomRectShapeDiff);
FYAxis:=AValue;
EndUpdate;
end;
procedure TCustomRectShape.DoMoveXAxis(ANewCoord: TPointF; AShift: TShiftState; AFactor: single);
var
newSize: Single;
u: TPointF;
begin
BeginUpdate(TCustomRectShapeDiff);
if AllowShearTransform and ((ssAlt in AShift) or (FXUnitBackup = PointF(0,0))) then
begin
FXAxis := FOriginBackup + AFactor*(ANewCoord - FOriginBackup);
FYAxis := FYAxisBackup;
FOrigin := FOriginBackup;
end else
if FXUnitBackup = PointF(0,0) then
begin
u := ANewCoord - FOriginBackup;
FXAxis := FOriginBackup + u;
FYAxis := FOriginBackup + PointF(-u.y,u.x);
FOrigin := FOriginBackup;
end else
begin
newSize := AFactor*FXUnitBackup*(ANewCoord-FOriginBackup);
if ssShift in AShift then
begin
FXAxis := FOriginBackup+FXUnitBackup*newSize;
FYAxis := FYAxisBackup;
FOrigin := FOriginBackup;
end else
begin
FXAxis := FXAxisBackup + ((AFactor+1)*0.5)*(newSize-FXSizeBackup)*FXUnitBackup;
FYAxis := FYAxisBackup + AFactor*(newSize-FXSizeBackup)*0.5*FXUnitBackup;
FOrigin := FOriginBackup + AFactor*(newSize-FXSizeBackup)*0.5*FXUnitBackup;
end;
end;
EnsureRatio(-AFactor,0);
UpdateFillFromRectDiff;
EndUpdate;
end;
procedure TCustomRectShape.DoMoveYAxis(ANewCoord: TPointF; AShift: TShiftState;
AFactor: single);
var
newSizeY: Single;
u: TPointF;
begin
BeginUpdate(TCustomRectShapeDiff);
if AllowShearTransform and ((ssAlt in AShift) or (FYUnitBackup = PointF(0,0))) then
begin
FYAxis := FOriginBackup + AFactor*(ANewCoord - FOriginBackup);
FXAxis := FXAxisBackup;
FOrigin := FOriginBackup;
end else
if FYUnitBackup = PointF(0,0) then
begin
u := ANewCoord - FOriginBackup;
FXAxis := FOriginBackup + PointF(u.y,-u.x);
FYAxis := FOriginBackup + u;
FOrigin := FOriginBackup;
end else
begin
newSizeY := AFactor*FYUnitBackup*(ANewCoord-FOriginBackup);
if ssShift in AShift then
begin
FYAxis := FOriginBackup+FYUnitBackup*newSizeY;
FXAxis := FXAxisBackup;
FOrigin := FOriginBackup;
end else
begin
FYAxis := FYAxisBackup + ((AFactor+1)*0.5)*(newSizeY-FYSizeBackup)*FYUnitBackup;
FXAxis := FXAxisBackup + AFactor*(newSizeY-FYSizeBackup)*0.5*FYUnitBackup;
FOrigin := FOriginBackup + AFactor*(newSizeY-FYSizeBackup)*0.5*FYUnitBackup;
end;
end;
EnsureRatio(0,-AFactor);
UpdateFillFromRectDiff;
EndUpdate;
end;
procedure TCustomRectShape.DoMoveXYCorner(ANewCoord: TPointF;
AShift: TShiftState; AFactorX, AFactorY: single);
var
ratio, d: single;
m: TAffineMatrix;
newSize, prevCornerVect, newCornerVect: TPointF;
angle,deltaAngle, zoom: single;
begin
BeginUpdate(TCustomRectShapeDiff);
if (ssAlt in AShift) and (VectDet(FXUnitBackup,FYUnitBackup)<>0) and (FXSizeBackup<>0) and (FYSizeBackup<>0) then
begin
prevCornerVect := AFactorX*(FXAxisBackup - FOriginBackup) + AFactorY*(FYAxisBackup - FOriginBackup);
newCornerVect := (ANewCoord - FOriginBackup)*(1/GetCornerPositition);
m := AffineMatrixScaledRotation(prevCornerVect, newCornerVect);
if not (ssShift in AShift) then
begin
angle := arctan2(-m[2,1],m[1,1])*2/Pi;
deltaAngle := 0;
if abs(frac(angle)) < 0.1 then deltaAngle := -frac(angle)
else if frac(angle) > 0.9 then deltaAngle := +1-frac(angle)
else if frac(angle) < -0.9 then deltaAngle := -1-frac(angle)
else if abs(frac(angle)-0.5) < 0.1 then deltaAngle := 0.5-frac(angle)
else if abs(frac(angle)+0.5) < 0.1 then deltaAngle := -0.5-frac(angle);
if deltaAngle <> 0 then
begin
angle := (angle+deltaAngle)*Pi/2;
zoom := VectLen(m[1,1],m[2,1]);
m := AffineMatrixRotationRad(angle)*AffineMatrixScale(zoom,zoom);
end;
end;
m := AffineMatrixTranslation(FOriginBackup.x,FOriginBackup.y)*m
*AffineMatrixTranslation(-FOriginBackup.x,-FOriginBackup.y);
FOrigin := FOriginBackup;
FXAxis := m * FXAxisBackup;
FYAxis := m * FYAxisBackup;
end else
begin
d := GetCornerPositition;
m := AffineMatrix(AFactorX*FXUnitBackup*d,AFactorY*FYUnitBackup*d,FOriginBackup);
if IsAffineMatrixInversible(m) then
begin
m := AffineMatrixInverse(m);
newSize := m*ANewCoord;
if (ssShift in AShift) and (FXSizeBackup <> 0) and (FYSizeBackup <> 0) then
begin
ratio := (newSize.X/FXSizeBackup + newSize.Y/FYSizeBackup)/2;
newSize.X := ratio*FXSizeBackup;
newSize.Y := ratio*FYSizeBackup;
end;
FXAxis := FXAxisBackup + (AFactorX+1)*0.5*sqrt(d)*(newSize.X-FXSizeBackup)*FXUnitBackup + AFactorY*(newSize.Y-FYSizeBackup)*0.5*sqrt(d)*FYUnitBackup;
FYAxis := FYAxisBackup + (AFactorY+1)*0.5*sqrt(d)*(newSize.Y-FYSizeBackup)*FYUnitBackup + AFactorX*(newSize.X-FXSizeBackup)*0.5*sqrt(d)*FXUnitBackup;
FOrigin := FOriginBackup + AFactorX*(newSize.X-FXSizeBackup)*0.5*sqrt(d)*FXUnitBackup
+ AFactorY*(newSize.Y-FYSizeBackup)*0.5*sqrt(d)*FYUnitBackup;
end;
end;
EnsureRatio(-AFactorX,-AFactorY);
UpdateFillFromRectDiff;
EndUpdate;
end;
procedure TCustomRectShape.OnMoveOrigin(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
Origin := ANewCoord;
end;
procedure TCustomRectShape.OnMoveXAxis(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
DoMoveXAxis(ANewCoord, AShift, 1);
end;
procedure TCustomRectShape.OnMoveYAxis(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
DoMoveYAxis(ANewCoord, AShift, 1);
end;
procedure TCustomRectShape.OnMoveXAxisNeg(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
DoMoveXAxis(ANewCoord, AShift, -1);
end;
procedure TCustomRectShape.OnMoveYAxisNeg(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
DoMoveYAxis(ANewCoord, AShift, -1);
end;
procedure TCustomRectShape.OnMoveXAxisAlt(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
DoMoveXAxis(ANewCoord, AShift+[ssAlt], 1);
end;
procedure TCustomRectShape.OnMoveYAxisAlt(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
DoMoveYAxis(ANewCoord, AShift+[ssAlt], 1);
end;
procedure TCustomRectShape.OnMoveXAxisNegAlt(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
DoMoveXAxis(ANewCoord, AShift+[ssAlt], -1);
end;
procedure TCustomRectShape.OnMoveYAxisNegAlt(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
DoMoveYAxis(ANewCoord, AShift+[ssAlt], -1);
end;
procedure TCustomRectShape.OnMoveXYCorner(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
DoMoveXYCorner(ANewCoord, AShift, 1, 1);
end;
procedure TCustomRectShape.OnMoveXNegYCorner(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
DoMoveXYCorner(ANewCoord, AShift, -1, 1);
end;
procedure TCustomRectShape.OnMoveXYNegCorner(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
DoMoveXYCorner(ANewCoord, AShift, 1, -1);
end;
procedure TCustomRectShape.OnMoveXNegYNegCorner(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
DoMoveXYCorner(ANewCoord, AShift, -1, -1);
end;
procedure TCustomRectShape.OnMoveXYCornerAlt(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
DoMoveXYCorner(ANewCoord, AShift+[ssAlt], 1, 1);
end;
procedure TCustomRectShape.OnMoveXNegYCornerAlt(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
DoMoveXYCorner(ANewCoord, AShift+[ssAlt], -1, 1);
end;
procedure TCustomRectShape.OnMoveXYNegCornerAlt(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
DoMoveXYCorner(ANewCoord, AShift+[ssAlt], 1, -1);
end;
procedure TCustomRectShape.OnMoveXNegYNegCornerAlt(ASender: TObject;
APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
begin
DoMoveXYCorner(ANewCoord, AShift+[ssAlt], -1, -1);
end;
procedure TCustomRectShape.OnStartMove(ASender: TObject; APointIndex: integer;
AShift: TShiftState);
begin
FOriginBackup := FOrigin;
FXAxisBackup := FXAxis;
FXUnitBackup := FXAxis-FOrigin;
FXSizeBackup := VectLen(FXUnitBackup);
if FXSizeBackup <> 0 then FXUnitBackup := (1/FXSizeBackup)*FXUnitBackup;
FYAxisBackup := FYAxis;
FYUnitBackup := FYAxis-FOrigin;
FYSizeBackup := VectLen(FYUnitBackup);
if FYSizeBackup <> 0 then FYUnitBackup := (1/FYSizeBackup)*FYUnitBackup;
FMatrixBackup := AffineMatrix(FXAxis-FOrigin, FYAxis-FOrigin, FOrigin);
end;
procedure TCustomRectShape.UpdateFillFromRectDiff;
var
newMatrix, matrixDiff: TAffineMatrix;
begin
newMatrix := AffineMatrix(FXAxis-FOrigin, FYAxis-FOrigin, FOrigin);
if IsAffineMatrixInversible(newMatrix) and IsAffineMatrixInversible(FMatrixBackup) then
begin
matrixDiff := newMatrix*AffineMatrixInverse(FMatrixBackup);
TransformFill(matrixDiff, True);
FMatrixBackup := newMatrix;
end;
end;
function TCustomRectShape.GetAffineBox(const AMatrix: TAffineMatrix; APixelCentered: boolean): TAffineBox;
var
m: TAffineMatrix;
begin
if not APixelCentered then
m := AffineMatrixTranslation(0.5,0.5) * MatrixForPixelCentered(AMatrix)
else
m := MatrixForPixelCentered(AMatrix);
result := m * TAffineBox.AffineBox(FOrigin - (FXAxis - FOrigin) - (FYAxis - FOrigin),
FXAxis - (FYAxis - FOrigin), FYAxis - (FXAxis - FOrigin));
end;
procedure TCustomRectShape.TransformFrame(const AMatrix: TAffineMatrix);
var
m: TAffineMatrix;
begin
BeginUpdate(TCustomRectShapeDiff);
m := MatrixForPixelCentered(AMatrix);
FOrigin := m*FOrigin;
FXAxis := m*FXAxis;
FYAxis := m*FYAxis;
EndUpdate;
end;
procedure TCustomRectShape.AlignTransform(const AMatrix: TAffineMatrix);
begin
Origin := AMatrix*Origin;
end;
function TCustomRectShape.GetOrthoRect(AMatrix: TAffineMatrix; out ARect: TRectF): boolean;
var
sx,sy: single;
o,ox,oy: TPointF;
m: TAffineMatrix;
begin
m := MatrixForPixelCentered(AMatrix);
o := m*FOrigin;
ox := m*FXAxis;
oy := m*FYAxis;
if (abs(ox.y-o.y)<1e-4) and (abs(oy.x-o.x)<1e-4) then
begin
sx := abs(ox.x-o.x);
sy := abs(oy.y-o.y);
ARect := RectF(o.x - sx, o.y - sy, o.x + sx, o.y + sy);
exit(true);
end else
begin
ARect := EmptyRectF;
exit(false);
end;
end;
function TCustomRectShape.ShowArrows: boolean;
begin
result := true;
end;
procedure TCustomRectShape.QuickDefine(constref APoint1, APoint2: TPointF);
begin
BeginUpdate(TCustomRectShapeDiff);
FOrigin := (APoint1+APoint2)*0.5;
FXAxis := PointF(APoint2.X,FOrigin.Y);
FYAxis := PointF(FOrigin.X,APoint2.Y);
EnsureRatio(-1,-1);
EndUpdate;
end;
function TCustomRectShape.SuggestGradientBox(AMatrix: TAffineMatrix): TAffineBox;
begin
Result:= GetAffineBox(AMatrix,False);
end;
procedure TCustomRectShape.LoadFromStorage(AStorage: TBGRACustomOriginalStorage);
begin
BeginUpdate;
inherited LoadFromStorage(AStorage);
FOrigin := AStorage.PointF['origin'];
FXAxis := AStorage.PointF['x-axis'];
FYAxis := AStorage.PointF['y-axis'];
FFixedRatio := AStorage.Float['fixed-ratio'];
EndUpdate;
end;
procedure TCustomRectShape.SaveToStorage(AStorage: TBGRACustomOriginalStorage);
begin
inherited SaveToStorage(AStorage);
AStorage.PointF['origin'] := FOrigin;
AStorage.PointF['x-axis'] := FXAxis;
AStorage.PointF['y-axis'] := FYAxis;
AStorage.Float['fixed-ratio'] := FFixedRatio;
end;
function TCustomRectShape.GetRenderBounds(ADestRect: TRect; AMatrix: TAffineMatrix; AOptions: TRenderBoundsOptions): TRectF;
begin
result := GetAffineBox(AMatrix, false).RectBoundsF;
end;
procedure TCustomRectShape.ConfigureCustomEditor(AEditor: TBGRAOriginalEditor);
var
d: Single;
u, v: TPointF;
idx,idxOrig, idxX,idxY,idxXNeg,idxYNeg: Integer;
begin
u := FXAxis - FOrigin;
v := FYAxis - FOrigin;
AEditor.AddStartMoveHandler(@OnStartMove);
d := GetCornerPositition;
if d <> 0 then
begin
idx := AEditor.AddPoint(FOrigin + (u+v)*d, @OnMoveXYCorner, false);
AEditor.AddPointAlternateMove(idx, @OnMoveXYCornerAlt);
idx := AEditor.AddPoint(FOrigin + (-u+v)*d, @OnMoveXNegYCorner, false);
AEditor.AddPointAlternateMove(idx, @OnMoveXNegYCornerAlt);
idx := AEditor.AddPoint(FOrigin + (u-v)*d, @OnMoveXYNegCorner, false);
AEditor.AddPointAlternateMove(idx, @OnMoveXYNegCornerAlt);
idx := AEditor.AddPoint(FOrigin + (-u-v)*d, @OnMoveXNegYNegCorner, false);
AEditor.AddPointAlternateMove(idx, @OnMoveXNegYNegCornerAlt);
end;
if ShowArrows then
begin
idxX := AEditor.AddArrow(FOrigin, FXAxis, @OnMoveXAxis);
idxY := AEditor.AddArrow(FOrigin, FYAxis, @OnMoveYAxis);
idxXNeg := AEditor.AddArrow(FOrigin, FOrigin - u, @OnMoveXAxisNeg);
idxYNeg := AEditor.AddArrow(FOrigin, FOrigin - v, @OnMoveYAxisNeg);
end else
begin
idxX := AEditor.AddPoint(FXAxis, @OnMoveXAxis);
idxY := AEditor.AddPoint(FYAxis, @OnMoveYAxis);
idxXNeg := AEditor.AddPoint(FOrigin - u, @OnMoveXAxisNeg);
idxYNeg := AEditor.AddPoint(FOrigin - v, @OnMoveYAxisNeg);
end;
AEditor.AddPointAlternateMove(idxX, @OnMoveXAxisAlt);
AEditor.AddPointAlternateMove(idxY, @OnMoveYAxisAlt);
AEditor.AddPointAlternateMove(idxXNeg, @OnMoveXAxisNegAlt);
AEditor.AddPointAlternateMove(idxYNeg, @OnMoveYAxisNegAlt);
idxOrig := AEditor.AddPoint(FOrigin, @OnMoveOrigin, true);
if ShowArrows and not FDisableHitBox then
begin
AEditor.SetHitBox(idxX, TAffineBox.AffineBox(Origin + (XAxis-Origin)*0.667 - (YAxis-Origin)*0.667,
Origin + (XAxis-Origin) - (YAxis-Origin)*0.667,
Origin + (XAxis-Origin)*0.667 + (YAxis-Origin)*0.667) );
AEditor.SetHitBox(idxY, TAffineBox.AffineBox(Origin - (XAxis-Origin)*0.667 + (YAxis-Origin)*0.667,
Origin + (XAxis-Origin)*0.667 + (YAxis-Origin)*0.667,
Origin - (XAxis-Origin)*0.667 + (YAxis-Origin)) );
AEditor.SetHitBox(idxXNeg, TAffineBox.AffineBox(Origin - (XAxis-Origin) - (YAxis-Origin)*0.667,
Origin - (XAxis-Origin)*0.667 - (YAxis-Origin)*0.667,
Origin - (XAxis-Origin) + (YAxis-Origin)*0.667) );
AEditor.SetHitBox(idxYNeg, TAffineBox.AffineBox(Origin - (XAxis-Origin)*0.667 - (YAxis-Origin),
Origin + (XAxis-Origin)*0.667 - (YAxis-Origin),
Origin - (XAxis-Origin)*0.667 - (YAxis-Origin)*0.667) );
AEditor.SetHitBox(idxOrig, TAffineBox.AffineBox(Origin - (XAxis-Origin)*0.667 - (YAxis-Origin)*0.667,
Origin + (XAxis-Origin)*0.667 - (YAxis-Origin)*0.667,
Origin - (XAxis-Origin)*0.667 + (YAxis-Origin)*0.667));
end;
end;
{ TRectShape }
function TRectShape.GetCornerPositition: single;
begin
result := 1;
end;
function TRectShape.GetIsSlow(const AMatrix: TAffineMatrix): boolean;
var
ab: TAffineBox;
backSurface, totalSurface, penSurface: Single;
begin
if not GetPenVisible and not GetBackVisible then
result := false
else
begin
ab := GetAffineBox(AMatrix, true);
backSurface := ab.Surface;
if GetPenVisible then
begin
penSurface := (ab.Width+ab.Height)*2*PenWidth;
if GetBackVisible then
totalSurface:= backSurface+penSurface/2
else
totalSurface := penSurface;
end else
totalSurface := backSurface;
result := (totalSurface > 800*600) or
((backSurface > 320*240) and GetBackVisible and BackFill.IsSlow(AMatrix)) or
((penSurface > 320*240) and GetPenVisible and PenFill.IsSlow(AMatrix));
end;
end;
class function TRectShape.Fields: TVectorShapeFields;
begin
Result:= [vsfPenFill, vsfPenWidth, vsfPenStyle, vsfJoinStyle, vsfBackFill];
end;
function TRectShape.AppendToSVG(AContent: TSVGContent; ADefs: TSVGDefine): TSVGElement;
var
topLeft, u, v: TPointF;
w, h: Single;
m: TAffineMatrix;
function ApproxPointEqual(const APoint1, APoint2: TPointF): boolean;
var
precision: Single;
begin
precision := (VectLen(APoint1) + VectLen(APoint2))*1e-6;
result := VectLen(APoint2-APoint1) <= precision;
end;
begin
topLeft := Origin - (XAxis - Origin) - (YAxis - Origin);
w := Width*2; h := Height*2;
if (XAxis.y <> 0) or (YAxis.x <> 0) then
begin
u := XAxis - Origin;
if w > 0 then u *= (2/w);
v := YAxis - Origin;
if h > 0 then v *= (2/h);
m := AffineMatrixTranslation(topLeft.X, topLeft.Y) *
AffineMatrix(u, v, PointF(0, 0)) *
AffineMatrixTranslation(-topLeft.X, -topLeft.Y);
end else
m := AffineMatrixIdentity;
if not PenVisible and (BackFill.FillType = vftTexture) and
(BackFill.TextureRepetition = trNone) and Assigned(BackFill.Texture) and
ApproxPointEqual(Origin + PointF(0.5, 0.5), BackFill.TextureMatrix * PointF(BackFill.Texture.Width/2, BackFill.Texture.Height/2)) and
ApproxPointEqual(XAxis + PointF(0.5, 0.5), BackFill.TextureMatrix * PointF(BackFill.Texture.Width, BackFill.Texture.Height/2)) and
ApproxPointEqual(YAxis + PointF(0.5, 0.5), BackFill.TextureMatrix * PointF(BackFill.Texture.Width/2, BackFill.Texture.Height)) then
begin
result := AContent.AppendImage(topLeft, PointF(w,h), BackFill.Texture, false);
result.opacity:= BackFill.TextureOpacity/255;
result.Matrix[cuPixel] := m;
end else
begin
result := AContent.AppendRect(topLeft, PointF(w, h));
result.Matrix[cuPixel] := m;
ApplyStrokeStyleToSVG(result, ADefs);
ApplyFillStyleToSVG(result, ADefs);
end;
end;
procedure TRectShape.Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix;
ADraft: boolean);
const GradientDithering = false;
var
pts: Array of TPointF;
orthoRect: TRectF;
r: TRect;
backScan, penScan: TBGRACustomScanner;
temp: TBGRABitmap;
i: Integer;
begin
pts := GetAffineBox(AMatrix, true).AsPolygon;
If GetBackVisible then
begin
if (BackFill.FillType = vftSolid) then backScan := nil
else backScan := BackFill.CreateScanner(AMatrix, ADraft);
if GetOrthoRect(AMatrix, orthoRect) then
begin
if ADraft then
begin
r:= rect(round(orthoRect.Left+0.5),round(orthoRect.Top+0.5),round(orthoRect.Right+0.5),round(orthoRect.Bottom+0.5));
if Assigned(backScan) then
ADest.FillRect(r, backScan, dmDrawWithTransparency) else
ADest.FillRect(r, BackFill.SolidColor, dmDrawWithTransparency)
end
else
begin
if Assigned(backScan) then
begin
if (BackFill.FillType = vftGradient) and GradientDithering then
begin
with orthoRect do
r := rect(floor(Left),floor(Top),ceil(Right),ceil(Bottom));
temp := TBGRABitmap.Create(0,0);
temp.SetSize(r.Width,r.Height);
temp.FillRect(0,0,r.Width,r.Height,backScan,dmSet,Point(r.Left,r.Top),daFloydSteinberg);
temp.ScanOffset := Point(-r.Left,-r.Top);
ADest.FillRectAntialias(orthoRect, temp);
temp.Free;
end else
ADest.FillRectAntialias(orthoRect, backScan);
end else
ADest.FillRectAntialias(orthoRect, BackFill.SolidColor);
end;
end else
begin
if ADraft then
begin
if Assigned(backScan) then
ADest.FillPoly(pts, backScan, dmDrawWithTransparency) else
ADest.FillPoly(pts, BackFill.SolidColor, dmDrawWithTransparency)
end
else
begin
if Assigned(backScan) then
begin
if BackFill.FillType = vftGradient then
begin
r := rect(floor(pts[0].x),floor(pts[0].y),ceil(pts[0].x),ceil(pts[0].y));
for i := 1 to high(pts) do
r.Union(rect(floor(pts[i].x),floor(pts[i].y),ceil(pts[i].x),ceil(pts[i].y)));
temp := TBGRABitmap.Create(0,0);
temp.SetSize(r.Width,r.Height);
temp.FillRect(0,0,r.Width,r.Height,backScan,dmSet,Point(r.Left,r.Top),daFloydSteinberg);
temp.ScanOffset := Point(-r.Left,-r.Top);
ADest.FillPolyAntialias(pts, temp);
temp.Free;
end else
ADest.FillPolyAntialias(pts, backScan);
end else
ADest.FillPolyAntialias(pts, BackFill.SolidColor);
end;
end;
backScan.Free;
end;
if GetPenVisible then
begin
if (PenFill.FillType = vftSolid) then penScan := nil
else penScan := PenFill.CreateScanner(AMatrix, ADraft);
pts := ComputeStroke(pts,true, AMatrix);
if ADraft and (PenWidth > 4) then
begin
if Assigned(penScan) then
ADest.FillPoly(pts, penScan, dmDrawWithTransparency) else
ADest.FillPoly(pts, PenColor, dmDrawWithTransparency)
end
else
begin
if Assigned(penScan) then
ADest.FillPolyAntialias(pts, penScan) else
ADest.FillPolyAntialias(pts, PenColor);
end;
penScan.Free;
end;
end;
function TRectShape.GetRenderBounds(ADestRect: TRect; AMatrix: TAffineMatrix; AOptions: TRenderBoundsOptions): TRectF;
var
i: Integer;
pts: ArrayOfTPointF;
xMargin, yMargin: single;
begin
if not (GetBackVisible or (rboAssumeBackFill in AOptions)) and not GetPenVisible(rboAssumePenFill in AOptions) then
result:= EmptyRectF
else
begin
result := inherited GetRenderBounds(ADestRect, AMatrix, AOptions);
if GetPenVisible(rboAssumePenFill in AOptions) then
begin
if (JoinStyle <> pjsMiter) or (Stroker.MiterLimit <= 1) then
begin
xMargin := (abs(AMatrix[1,1])+abs(AMatrix[1,2]))*PenWidth*0.5;
yMargin := (abs(AMatrix[2,1])+abs(AMatrix[2,2]))*PenWidth*0.5;
result.Left -= xMargin;
result.Top -= yMargin;
result.Right += xMargin;
result.Bottom += yMargin;
end else
begin
pts := ComputeStroke(GetAffineBox(AMatrix, false).AsPolygon, true, AMatrix);
for i := 0 to high(pts) do
begin
if pts[i].x < result.Left then result.Left := pts[i].x;
if pts[i].x > result.Right then result.Right := pts[i].x;
if pts[i].y < result.Top then result.Top := pts[i].y;
if pts[i].y > result.Bottom then result.Bottom := pts[i].y;
end;
end;
end;
end;
end;
function TRectShape.PointInShape(APoint: TPointF): boolean;
var
pts: ArrayOfTPointF;
box: TAffineBox;
begin
box := GetAffineBox(AffineMatrixIdentity, true);
if GetBackVisible and box.Contains(APoint) then
result := true else
if GetPenVisible then
begin
pts := ComputeStroke(box.AsPolygon, true, AffineMatrixIdentity);
result:= IsPointInPolygon(pts, APoint, true);
end else
result := false;
end;
function TRectShape.PointInShape(APoint: TPointF; ARadius: single): boolean;
var
pts: ArrayOfTPointF;
box: TAffineBox;
begin
if GetPenVisible or GetBackVisible then
begin
box := GetAffineBox(AffineMatrixIdentity, true);
pts := ComputeStrokeEnvelope(box.AsPolygon, true, ARadius*2);
result:= IsPointInPolygon(pts, APoint, true);
end
else result := false;
end;
function TRectShape.PointInBack(APoint: TPointF): boolean;
var
box: TAffineBox;
scan: TBGRACustomScanner;
begin
if GetBackVisible then
begin
box := GetAffineBox(AffineMatrixIdentity, true);
result := box.Contains(APoint);
if result and (BackFill.FillType = vftTexture) then
begin
scan := BackFill.CreateScanner(AffineMatrixIdentity, false);
if scan.ScanAt(APoint.X,APoint.Y).alpha = 0 then result := false;
scan.Free;
end;
end else
result := false;
end;
function TRectShape.PointInPen(APoint: TPointF): boolean;
var
pts: ArrayOfTPointF;
begin
if GetPenVisible then
begin
pts := GetAffineBox(AffineMatrixIdentity, true).AsPolygon;
pts := ComputeStroke(pts,true, AffineMatrixIdentity);
result:= IsPointInPolygon(pts, APoint, true);
end else
result := false;
end;
class function TRectShape.StorageClassName: RawByteString;
begin
result := 'rect';
end;
{ TEllipseShape }
function TEllipseShape.GetCornerPositition: single;
begin
result := sqrt(2)/2;
end;
constructor TEllipseShape.Create(AContainer: TVectorOriginal);
begin
inherited Create(AContainer);
inherited SetJoinStyle(pjsRound);
end;
class function TEllipseShape.Fields: TVectorShapeFields;
begin
Result:= [vsfPenFill, vsfPenWidth, vsfPenStyle, vsfBackFill];
end;
function TEllipseShape.AppendToSVG(AContent: TSVGContent; ADefs: TSVGDefine): TSVGElement;
var
u, v: TPointF;
rx, ry: Single;
begin
rx := Width; ry := Height;
if rx <> ry then
result := AContent.AppendEllipse(Origin, PointF(rx, ry))
else result := AContent.AppendCircle(Origin, rx);
if (XAxis.y <> 0) or (YAxis.x <> 0) then
begin
u := XAxis - Origin;
if rx > 0 then u *= (1/rx);
v := YAxis - Origin;
if ry > 0 then v *= (1/ry);
result.matrix[cuPixel] := AffineMatrixTranslation(Origin.X, Origin.Y) *
AffineMatrix(u, v, PointF(0, 0)) *
AffineMatrixTranslation(-Origin.X, -Origin.Y);
end;
ApplyStrokeStyleToSVG(result, ADefs);
ApplyFillStyleToSVG(result, ADefs);
end;
function TEllipseShape.GetAlignBounds(const ALayoutRect: TRect;
const AMatrix: TAffineMatrix): TRectF;
var
m: TAffineMatrix;
pts: ArrayOfTPointF;
i: Integer;
zoom: Single;
procedure IncludePoint(const APoint: TPointF);
begin
if APoint.x < result.Left then result.Left := APoint.x else
if APoint.x > result.Right then result.Right := APoint.x;
if APoint.y < result.Top then result.Top := APoint.y else
if APoint.y > result.Bottom then result.Bottom := APoint.y;
end;
begin
m:= AffineMatrixTranslation(0.5,0.5)*MatrixForPixelCentered(AMatrix);
pts := ComputeEllipse(m*FOrigin, m*FXAxis, m*FYAxis);
if pts = nil then exit(EmptyRectF);
result.TopLeft := pts[0];
result.BottomRight := pts[0];
for i := 0 to high(pts) do IncludePoint(pts[i]);
IncludePoint(m*XAxis);
IncludePoint(m*YAxis);
IncludePoint(m*(Origin-(XAxis-Origin)));
IncludePoint(m*(Origin-(YAxis-Origin)));
if GetPenVisible then
begin
zoom := (VectLen(AMatrix[1,1],AMatrix[2,1])+VectLen(AMatrix[1,2],AMatrix[2,2]))/2;
result.Left -= zoom*PenWidth/2;
result.Right += zoom*PenWidth/2;
result.Top -= zoom*PenWidth/2;
result.Bottom += zoom*PenWidth/2;
end;
end;
procedure TEllipseShape.Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix;
ADraft: boolean);
var
pts: Array of TPointF;
orthoRect: TRectF;
center, radius: TPointF;
draftPen, isOrtho: Boolean;
r: TRect;
backScan, penScan: TBGRACustomScanner;
penZoom: Single;
m: TAffineMatrix;
begin
isOrtho := GetOrthoRect(AMatrix, orthoRect);
if isOrtho then
begin
center := (orthoRect.TopLeft+orthoRect.BottomRight)*0.5;
radius := (orthoRect.BottomRight-orthoRect.TopLeft)*0.5;
If GetBackVisible then
begin
if BackFill.FillType = vftSolid then backScan := nil
else backScan := BackFill.CreateScanner(AMatrix, ADraft);
if ADraft then
begin
r := rect(round(orthoRect.Left),round(orthoRect.Top),round(orthoRect.Right),round(orthoRect.Bottom));
if Assigned(backScan) then
ADest.FillEllipseInRect(r, backScan, dmDrawWithTransparency) else
ADest.FillEllipseInRect(r, BackFill.SolidColor, dmDrawWithTransparency)
end
else
begin
if Assigned(backScan) then
ADest.FillEllipseAntialias(center.x, center.y, radius.x, radius.y, backScan) else
ADest.FillEllipseAntialias(center.x, center.y, radius.x, radius.y, BackFill.SolidColor);
end;
backScan.Free;
end;
if GetPenVisible then
begin
if PenFill.FillType = vftSolid then penScan := nil
else penScan := PenFill.CreateScanner(AMatrix, ADraft);
draftPen := ADraft and (PenWidth > 4);
if IsAffineMatrixScaledRotation(AMatrix) and not (draftPen and Assigned(penScan)) then
begin
penZoom := VectLen(AMatrix[1,1],AMatrix[2,1]);
ADest.CustomPenStyle := PenStyle;
if draftPen then
ADest.Ellipse(center.x, center.y, radius.x, radius.y, PenColor, PenWidth*penZoom, dmDrawWithTransparency)
else
begin
if Assigned(penScan) then
ADest.EllipseAntialias(center.x, center.y, radius.x, radius.y, penScan, PenWidth*penZoom) else
ADest.EllipseAntialias(center.x, center.y, radius.x, radius.y, PenColor, PenWidth*penZoom);
end;
ADest.PenStyle := psSolid;
end else
begin
m:= MatrixForPixelCentered(AMatrix);
pts := ComputeEllipse(m*FOrigin, m*FXAxis, m*FYAxis);
pts := ComputeStroke(pts,true, AMatrix);
if draftPen then
begin
if Assigned(penScan) then
ADest.FillPoly(pts, penScan, dmDrawWithTransparency) else
ADest.FillPoly(pts, PenColor, dmDrawWithTransparency)
end
else
begin
if Assigned(penScan) then
ADest.FillPolyAntialias(pts, penScan) else
ADest.FillPolyAntialias(pts, PenColor);
end;
end;
penScan.Free;
end;
end else
begin
m:= MatrixForPixelCentered(AMatrix);
pts := ComputeEllipse(m*FOrigin, m*FXAxis, m*FYAxis);
If GetBackVisible then
begin
if BackFill.FillType = vftSolid then backScan := nil
else backScan := BackFill.CreateScanner(AMatrix, ADraft);
if ADraft then
begin
if Assigned(backScan) then
ADest.FillPoly(pts, backScan, dmDrawWithTransparency) else
ADest.FillPoly(pts, BackFill.SolidColor, dmDrawWithTransparency)
end
else
begin
if Assigned(backScan) then
ADest.FillPolyAntialias(pts, backScan) else
ADest.FillPolyAntialias(pts, BackFill.SolidColor)
end;
backScan.Free;
end;
if GetPenVisible then
begin
if PenFill.FillType = vftSolid then penScan := nil
else penScan := PenFill.CreateScanner(AMatrix, ADraft);
pts := ComputeStroke(pts,true, AMatrix);
if ADraft and (PenWidth > 4) then
begin
if Assigned(penScan) then
ADest.FillPoly(pts, penScan, dmDrawWithTransparency) else
ADest.FillPoly(pts, PenColor, dmDrawWithTransparency)
end
else
begin
if Assigned(penScan) then
ADest.FillPolyAntialias(pts, penScan) else
ADest.FillPolyAntialias(pts, PenColor);
end;
penScan.Free;
end;
end;
end;
function TEllipseShape.GetRenderBounds({%H-}ADestRect: TRect; AMatrix: TAffineMatrix; AOptions: TRenderBoundsOptions): TRectF;
var
xMargin, yMargin: single;
begin
if not (GetBackVisible or (rboAssumeBackFill in AOptions)) and not GetPenVisible(rboAssumePenFill in AOptions) then
result:= EmptyRectF
else
begin
result := inherited GetRenderBounds(ADestRect, AMatrix, AOptions);
if GetPenVisible(rboAssumePenFill in AOptions) then
begin
xMargin := (abs(AMatrix[1,1])+abs(AMatrix[1,2]))*PenWidth*0.5;
yMargin := (abs(AMatrix[2,1])+abs(AMatrix[2,2]))*PenWidth*0.5;
result.Left -= xMargin;
result.Top -= yMargin;
result.Right += xMargin;
result.Bottom += yMargin;
end;
end;
end;
function TEllipseShape.PointInShape(APoint: TPointF): boolean;
var
pts: ArrayOfTPointF;
begin
pts := ComputeEllipse(FOrigin, FXAxis, FYAxis);
if GetBackVisible and IsPointInPolygon(pts, APoint, true) then
result := true else
if GetPenVisible then
begin
pts := ComputeStroke(pts, true, AffineMatrixIdentity);
result:= IsPointInPolygon(pts, APoint, true);
end else
result := false;
end;
function TEllipseShape.PointInShape(APoint: TPointF; ARadius: single): boolean;
var
pts: ArrayOfTPointF;
begin
if GetPenVisible or GetBackVisible then
begin
pts := ComputeEllipse(FOrigin, FXAxis, FYAxis);
pts := ComputeStrokeEnvelope(pts, true, ARadius*2);
result:= IsPointInPolygon(pts, APoint, true);
end else
result := false;
end;
function TEllipseShape.PointInBack(APoint: TPointF): boolean;
var
pts: ArrayOfTPointF;
scan: TBGRACustomScanner;
begin
if GetBackVisible then
begin
pts := ComputeEllipse(FOrigin, FXAxis, FYAxis);
result:= IsPointInPolygon(pts, APoint, true);
if result and (BackFill.FillType = vftTexture) then
begin
scan := BackFill.CreateScanner(AffineMatrixIdentity, false);
if scan.ScanAt(APoint.X,APoint.Y).alpha = 0 then result := false;
scan.Free;
end;
end else
result := false;
end;
function TEllipseShape.PointInPen(APoint: TPointF): boolean;
var
pts: ArrayOfTPointF;
begin
if GetPenVisible then
begin
pts := ComputeEllipse(FOrigin, FXAxis, FYAxis);
pts := ComputeStroke(pts,true, AffineMatrixIdentity);
result:= IsPointInPolygon(pts, APoint, true);
end else
result := false;
end;
function TEllipseShape.GetIsSlow(const AMatrix: TAffineMatrix): boolean;
var
ab: TAffineBox;
backSurface, totalSurface, penSurface: Single;
begin
if not GetPenVisible and not GetBackVisible then
result := false
else
begin
ab := GetAffineBox(AMatrix, true);
backSurface := ab.Surface*Pi/4;
if GetPenVisible then
begin
penSurface := (ab.Width+ab.Height)*(Pi/2)*PenWidth;
if GetBackVisible then
totalSurface:= backSurface+penSurface/2
else
totalSurface := penSurface;
end else
totalSurface := backSurface;
result := (totalSurface > 640*480) or
((backSurface > 320*240) and GetBackVisible and BackFill.IsSlow(AMatrix)) or
((penSurface > 320*240) and GetPenVisible and PenFill.IsSlow(AMatrix));
end;
end;
class function TEllipseShape.StorageClassName: RawByteString;
begin
result := 'ellipse';
end;
{ TPhongShape }
procedure TPhongShape.SetShapeKind(AValue: TPhongShapeKind);
begin
if FShapeKind=AValue then Exit;
BeginUpdate(TPhongShapeDiff);
FShapeKind:=AValue;
EndUpdate;
end;
procedure TPhongShape.OnMoveLightPos(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
LightPosition := ANewCoord;
end;
procedure TPhongShape.SetBorderSizePercent(AValue: single);
begin
if FBorderSizePercent=AValue then Exit;
BeginUpdate(TPhongShapeDiff);
FBorderSizePercent:=AValue;
EndUpdate;
end;
procedure TPhongShape.SetLightPosition(AValue: TPointF);
begin
if FLightPosition=AValue then Exit;
BeginUpdate(TPhongShapeDiff);
FLightPosition:=AValue;
EndUpdate;
end;
procedure TPhongShape.SetShapeAltitudePercent(AValue: single);
begin
if FShapeAltitudePercent=AValue then Exit;
BeginUpdate(TPhongShapeDiff);
FShapeAltitudePercent:=AValue;
EndUpdate;
end;
function TPhongShape.GetEnvelope: ArrayOfTPointF;
var
box: TAffineBox;
begin
case ShapeKind of
pskHalfSphere, pskConeTop: result := ComputeEllipse(FOrigin, FXAxis, FYAxis);
pskConeSide: result := PointsF([FOrigin - (FYAxis-FOrigin), FYAxis + (FXAxis-FOrigin), FYAxis - (FXAxis-FOrigin)]);
else
begin
box := GetAffineBox(AffineMatrixIdentity, true);
result := box.AsPolygon;
end;
end;
end;
function TPhongShape.AllowShearTransform: boolean;
begin
Result:= false;
end;
constructor TPhongShape.Create(AContainer: TVectorOriginal);
begin
inherited Create(AContainer);
FShapeKind:= pskRectangle;
FLightPosition := PointF(0,0);
FShapeAltitudePercent:= DefaultPhongShapeAltitudePercent;
FBorderSizePercent:= DefaultPhongBorderSizePercent;
end;
destructor TPhongShape.Destroy;
begin
inherited Destroy;
end;
function TPhongShape.GetCornerPositition: single;
begin
if ShapeKind in [pskHalfSphere,pskConeTop] then
result := sqrt(2)/2
else
result := 1;
end;
class function TPhongShape.Fields: TVectorShapeFields;
begin
Result:= [vsfBackFill];
end;
class function TPhongShape.PreferPixelCentered: boolean;
begin
Result:= false;
end;
function TPhongShape.AppendToSVG(AContent: TSVGContent; ADefs: TSVGDefine): TSVGElement;
var
u, v: TPointF;
rx, ry: Single;
p: TBGRAPath;
begin
rx := Width; ry := Height;
case ShapeKind of
pskHalfSphere, pskConeTop:
if rx <> ry then
result := AContent.AppendEllipse(Origin, PointF(rx, ry))
else result := AContent.AppendCircle(Origin, rx);
pskConeSide: begin
p := TBGRAPath.Create;
p.moveTo(Origin.x, origin.y - ry);
p.lineTo(Origin.x + rx, Origin.y + ry);
p.lineTo(Origin.x - rx, Origin.y + ry);
result := AContent.AppendPath(p);
p.Free;
end
else {pskRectangle, pskRoundRectangle, pskHorizCylinder, pskVertCylinder}
result := AContent.AppendRect(Origin.x - rx, Origin.y - ry, rx*2, ry*2);
end;
if (XAxis.y <> 0) or (YAxis.x <> 0) then
begin
u := XAxis - Origin;
if rx > 0 then u *= (1/rx);
v := YAxis - Origin;
if ry > 0 then v *= (1/ry);
result.matrix[cuPixel] := AffineMatrixTranslation(Origin.X, Origin.Y) *
AffineMatrix(u, v, PointF(0, 0)) *
AffineMatrixTranslation(-Origin.X, -Origin.Y);
end;
result.strokeNone;
ApplyFillStyleToSVG(result, ADefs);
end;
function TPhongShape.GetAlignBounds(const ALayoutRect: TRect;
const AMatrix: TAffineMatrix): TRectF;
var
m: TAffineMatrix;
pts: ArrayOfTPointF;
i: Integer;
procedure IncludePoint(const APoint: TPointF);
begin
if APoint.x < result.Left then result.Left := APoint.x else
if APoint.x > result.Right then result.Right := APoint.x;
if APoint.y < result.Top then result.Top := APoint.y else
if APoint.y > result.Bottom then result.Bottom := APoint.y;
end;
begin
m:= AffineMatrixTranslation(0.5,0.5)*MatrixForPixelCentered(AMatrix);
if ShapeKind in[pskHalfSphere,pskConeTop] then
begin
pts := ComputeEllipse(m*FOrigin, m*FXAxis, m*FYAxis);
if pts = nil then exit(EmptyRectF);
result.TopLeft := pts[0];
result.BottomRight := pts[0];
for i := 0 to high(pts) do IncludePoint(pts[i]);
IncludePoint(m*XAxis);
IncludePoint(m*YAxis);
IncludePoint(m*(Origin-(XAxis-Origin)));
IncludePoint(m*(Origin-(YAxis-Origin)));
end else
if ShapeKind = pskConeSide then
begin
result.TopLeft := m*Origin;
result.BottomRight := m*Origin;
IncludePoint(m*(XAxis+(YAxis-Origin)));
IncludePoint(m*(Origin-(XAxis-Origin)+(YAxis-Origin)));
IncludePoint(m*(Origin-(YAxis-Origin)));
end else
result := inherited GetAlignBounds(ALayoutRect,AMatrix);
end;
procedure TPhongShape.ConfigureCustomEditor(AEditor: TBGRAOriginalEditor);
var
idxLight: Integer;
begin
inherited ConfigureCustomEditor(AEditor);
idxLight := AEditor.AddPoint(FLightPosition, @OnMoveLightPos, true);
if AEditor is TVectorOriginalEditor then
TVectorOriginalEditor(AEditor).AddLabel(idxLight, rsLightPosition, taCenter, tlTop);
end;
procedure TPhongShape.MouseDown(RightButton: boolean; Shift: TShiftState; X,
Y: single; var ACursor: TOriginalEditorCursor; var AHandled: boolean);
begin
inherited MouseDown(RightButton, Shift, X, Y, ACursor, AHandled);
if not AHandled then
begin
if RightButton then
begin
LightPosition := PointF(x,y);
AHandled := true;
end;
end;
end;
procedure TPhongShape.LoadFromStorage(AStorage: TBGRACustomOriginalStorage);
begin
BeginUpdate;
inherited LoadFromStorage(AStorage);
LightPosition := AStorage.PointF['light-pos'];
if isEmptyPointF(LightPosition) then LightPosition := PointF(0,0);
case AStorage.RawString['shape-kind'] of
'round-rectangle': ShapeKind:= pskRoundRectangle;
'half-sphere': ShapeKind := pskHalfSphere;
'cone-top': ShapeKind := pskConeTop;
'cone-side': ShapeKind := pskConeSide;
'horizontal-cylinder': ShapeKind := pskHorizCylinder;
'vertical-cylinder': ShapeKind := pskVertCylinder;
else
{'rectangle'} ShapeKind:= pskRectangle;
end;
ShapeAltitudePercent := AStorage.FloatDef['shape-altitude-percent', DefaultPhongShapeAltitudePercent];
if ShapeKind in[pskRectangle,pskRoundRectangle] then
BorderSizePercent := AStorage.FloatDef['border-size-percent', DefaultPhongBorderSizePercent]
else
BorderSizePercent := DefaultPhongBorderSizePercent;
EndUpdate;
end;
procedure TPhongShape.SaveToStorage(AStorage: TBGRACustomOriginalStorage);
begin
inherited SaveToStorage(AStorage);
AStorage.PointF['light-pos'] := LightPosition;
case ShapeKind of
pskRectangle: AStorage.RawString['shape-kind'] := 'rectangle';
pskRoundRectangle: AStorage.RawString['shape-kind'] := 'round-rectangle';
pskHalfSphere: AStorage.RawString['shape-kind'] := 'half-sphere';
pskConeTop: AStorage.RawString['shape-kind'] := 'cone-top';
pskConeSide: AStorage.RawString['shape-kind'] := 'cone-side';
pskHorizCylinder: AStorage.RawString['shape-kind'] := 'horizontal-cylinder';
pskVertCylinder: AStorage.RawString['shape-kind'] := 'vertical-cylinder';
end;
AStorage.Float['shape-altitude-percent'] := ShapeAltitudePercent;
if ShapeKind in[pskRectangle,pskRoundRectangle] then
AStorage.Float['border-size-percent'] := FBorderSizePercent;
end;
procedure TPhongShape.Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix;
ADraft: boolean);
var
ab,abRaster: TAffineBox;
mapWidth,mapHeight: integer;
shader: TPhongShading;
approxFactor,borderSize: single;
m,mInv: TAffineMatrix;
h, lightPosZ: single;
map,raster: TBGRABitmap;
u,v,lightPosF: TPointF;
scan: TBGRACustomScanner;
rectRenderF,rectRasterF: TRectF;
rectRender,rectRaster, prevClip: TRect;
begin
if not GetBackVisible then exit;
//determine final render bounds
rectRenderF := GetRenderBounds(InfiniteRect,AMatrix);
if IsEmptyRectF(rectRenderF) then exit;
rectRender := rect(floor(rectRenderF.Left),floor(rectRenderF.Top),ceil(rectRenderF.Right),ceil(rectRenderF.Bottom));
rectRender.Intersect(ADest.ClipRect);
if IsRectEmpty(rectRender) then exit;
//determine map size before transform
ab := GetAffineBox(AMatrix, false);
if (ab.Width = 0) or (ab.Height = 0) then exit;
if ab.Width > ab.Height then
begin
mapWidth := ceil(ab.Width);
mapHeight := ceil(ab.Surface/ab.Width);
end else
begin
mapWidth := ceil(ab.Surface/ab.Height);
mapHeight := ceil(ab.Height);
end;
approxFactor := 1;
if ADraft then
begin
if mapWidth > 100 then approxFactor:= min(approxFactor, 100/mapWidth);
if mapHeight > 100 then approxFactor:= min(approxFactor, 100/mapHeight);
end else
begin
if mapWidth > 800 then approxFactor:= min(approxFactor, 800/mapWidth);
if mapHeight > 800 then approxFactor:= min(approxFactor, 800/mapHeight);
end;
mapWidth:= ceil(mapWidth*approxFactor);
mapHeight:= ceil(mapHeight*approxFactor);
//determine map transform
u := (ab.TopRight-ab.TopLeft)*(1/ab.Width);
v := (ab.BottomLeft-ab.TopLeft)*(1/ab.Height);
m := AffineMatrix(u,v,ab.TopLeft)*AffineMatrixScale(ab.Width/mapWidth,ab.Height/mapHeight);
borderSize := FBorderSizePercent/200*min(ab.Width,ab.Height);
if not IsAffineMatrixInversible(m) then exit;
mInv := AffineMatrixInverse(m);
try
//create height map
map := nil;
case ShapeKind of
pskRoundRectangle: begin
map := CreateRoundRectanglePreciseMap(mapWidth,mapHeight,
round(borderSize*mapWidth/ab.Width),
round(borderSize*mapHeight/ab.Height),[]);
h := FShapeAltitudePercent*approxFactor;
end;
pskHalfSphere: begin
map := CreateSpherePreciseMap(mapWidth,mapHeight);
h := FShapeAltitudePercent/100*sqrt(mapWidth*mapHeight);
end;
pskConeTop: begin
map := CreateConePreciseMap(mapWidth,mapHeight);
h := FShapeAltitudePercent/100*sqrt(mapWidth*mapHeight);
end;
pskConeSide: begin
map := CreateVerticalConePreciseMap(mapWidth,mapHeight);
h := FShapeAltitudePercent/100*mapWidth;
end;
pskHorizCylinder: begin
map := CreateHorizontalCylinderPreciseMap(mapWidth,mapHeight);
h := FShapeAltitudePercent/100*mapHeight;
end;
pskVertCylinder: begin
map := CreateVerticalCylinderPreciseMap(mapWidth,mapHeight);
h := FShapeAltitudePercent/100*mapWidth;
end;
else
{pskRectangle: }begin
map := CreateRectanglePreciseMap(mapWidth,mapHeight,
round(borderSize*mapWidth/ab.Width),
round(borderSize*mapHeight/ab.Height),[]);
h := FShapeAltitudePercent*approxFactor;
end;
end;
abRaster := mInv*TAffineBox.AffineBox(rectRenderF);
rectRasterF := abRaster.RectBoundsF;
rectRaster := rect(floor(rectRasterF.Left),floor(rectRasterF.Top),ceil(rectRasterF.Right),ceil(rectRasterF.Bottom));
raster := nil;
shader := nil;
if IntersectRect(rectRaster, rectRaster, rect(0,0,mapWidth,mapHeight)) then
try
shader:= TPhongShading.Create;
shader.AmbientFactor := 0.5;
shader.NegativeDiffusionFactor := 0.15;
lightPosF := AffineMatrixTranslation(-rectRaster.Left,-rectRaster.Top)
*mInv*AMatrix*FLightPosition;
lightPosZ := 100*Power(approxFactor,1.1);
if h*3/2 > lightPosZ then lightposZ := h*3/2;
shader.LightPosition3D := Point3D(lightPosF.x,lightPosF.y,lightPosZ);
raster := TBGRABitmap.Create(rectRaster.Width,rectRaster.Height);
if BackFill.FillType = vftSolid then
shader.Draw(raster,map,h,-rectRaster.Left,-rectRaster.Top,BackFill.SolidColor)
else
begin
scan := BackFill.CreateScanner(AffineMatrixTranslation(-rectRaster.left,-rectRaster.top)*mInv*AMatrix,ADraft);
shader.DrawScan(raster,map,h,-rectRaster.Left,-rectRaster.Top,scan);
scan.Free;
end;
prevClip := ADest.ClipRect;
ADest.ClipRect := rectRender;
if ADraft then
ADest.PutImageAffine(m*AffineMatrixTranslation(rectRaster.Left,rectRaster.Top),raster,rfBox,dmDrawWithTransparency)
else
ADest.PutImageAffine(m*AffineMatrixTranslation(rectRaster.Left,rectRaster.Top),raster,rfHalfCosine,dmDrawWithTransparency);
ADest.ClipRect := prevClip;
finally
raster.Free;
shader.Free;
end;
finally
map.Free;
end;
end;
function TPhongShape.GetRenderBounds(ADestRect: TRect; AMatrix: TAffineMatrix;
AOptions: TRenderBoundsOptions): TRectF;
begin
if not (GetBackVisible or (rboAssumeBackFill in AOptions)) then
result:= EmptyRectF
else
result := inherited GetRenderBounds(ADestRect, AMatrix, AOptions);
end;
function TPhongShape.PointInShape(APoint: TPointF): boolean;
var
pts: ArrayOfTPointF;
begin
if not GetBackVisible then exit(false);
pts := GetEnvelope;
result := IsPointInPolygon(pts, APoint, true);
end;
function TPhongShape.PointInShape(APoint: TPointF; ARadius: single): boolean;
var
pts: ArrayOfTPointF;
begin
if GetBackVisible then
begin
pts := ComputeStrokeEnvelope(GetEnvelope, true, ARadius*2);
result:= IsPointInPolygon(pts, APoint, true);
end
else result := false;
end;
function TPhongShape.PointInBack(APoint: TPointF): boolean;
var
scan: TBGRACustomScanner;
begin
result := PointInShape(APoint);
if result and (BackFill.FillType = vftTexture) then
begin
scan := BackFill.CreateScanner(AffineMatrixIdentity, false);
if scan.ScanAt(APoint.X,APoint.Y).alpha = 0 then result := false;
scan.Free;
end;
end;
function TPhongShape.GetIsSlow(const AMatrix: TAffineMatrix): boolean;
var
ab: TAffineBox;
begin
if not GetBackVisible then exit(false);
ab := GetAffineBox(AMatrix, true);
result := ab.Surface > 320*240;
end;
function TPhongShape.GetGenericCost: integer;
begin
Result:= 10;
end;
procedure TPhongShape.Transform(const AMatrix: TAffineMatrix);
begin
BeginUpdate(TPhongShapeDiff);
LightPosition := AMatrix*LightPosition;
inherited Transform(AMatrix);
EndUpdate;
end;
class function TPhongShape.StorageClassName: RawByteString;
begin
result := 'phong';
end;
initialization
RegisterVectorShape(TRectShape);
RegisterVectorShape(TEllipseShape);
RegisterVectorShape(TPhongShape);
end.
./lazpaint-7.1.6/lazpaintcontrols/lcvectorialfill.pas 0000664 0001750 0001750 00000055333 13761713342 023211 0 ustar circular circular // SPDX-License-Identifier: GPL-3.0-only
unit LCVectorialFill;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, BGRATransform, BGRAGradientOriginal, BGRABitmap, BGRABitmapTypes,
BGRALayerOriginal;
type
TTextureRepetition = (trNone, trRepeatX, trRepeatY, trRepeatBoth);
TTransparentMode = (tmEnforeAllChannelsZero, tmAlphaZeroOnly, tmNoFill);
TVectorialFillType = (vftNone, vftSolid, vftGradient, vftTexture);
TVectorialFillTypes = set of TVectorialFillType;
TVectorialFill = class;
TCustomVectorialFillDiff = class
procedure Apply(AFill: TVectorialFill); virtual; abstract;
procedure Unapply(AFill: TVectorialFill); virtual; abstract;
function IsIdentity: boolean; virtual; abstract;
function CanAppend(ADiff: TCustomVectorialFillDiff): boolean; virtual; abstract;
procedure Append(ADiff: TCustomVectorialFillDiff); virtual; abstract;
end;
TVectorialFillChangeEvent = procedure(ASender: TObject; var ADiff: TCustomVectorialFillDiff) of object;
{ TVectorialFillGradientDiff }
TVectorialFillGradientDiff = class(TCustomVectorialFillDiff)
protected
FGradientDiff: TBGRAGradientOriginalDiff;
public
constructor Create(AGradientDiff: TBGRAGradientOriginalDiff);
destructor Destroy; override;
procedure Apply(AFill: TVectorialFill); override;
procedure Unapply(AFill: TVectorialFill); override;
function IsIdentity: boolean; override;
function CanAppend(ADiff: TCustomVectorialFillDiff): boolean; override;
procedure Append(ADiff: TCustomVectorialFillDiff); override;
end;
{ TVectorialFillDiff }
TVectorialFillDiff = class(TCustomVectorialFillDiff)
protected
FStart,FEnd: TVectorialFill;
FTransparentMode: TTransparentMode;
public
constructor Create(AFrom: TVectorialFill);
procedure ComputeDiff(ATo: TVectorialFill);
destructor Destroy; override;
procedure Apply(AFill: TVectorialFill); override;
procedure Unapply(AFill: TVectorialFill); override;
function IsIdentity: boolean; override;
function CanAppend(ADiff: TCustomVectorialFillDiff): boolean; override;
procedure Append(ADiff: TCustomVectorialFillDiff); override;
end;
{ TVectorialFill }
TVectorialFill = class
protected
FColor: TBGRAPixel;
FIsSolid: boolean;
FTexture: TBGRABitmap;
FTextureMatrix: TAffineMatrix;
FTextureMatrixBackup: TAffineMatrix;
FTextureOpacity: byte;
FTextureRepetition: TTextureRepetition;
FTextureAverageColor: TBGRAPixel;
FTextureAverageColorComputed: boolean;
FTransparentMode: TTransparentMode;
FGradient: TBGRALayerGradientOriginal;
FOnChange: TVectorialFillChangeEvent;
FOnBeforeChange: TNotifyEvent;
FDiff: TVectorialFillDiff;
procedure GradientChange({%H-}ASender: TObject; {%H-}ABounds: PRectF; var ADiff: TBGRAOriginalDiff);
procedure Init; virtual;
function GetFillType: TVectorialFillType;
function GetIsEditable: boolean;
function GetAverageColor: TBGRAPixel;
procedure SetOnChange(AValue: TVectorialFillChangeEvent);
procedure SetTextureMatrix(AValue: TAffineMatrix);
procedure SetTextureOpacity(AValue: byte);
procedure SetTextureRepetition(AValue: TTextureRepetition);
procedure SetTransparentMode(AValue: TTransparentMode);
procedure InternalClear;
procedure BeginUpdate;
procedure EndUpdate;
procedure NotifyChangeWithoutDiff;
procedure ConfigureTextureEditor(AEditor: TBGRAOriginalEditor);
procedure TextureMoveOrigin({%H-}ASender: TObject; {%H-}APrevCoord,
ANewCoord: TPointF; {%H-}AShift: TShiftState);
procedure TextureMoveXAxis({%H-}ASender: TObject; {%H-}APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
procedure TextureMoveYAxis({%H-}ASender: TObject; {%H-}APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
procedure TextureStartMove({%H-}ASender: TObject; {%H-}AIndex: integer;
{%H-}AShift: TShiftState);
public
constructor Create;
procedure Clear;
constructor CreateAsSolid(AColor: TBGRAPixel);
constructor CreateAsTexture(ATexture: TBGRABitmap; AMatrix: TAffineMatrix; AOpacity: byte = 255;
ATextureRepetition: TTextureRepetition = trRepeatBoth);
constructor CreateAsGradient(AGradient: TBGRALayerGradientOriginal; AOwned: boolean);
procedure SetSolid(AColor: TBGRAPixel);
procedure SetTexture(ATexture: TBGRABitmap; AMatrix: TAffineMatrix; AOpacity: byte = 255;
ATextureRepetition: TTextureRepetition = trRepeatBoth);
procedure SetGradient(AGradient: TBGRALayerGradientOriginal; AOwned: boolean);
procedure ConfigureEditor(AEditor: TBGRAOriginalEditor);
function CreateScanner(AMatrix: TAffineMatrix; ADraft: boolean): TBGRACustomScanner;
function IsSlow(AMatrix: TAffineMatrix): boolean;
function IsFullyTransparent: boolean;
procedure Transform(AMatrix: TAffineMatrix);
function Duplicate: TVectorialFill; virtual;
destructor Destroy; override;
function Equals(Obj: TObject): boolean; override;
class function Equal(AFill1, AFill2: TVectorialFill): boolean;
procedure Assign(Obj: TObject);
procedure AssignExceptGeometry(Obj: TObject);
procedure FitGeometry(const ABox: TAffineBox);
procedure ApplyOpacity(AOpacity: Byte);
property FillType: TVectorialFillType read GetFillType;
property IsEditable: boolean read GetIsEditable;
property Gradient: TBGRALayerGradientOriginal read FGradient;
property SolidColor: TBGRAPixel read FColor write SetSolid;
property AverageColor: TBGRAPixel read GetAverageColor;
property Texture: TBGRABitmap read FTexture;
property TextureMatrix: TAffineMatrix read FTextureMatrix write SetTextureMatrix;
property TextureOpacity: byte read FTextureOpacity write SetTextureOpacity;
property TextureRepetition: TTextureRepetition read FTextureRepetition write SetTextureRepetition;
property OnChange: TVectorialFillChangeEvent read FOnChange write SetOnChange;
property OnBeforeChange: TNotifyEvent read FOnBeforeChange write FOnBeforeChange;
property TransparentMode: TTransparentMode read FTransparentMode write SetTransparentMode;
end;
implementation
uses BGRAGradientScanner, BGRABlend, LCResourceString;
{ TVectorialFillDiff }
constructor TVectorialFillDiff.Create(AFrom: TVectorialFill);
begin
FStart := TVectorialFill.Create;
FStart.TransparentMode:= AFrom.TransparentMode;
FStart.Assign(AFrom);
end;
procedure TVectorialFillDiff.ComputeDiff(ATo: TVectorialFill);
begin
FEnd := TVectorialFill.Create;
FEnd.TransparentMode := ATo.TransparentMode;
FEnd.Assign(ATo);
end;
destructor TVectorialFillDiff.Destroy;
begin
FStart.Free;
FEnd.Free;
inherited Destroy;
end;
procedure TVectorialFillDiff.Apply(AFill: TVectorialFill);
var
oldChange: TVectorialFillChangeEvent;
begin
oldChange := AFill.OnChange;
AFill.OnChange := nil;
AFill.Assign(FEnd);
AFill.OnChange := oldChange;
AFill.NotifyChangeWithoutDiff;
end;
procedure TVectorialFillDiff.Unapply(AFill: TVectorialFill);
var
oldChange: TVectorialFillChangeEvent;
begin
oldChange := AFill.OnChange;
AFill.OnChange := nil;
AFill.Assign(FStart);
AFill.OnChange := oldChange;
AFill.NotifyChangeWithoutDiff;
end;
function TVectorialFillDiff.IsIdentity: boolean;
begin
result := TVectorialFill.Equal(FStart,FEnd);
end;
function TVectorialFillDiff.CanAppend(ADiff: TCustomVectorialFillDiff
): boolean;
begin
result := ADiff is TVectorialFillDiff;
end;
procedure TVectorialFillDiff.Append(ADiff: TCustomVectorialFillDiff);
begin
FEnd.Assign((ADiff as TVectorialFillDiff).FEnd);
end;
{ TVectorialFillGradientDiff }
constructor TVectorialFillGradientDiff.Create(
AGradientDiff: TBGRAGradientOriginalDiff);
begin
FGradientDiff := AGradientDiff;
end;
destructor TVectorialFillGradientDiff.Destroy;
begin
FGradientDiff.Free;
inherited Destroy;
end;
procedure TVectorialFillGradientDiff.Apply(AFill: TVectorialFill);
begin
if AFill.FillType = vftGradient then
FGradientDiff.Apply(AFill.Gradient);
end;
procedure TVectorialFillGradientDiff.Unapply(AFill: TVectorialFill);
begin
if AFill.FillType = vftGradient then
FGradientDiff.Unapply(AFill.Gradient);
end;
function TVectorialFillGradientDiff.IsIdentity: boolean;
begin
result := false;
end;
function TVectorialFillGradientDiff.CanAppend(ADiff: TCustomVectorialFillDiff): boolean;
begin
result := (ADiff is TVectorialFillGradientDiff) and
FGradientDiff.CanAppend(TVectorialFillGradientDiff(ADiff).FGradientDiff);
end;
procedure TVectorialFillGradientDiff.Append(ADiff: TCustomVectorialFillDiff);
var
nextDiff: TVectorialFillGradientDiff;
begin
nextDiff := ADiff as TVectorialFillGradientDiff;
FGradientDiff.Append(nextDiff.FGradientDiff);
end;
{ TVectorialFill }
procedure TVectorialFill.SetOnChange(AValue: TVectorialFillChangeEvent);
begin
if FOnChange=AValue then Exit;
FOnChange:=AValue;
end;
procedure TVectorialFill.SetTextureMatrix(AValue: TAffineMatrix);
begin
if FillType <> vftTexture then raise exception.Create(rsNotTextureFill);
if FTextureMatrix=AValue then Exit;
BeginUpdate;
FTextureMatrix:=AValue;
EndUpdate;
end;
procedure TVectorialFill.SetTextureOpacity(AValue: byte);
begin
if FillType <> vftTexture then raise exception.Create(rsNotTextureFill);
if FTextureOpacity=AValue then Exit;
BeginUpdate;
FTextureOpacity:=AValue;
EndUpdate;
end;
procedure TVectorialFill.InternalClear;
begin
if Assigned(FTexture) then
begin
FTexture.FreeReference;
FTexture := nil;
end;
if Assigned(FGradient) then
begin
FGradient.OnChange := nil;
FreeAndNil(FGradient);
end;
FIsSolid := false;
FColor := BGRAPixelTransparent;
FTextureMatrix := AffineMatrixIdentity;
FTextureRepetition:= trRepeatBoth;
FTextureAverageColorComputed:= false;
end;
procedure TVectorialFill.BeginUpdate;
begin
if Assigned(OnBeforeChange) then
OnBeforeChange(self);
if Assigned(OnChange) and (FDiff = nil) then
FDiff := TVectorialFillDiff.Create(self);
end;
procedure TVectorialFill.EndUpdate;
begin
if Assigned(OnChange) then
begin
if Assigned(FDiff) then
begin
FDiff.ComputeDiff(self);
if not FDiff.IsIdentity then OnChange(self, FDiff);
end
else
OnChange(self, FDiff);
end;
FreeAndNil(FDiff);
end;
procedure TVectorialFill.NotifyChangeWithoutDiff;
var diff: TCustomVectorialFillDiff;
begin
if Assigned(FOnChange) then
begin
diff := nil;
FOnChange(self, diff);
end;
end;
procedure TVectorialFill.ConfigureTextureEditor(AEditor: TBGRAOriginalEditor);
var
origin, xAxisRel, yAxisRel: TPointF;
begin
if Assigned(FTexture) then
begin
origin := PointF(FTextureMatrix[1,3],FTextureMatrix[2,3]);
xAxisRel := PointF(FTextureMatrix[1,1],FTextureMatrix[2,1]);
yAxisRel := PointF(FTextureMatrix[1,2],FTextureMatrix[2,2]);
AEditor.AddPoint(origin, @TextureMoveOrigin, true);
if FTexture.Width > 0 then
AEditor.AddArrow(origin, origin+xAxisRel*FTexture.Width, @TextureMoveXAxis);
if FTexture.Height > 0 then
AEditor.AddArrow(origin, origin+yAxisRel*FTexture.Height, @TextureMoveYAxis);
AEditor.AddStartMoveHandler(@TextureStartMove);
end;
end;
procedure TVectorialFill.TextureMoveOrigin(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
begin
BeginUpdate;
FTextureMatrix[1,3] := ANewCoord.x;
FTextureMatrix[2,3] := ANewCoord.y;
EndUpdate;
end;
procedure TVectorialFill.TextureMoveXAxis(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
var
origin, xAxisRel: TPointF;
begin
BeginUpdate;
FTextureMatrix := FTextureMatrixBackup;
origin := PointF(FTextureMatrix[1,3],FTextureMatrix[2,3]);
xAxisRel := (ANewCoord - origin)*(1/FTexture.Width);
if ssAlt in AShift then
begin
FTextureMatrix[1,1] := xAxisRel.x;
FTextureMatrix[2,1] := xAxisRel.y;
end
else
FTextureMatrix := AffineMatrixTranslation(origin.x,origin.y)*
AffineMatrixScaledRotation(PointF(FTextureMatrix[1,1],FTextureMatrix[2,1]), xAxisRel)*
AffineMatrixLinear(FTextureMatrix);
EndUpdate;
end;
procedure TVectorialFill.TextureMoveYAxis(ASender: TObject; APrevCoord,
ANewCoord: TPointF; AShift: TShiftState);
var
origin, yAxisRel: TPointF;
begin
BeginUpdate;
FTextureMatrix := FTextureMatrixBackup;
origin := PointF(FTextureMatrix[1,3],FTextureMatrix[2,3]);
yAxisRel := (ANewCoord - origin)*(1/FTexture.Height);
if ssAlt in AShift then
begin
FTextureMatrix[1,2] := yAxisRel.x;
FTextureMatrix[2,2] := yAxisRel.y;
end
else
FTextureMatrix := AffineMatrixTranslation(origin.x,origin.y)*
AffineMatrixScaledRotation(PointF(FTextureMatrix[1,2],FTextureMatrix[2,2]), yAxisRel)*
AffineMatrixLinear(FTextureMatrix);
EndUpdate;
end;
procedure TVectorialFill.TextureStartMove(ASender: TObject; AIndex: integer;
AShift: TShiftState);
begin
FTextureMatrixBackup := FTextureMatrix;
end;
procedure TVectorialFill.Init;
begin
FColor := BGRAPixelTransparent;
FTexture := nil;
FTextureMatrix := AffineMatrixIdentity;
FTextureOpacity:= 255;
FTextureAverageColorComputed:= false;
FGradient := nil;
FIsSolid := false;
FTransparentMode := tmEnforeAllChannelsZero;
end;
function TVectorialFill.GetIsEditable: boolean;
begin
result:= FillType in [vftGradient, vftTexture];
end;
procedure TVectorialFill.SetTextureRepetition(AValue: TTextureRepetition);
begin
if FillType <> vftTexture then raise exception.Create(rsNotTextureFill);
if FTextureRepetition=AValue then Exit;
BeginUpdate;
FTextureRepetition:=AValue;
EndUpdate;
end;
function TVectorialFill.GetFillType: TVectorialFillType;
begin
if FIsSolid then result:= vftSolid
else if Assigned(FGradient) then result := vftGradient
else if Assigned(FTexture) then result := vftTexture
else result := vftNone;
end;
function TVectorialFill.GetAverageColor: TBGRAPixel;
begin
case FillType of
vftNone: result := BGRAPixelTransparent;
vftGradient: result := Gradient.AverageColor;
vftTexture: begin
if not FTextureAverageColorComputed then
begin
if Assigned(FTexture) then
FTextureAverageColor := FTexture.AverageColor
else
FTextureAverageColor := BGRAPixelTransparent;
FTextureAverageColorComputed := true;
end;
result := FTextureAverageColor;
result.alpha := BGRABlend.ApplyOpacity(result.alpha, TextureOpacity);
end
else {vftSolid} result := SolidColor;
end;
end;
procedure TVectorialFill.SetTransparentMode(AValue: TTransparentMode);
begin
if FTransparentMode=AValue then Exit;
if (FillType = vftSolid) and (SolidColor.alpha = 0) then
begin
case FTransparentMode of
tmNoFill: Clear;
tmEnforeAllChannelsZero: SolidColor := BGRAPixelTransparent;
end;
end;
FTransparentMode:=AValue;
end;
procedure TVectorialFill.GradientChange(ASender: TObject; ABounds: PRectF; var ADiff: TBGRAOriginalDiff);
var
fillDiff: TVectorialFillGradientDiff;
begin
if Assigned(FDiff) then
begin
FreeAndNil(ADiff);
exit;
end;
if Assigned(OnChange) then
begin
if Assigned(ADiff) then
begin
fillDiff := TVectorialFillGradientDiff.Create(ADiff as TBGRAGradientOriginalDiff);
ADiff := nil;
end else
fillDiff := nil;
FOnChange(self, fillDiff);
fillDiff.Free;
end;
end;
constructor TVectorialFill.Create;
begin
Init;
end;
procedure TVectorialFill.Clear;
begin
if FillType <> vftNone then
begin
BeginUpdate;
InternalClear;
EndUpdate;
end else
InternalClear;
end;
constructor TVectorialFill.CreateAsSolid(AColor: TBGRAPixel);
begin
Init;
SetSolid(AColor);
end;
constructor TVectorialFill.CreateAsTexture(ATexture: TBGRABitmap;
AMatrix: TAffineMatrix; AOpacity: byte; ATextureRepetition: TTextureRepetition);
begin
Init;
SetTexture(ATexture,AMatrix,AOpacity,ATextureRepetition);
end;
constructor TVectorialFill.CreateAsGradient(
AGradient: TBGRALayerGradientOriginal; AOwned: boolean);
begin
Init;
SetGradient(AGradient,AOwned);
end;
procedure TVectorialFill.SetSolid(AColor: TBGRAPixel);
begin
if AColor.alpha = 0 then
case TransparentMode of
tmNoFill: begin Clear; exit; end;
tmEnforeAllChannelsZero: AColor := BGRAPixelTransparent;
end;
if (FillType = vftSolid) and SolidColor.EqualsExactly(AColor) then exit;
BeginUpdate;
InternalClear;
FColor := AColor;
FIsSolid:= true;
EndUpdate;
end;
procedure TVectorialFill.SetTexture(ATexture: TBGRABitmap;
AMatrix: TAffineMatrix; AOpacity: byte; ATextureRepetition: TTextureRepetition);
begin
BeginUpdate;
InternalClear;
FTexture := ATexture.NewReference as TBGRABitmap;
FTextureMatrix := AMatrix;
FTextureOpacity:= AOpacity;
FTextureRepetition:= ATextureRepetition;
FTextureAverageColorComputed:= false;
EndUpdate;
end;
procedure TVectorialFill.SetGradient(AGradient: TBGRALayerGradientOriginal;
AOwned: boolean);
begin
BeginUpdate;
InternalClear;
if AOwned then FGradient := AGradient
else FGradient := AGradient.Duplicate as TBGRALayerGradientOriginal;
FGradient.OnChange:= @GradientChange;
EndUpdate;
end;
procedure TVectorialFill.ConfigureEditor(AEditor: TBGRAOriginalEditor);
begin
case FillType of
vftGradient: Gradient.ConfigureEditor(AEditor);
vftTexture: ConfigureTextureEditor(AEditor);
end;
end;
function TVectorialFill.CreateScanner(AMatrix: TAffineMatrix; ADraft: boolean
): TBGRACustomScanner;
var
bmpTransf: TBGRAAffineBitmapTransform;
filter: TResampleFilter;
m: TAffineMatrix;
begin
if Assigned(FTexture) then
begin
m := AMatrix*FTextureMatrix;
if ADraft or TBGRABitmap.IsAffineRoughlyTranslation(m, rect(0,0,FTexture.Width,FTexture.Height)) then filter := rfBox
else filter := rfHalfCosine;
bmpTransf := TBGRAAffineBitmapTransform.Create(FTexture,
FTextureRepetition in[trRepeatX,trRepeatBoth],
FTextureRepetition in[trRepeatY,trRepeatBoth], filter);
bmpTransf.ViewMatrix := m;
if FTextureOpacity <> 255 then
result:= TBGRAOpacityScanner.Create(bmpTransf, FTextureOpacity, true)
else
result := bmpTransf;
end else
if Assigned(FGradient) then
result := FGradient.CreateScanner(AMatrix, ADraft)
else if FIsSolid then
result := TBGRAConstantScanner.Create(FColor)
else
result := nil;
end;
function TVectorialFill.IsSlow(AMatrix: TAffineMatrix): boolean;
var
m: TAffineMatrix;
begin
if Assigned(FTexture) then
begin
m := AMatrix*FTextureMatrix;
result := not TBGRABitmap.IsAffineRoughlyTranslation(m, rect(0,0,FTexture.Width,FTexture.Height));
end else
result := (FillType = vftGradient);
end;
function TVectorialFill.IsFullyTransparent: boolean;
begin
case FillType of
vftNone: result := true;
vftSolid: result:= SolidColor.alpha = 0;
else result:= false;
end;
end;
procedure TVectorialFill.Transform(AMatrix: TAffineMatrix);
begin
case FillType of
vftGradient: Gradient.Transform(AMatrix);
vftTexture:
begin
BeginUpdate;
FTextureMatrix := AMatrix*FTextureMatrix;
EndUpdate;
end;
end;
end;
function TVectorialFill.Duplicate: TVectorialFill;
begin
result := TVectorialFill.Create;
result.Assign(self);
end;
destructor TVectorialFill.Destroy;
begin
InternalClear;
inherited Destroy;
end;
function TVectorialFill.Equals(Obj: TObject): boolean;
var
other: TVectorialFill;
begin
if inherited Equals(Obj) then
result := true
else
if Obj = nil then
result := (FillType = vftNone)
else
if Obj is TVectorialFill then
begin
other := TVectorialFill(Obj);
if Self = nil then
result := (other.FillType = vftNone)
else
begin
case other.FillType of
vftSolid: result := (FillType = vftSolid) and other.SolidColor.EqualsExactly(SolidColor);
vftGradient: result := (FillType = vftGradient) and (other.Gradient.Equals(Gradient));
vftTexture: result := (FillType = vftTexture) and (other.Texture = Texture) and
(other.TextureMatrix = TextureMatrix) and (other.TextureOpacity = TextureOpacity)
and (other.TextureRepetition = TextureRepetition);
else
result := FillType = vftNone;
end;
end;
end else
result:= false;
end;
class function TVectorialFill.Equal(AFill1, AFill2: TVectorialFill): boolean;
begin
if AFill1 = nil then
begin
if AFill2 = nil then result := true
else result := (AFill2.FillType = vftNone);
end else
result := AFill1.Equals(AFill2);
end;
procedure TVectorialFill.Assign(Obj: TObject);
var
other: TVectorialFill;
begin
if Obj = nil then Clear else
if Obj is TVectorialFill then
begin
other := TVectorialFill(Obj);
case other.FillType of
vftSolid: SetSolid(other.SolidColor);
vftGradient: SetGradient(other.Gradient, false);
vftTexture: SetTexture(other.Texture, other.TextureMatrix, other.TextureOpacity, other.TextureRepetition);
else Clear;
end;
end else
raise exception.Create(rsIncompatibleType);
end;
procedure TVectorialFill.AssignExceptGeometry(Obj: TObject);
var
other: TVectorialFill;
tempGrad: TBGRALayerGradientOriginal;
begin
if Obj = nil then Clear else
if Obj is TVectorialFill then
begin
other := TVectorialFill(Obj);
case other.FillType of
vftSolid: SetSolid(other.SolidColor);
vftGradient: begin
if self.FillType = vftGradient then
tempGrad := self.Gradient.Duplicate as TBGRALayerGradientOriginal
else
tempGrad := TBGRALayerGradientOriginal.Create;
tempGrad.AssignExceptGeometry(other.Gradient);
SetGradient(tempGrad, true);
end;
vftTexture: if self.FillType = vftTexture then
SetTexture(other.Texture, self.TextureMatrix, other.TextureOpacity, other.TextureRepetition)
else SetTexture(other.Texture, AffineMatrixIdentity, other.TextureOpacity, other.TextureRepetition);
else Clear;
end;
end else
raise exception.Create(rsIncompatibleType);
end;
procedure TVectorialFill.FitGeometry(const ABox: TAffineBox);
var
sx,sy: single;
u, v: TPointF;
begin
case FillType of
vftTexture:
if Assigned(Texture) then
begin
if not (TextureRepetition in [trRepeatX,trRepeatBoth]) and (Texture.Width > 0) then
sx:= 1/Texture.Width else if ABox.Width > 0 then sx:= 1/ABox.Width else sx := 1;
if not (TextureRepetition in [trRepeatY,trRepeatBoth]) and (Texture.Height > 0) then
sy:= 1/Texture.Height else if ABox.Height > 0 then sy:= 1/ABox.Height else sy := 1;
u := (ABox.TopRight-ABox.TopLeft)*sx;
v := (ABox.BottomLeft-ABox.TopLeft)*sy;
TextureMatrix := AffineMatrix(u, v, ABox.TopLeft);
end;
vftGradient:
Gradient.FitGeometry(ABox);
end;
end;
procedure TVectorialFill.ApplyOpacity(AOpacity: Byte);
var
c: TBGRAPixel;
begin
case FillType of
vftSolid: begin
c := SolidColor;
c.alpha := BGRABlend.ApplyOpacity(c.alpha, AOpacity);
SolidColor := c;
end;
vftGradient: Gradient.ApplyOpacity(AOpacity);
vftTexture: TextureOpacity := BGRABlend.ApplyOpacity(TextureOpacity, AOpacity);
end;
end;
end.
./lazpaint-7.1.6/resources/ 0000775 0001750 0001750 00000000000 13761713342 015721 5 ustar circular circular ./lazpaint-7.1.6/resources/icon/ 0000775 0001750 0001750 00000000000 13762273013 016646 5 ustar circular circular ./lazpaint-7.1.6/resources/icon/256x256.png 0000664 0001750 0001750 00000307205 13761713342 020327 0 ustar circular circular ‰PNG
IHDR \r¨f ŽLIDATxœì½x\é‘6ºÉf“lr³p³ÿBhÌ0Ê(Ë