← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to lcl/lazcanvas.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lcl/lazcanvas.pas
 
1
{
 
2
 /***************************************************************************
 
3
                              lazcanvas.pas
 
4
                              ---------------
 
5
 
 
6
 ***************************************************************************/
 
7
 
 
8
 *****************************************************************************
 
9
 *                                                                           *
 
10
 *  This file is part of the Lazarus Component Library (LCL)                 *
 
11
 *                                                                           *
 
12
 *  See the file COPYING.modifiedLGPL.txt, included in this distribution,    *
 
13
 *  for details about the copyright.                                         *
 
14
 *                                                                           *
 
15
 *  This program is distributed in the hope that it will be useful,          *
 
16
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
 
17
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
 
18
 *                                                                           *
 
19
 *****************************************************************************
 
20
 
 
21
  Author: Felipe Monteiro de Carvalho
 
22
 
 
23
  Abstract:
 
24
    Classes and functions for extending TFPImageCanvas to support more stretching
 
25
    filters and to support all features from the LCL TCanvas
 
26
 
 
27
    TLazCanvas also fixes various small problems and incompatibilities between
 
28
    TFPImageCanvas versions, making the interface smoother for its users
 
29
 
 
30
  Dont use anything from the LCL here as this unit should be kept strictly independent
 
31
  only LCLProc for DebugLn is allowed, but only during debuging
 
32
}
 
33
unit lazcanvas;
 
34
 
 
35
{$mode objfpc}{$H+}
 
36
{.$define lazcanvas_debug}
 
37
 
 
38
interface
 
39
 
 
40
uses
 
41
  // RTL
 
42
  Classes, SysUtils, contnrs, Math,
 
43
  // FCL-Image
 
44
  fpimgcanv, fpcanvas, fpimage, clipping, pixtools, fppixlcanv,
 
45
  // regions
 
46
  lazregions
 
47
  {$ifdef lazcanvas_debug}, LCLProc{$endif};
 
48
 
 
49
type
 
50
 
 
51
  { TFPSharpInterpolation }
 
52
 
 
53
  // This does a very sharp and square interpolation for stretching,
 
54
  // similar to StretchBlt from the Windows API
 
55
  TFPSharpInterpolation = class (TFPCustomInterpolation)
 
56
  protected
 
57
    procedure Execute (x,y,w,h : integer); override;
 
58
  end;
 
59
 
 
60
  { TLazCanvasState }
 
61
 
 
62
  TLazCanvasState = class
 
63
  public
 
64
    Brush: TFPCustomBrush;
 
65
    Pen: TFPCustomPen;
 
66
    Font: TFPCustomFont;
 
67
    BaseWindowOrg: TPoint;
 
68
    WindowOrg: TPoint;
 
69
    Clipping: Boolean;
 
70
    ClipRegion: TFPCustomRegion;
 
71
    destructor Destroy; override;
 
72
  end;
 
73
 
 
74
  { TLazCanvas }
 
75
 
 
76
  TLazCanvas = class(TFPImageCanvas)
 
77
  private
 
78
    FAssignedBrush: TFPCustomBrush;
 
79
    FAssignedFont: TFPCustomFont;
 
80
    FAssignedPen: TFPCustomPen;
 
81
    FBaseWindowOrg: TPoint;
 
82
    {$if defined(ver2_4) or defined(ver2_5) or defined(ver2_6)}
 
83
    FLazClipRegion: TFPCustomRegion;
 
84
    {$endif}
 
85
    FWindowOrg: TPoint; // already in absolute coords with BaseWindowOrg summed up
 
86
    GraphicStateList: TFPList; // TLazCanvasState
 
87
    function GetAssignedBrush: TFPCustomBrush;
 
88
    function GetAssignedPen: TFPCustomPen;
 
89
    function GetAssignedFont: TFPCustomFont;
 
90
    function GetWindowOrg: TPoint;
 
91
    procedure SetWindowOrg(AValue: TPoint);
 
92
  protected
 
93
    procedure SetColor (x,y:integer; const AValue:TFPColor); override;
 
94
    function DoCreateDefaultFont : TFPCustomFont; override;
 
95
    // Routines broken/unimplemented/incompatible in FPC
 
96
    procedure DoRectangle (const Bounds:TRect); override;
 
97
    procedure DoRectangleFill (const Bounds:TRect); override;
 
98
    procedure DoPolygonFill (const points:array of TPoint); override;
 
99
    // Routines which don't work with out extended clipping in TFPImageCanvas
 
100
    procedure DoLine (x1,y1,x2,y2:integer); override;
 
101
  public
 
102
    HasNoImage: Boolean;
 
103
    NativeDC: PtrInt; // Utilized by LCL-CustomDrawn
 
104
    ExtraFontData: TObject; // Utilized by LCL-CustomDrawn
 
105
    constructor create (AnImage : TFPCustomImage);
 
106
    destructor destroy; override;
 
107
    procedure SetLazClipRegion(ARegion: TLazRegion);
 
108
    // Canvas states list
 
109
    function SaveState: Integer;
 
110
    procedure RestoreState(AIndex: Integer);
 
111
    // A simple operation to bring the Canvas in the default LCL TCanvas state
 
112
    procedure ResetCanvasState;
 
113
    // Alpha blending operations
 
114
    procedure AlphaBlend(ASource: TLazCanvas;
 
115
      const ADestX, ADestY, ASourceX, ASourceY, ASourceWidth, ASourceHeight: Integer);
 
116
    procedure AlphaBlendIgnoringDestPixels(ASource: TLazCanvas;
 
117
      const ADestX, ADestY, ASourceX, ASourceY, ASourceWidth, ASourceHeight: Integer);
 
118
    procedure CanvasCopyRect(ASource: TLazCanvas;
 
119
      const ADestX, ADestY, ASourceX, ASourceY, ASourceWidth, ASourceHeight: Integer);
 
120
    // Compatibility with older FPC versions
 
121
    {$if defined(ver2_4) or defined(ver2_5)}
 
122
    procedure FillRect(const ARect: TRect);
 
123
    procedure FillRect(X1,Y1,X2,Y2: Integer);
 
124
    {$endif}
 
125
    // Fills the entire drawing with a color
 
126
    // AIgnoreClippingAndWindowOrg speeds up the drawing a lot, but it is dangerous,
 
127
    // don't use it unless you know what you are doing!
 
128
    procedure FillColor(AColor: TFPColor; AIgnoreClippingAndWindowOrg: Boolean = False);
 
129
    // Utilized by LCLIntf.SelectObject and by RestoreState
 
130
    // This needed to be added because Pen/Brush.Assign raises exceptions
 
131
    procedure AssignPenData(APen: TFPCustomPen);
 
132
    procedure AssignBrushData(ABrush: TFPCustomBrush);
 
133
    procedure AssignFontData(AFont: TFPCustomFont);
 
134
    // These properties are utilized to implement LCLIntf.SelectObject
 
135
    // to keep track of which brush handle was assigned to this canvas
 
136
    // They are not utilized by TLazCanvas itself
 
137
    property AssignedPen: TFPCustomPen read GetAssignedPen write FAssignedPen;
 
138
    property AssignedBrush: TFPCustomBrush read GetAssignedBrush write FAssignedBrush;
 
139
    property AssignedFont: TFPCustomFont read GetAssignedFont write FAssignedFont;
 
140
    //
 
141
    // SetWindowOrg operations will be relative to BaseWindowOrg,
 
142
    // This is very useful for implementing the non-native wincontrol,
 
143
    // because operations of SetWindowOrg inside a non-native wincontrol will be
 
144
    // based upon the BaseWindowOrg which is set relative to the Form canvas
 
145
    property BaseWindowOrg: TPoint read FBaseWindowOrg write FBaseWindowOrg;
 
146
    {$if defined(ver2_4) or defined(ver2_5) or defined(ver2_6)}
 
147
    property ClipRegion: TFPCustomRegion read FLazClipRegion write FLazClipRegion;
 
148
    {$endif}
 
149
    property WindowOrg: TPoint read GetWindowOrg write SetWindowOrg;
 
150
  end;
 
151
 
 
152
implementation
 
153
 
 
154
{ TLazCanvasState }
 
155
 
 
156
destructor TLazCanvasState.Destroy;
 
157
begin
 
158
  if Brush <> nil then Brush.Free;
 
159
  if Pen <> nil then Pen.Free;
 
160
  inherited Destroy;
 
161
end;
 
162
 
 
163
{ TLazCanvas }
 
164
 
 
165
function TLazCanvas.GetAssignedBrush: TFPCustomBrush;
 
166
begin
 
167
  if FAssignedBrush = nil then
 
168
    Result := TFPEmptyBrush.Create
 
169
  else
 
170
    Result := FAssignedBrush;
 
171
end;
 
172
 
 
173
function TLazCanvas.GetAssignedPen: TFPCustomPen;
 
174
begin
 
175
  if FAssignedPen = nil then
 
176
    Result := TFPEmptyPen.Create
 
177
  else
 
178
    Result := FAssignedPen;
 
179
end;
 
180
 
 
181
function TLazCanvas.GetAssignedFont: TFPCustomFont;
 
182
begin
 
183
  if FAssignedFont = nil then
 
184
    Result := TFPEmptyFont.Create
 
185
  else
 
186
    Result := FAssignedFont;
 
187
end;
 
188
 
 
189
function TLazCanvas.GetWindowOrg: TPoint;
 
190
begin
 
191
  Result := Point(FWindowOrg.X-FBaseWindowOrg.X, FWindowOrg.Y-FBaseWindowOrg.Y)
 
192
end;
 
193
 
 
194
procedure TLazCanvas.SetWindowOrg(AValue: TPoint);
 
195
begin
 
196
  FWindowOrg.X := AValue.X+FBaseWindowOrg.X;
 
197
  FWindowOrg.Y := AValue.Y+FBaseWindowOrg.Y;
 
198
  {$ifdef lazcanvas_debug}
 
199
  DebugLn(Format('[TLazCanvas.SetWindowOrg] AValue=%d,%d BaseWindowOrg=%d,%d', [AValue.X, AValue.Y, FBaseWindowOrg.X, FBaseWindowOrg.y]));
 
200
  {$endif}
 
201
end;
 
202
 
 
203
procedure TLazCanvas.SetColor(x, y: integer; const AValue: TFPColor);
 
204
var
 
205
  lx, ly: Integer;
 
206
begin
 
207
  lx := x + FWindowOrg.X;
 
208
  ly := y + FWindowOrg.Y;
 
209
  {$if defined(ver2_4) or defined(ver2_5) or defined(ver2_6)}
 
210
  if Clipping and (not FLazClipRegion.IsPointInRegion(lx, ly)) then
 
211
    Exit;
 
212
  if (lx >= 0) and (lx < width) and (ly >= 0) and (ly < height) then
 
213
      Image.Colors[lx,ly] := AValue;
 
214
  {$else}
 
215
  if Clipping and (not FClipRegion.IsPointInRegion(lx, ly)) then
 
216
    Exit;
 
217
  if (lx >= 0) and (lx < width) and (ly >= 0) and (ly < height) then
 
218
      FImage.Colors[lx,ly] := AValue;
 
219
  {$endif}
 
220
end;
 
221
 
 
222
function TLazCanvas.DoCreateDefaultFont: TFPCustomFont;
 
223
begin
 
224
  result := TFPEmptyFont.Create;
 
225
  Result.Size := 0; // To allow it to use the default platform size
 
226
  Result.FPColor := colBlack;
 
227
end;
 
228
 
 
229
// The coordinates utilized by DoRectangle in fcl-image are not TCanvas compatible
 
230
// so we reimplement it here
 
231
procedure TLazCanvas.DoRectangle (const Bounds:TRect);
 
232
var pattern : longword;
 
233
 
 
234
  procedure CheckLine (x1,y1, x2,y2 : integer);
 
235
  begin
 
236
//    if clipping then
 
237
//      CheckLineClipping (ClipRect, x1,y1, x2,y2);
 
238
    if x1 >= 0 then
 
239
      DrawSolidLine (self, x1,y1, x2,y2, Pen.FPColor)
 
240
  end;
 
241
 
 
242
  procedure CheckPLine (x1,y1, x2,y2 : integer);
 
243
  begin
 
244
//    if clipping then
 
245
//      CheckLineClipping (ClipRect, x1,y1, x2,y2);
 
246
    if x1 >= 0 then
 
247
      DrawPatternLine (self, x1,y1, x2,y2, pattern, Pen.FPColor)
 
248
  end;
 
249
 
 
250
var b : TRect;
 
251
    r : integer;
 
252
 
 
253
begin
 
254
  b := bounds;
 
255
  b.right := b.Right-1;
 
256
  b.bottom := b.bottom-1;
 
257
  if pen.style = psSolid then
 
258
    for r := 1 to pen.width do
 
259
      begin
 
260
      with b do
 
261
        begin
 
262
        CheckLine (left,top,left,bottom);
 
263
        CheckLine (left,bottom,right,bottom);
 
264
        CheckLine (right,bottom,right,top);
 
265
        CheckLine (right,top,left,top);
 
266
        end;
 
267
      DecRect (b);
 
268
      end
 
269
  else if pen.style <> psClear then
 
270
    begin
 
271
    if pen.style = psPattern then
 
272
      pattern := Pen.pattern
 
273
    else
 
274
      pattern := PenPatterns[pen.style];
 
275
    with b do
 
276
      begin
 
277
      CheckPLine (left,top,left,bottom);
 
278
      CheckPLine (left,bottom,right,bottom);
 
279
      CheckPLine (right,bottom,right,top);
 
280
      CheckPLine (right,top,left,top);
 
281
      end;
 
282
    end;
 
283
end;
 
284
 
 
285
procedure TLazCanvas.DoRectangleFill(const Bounds: TRect);
 
286
var b : TRect;
 
287
begin
 
288
  b := Bounds;
 
289
  SortRect (b);
 
290
//  if clipping then
 
291
//    CheckRectClipping (ClipRect, B);
 
292
  with b do
 
293
    case Brush.style of
 
294
      bsSolid : FillRectangleColor (self, left,top, right,bottom);
 
295
      bsPattern : FillRectanglePattern (self, left,top, right,bottom, brush.pattern);
 
296
      bsImage :
 
297
        if assigned (brush.image) then
 
298
          if RelativeBrushImage then
 
299
            FillRectangleImageRel (self, left,top, right,bottom, brush.image)
 
300
          else
 
301
            FillRectangleImage (self, left,top, right,bottom, brush.image)
 
302
        else
 
303
          raise PixelCanvasException.Create (sErrNoImage);
 
304
      bsBDiagonal : FillRectangleHashDiagonal (self, b, HashWidth);
 
305
      bsFDiagonal : FillRectangleHashBackDiagonal (self, b, HashWidth);
 
306
      bsCross :
 
307
        begin
 
308
        FillRectangleHashHorizontal (self, b, HashWidth);
 
309
        FillRectangleHashVertical (self, b, HashWidth);
 
310
        end;
 
311
      bsDiagCross :
 
312
        begin
 
313
        FillRectangleHashDiagonal (self, b, HashWidth);
 
314
        FillRectangleHashBackDiagonal (self, b, HashWidth);
 
315
        end;
 
316
      bsHorizontal : FillRectangleHashHorizontal (self, b, HashWidth);
 
317
      bsVertical : FillRectangleHashVertical (self, b, HashWidth);
 
318
    end;
 
319
end;
 
320
 
 
321
// unimplemented in FPC
 
322
procedure TLazCanvas.DoPolygonFill(const points: array of TPoint);
 
323
var
 
324
  lBoundingBox: TRect;
 
325
  x, y, i: integer;
 
326
begin
 
327
  if Brush.Style = bsClear then Exit;
 
328
 
 
329
  // Find the Bounding Box of the Polygon
 
330
  lBoundingBox := Rect(0, 0, 0, 0);
 
331
  for i := low(Points) to High(Points) do
 
332
  begin
 
333
    lBoundingBox.Left := Min(Points[i].X, lBoundingBox.Left);
 
334
    lBoundingBox.Top := Min(Points[i].Y, lBoundingBox.Top);
 
335
    lBoundingBox.Right := Max(Points[i].X, lBoundingBox.Right);
 
336
    lBoundingBox.Bottom := Max(Points[i].Y, lBoundingBox.Bottom);
 
337
  end;
 
338
 
 
339
  // Now scan all points using IsPointInPolygon
 
340
  for x := lBoundingBox.Left to lBoundingBox.Right do
 
341
    for y := lBoundingBox.Top to lBoundingBox.Bottom do
 
342
    begin
 
343
      if IsPointInPolygon(X, Y, Points) then SetColor(X, Y, Brush.FPColor);
 
344
    end;
 
345
end;
 
346
 
 
347
procedure TLazCanvas.DoLine(x1, y1, x2, y2: integer);
 
348
  procedure DrawOneLine (xx1,yy1, xx2,yy2:integer);
 
349
  begin
 
350
    if Clipping then
 
351
      CheckLineClipping (ClipRect, xx1,yy1, xx2,yy2);
 
352
    DrawSolidLine (self, xx1,yy1, xx2,yy2, Pen.FPColor);
 
353
  end;
 
354
 
 
355
  procedure SolidThickLine;
 
356
  var w1, w2, r : integer;
 
357
      MoreHor : boolean;
 
358
  begin
 
359
    // determine lines above and under
 
360
    w1 := pen.width div 2;
 
361
    w2 := w1;
 
362
    if w1+w2 = pen.width then
 
363
      dec (w1);
 
364
    // determine slanting
 
365
    MoreHor := (abs(x2-x1) < abs(y2-y1));
 
366
    if MoreHor then
 
367
      begin  // add lines left/right
 
368
      for r := 1 to w1 do
 
369
        DrawOneLine (x1-r,y1, x2-r,y2);
 
370
      for r := 1 to w2 do
 
371
        DrawOneLine (x1+r,y1, x2+r,y2);
 
372
      end
 
373
    else
 
374
      begin  // add lines above/under
 
375
      for r := 1 to w1 do
 
376
        DrawOneLine (x1,y1-r, x2,y2-r);
 
377
      for r := 1 to w2 do
 
378
        DrawOneLine (x1,y1+r, x2,y2+r);
 
379
      end;
 
380
  end;
 
381
 
 
382
begin
 
383
{ We can are not clip here because we clip in each drawn pixel
 
384
  or introduce a more complex algorithm to take into account lazregions
 
385
  if Clipping then
 
386
    CheckLineClipping (ClipRect, x1,y1, x2,y2);}
 
387
  case Pen.style of
 
388
    psSolid :
 
389
      begin
 
390
      DrawSolidLine (self, x1,y1, x2,y2, Pen.FPColor);
 
391
      if pen.width > 1 then
 
392
        SolidThickLine;
 
393
      end;
 
394
    psPattern:
 
395
      DrawPatternLine (self, x1,y1, x2,y2, pen.pattern);
 
396
      // Patterned lines have width always at 1
 
397
    psDash, psDot, psDashDot, psDashDotDot :
 
398
      DrawPatternLine (self, x1,y1, x2,y2, PenPatterns[Pen.Style]);
 
399
  end;
 
400
end;
 
401
 
 
402
constructor TLazCanvas.create(AnImage: TFPCustomImage);
 
403
begin
 
404
  inherited Create(AnImage);
 
405
  GraphicStateList := TFPList.Create;
 
406
  HasNoImage := AnImage = nil;
 
407
end;
 
408
 
 
409
destructor TLazCanvas.destroy;
 
410
begin
 
411
  GraphicStateList.Free;
 
412
  if FAssignedBrush <> nil then FAssignedBrush.Free;
 
413
  if FAssignedPen <> nil then FAssignedPen.Free;
 
414
  inherited destroy;
 
415
end;
 
416
 
 
417
procedure TLazCanvas.SetLazClipRegion(ARegion: TLazRegion);
 
418
begin
 
419
  Clipping := True;
 
420
  {$if defined(ver2_4) or defined(ver2_5) or defined(ver2_6)}
 
421
  ClipRect := TLazRegionRect(ARegion.Parts.Items[0]).Rect;
 
422
  FLazClipRegion := ARegion;
 
423
  {$else}
 
424
  ClipRegion := ARegion;
 
425
  {$endif}
 
426
end;
 
427
 
 
428
function TLazCanvas.SaveState: Integer;
 
429
var
 
430
  lState: TLazCanvasState;
 
431
begin
 
432
  lState := TLazCanvasState.Create;
 
433
 
 
434
  lState.Brush := Brush.CopyBrush;
 
435
  lState.Pen := Pen.CopyPen;
 
436
  lState.Font := Font.CopyFont;
 
437
  lState.BaseWindowOrg := BaseWindowOrg;
 
438
  lState.WindowOrg := WindowOrg;
 
439
  lState.Clipping := Clipping;
 
440
 
 
441
  Result := GraphicStateList.Add(lState);
 
442
end;
 
443
 
 
444
// if AIndex is positive, it represents the wished saved dc instance
 
445
// if AIndex is negative, it's a relative number from last pushed state
 
446
procedure TLazCanvas.RestoreState(AIndex: Integer);
 
447
var
 
448
  lState: TLazCanvasState;
 
449
begin
 
450
  if AIndex < 0 then AIndex := AIndex + GraphicStateList.Count;
 
451
  lState := TLazCanvasState(GraphicStateList.Items[AIndex]);
 
452
  GraphicStateList.Delete(AIndex);
 
453
  if lState = nil then Exit;
 
454
 
 
455
  AssignPenData(lState.Pen);
 
456
  AssignBrushData(lState.Brush);
 
457
  AssignFontData(lState.Font);
 
458
  BaseWindowOrg := lState.BaseWindowOrg;
 
459
  WindowOrg := lState.WindowOrg;
 
460
  Clipping := lState.Clipping;
 
461
 
 
462
  lState.Free;
 
463
end;
 
464
 
 
465
procedure TLazCanvas.ResetCanvasState;
 
466
begin
 
467
  Pen.FPColor := colBlack;
 
468
  Pen.Style := psSolid;
 
469
 
 
470
  Brush.FPColor := colWhite;
 
471
  Brush.Style := bsSolid;
 
472
end;
 
473
 
 
474
procedure TLazCanvas.AlphaBlend(ASource: TLazCanvas;
 
475
  const ADestX, ADestY, ASourceX, ASourceY, ASourceWidth, ASourceHeight: Integer);
 
476
var
 
477
  x, y, CurDestX, CurDestY, CurSrcX, CurSrcY: Integer;
 
478
  MaskValue, InvMaskValue: Word;
 
479
  CurColor, SrcColor: TFPColor;
 
480
  lDrawWidth, lDrawHeight: Integer;
 
481
begin
 
482
  // Take care not to draw outside the destination area
 
483
  lDrawWidth := Min(Self.Width - ADestX, ASource.Width - ASourceX);
 
484
  lDrawHeight := Min(Self.Height - ADestY, ASource.Height - ASourceY);
 
485
  lDrawWidth := Min(lDrawWidth, ASourceWidth);
 
486
  lDrawHeight := Min(lDrawHeight, ASourceHeight);
 
487
  //DebugLn(Format('[TLazCanvas.AlphaBlend] lDrawWidth=%d lDrawHeight=%d',
 
488
  //  [lDrawWidth, lDrawHeight]));
 
489
  for y := 0 to lDrawHeight - 1 do
 
490
  begin
 
491
    for x := 0 to lDrawWidth - 1 do
 
492
    begin
 
493
      CurDestX := ADestX + x;
 
494
      CurDestY := ADestY + y;
 
495
      CurSrcX := ASourceX + x;
 
496
      CurSrcY := ASourceY + y;
 
497
 
 
498
      // Never draw outside the destination
 
499
      if (CurDestX < 0) or (CurDestY < 0) then Continue;
 
500
 
 
501
      MaskValue := ASource.Colors[CurSrcX, CurSrcY].alpha;
 
502
      InvMaskValue := $FFFF - MaskValue;
 
503
 
 
504
      if MaskValue = $FFFF then
 
505
      begin
 
506
        Self.Colors[CurDestX, CurDestY] := ASource.Colors[CurSrcX, CurSrcY];
 
507
      end
 
508
      else if MaskValue > $00 then
 
509
      begin
 
510
        CurColor := Self.Colors[CurDestX, CurDestY];
 
511
        SrcColor := ASource.Colors[CurSrcX, CurSrcY];
 
512
 
 
513
        CurColor.Red := Round(
 
514
          CurColor.Red * InvMaskValue / $FFFF +
 
515
          SrcColor.Red * MaskValue / $FFFF);
 
516
 
 
517
        CurColor.Green := Round(
 
518
          CurColor.Green * InvMaskValue / $FFFF +
 
519
          SrcColor.Green * MaskValue / $FFFF);
 
520
 
 
521
        CurColor.Blue := Round(
 
522
          CurColor.Blue * InvMaskValue / $FFFF +
 
523
          SrcColor.Blue * MaskValue / $FFFF);
 
524
 
 
525
        CurColor.alpha := alphaOpaque;
 
526
 
 
527
        {DebugLn(Format('Alpha blending pixels Old=%d %d Src=%d %d New=%d %d alpha=%d',
 
528
          [Self.Colors[CurDestX, CurDestY].Red, Self.Colors[CurDestX, CurDestY].Green,
 
529
           SrcColor.Red, SrcColor.Green,
 
530
           CurColor.Red, CurColor.Green,
 
531
           MaskValue
 
532
           ]));}
 
533
 
 
534
        Self.Colors[CurDestX, CurDestY] := CurColor;
 
535
      end;
 
536
    end;
 
537
  end;
 
538
end;
 
539
 
 
540
// This is a safer version in case one doesnt trust the destination pixels
 
541
// It will draw as if the target area contained opaque white
 
542
procedure TLazCanvas.AlphaBlendIgnoringDestPixels(ASource: TLazCanvas;
 
543
  const ADestX, ADestY, ASourceX, ASourceY, ASourceWidth, ASourceHeight: Integer
 
544
  );
 
545
var
 
546
  x, y, CurDestX, CurDestY, CurSrcX, CurSrcY: Integer;
 
547
  MaskValue, InvMaskValue: Word;
 
548
  CurColor, SrcColor: TFPColor;
 
549
  lDrawWidth, lDrawHeight: Integer;
 
550
begin
 
551
  // Take care not to draw outside the destination area
 
552
  lDrawWidth := Min(Self.Width - ADestX, ASource.Width - ASourceX);
 
553
  lDrawHeight := Min(Self.Height - ADestY, ASource.Height - ASourceY);
 
554
  lDrawWidth := Min(lDrawWidth, ASourceWidth);
 
555
  lDrawHeight := Min(lDrawHeight, ASourceHeight);
 
556
  //DebugLn(Format('[TLazCanvas.AlphaBlendIgnoringDestPixels] lDrawWidth=%d lDrawHeight=%d',
 
557
    //[lDrawWidth, lDrawHeight]));
 
558
  for y := 0 to lDrawHeight - 1 do
 
559
  begin
 
560
    for x := 0 to lDrawWidth - 1 do
 
561
    begin
 
562
      CurDestX := ADestX + x;
 
563
      CurDestY := ADestY + y;
 
564
      CurSrcX := ASourceX + x;
 
565
      CurSrcY := ASourceY + y;
 
566
 
 
567
      // Never draw outside the destination
 
568
      if (CurDestX < 0) or (CurDestY < 0) then Continue;
 
569
 
 
570
      MaskValue := ASource.Colors[CurSrcX, CurSrcY].alpha;
 
571
      InvMaskValue := $FFFF - MaskValue;
 
572
 
 
573
      if MaskValue = $FFFF then
 
574
      begin
 
575
        Self.Colors[CurDestX, CurDestY] := ASource.Colors[CurSrcX, CurSrcY];
 
576
      end
 
577
      // Theorically it should be > 0 but we make a filter here to exclude low-alpha pixels
 
578
      // because those cause small white pixels in the image
 
579
      else if MaskValue > $4000 then
 
580
      begin
 
581
        SrcColor := ASource.Colors[CurSrcX, CurSrcY];
 
582
 
 
583
        CurColor.Red := InvMaskValue + (SrcColor.Red * MaskValue) div $FFFF;
 
584
        CurColor.Green := InvMaskValue + (SrcColor.Green * MaskValue) div $FFFF;
 
585
        CurColor.Blue := InvMaskValue + (SrcColor.Blue * MaskValue) div $FFFF;
 
586
        CurColor.alpha := alphaOpaque;
 
587
 
 
588
        Self.Colors[CurDestX, CurDestY] := CurColor;
 
589
      end;
 
590
    end;
 
591
  end;
 
592
end;
 
593
 
 
594
procedure TLazCanvas.CanvasCopyRect(ASource: TLazCanvas; const ADestX, ADestY,
 
595
  ASourceX, ASourceY, ASourceWidth, ASourceHeight: Integer);
 
596
var
 
597
  x, y, CurDestX, CurDestY, CurSrcX, CurSrcY: Integer;
 
598
  lDrawWidth, lDrawHeight: Integer;
 
599
  lColor: TFPColor;
 
600
begin
 
601
  // Take care not to draw outside the source and also not outside the destination area
 
602
  lDrawWidth := Min(Self.Width - ADestX, ASource.Width - ASourceX);
 
603
  lDrawHeight := Min(Self.Height - ADestY, ASource.Height - ASourceY);
 
604
  lDrawWidth := Min(lDrawWidth, ASourceWidth);
 
605
  lDrawHeight := Min(lDrawHeight, ASourceHeight);
 
606
 
 
607
  for y := 0 to lDrawHeight - 1 do
 
608
  begin
 
609
    for x := 0 to lDrawWidth - 1 do
 
610
    begin
 
611
      CurDestX := ADestX + x;
 
612
      CurDestY := ADestY + y;
 
613
      CurSrcX := ASourceX + x;
 
614
      CurSrcY := ASourceY + y;
 
615
 
 
616
      // Never draw outside the destination
 
617
      if (CurDestX < 0) or (CurDestY < 0) then Continue;
 
618
 
 
619
      lColor := ASource.Colors[CurSrcX, CurSrcY];
 
620
      Self.Colors[CurDestX, CurDestY] := lColor;
 
621
    end;
 
622
  end;
 
623
end;
 
624
 
 
625
{$if defined(ver2_4) or defined(ver2_5)}
 
626
procedure TLazCanvas.FillRect(const ARect: TRect);
 
627
begin
 
628
  if (Brush.style <> bsClear) then
 
629
    begin
 
630
    //if not (brush is TFPCustomDrawBrush) then
 
631
      DoRectangleFill (ARect)
 
632
    //else
 
633
    //  with ARect do
 
634
    //    TFPCustomDrawBrush(Brush).Rectangle (left,top,right,bottom);
 
635
    end;
 
636
end;
 
637
 
 
638
procedure TLazCanvas.FillRect(X1, Y1, X2, Y2: Integer);
 
639
begin
 
640
  FillRect (Rect(X1,Y1,X2,Y2));
 
641
end;
 
642
{$endif}
 
643
 
 
644
procedure TLazCanvas.FillColor(AColor: TFPColor;
 
645
  AIgnoreClippingAndWindowOrg: Boolean);
 
646
var
 
647
  x, y: Integer;
 
648
begin
 
649
  if AIgnoreClippingAndWindowOrg then
 
650
  begin
 
651
    for y := 0 to Height-1 do
 
652
      for x := 0 to Width-1 do
 
653
        Image.Colors[x, y] := AColor;
 
654
  end
 
655
  else
 
656
  begin
 
657
    for y := 0 to Height-1 do
 
658
      for x := 0 to Width-1 do
 
659
        SetColor(x, y, AColor);
 
660
  end;
 
661
end;
 
662
 
 
663
procedure TLazCanvas.AssignPenData(APen: TFPCustomPen);
 
664
begin
 
665
  if APen = nil then Exit;
 
666
  Pen.FPColor := APen.FPColor;
 
667
  Pen.Style := APen.Style;
 
668
  Pen.Width := APen.Width;
 
669
end;
 
670
 
 
671
procedure TLazCanvas.AssignBrushData(ABrush: TFPCustomBrush);
 
672
begin
 
673
  if ABrush = nil then Exit;
 
674
  Brush.FPColor := ABrush.FPColor;
 
675
  Brush.Style := ABrush.Style;
 
676
end;
 
677
 
 
678
procedure TLazCanvas.AssignFontData(AFont: TFPCustomFont);
 
679
begin
 
680
  if AFont = nil then Exit;
 
681
  Font.FPColor := AFont.FPColor;
 
682
  Font.Name := AFont.Name;
 
683
  Font.Size := AFont.Size;
 
684
  Font.Bold := AFont.Bold;
 
685
  Font.Italic := AFont.Italic;
 
686
  Font.Underline := AFont.Underline;
 
687
  {$IF (FPC_FULLVERSION=20601) or (FPC_FULLVERSION>=20701)} //changed in 2.6.1 and 2.7; remove when FPC 2.6.2+ only is supported
 
688
  Font.StrikeThrough := AFont.StrikeThrough;
 
689
  {$ELSE}
 
690
  Font.StrikeTrough := AFont.StrikeTrough; //old version with typo
 
691
  {$ENDIF}
 
692
end;
 
693
 
 
694
{ TFPWindowsSharpInterpolation }
 
695
 
 
696
procedure TFPSharpInterpolation.Execute(x, y, w, h: integer);
 
697
// paint Image on Canvas at x,y,w*h
 
698
var
 
699
  srcx, srcy: Integer; // current coordinates in the source image
 
700
  dx, dy, dw, dh: Integer; // current coordinates in the destination canvas
 
701
  lWidth, lHeight: Integer; // Image size
 
702
  lColor: TFPColor;
 
703
begin
 
704
  if (w<=0) or (h<=0) or (image.Width=0) or (image.Height=0) then
 
705
    exit;
 
706
 
 
707
  lWidth := Image.Width-1;
 
708
  lHeight := Image.Height-1;
 
709
  dw := w - 1;
 
710
  dh := h - 1;
 
711
 
 
712
  for dx := 0 to w-1 do
 
713
   for dy := 0 to h-1 do
 
714
   begin
 
715
     srcx := Round((dx / dw) * lWidth);
 
716
     srcy := Round((dy / dh) * lHeight);
 
717
     lColor := Image.Colors[srcx, srcy];
 
718
     Canvas.Colors[dx+x, dy+y] := lColor;
 
719
   end;
 
720
end;
 
721
 
 
722
end.
 
723