mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-18 07:49:12 +02:00
* Patches from Mattias Gaertner to include FPCanvas in LCL
This commit is contained in:
michael
parent
ef3b19b316
commit
6c91e99415
@ -32,7 +32,7 @@ begin
|
||||
self.Style := Style;
|
||||
self.Image := Image;
|
||||
end;
|
||||
inherited;
|
||||
inherited DoCopyProps(From);
|
||||
end;
|
||||
|
||||
function TFPCustomBrush.CopyBrush : TFPCustomBrush;
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
{%MainUnit fpcanvas.pp}
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
@ -30,17 +31,19 @@ end;
|
||||
destructor TFPCustomCanvas.Destroy;
|
||||
begin
|
||||
FRemovingHelpers := True;
|
||||
// first remove all helper references
|
||||
RemoveHelpers;
|
||||
// then free helpers
|
||||
FDefaultFont.Free;
|
||||
FDefaultBrush.Free;
|
||||
FDefaultPen.Free;
|
||||
RemoveHelpers;
|
||||
FHelpers.Free;
|
||||
FRemovingHelpers := False;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.CheckHelper (AHelper:TFPCanvasHelper);
|
||||
var r : integer;
|
||||
// remove references to AHelper
|
||||
begin
|
||||
if AHelper = FPen then
|
||||
FPen := nil
|
||||
@ -57,9 +60,7 @@ begin
|
||||
else if AHelper = FDefaultBrush then
|
||||
FDefaultBrush := CreateDefaultBrush;
|
||||
end;
|
||||
r := FHelpers.IndexOf (AHelper);
|
||||
if (r >= 0) then
|
||||
FHelpers.delete (r);
|
||||
FHelpers.Remove (AHelper);
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.RemoveHelpers;
|
||||
@ -120,6 +121,11 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
function TFPCustomCanvas.GetClipRect: TRect;
|
||||
begin
|
||||
Result:=FClipRect;
|
||||
end;
|
||||
|
||||
function TFPCustomCanvas.CreateFont : TFPCustomFont;
|
||||
begin
|
||||
result := DoCreateDefaultFont;
|
||||
@ -146,11 +152,16 @@ end;
|
||||
procedure TFPCustomCanvas.SetFont (AValue:TFPCustomFont);
|
||||
begin
|
||||
if (AValue <> FFont) and AllowFont(AValue) then
|
||||
begin
|
||||
if FManageResources then
|
||||
FFont.Assign(AValue)
|
||||
else
|
||||
begin
|
||||
AValue.AllocateResources (self);
|
||||
FFont := AValue;
|
||||
AddHelper (AValue);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TFPCustomCanvas.GetFont : TFPCustomFont;
|
||||
@ -177,11 +188,16 @@ end;
|
||||
procedure TFPCustomCanvas.SetBrush (AValue:TFPCustomBrush);
|
||||
begin
|
||||
if (AValue <> FBrush) and AllowBrush(AValue) then
|
||||
begin
|
||||
if FManageResources then
|
||||
FBrush.Assign(AValue)
|
||||
else
|
||||
begin
|
||||
AValue.AllocateResources (self);
|
||||
FBrush := AValue;
|
||||
AddHelper (AValue);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TFPCustomCanvas.GetBrush : TFPCustomBrush;
|
||||
@ -208,11 +224,16 @@ end;
|
||||
procedure TFPCustomCanvas.SetPen (AValue:TFPCustomPen);
|
||||
begin
|
||||
if (AValue <> FPen) and AllowPen (AValue) then
|
||||
begin
|
||||
if FManageResources then
|
||||
FPen.Assign(AValue)
|
||||
else
|
||||
begin
|
||||
AValue.AllocateResources (self);
|
||||
FPen := AValue;
|
||||
AddHelper (AValue);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TFPCustomCanvas.GetPen : TFPCustomPen;
|
||||
@ -223,6 +244,16 @@ begin
|
||||
result := FDefaultPen;
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.SetClipRect(const AValue: TRect);
|
||||
begin
|
||||
FClipRect:=AValue;
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.SetPenPos(const AValue: TPoint);
|
||||
begin
|
||||
FPenPos:=AValue;
|
||||
end;
|
||||
|
||||
function TFPCustomCanvas.DoAllowPen (APen : TFPCustomPen) : boolean;
|
||||
begin
|
||||
result := false;
|
||||
@ -255,6 +286,11 @@ begin
|
||||
raise TFPCanvasException.Create (ErrNoLock);
|
||||
end;
|
||||
|
||||
function TFPCustomCanvas.Locked: boolean;
|
||||
begin
|
||||
Result:=FLocks>0;
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.TextOut (x,y:integer;text:string);
|
||||
begin
|
||||
if Font is TFPCustomDrawFont then
|
||||
@ -293,19 +329,19 @@ end;
|
||||
|
||||
procedure TFPCustomCanvas.DoLineTo (x,y:integer);
|
||||
begin
|
||||
DoLine (FCurrent.X,FCurrent.y, x,y);
|
||||
DoLine (FPenPos.X,FPenPos.y, x,y);
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.MoveTo (x,y:integer);
|
||||
begin
|
||||
FCurrent.x := x;
|
||||
FCurrent.y := y;
|
||||
FPenPos.x := x;
|
||||
FPenPos.y := y;
|
||||
DoMoveTo (x,y);
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.MoveTo (p:TPoint);
|
||||
begin
|
||||
FCurrent := p;
|
||||
FPenPos := p;
|
||||
DoMoveTo (p.x,p.y);
|
||||
end;
|
||||
|
||||
@ -313,11 +349,11 @@ procedure TFPCustomCanvas.LineTo (x,y:integer);
|
||||
begin
|
||||
if Pen.Style <> psClear then
|
||||
if Pen is TFPCustomDrawPen then
|
||||
TFPCustomDrawPen(Pen).DrawLine (FCurrent.x, FCurrent.y, x, y)
|
||||
TFPCustomDrawPen(Pen).DrawLine (FPenPos.x, FPenPos.y, x, y)
|
||||
else
|
||||
DoLineTo (x,y);
|
||||
FCurrent.x := x;
|
||||
FCurrent.y := y;
|
||||
FPenPos.x := x;
|
||||
FPenPos.y := y;
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.LineTo (p:TPoint);
|
||||
@ -332,11 +368,11 @@ begin
|
||||
TFPCustomDrawPen(Pen).DrawLine (x1,y1, x2,y2)
|
||||
else
|
||||
DoLine (x1,y1, x2,y2);
|
||||
FCurrent.x := x2;
|
||||
FCurrent.y := y2;
|
||||
FPenPos.x := x2;
|
||||
FPenPos.y := y2;
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.Line (p1,p2:TPoint);
|
||||
procedure TFPCustomCanvas.Line (const p1,p2:TPoint);
|
||||
begin
|
||||
Line (p1.x,p1.y,p2.x,p2.y);
|
||||
end;
|
||||
@ -354,7 +390,7 @@ begin
|
||||
TFPCustomDrawPen(Pen).Polyline (points,false)
|
||||
else
|
||||
DoPolyline (points);
|
||||
FCurrent := points[high(points)];
|
||||
FPenPos := points[high(points)];
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.Clear;
|
||||
@ -538,7 +574,8 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.CopyRect (x,y:integer; canvas:TFPCustomCanvas; SourceRect:TRect);
|
||||
procedure TFPCustomCanvas.CopyRect (x,y:integer; canvas:TFPCustomCanvas;
|
||||
SourceRect:TRect);
|
||||
var xx,r,t : integer;
|
||||
begin
|
||||
SortRect (SourceRect);
|
||||
|
||||
@ -32,8 +32,11 @@ type
|
||||
|
||||
TFPCustomCanvas = class;
|
||||
|
||||
{ TFPCanvasHelper }
|
||||
|
||||
TFPCanvasHelper = class(TPersistent)
|
||||
private
|
||||
FDelayAllocate: boolean;
|
||||
FFPColor : TFPColor;
|
||||
FAllocated,
|
||||
FFixedCanvas : boolean;
|
||||
@ -41,10 +44,10 @@ type
|
||||
FFlags : word;
|
||||
FOnChange: TNotifyEvent;
|
||||
FOnChanging: TNotifyEvent;
|
||||
function GetAllocated : boolean;
|
||||
procedure NotifyCanvas;
|
||||
protected
|
||||
// flags 0-15 are reserved for FPCustomCanvas
|
||||
function GetAllocated: boolean; virtual;
|
||||
procedure SetFlags (index:integer; AValue:boolean); virtual;
|
||||
function GetFlags (index:integer) : boolean; virtual;
|
||||
procedure CheckAllocated (ValueNeeded:boolean);
|
||||
@ -52,17 +55,18 @@ type
|
||||
procedure DoAllocateResources; virtual;
|
||||
procedure DoDeAllocateResources; virtual;
|
||||
procedure DoCopyProps (From:TFPCanvasHelper); virtual;
|
||||
procedure SetFPColor (AValue:TFPColor); virtual;
|
||||
procedure SetFPColor (const AValue:TFPColor); virtual;
|
||||
procedure Changing; dynamic;
|
||||
procedure Changed; dynamic;
|
||||
Procedure Lock;
|
||||
Procedure UnLock;
|
||||
public
|
||||
constructor Create; virtual;
|
||||
destructor destroy; override;
|
||||
destructor Destroy; override;
|
||||
// prepare helper for use
|
||||
procedure AllocateResources (ACanvas : TFPCustomCanvas);
|
||||
// free all resource used bby this helper
|
||||
procedure AllocateResources (ACanvas : TFPCustomCanvas;
|
||||
CanDelay: boolean = true);
|
||||
// free all resource used by this helper
|
||||
procedure DeallocateResources;
|
||||
property Allocated : boolean read GetAllocated;
|
||||
// properties cannot be changed when allocated
|
||||
@ -73,6 +77,7 @@ type
|
||||
property FPColor : TFPColor read FFPColor Write SetFPColor;
|
||||
property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
|
||||
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
||||
property DelayAllocate: boolean read FDelayAllocate write FDelayAllocate;
|
||||
end;
|
||||
|
||||
TFPCustomFont = class (TFPCanvasHelper)
|
||||
@ -149,9 +154,12 @@ type
|
||||
end;
|
||||
TFPCustomBrushClass = class of TFPCustomBrush;
|
||||
|
||||
TFPCustomCanvas = class
|
||||
{ TFPCustomCanvas }
|
||||
|
||||
TFPCustomCanvas = class(TPersistent)
|
||||
private
|
||||
FClipping,
|
||||
FManageResources: boolean;
|
||||
FRemovingHelpers : boolean;
|
||||
FDefaultFont,
|
||||
FFont : TFPCustomFont;
|
||||
@ -159,7 +167,7 @@ type
|
||||
FBrush : TFPCustomBrush;
|
||||
FDefaultPen,
|
||||
FPen : TFPCustomPen;
|
||||
FCurrent : TPoint;
|
||||
FPenPos : TPoint;
|
||||
FClipRect : TRect;
|
||||
FHelpers : TList;
|
||||
FLocks : integer;
|
||||
@ -183,12 +191,15 @@ type
|
||||
function DoAllowFont (AFont : TFPCustomFont) : boolean; virtual;
|
||||
function DoAllowPen (APen : TFPCustomPen) : boolean; virtual;
|
||||
function DoAllowBrush (ABrush : TFPCustomBrush) : boolean; virtual;
|
||||
procedure SetColor (x,y:integer; Value:TFPColor); Virtual; abstract;
|
||||
procedure SetColor (x,y:integer; const Value:TFPColor); Virtual; abstract;
|
||||
function GetColor (x,y:integer) : TFPColor; Virtual; abstract;
|
||||
procedure SetHeight (AValue : integer); virtual; abstract;
|
||||
function GetHeight : integer; virtual; abstract;
|
||||
procedure SetWidth (AValue : integer); virtual; abstract;
|
||||
function GetWidth : integer; virtual; abstract;
|
||||
function GetClipRect: TRect; virtual;
|
||||
procedure SetClipRect(const AValue: TRect); virtual;
|
||||
procedure SetPenPos(const AValue: TPoint); virtual;
|
||||
procedure DoLockCanvas; virtual;
|
||||
procedure DoUnlockCanvas; virtual;
|
||||
procedure DoTextOut (x,y:integer;text:string); virtual; abstract;
|
||||
@ -218,6 +229,7 @@ type
|
||||
destructor destroy; override;
|
||||
procedure LockCanvas;
|
||||
procedure UnlockCanvas;
|
||||
function Locked: boolean;
|
||||
function CreateFont : TFPCustomFont;
|
||||
function CreatePen : TFPCustomPen;
|
||||
function CreateBrush : TFPCustomBrush;
|
||||
@ -243,7 +255,7 @@ type
|
||||
procedure LineTo (x,y:integer);
|
||||
procedure LineTo (p:TPoint);
|
||||
procedure Line (x1,y1,x2,y2:integer);
|
||||
procedure Line (p1,p2:TPoint);
|
||||
procedure Line (const p1,p2:TPoint);
|
||||
procedure Line (const points:TRect);
|
||||
// other procedures
|
||||
procedure CopyRect (x,y:integer; canvas:TFPCustomCanvas; SourceRect:TRect);
|
||||
@ -254,11 +266,12 @@ type
|
||||
property Pen : TFPCustomPen read GetPen write SetPen;
|
||||
property Brush : TFPCustomBrush read GetBrush write SetBrush;
|
||||
property Colors [x,y:integer] : TFPColor read GetColor write SetColor;
|
||||
property ClipRect : TRect read FClipRect write FClipRect;
|
||||
property ClipRect : TRect read GetClipRect write SetClipRect;
|
||||
property Clipping : boolean read FClipping write FClipping;
|
||||
property PenPos : TPoint read FCurrent write FCurrent;
|
||||
property PenPos : TPoint read FPenPos write SetPenPos;
|
||||
property Height : integer read GetHeight write SetHeight;
|
||||
property Width : integer read GetWidth write SetWidth;
|
||||
property ManageResources: boolean read FManageResources write FManageResources;
|
||||
end;
|
||||
|
||||
TFPCustomDrawFont = class (TFPCustomFont)
|
||||
@ -280,12 +293,12 @@ type
|
||||
TFPCustomDrawPen = class (TFPCustomPen)
|
||||
private
|
||||
procedure DrawLine (x1,y1,x2,y2:integer);
|
||||
procedure Polyline (points:array of TPoint; close:boolean);
|
||||
procedure Polyline (const points:array of TPoint; close:boolean);
|
||||
procedure Ellipse (left,top, right,bottom:integer);
|
||||
procedure Rectangle (left,top, right,bottom:integer);
|
||||
protected
|
||||
procedure DoDrawLine (x1,y1,x2,y2:integer); virtual; abstract;
|
||||
procedure DoPolyline (points:array of TPoint; close:boolean); virtual; abstract;
|
||||
procedure DoPolyline (const points:array of TPoint; close:boolean); virtual; abstract;
|
||||
procedure DoEllipse (left,top, right,bottom:integer); virtual; abstract;
|
||||
procedure DoRectangle (left,top, right,bottom:integer); virtual; abstract;
|
||||
end;
|
||||
@ -298,12 +311,12 @@ type
|
||||
procedure Rectangle (left,top, right,bottom:integer);
|
||||
procedure FloodFill (x,y:integer);
|
||||
procedure Ellipse (left,top, right,bottom:integer);
|
||||
procedure Polygon (points:array of TPoint);
|
||||
procedure Polygon (const points:array of TPoint);
|
||||
public
|
||||
procedure DoRectangle (left,top, right,bottom:integer); virtual; abstract;
|
||||
procedure DoEllipse (left,top, right,bottom:integer); virtual; abstract;
|
||||
procedure DoFloodFill (x,y:integer); virtual; abstract;
|
||||
procedure DoPolygon (points:array of TPoint); virtual; abstract;
|
||||
procedure DoPolygon (const points:array of TPoint); virtual; abstract;
|
||||
end;
|
||||
|
||||
TFPEmptyBrush = class (TFPCustomBrush)
|
||||
|
||||
@ -20,7 +20,7 @@ begin
|
||||
DoDrawLine (x1,y1,x2,y2);
|
||||
end;
|
||||
|
||||
procedure TFPCustomDrawPen.Polyline (points:array of TPoint; close:boolean);
|
||||
procedure TFPCustomDrawPen.Polyline (const points:array of TPoint; close:boolean);
|
||||
begin
|
||||
DoPolyLine (points, false);
|
||||
end;
|
||||
@ -52,7 +52,7 @@ begin
|
||||
DoEllipse (left,top,right,bottom);
|
||||
end;
|
||||
|
||||
procedure TFPCustomDrawBrush.Polygon (points:array of TPoint);
|
||||
procedure TFPCustomDrawBrush.Polygon (const points:array of TPoint);
|
||||
begin
|
||||
DoPolygon (points);
|
||||
end;
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
{%MainUnit fpcanvas.pp}
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
@ -36,17 +37,26 @@ begin
|
||||
end;
|
||||
|
||||
procedure TFPCanvasHelper.NotifyCanvas;
|
||||
// called to unbind from canvas
|
||||
begin
|
||||
if FCanvas<>nil then
|
||||
FCanvas.CheckHelper (self);
|
||||
end;
|
||||
|
||||
procedure TFPCanvasHelper.CheckAllocated (ValueNeeded:boolean);
|
||||
|
||||
procedure RaiseErrAllocation;
|
||||
begin
|
||||
Raise TFPFontException.CreateFmt (ErrAllocation,
|
||||
[EFont, ErrAlloc[ValueNeeded]]);
|
||||
end;
|
||||
|
||||
begin
|
||||
if (Allocated <> ValueNeeded) then
|
||||
Raise TFPFontException.CreateFmt (ErrAllocation, [EFont, ErrAlloc[ValueNeeded]]);
|
||||
RaiseErrAllocation;
|
||||
end;
|
||||
|
||||
procedure TFPCanvasHelper.SetFPColor (AValue:TFPColor);
|
||||
procedure TFPCanvasHelper.SetFPColor(const AValue:TFPColor);
|
||||
begin
|
||||
FFPColor := AValue;
|
||||
end;
|
||||
@ -92,12 +102,14 @@ begin
|
||||
result := FAllocated;
|
||||
end;
|
||||
|
||||
procedure TFPCanvasHelper.AllocateResources (ACanvas : TFPCustomCanvas);
|
||||
procedure TFPCanvasHelper.AllocateResources (ACanvas : TFPCustomCanvas;
|
||||
CanDelay: boolean);
|
||||
begin
|
||||
if FFixedCanvas and FAllocated then
|
||||
DeallocateResources;
|
||||
try
|
||||
FCanvas := ACanvas;
|
||||
if DelayAllocate and CanDelay then exit;
|
||||
try
|
||||
DoAllocateResources;
|
||||
FAllocated := True;
|
||||
except
|
||||
@ -120,7 +132,6 @@ end;
|
||||
|
||||
procedure TFPCanvasHelper.DoCopyProps (From:TFPCanvasHelper);
|
||||
begin
|
||||
FCanvas := nil;
|
||||
FPColor := from.FPColor;
|
||||
end;
|
||||
|
||||
|
||||
@ -25,7 +25,7 @@ type
|
||||
private
|
||||
FImage : TFPCustomImage;
|
||||
protected
|
||||
procedure SetColor (x,y:integer; AValue:TFPColor); override;
|
||||
procedure SetColor (x,y:integer; const AValue:TFPColor); override;
|
||||
function GetColor (x,y:integer) : TFPColor; override;
|
||||
procedure SetHeight (AValue : integer); override;
|
||||
function GetHeight : integer; override;
|
||||
@ -52,7 +52,7 @@ begin
|
||||
inherited destroy;
|
||||
end;
|
||||
|
||||
procedure TFPImageCanvas.SetColor (x,y:integer; AValue:TFPColor);
|
||||
procedure TFPImageCanvas.SetColor (x,y:integer; const AValue:TFPColor);
|
||||
begin
|
||||
if (x >= 0) and (x < width) and (y >= 0) and (y < height) then
|
||||
if not clipping or PointInside (x,y, ClipRect) then
|
||||
|
||||
Loading…
Reference in New Issue
Block a user