source: trunk/Packages/Graphics32/GR32_Layers.pas

Last change on this file was 2, checked in by chronos, 6 years ago
File size: 51.7 KB
Line 
1unit GR32_Layers;
2
3(* ***** BEGIN LICENSE BLOCK *****
4 * Version: MPL 1.1 or LGPL 2.1 with linking exception
5 *
6 * The contents of this file are subject to the Mozilla Public License Version
7 * 1.1 (the "License"); you may not use this file except in compliance with
8 * the License. You may obtain a copy of the License at
9 * http://www.mozilla.org/MPL/
10 *
11 * Software distributed under the License is distributed on an "AS IS" basis,
12 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
13 * for the specific language governing rights and limitations under the
14 * License.
15 *
16 * Alternatively, the contents of this file may be used under the terms of the
17 * Free Pascal modified version of the GNU Lesser General Public License
18 * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions
19 * of this license are applicable instead of those above.
20 * Please see the file LICENSE.txt for additional information concerning this
21 * license.
22 *
23 * The Original Code is Graphics32
24 *
25 * The Initial Developer of the Original Code is
26 * Alex A. Denisov
27 *
28 * Portions created by the Initial Developer are Copyright (C) 2000-2009
29 * the Initial Developer. All Rights Reserved.
30 *
31 * Contributor(s):
32 * Andre Beckedorf <Andre@metaException.de>
33 * Michael Hansen <dyster_tid@hotmail.com>
34 * Dieter Köhler <dieter.koehler@philo.de>
35 *
36 * ***** END LICENSE BLOCK ***** *)
37
38interface
39
40{$INCLUDE GR32.inc}
41
42uses
43{$IFDEF FPC}
44 Controls, Graphics, Forms,
45{$ELSE}
46 Windows, Controls, Graphics, Forms,
47{$ENDIF}
48 Classes, SysUtils, Math, GR32;
49
50const
51 { Layer Options Bits }
52 LOB_VISIBLE = $80000000; // 31-st bit
53 LOB_GDI_OVERLAY = $40000000; // 30-th bit
54 LOB_MOUSE_EVENTS = $20000000; // 29-th bit
55 LOB_NO_UPDATE = $10000000; // 28-th bit
56 LOB_NO_CAPTURE = $08000000; // 27-th bit
57 LOB_INVALID = $04000000; // 26-th bit
58 LOB_FORCE_UPDATE = $02000000; // 25-th bit
59 LOB_RESERVED_24 = $01000000; // 24-th bit
60 LOB_RESERVED_MASK = $FF000000;
61
62type
63 TCustomLayer = class;
64 TPositionedLayer = class;
65 TRubberbandLayer = class;
66 TLayerClass = class of TCustomLayer;
67
68 TLayerCollection = class;
69
70 TLayerUpdateEvent = procedure(Sender: TObject; Layer: TCustomLayer) of object;
71 TAreaUpdateEvent = TAreaChangedEvent;
72 TLayerListNotification = (lnLayerAdded, lnLayerInserted, lnLayerDeleted, lnCleared);
73 TLayerListNotifyEvent = procedure(Sender: TLayerCollection; Action: TLayerListNotification;
74 Layer: TCustomLayer; Index: Integer) of object;
75 TGetScaleEvent = procedure(Sender: TObject; out ScaleX, ScaleY: TFloat) of object;
76 TGetShiftEvent = procedure(Sender: TObject; out ShiftX, ShiftY: TFloat) of object;
77
78 TLayerCollection = class(TPersistent)
79 private
80 FItems: TList;
81 FMouseEvents: Boolean;
82 FMouseListener: TCustomLayer;
83 FUpdateCount: Integer;
84 FOwner: TPersistent;
85 FOnChanging: TNotifyEvent;
86 FOnChange: TNotifyEvent;
87 FOnGDIUpdate: TNotifyEvent;
88 FOnListNotify: TLayerListNotifyEvent;
89 FOnLayerUpdated: TLayerUpdateEvent;
90 FOnAreaUpdated: TAreaUpdateEvent;
91 FOnGetViewportScale: TGetScaleEvent;
92 FOnGetViewportShift: TGetShiftEvent;
93 function GetCount: Integer;
94 procedure InsertItem(Item: TCustomLayer);
95 procedure RemoveItem(Item: TCustomLayer);
96 procedure SetMouseEvents(Value: Boolean);
97 procedure SetMouseListener(Value: TCustomLayer);
98 protected
99 procedure BeginUpdate;
100 procedure Changed;
101 procedure Changing;
102 procedure EndUpdate;
103 function FindLayerAtPos(X, Y: Integer; OptionsMask: Cardinal): TCustomLayer;
104 function GetItem(Index: Integer): TCustomLayer;
105 function GetOwner: TPersistent; override;
106 procedure GDIUpdate;
107 procedure DoUpdateLayer(Layer: TCustomLayer);
108 procedure DoUpdateArea(const Rect: TRect);
109 procedure Notify(Action: TLayerListNotification; Layer: TCustomLayer; Index: Integer);
110 procedure SetItem(Index: Integer; Value: TCustomLayer);
111 function MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): TCustomLayer;
112 function MouseMove(Shift: TShiftState; X, Y: Integer): TCustomLayer;
113 function MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): TCustomLayer;
114
115 property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
116 property OnChange: TNotifyEvent read FOnChange write FOnChange;
117 property OnListNotify: TLayerListNotifyEvent read FOnListNotify write FOnListNotify;
118 property OnGDIUpdate: TNotifyEvent read FOnGDIUpdate write FOnGDIUpdate;
119 property OnLayerUpdated: TLayerUpdateEvent read FOnLayerUpdated write FOnLayerUpdated;
120 property OnAreaUpdated: TAreaUpdateEvent read FOnAreaUpdated write FOnAreaUpdated;
121 property OnGetViewportScale: TGetScaleEvent read FOnGetViewportScale write FOnGetViewportScale;
122 property OnGetViewportShift: TGetShiftEvent read FOnGetViewportShift write FOnGetViewportShift;
123 public
124 constructor Create(AOwner: TPersistent);
125 destructor Destroy; override;
126
127 function Add(ItemClass: TLayerClass): TCustomLayer;
128 procedure Assign(Source: TPersistent); override;
129 procedure Clear;
130 procedure Delete(Index: Integer);
131 function Insert(Index: Integer; ItemClass: TLayerClass): TCustomLayer;
132 function LocalToViewport(const APoint: TFloatPoint; AScaled: Boolean): TFloatPoint;
133 function ViewportToLocal(const APoint: TFloatPoint; AScaled: Boolean): TFloatPoint;
134 procedure GetViewportScale(out ScaleX, ScaleY: TFloat); virtual;
135 procedure GetViewportShift(out ShiftX, ShiftY: TFloat); virtual;
136
137 property Count: Integer read GetCount;
138 property Owner: TPersistent read FOwner;
139 property Items[Index: Integer]: TCustomLayer read GetItem write SetItem; default;
140 property MouseListener: TCustomLayer read FMouseListener write SetMouseListener;
141 property MouseEvents: Boolean read FMouseEvents write SetMouseEvents;
142 end;
143
144{$IFDEF COMPILER2009_UP}
145 TLayerEnum = class
146 private
147 FIndex: Integer;
148 FLayerCollection: TLayerCollection;
149 public
150 constructor Create(ALayerCollection: TLayerCollection);
151
152 function GetCurrent: TCustomLayer;
153 function MoveNext: Boolean;
154
155 property Current: TCustomLayer read GetCurrent;
156 end;
157
158 TLayerCollectionHelper = class Helper for TLayerCollection
159 public
160 function GetEnumerator: TLayerEnum;
161 end;
162{$ENDIF}
163
164 TLayerState = (lsMouseLeft, lsMouseRight, lsMouseMiddle);
165 TLayerStates = set of TLayerState;
166
167 TPaintLayerEvent = procedure(Sender: TObject; Buffer: TBitmap32) of object;
168 THitTestEvent = procedure(Sender: TObject; X, Y: Integer; var Passed: Boolean) of object;
169
170 TCustomLayer = class(TNotifiablePersistent)
171 private
172 FCursor: TCursor;
173 FFreeNotifies: TList;
174 FLayerCollection: TLayerCollection;
175 FLayerStates: TLayerStates;
176 FLayerOptions: Cardinal;
177 FTag: Integer;
178 FClicked: Boolean;
179 FOnHitTest: THitTestEvent;
180 FOnMouseDown: TMouseEvent;
181 FOnMouseMove: TMouseMoveEvent;
182 FOnMouseUp: TMouseEvent;
183 FOnPaint: TPaintLayerEvent;
184 FOnDestroy: TNotifyEvent;
185 FOnDblClick: TNotifyEvent;
186 FOnClick: TNotifyEvent;
187 function GetIndex: Integer;
188 function GetMouseEvents: Boolean;
189 function GetVisible: Boolean;
190 procedure SetMouseEvents(Value: Boolean);
191 procedure SetVisible(Value: Boolean);
192 function GetInvalid: Boolean;
193 procedure SetInvalid(Value: Boolean);
194 function GetForceUpdate: Boolean;
195 procedure SetForceUpdate(Value: Boolean);
196 protected
197 procedure AddNotification(ALayer: TCustomLayer);
198 procedure Changing;
199 procedure Click;
200 procedure DblClick;
201 function DoHitTest(X, Y: Integer): Boolean; virtual;
202 procedure DoPaint(Buffer: TBitmap32);
203 function GetOwner: TPersistent; override;
204 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual;
205 procedure MouseMove(Shift: TShiftState; X, Y: Integer); virtual;
206 procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual;
207 procedure Notification(ALayer: TCustomLayer); virtual;
208 procedure Paint(Buffer: TBitmap32); virtual;
209 procedure PaintGDI(Canvas: TCanvas); virtual;
210 procedure RemoveNotification(ALayer: TCustomLayer);
211 procedure SetIndex(Value: Integer); virtual;
212 procedure SetCursor(Value: TCursor); virtual;
213 procedure SetLayerCollection(Value: TLayerCollection); virtual;
214 procedure SetLayerOptions(Value: Cardinal); virtual;
215
216 property Invalid: Boolean read GetInvalid write SetInvalid;
217 property ForceUpdate: Boolean read GetForceUpdate write SetForceUpdate;
218 public
219 constructor Create(ALayerCollection: TLayerCollection); virtual;
220 destructor Destroy; override;
221
222 procedure BeforeDestruction; override;
223 procedure BringToFront;
224 procedure Changed; overload; override;
225 procedure Changed(const Rect: TRect); reintroduce; overload;
226 procedure Update; overload;
227 procedure Update(const Rect: TRect); overload;
228 function HitTest(X, Y: Integer): Boolean;
229 procedure SendToBack;
230 procedure SetAsMouseListener;
231
232 property Cursor: TCursor read FCursor write SetCursor;
233 property Index: Integer read GetIndex write SetIndex;
234 property LayerCollection: TLayerCollection read FLayerCollection write SetLayerCollection;
235 property LayerOptions: Cardinal read FLayerOptions write SetLayerOptions;
236 property LayerStates: TLayerStates read FLayerStates;
237 property MouseEvents: Boolean read GetMouseEvents write SetMouseEvents;
238 property Tag: Integer read FTag write FTag;
239 property Visible: Boolean read GetVisible write SetVisible;
240
241 property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
242 property OnHitTest: THitTestEvent read FOnHitTest write FOnHitTest;
243 property OnPaint: TPaintLayerEvent read FOnPaint write FOnPaint;
244 property OnClick: TNotifyEvent read FOnClick write FOnClick;
245 property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
246 property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
247 property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
248 property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
249 end;
250
251 TPositionedLayer = class(TCustomLayer)
252 private
253 FLocation: TFloatRect;
254 FScaled: Boolean;
255 procedure SetLocation(const Value: TFloatRect);
256 procedure SetScaled(Value: Boolean);
257 protected
258 function DoHitTest(X, Y: Integer): Boolean; override;
259 procedure DoSetLocation(const NewLocation: TFloatRect); virtual;
260 public
261 constructor Create(ALayerCollection: TLayerCollection); override;
262
263 function GetAdjustedRect(const R: TFloatRect): TFloatRect; virtual;
264 function GetAdjustedLocation: TFloatRect;
265
266 property Location: TFloatRect read FLocation write SetLocation;
267 property Scaled: Boolean read FScaled write SetScaled;
268 end;
269
270 TBitmapLayer = class(TPositionedLayer)
271 private
272 FBitmap: TBitmap32;
273 FAlphaHit: Boolean;
274 FCropped: Boolean;
275 procedure BitmapAreaChanged(Sender: TObject; const Area: TRect; const Info: Cardinal);
276 procedure SetBitmap(Value: TBitmap32);
277 procedure SetCropped(Value: Boolean);
278 protected
279 function DoHitTest(X, Y: Integer): Boolean; override;
280 procedure Paint(Buffer: TBitmap32); override;
281 public
282 constructor Create(ALayerCollection: TLayerCollection); override;
283 destructor Destroy; override;
284
285 property AlphaHit: Boolean read FAlphaHit write FAlphaHit;
286 property Bitmap: TBitmap32 read FBitmap write SetBitmap;
287 property Cropped: Boolean read FCropped write SetCropped;
288 end;
289
290 TRBDragState = (dsNone, dsMove, dsSizeL, dsSizeT, dsSizeR, dsSizeB,
291 dsSizeTL, dsSizeTR, dsSizeBL, dsSizeBR);
292 TRBHandles = set of (rhCenter, rhSides, rhCorners, rhFrame,
293 rhNotLeftSide, rhNotRightSide, rhNotTopSide, rhNotBottomSide,
294 rhNotTLCorner, rhNotTRCorner, rhNotBLCorner, rhNotBRCorner);
295 TRBOptions = set of (roProportional, roConstrained, roQuantized);
296 TRBResizingEvent = procedure(
297 Sender: TObject;
298 const OldLocation: TFloatRect;
299 var NewLocation: TFloatRect;
300 DragState: TRBDragState;
301 Shift: TShiftState) of object;
302 TRBConstrainEvent = TRBResizingEvent;
303
304 TRubberbandPassMouse = class(TPersistent)
305 private
306 FOwner: TRubberbandLayer;
307 FEnabled: Boolean;
308 FToChild: Boolean;
309 FLayerUnderCursor: Boolean;
310 FCancelIfPassed: Boolean;
311 protected
312 function GetChildUnderCursor(X, Y: Integer): TPositionedLayer;
313 public
314 constructor Create(AOwner: TRubberbandLayer);
315
316 property Enabled: Boolean read FEnabled write FEnabled default False;
317 property ToChild: Boolean read FToChild write FToChild default False;
318 property ToLayerUnderCursor: Boolean read FLayerUnderCursor write FLayerUnderCursor default False;
319 property CancelIfPassed: Boolean read FCancelIfPassed write FCancelIfPassed default False;
320 end;
321
322 TRubberbandLayer = class(TPositionedLayer)
323 private
324 FChildLayer: TPositionedLayer;
325 FFrameStipplePattern: TArrayOfColor32;
326 FFrameStippleStep: TFloat;
327 FFrameStippleCounter: TFloat;
328 FHandleFrame: TColor32;
329 FHandleFill: TColor32;
330 FHandles: TRBHandles;
331 FHandleSize: TFloat;
332 FMinWidth: TFloat;
333 FMaxHeight: TFloat;
334 FMinHeight: TFloat;
335 FMaxWidth: TFloat;
336 FOnUserChange: TNotifyEvent;
337 FOnResizing: TRBResizingEvent;
338 FOnConstrain: TRBConstrainEvent;
339 FOptions: TRBOptions;
340 FQuantized: Integer;
341 FPassMouse: TRubberbandPassMouse;
342 procedure SetFrameStippleStep(const Value: TFloat);
343 procedure SetFrameStippleCounter(const Value: TFloat);
344 procedure SetChildLayer(Value: TPositionedLayer);
345 procedure SetHandleFill(Value: TColor32);
346 procedure SetHandleFrame(Value: TColor32);
347 procedure SetHandles(Value: TRBHandles);
348 procedure SetHandleSize(Value: TFloat);
349 procedure SetOptions(const Value: TRBOptions);
350 procedure SetQuantized(const Value: Integer);
351 protected
352 FIsDragging: Boolean;
353 FDragState: TRBDragState;
354 FOldLocation: TFloatRect;
355 FMouseShift: TFloatPoint;
356 function DoHitTest(X, Y: Integer): Boolean; override;
357 procedure DoResizing(var OldLocation, NewLocation: TFloatRect; DragState: TRBDragState; Shift: TShiftState); virtual;
358 procedure DoConstrain(var OldLocation, NewLocation: TFloatRect; DragState: TRBDragState; Shift: TShiftState); virtual;
359 procedure DoSetLocation(const NewLocation: TFloatRect); override;
360 function GetDragState(X, Y: Integer): TRBDragState; virtual;
361 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
362 procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
363 procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
364 procedure Notification(ALayer: TCustomLayer); override;
365 procedure Paint(Buffer: TBitmap32); override;
366 procedure SetLayerOptions(Value: Cardinal); override;
367 procedure SetDragState(const Value: TRBDragState); overload;
368 procedure SetDragState(const Value: TRBDragState; const X, Y: Integer); overload;
369 procedure UpdateChildLayer;
370 procedure DrawHandle(Buffer: TBitmap32; X, Y: TFloat); virtual;
371 public
372 constructor Create(ALayerCollection: TLayerCollection); override;
373 destructor Destroy; override;
374
375 procedure SetFrameStipple(const Value: Array of TColor32);
376 procedure Quantize;
377
378 property ChildLayer: TPositionedLayer read FChildLayer write SetChildLayer;
379 property Options: TRBOptions read FOptions write SetOptions;
380 property Handles: TRBHandles read FHandles write SetHandles;
381 property HandleSize: TFloat read FHandleSize write SetHandleSize;
382 property HandleFill: TColor32 read FHandleFill write SetHandleFill;
383 property HandleFrame: TColor32 read FHandleFrame write SetHandleFrame;
384 property FrameStippleStep: TFloat read FFrameStippleStep write SetFrameStippleStep;
385 property FrameStippleCounter: TFloat read FFrameStippleCounter write SetFrameStippleCounter;
386 property MaxHeight: TFloat read FMaxHeight write FMaxHeight;
387 property MaxWidth: TFloat read FMaxWidth write FMaxWidth;
388 property MinHeight: TFloat read FMinHeight write FMinHeight;
389 property MinWidth: TFloat read FMinWidth write FMinWidth;
390 property Quantized: Integer read FQuantized write SetQuantized default 8;
391 property PassMouseToChild: TRubberbandPassMouse read FPassMouse;
392
393 property OnUserChange: TNotifyEvent read FOnUserChange write FOnUserChange;
394 property OnConstrain: TRBConstrainEvent read FOnConstrain write FOnConstrain;
395 property OnResizing: TRBResizingEvent read FOnResizing write FOnResizing;
396 end;
397
398implementation
399
400uses
401 TypInfo, GR32_Image, GR32_LowLevel, GR32_Resamplers, GR32_RepaintOpt, Types;
402
403{ mouse state mapping }
404const
405 CStateMap: array [TMouseButton] of TLayerState =
406 (lsMouseLeft, lsMouseRight, lsMouseMiddle {$IFDEF FPC}, lsMouseMiddle,
407 lsMouseMiddle{$ENDIF});
408
409type
410 TImage32Access = class(TCustomImage32);
411
412{ TLayerCollection }
413
414function TLayerCollection.Add(ItemClass: TLayerClass): TCustomLayer;
415begin
416 Result := ItemClass.Create(Self);
417 Result.Index := FItems.Count - 1;
418 Notify(lnLayerAdded, Result, Result.Index);
419end;
420
421procedure TLayerCollection.Assign(Source: TPersistent);
422var
423 I: Integer;
424 Item: TCustomLayer;
425begin
426 if Source is TLayerCollection then
427 begin
428 BeginUpdate;
429 try
430 while FItems.Count > 0 do TCustomLayer(FItems.Last).Free;
431 for I := 0 to TLayerCollection(Source).Count - 1 do
432 begin
433 Item := TLayerCollection(Source).Items[I];
434 Add(TLayerClass(Item.ClassType)).Assign(Item);
435 end;
436 finally
437 EndUpdate;
438 end;
439 Exit;
440 end;
441 inherited Assign(Source);
442end;
443
444procedure TLayerCollection.BeginUpdate;
445begin
446 if FUpdateCount = 0 then
447 Changing;
448 Inc(FUpdateCount);
449end;
450
451procedure TLayerCollection.Changed;
452begin
453 if Assigned(FOnChange) then
454 FOnChange(Self);
455end;
456
457procedure TLayerCollection.Changing;
458begin
459 if Assigned(FOnChanging) then
460 FOnChanging(Self);
461end;
462
463procedure TLayerCollection.Clear;
464begin
465 BeginUpdate;
466 try
467 while FItems.Count > 0 do TCustomLayer(FItems.Last).Free;
468 Notify(lnCleared, nil, 0);
469 finally
470 EndUpdate;
471 end;
472end;
473
474constructor TLayerCollection.Create(AOwner: TPersistent);
475begin
476 FOwner := AOwner;
477 FItems := TList.Create;
478 FMouseEvents := True;
479end;
480
481procedure TLayerCollection.Delete(Index: Integer);
482begin
483 TCustomLayer(FItems[Index]).Free;
484end;
485
486destructor TLayerCollection.Destroy;
487begin
488 FUpdateCount := 1; // disable update notification
489 if Assigned(FItems) then
490 Clear;
491 FItems.Free;
492 inherited;
493end;
494
495procedure TLayerCollection.EndUpdate;
496begin
497 Dec(FUpdateCount);
498 if FUpdateCount = 0 then
499 Changed;
500 Assert(FUpdateCount >= 0, 'Unpaired EndUpdate');
501end;
502
503function TLayerCollection.FindLayerAtPos(X, Y: Integer; OptionsMask: Cardinal): TCustomLayer;
504var
505 I: Integer;
506begin
507 for I := Count - 1 downto 0 do
508 begin
509 Result := Items[I];
510 if (Result.LayerOptions and OptionsMask) = 0 then
511 Continue; // skip to the next one
512 if Result.HitTest(X, Y) then Exit;
513 end;
514 Result := nil;
515end;
516
517procedure TLayerCollection.GDIUpdate;
518begin
519 if (FUpdateCount = 0) and Assigned(FOnGDIUpdate) then
520 FOnGDIUpdate(Self);
521end;
522
523function TLayerCollection.GetCount: Integer;
524begin
525 Result := FItems.Count;
526end;
527
528function TLayerCollection.GetItem(Index: Integer): TCustomLayer;
529begin
530 Result := FItems[Index];
531end;
532
533function TLayerCollection.GetOwner: TPersistent;
534begin
535 Result := FOwner;
536end;
537
538function TLayerCollection.Insert(Index: Integer; ItemClass: TLayerClass): TCustomLayer;
539begin
540 BeginUpdate;
541 try
542 Result := Add(ItemClass);
543 Result.Index := Index;
544 Notify(lnLayerInserted, Result, Index);
545 finally
546 EndUpdate;
547 end;
548end;
549
550procedure TLayerCollection.InsertItem(Item: TCustomLayer);
551var
552 Index: Integer;
553begin
554 BeginUpdate;
555 try
556 Index := FItems.Add(Item);
557 Item.FLayerCollection := Self;
558 Notify(lnLayerAdded, Item, Index);
559 finally
560 EndUpdate;
561 end;
562end;
563
564function TLayerCollection.LocalToViewport(const APoint: TFloatPoint; AScaled: Boolean): TFloatPoint;
565var
566 ScaleX, ScaleY, ShiftX, ShiftY: TFloat;
567begin
568 if AScaled then
569 begin
570 GetViewportShift(ShiftX, ShiftY);
571 GetViewportScale(ScaleX, ScaleY);
572
573 Result.X := APoint.X * ScaleX + ShiftX;
574 Result.Y := APoint.Y * ScaleY + ShiftY;
575 end
576 else
577 Result := APoint;
578end;
579
580function TLayerCollection.ViewportToLocal(const APoint: TFloatPoint; AScaled: Boolean): TFloatPoint;
581var
582 ScaleX, ScaleY, ShiftX, ShiftY: TFloat;
583begin
584 if AScaled then
585 begin
586 GetViewportShift(ShiftX, ShiftY);
587 GetViewportScale(ScaleX, ScaleY);
588
589 Result.X := (APoint.X - ShiftX) / ScaleX;
590 Result.Y := (APoint.Y - ShiftY) / ScaleY;
591 end
592 else
593 Result := APoint;
594end;
595
596function TLayerCollection.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): TCustomLayer;
597begin
598 if Assigned(MouseListener) then
599 Result := MouseListener
600 else
601 Result := FindLayerAtPos(X, Y, LOB_MOUSE_EVENTS);
602
603 if (Result <> MouseListener) and ((Result = nil) or ((Result.FLayerOptions and LOB_NO_CAPTURE) = 0)) then
604 MouseListener := Result; // capture the mouse
605
606 if Assigned(MouseListener) then
607 begin
608 Include(MouseListener.FLayerStates, CStateMap[Button]);
609 MouseListener.MouseDown(Button, Shift, X, Y);
610 end;
611end;
612
613function TLayerCollection.MouseMove(Shift: TShiftState; X, Y: Integer): TCustomLayer;
614begin
615 Result := MouseListener;
616 if Result = nil then
617 Result := FindLayerAtPos(X, Y, LOB_MOUSE_EVENTS);
618
619 if Assigned(Result) then
620 Result.MouseMove(Shift, X, Y)
621 else if FOwner is TControl then
622 Screen.Cursor := TControl(FOwner).Cursor;
623end;
624
625function TLayerCollection.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): TCustomLayer;
626begin
627 Result := MouseListener;
628 if Result = nil then
629 Result := FindLayerAtPos(X, Y, LOB_MOUSE_EVENTS);
630
631 if Assigned(Result) then
632 begin
633 Exclude(Result.FLayerStates, CStateMap[Button]);
634 Result.MouseUp(Button, Shift, X, Y);
635 end;
636
637 if Assigned(MouseListener) and
638 (MouseListener.FLayerStates *
639 [lsMouseLeft, lsMouseRight, lsMouseMiddle] = []) then
640 MouseListener := nil; // reset mouse capture
641end;
642
643procedure TLayerCollection.Notify(Action: TLayerListNotification; Layer: TCustomLayer; Index: Integer);
644begin
645 if Assigned(FOnListNotify) then
646 FOnListNotify(Self, Action, Layer, Index);
647end;
648
649procedure TLayerCollection.RemoveItem(Item: TCustomLayer);
650var
651 Index: Integer;
652begin
653 BeginUpdate;
654 try
655 Index := FItems.IndexOf(Item);
656 if Index >= 0 then
657 begin
658 FItems.Delete(Index);
659 Item.FLayerCollection := nil;
660 Notify(lnLayerDeleted, Item, Index);
661 end;
662 finally
663 EndUpdate;
664 end;
665end;
666
667procedure TLayerCollection.SetItem(Index: Integer; Value: TCustomLayer);
668begin
669 TCollectionItem(FItems[Index]).Assign(Value);
670end;
671
672procedure TLayerCollection.SetMouseEvents(Value: Boolean);
673begin
674 FMouseEvents := Value;
675 MouseListener := nil;
676end;
677
678procedure TLayerCollection.SetMouseListener(Value: TCustomLayer);
679begin
680 if Value <> FMouseListener then
681 begin
682 if Assigned(FMouseListener) then
683 FMouseListener.FLayerStates := FMouseListener.FLayerStates -
684 [lsMouseLeft, lsMouseRight, lsMouseMiddle];
685 FMouseListener := Value;
686 end;
687end;
688
689procedure TLayerCollection.DoUpdateArea(const Rect: TRect);
690begin
691 if Assigned(FOnAreaUpdated) then
692 FOnAreaUpdated(Self, Rect, AREAINFO_RECT);
693 Changed;
694end;
695
696procedure TLayerCollection.DoUpdateLayer(Layer: TCustomLayer);
697begin
698 if Assigned(FOnLayerUpdated) then
699 FOnLayerUpdated(Self, Layer);
700 Changed;
701end;
702
703procedure TLayerCollection.GetViewportScale(out ScaleX, ScaleY: TFloat);
704begin
705 if Assigned(FOnGetViewportScale) then
706 FOnGetViewportScale(Self, ScaleX, ScaleY)
707 else
708 begin
709 ScaleX := 1;
710 ScaleY := 1;
711 end;
712end;
713
714procedure TLayerCollection.GetViewportShift(out ShiftX, ShiftY: TFloat);
715begin
716 if Assigned(FOnGetViewportShift) then
717 FOnGetViewportShift(Self, ShiftX, ShiftY)
718 else
719 begin
720 ShiftX := 0;
721 ShiftY := 0;
722 end;
723end;
724
725
726{$IFDEF COMPILER2009_UP}
727{ TLayerEnum }
728
729constructor TLayerEnum.Create(ALayerCollection: TLayerCollection);
730begin
731 inherited Create;
732 FLayerCollection := ALayerCollection;
733 FIndex := -1;
734end;
735
736function TLayerEnum.GetCurrent: TCustomLayer;
737begin
738 Result := FLayerCollection.Items[FIndex];
739end;
740
741function TLayerEnum.MoveNext: Boolean;
742begin
743 Result := FIndex < Pred(FLayerCollection.Count);
744 if Result then
745 Inc(FIndex);
746end;
747
748
749{ TLayerCollectionHelper }
750
751function TLayerCollectionHelper.GetEnumerator: TLayerEnum;
752begin
753 Result := TLayerEnum.Create(Self);
754end;
755{$ENDIF}
756
757
758{ TCustomLayer }
759
760constructor TCustomLayer.Create(ALayerCollection: TLayerCollection);
761begin
762 LayerCollection := ALayerCollection;
763 FLayerOptions := LOB_VISIBLE;
764end;
765
766destructor TCustomLayer.Destroy;
767var
768 I: Integer;
769begin
770 if Assigned(FFreeNotifies) then
771 begin
772 for I := FFreeNotifies.Count - 1 downto 0 do
773 begin
774 TCustomLayer(FFreeNotifies[I]).Notification(Self);
775 if FFreeNotifies = nil then Break;
776 end;
777 FFreeNotifies.Free;
778 FFreeNotifies := nil;
779 end;
780 SetLayerCollection(nil);
781 inherited;
782end;
783
784procedure TCustomLayer.AddNotification(ALayer: TCustomLayer);
785begin
786 if not Assigned(FFreeNotifies) then
787 FFreeNotifies := TList.Create;
788 if FFreeNotifies.IndexOf(ALayer) < 0 then
789 FFreeNotifies.Add(ALayer);
790end;
791
792procedure TCustomLayer.BeforeDestruction;
793begin
794 if Assigned(FOnDestroy) then
795 FOnDestroy(Self);
796 inherited;
797end;
798
799procedure TCustomLayer.BringToFront;
800begin
801 Index := LayerCollection.Count;
802end;
803
804procedure TCustomLayer.Changed;
805begin
806 if UpdateCount > 0 then Exit;
807 if Assigned(FLayerCollection) and ((FLayerOptions and LOB_NO_UPDATE) = 0) then
808 begin
809 Update;
810 if Visible then
811 FLayerCollection.Changed
812 else if (FLayerOptions and LOB_GDI_OVERLAY) <> 0 then
813 FLayerCollection.GDIUpdate;
814
815 inherited;
816 end;
817end;
818
819procedure TCustomLayer.Changed(const Rect: TRect);
820begin
821 if UpdateCount > 0 then Exit;
822 if Assigned(FLayerCollection) and ((FLayerOptions and LOB_NO_UPDATE) = 0) then
823 begin
824 Update(Rect);
825 if Visible then
826 FLayerCollection.Changed
827 else if (FLayerOptions and LOB_GDI_OVERLAY) <> 0 then
828 FLayerCollection.GDIUpdate;
829
830 inherited Changed;
831 end;
832end;
833
834procedure TCustomLayer.Changing;
835begin
836 if UpdateCount > 0 then Exit;
837 if Visible and Assigned(FLayerCollection) and
838 ((FLayerOptions and LOB_NO_UPDATE) = 0) then
839 FLayerCollection.Changing;
840end;
841
842procedure TCustomLayer.Click;
843begin
844 FClicked := False;
845 if Assigned(FOnClick) then
846 FOnClick(Self);
847end;
848
849procedure TCustomLayer.DblClick;
850begin
851 FClicked := False;
852 if Assigned(FOnDblClick) then
853 FOnDblClick(Self);
854end;
855
856function TCustomLayer.DoHitTest(X, Y: Integer): Boolean;
857begin
858 Result := Visible;
859end;
860
861procedure TCustomLayer.DoPaint(Buffer: TBitmap32);
862begin
863 Paint(Buffer);
864 if Assigned(FOnPaint) then
865 FOnPaint(Self, Buffer);
866end;
867
868function TCustomLayer.GetIndex: Integer;
869begin
870 if Assigned(FLayerCollection) then
871 Result := FLayerCollection.FItems.IndexOf(Self)
872 else
873 Result := -1;
874end;
875
876function TCustomLayer.GetMouseEvents: Boolean;
877begin
878 Result := FLayerOptions and LOB_MOUSE_EVENTS <> 0;
879end;
880
881function TCustomLayer.GetOwner: TPersistent;
882begin
883 Result := FLayerCollection;
884end;
885
886function TCustomLayer.GetVisible: Boolean;
887begin
888 Result := FLayerOptions and LOB_VISIBLE <> 0;
889end;
890
891function TCustomLayer.HitTest(X, Y: Integer): Boolean;
892begin
893 Result := DoHitTest(X, Y);
894 if Assigned(FOnHitTest) then
895 FOnHitTest(Self, X, Y, Result);
896end;
897
898procedure TCustomLayer.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
899begin
900 if (Button = mbLeft) then
901 begin
902 if (ssDouble in Shift) then
903 DblClick
904 else
905 FClicked := True;
906 end;
907 if Assigned(FOnMouseDown) then
908 FOnMouseDown(Self, Button, Shift, X, Y);
909end;
910
911procedure TCustomLayer.MouseMove(Shift: TShiftState; X, Y: Integer);
912begin
913 Screen.Cursor := Cursor;
914 if Assigned(FOnMouseMove) then
915 FOnMouseMove(Self, Shift, X, Y);
916end;
917
918procedure TCustomLayer.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
919begin
920 Screen.Cursor := crDefault;
921 if (Button = mbLeft) and FClicked then
922 Click;
923 if Assigned(FOnMouseUp) then
924 FOnMouseUp(Self, Button, Shift, X, Y);
925end;
926
927procedure TCustomLayer.Notification(ALayer: TCustomLayer);
928begin
929 // do nothing by default
930end;
931
932procedure TCustomLayer.Paint(Buffer: TBitmap32);
933begin
934 // descendants override this method
935end;
936
937procedure TCustomLayer.PaintGDI(Canvas: TCanvas);
938begin
939 // descendants override this method
940end;
941
942procedure TCustomLayer.RemoveNotification(ALayer: TCustomLayer);
943begin
944 if Assigned(FFreeNotifies) then
945 begin
946 FFreeNotifies.Remove(ALayer);
947 if FFreeNotifies.Count = 0 then
948 begin
949 FFreeNotifies.Free;
950 FFreeNotifies := nil;
951 end;
952 end;
953end;
954
955procedure TCustomLayer.SendToBack;
956begin
957 Index := 0;
958end;
959
960procedure TCustomLayer.SetAsMouseListener;
961begin
962 FLayerCollection.MouseListener := Self;
963 Screen.Cursor := Cursor;
964end;
965
966procedure TCustomLayer.SetCursor(Value: TCursor);
967begin
968 if Value <> FCursor then
969 begin
970 FCursor := Value;
971 if FLayerCollection.MouseListener = Self then
972 Screen.Cursor := Value;
973 end;
974end;
975
976procedure TCustomLayer.SetIndex(Value: Integer);
977var
978 CurIndex: Integer;
979begin
980 CurIndex := GetIndex;
981 if (CurIndex >= 0) and (CurIndex <> Value) then
982 with FLayerCollection do
983 begin
984 if Value < 0 then Value := 0;
985 if Value >= Count then Value := Count - 1;
986 if Value <> CurIndex then
987 begin
988 if Visible then BeginUpdate;
989 try
990 FLayerCollection.FItems.Move(CurIndex, Value);
991 finally
992 if Visible then EndUpdate;
993 end;
994 end;
995 end;
996end;
997
998procedure TCustomLayer.SetLayerCollection(Value: TLayerCollection);
999begin
1000 if FLayerCollection <> Value then
1001 begin
1002 if Assigned(FLayerCollection) then
1003 begin
1004 if FLayerCollection.MouseListener = Self then
1005 FLayerCollection.MouseListener := nil;
1006 FLayerCollection.RemoveItem(Self);
1007 end;
1008 if Assigned(Value) then
1009 Value.InsertItem(Self);
1010 FLayerCollection := Value;
1011 end;
1012end;
1013
1014procedure TCustomLayer.SetLayerOptions(Value: Cardinal);
1015begin
1016 Changing;
1017 FLayerOptions := Value;
1018 Changed;
1019end;
1020
1021procedure TCustomLayer.SetMouseEvents(Value: Boolean);
1022begin
1023 if Value then
1024 LayerOptions := LayerOptions or LOB_MOUSE_EVENTS
1025 else
1026 LayerOptions := LayerOptions and not LOB_MOUSE_EVENTS;
1027end;
1028
1029procedure TCustomLayer.SetVisible(Value: Boolean);
1030begin
1031 if Value then
1032 LayerOptions := LayerOptions or LOB_VISIBLE
1033 else
1034 begin
1035 ForceUpdate := True;
1036 LayerOptions := LayerOptions and not LOB_VISIBLE;
1037 ForceUpdate := False;
1038 end;
1039end;
1040
1041procedure TCustomLayer.Update;
1042begin
1043 if Assigned(FLayerCollection) and
1044 (Visible or (LayerOptions and LOB_FORCE_UPDATE <> 0)) then
1045 FLayerCollection.DoUpdateLayer(Self);
1046end;
1047
1048procedure TCustomLayer.Update(const Rect: TRect);
1049begin
1050 if Assigned(FLayerCollection) then
1051 FLayerCollection.DoUpdateArea(Rect);
1052end;
1053
1054function TCustomLayer.GetInvalid: Boolean;
1055begin
1056 Result := LayerOptions and LOB_INVALID <> 0;
1057end;
1058
1059procedure TCustomLayer.SetInvalid(Value: Boolean);
1060begin
1061 // don't use LayerOptions here since this is internal and we don't want to
1062 // trigger Changing and Changed as this will definitely cause a stack overflow.
1063 if Value then
1064 FLayerOptions := FLayerOptions or LOB_INVALID
1065 else
1066 FLayerOptions := FLayerOptions and not LOB_INVALID;
1067end;
1068
1069function TCustomLayer.GetForceUpdate: Boolean;
1070begin
1071 Result := LayerOptions and LOB_FORCE_UPDATE <> 0;
1072end;
1073
1074procedure TCustomLayer.SetForceUpdate(Value: Boolean);
1075begin
1076 // don't use LayerOptions here since this is internal and we don't want to
1077 // trigger Changing and Changed as this will definitely cause a stack overflow.
1078 if Value then
1079 FLayerOptions := FLayerOptions or LOB_FORCE_UPDATE
1080 else
1081 FLayerOptions := FLayerOptions and not LOB_FORCE_UPDATE;
1082end;
1083
1084{ TPositionedLayer }
1085
1086constructor TPositionedLayer.Create(ALayerCollection: TLayerCollection);
1087begin
1088 inherited;
1089 with FLocation do
1090 begin
1091 Left := 0;
1092 Top := 0;
1093 Right := 64;
1094 Bottom := 64;
1095 end;
1096 FLayerOptions := LOB_VISIBLE or LOB_MOUSE_EVENTS;
1097end;
1098
1099function TPositionedLayer.DoHitTest(X, Y: Integer): Boolean;
1100begin
1101 with GetAdjustedRect(FLocation) do
1102 Result := (X >= Left) and (X < Right) and (Y >= Top) and (Y < Bottom) and
1103 inherited DoHitTest(X, Y);
1104end;
1105
1106procedure TPositionedLayer.DoSetLocation(const NewLocation: TFloatRect);
1107begin
1108 FLocation := NewLocation;
1109end;
1110
1111function TPositionedLayer.GetAdjustedLocation: TFloatRect;
1112begin
1113 Result := GetAdjustedRect(FLocation);
1114end;
1115
1116function TPositionedLayer.GetAdjustedRect(const R: TFloatRect): TFloatRect;
1117var
1118 ScaleX, ScaleY, ShiftX, ShiftY: TFloat;
1119begin
1120 if Scaled and Assigned(FLayerCollection) then
1121 begin
1122 FLayerCollection.GetViewportShift(ShiftX, ShiftY);
1123 FLayerCollection.GetViewportScale(ScaleX, ScaleY);
1124
1125 with Result do
1126 begin
1127 Left := R.Left * ScaleX + ShiftX;
1128 Top := R.Top * ScaleY + ShiftY;
1129 Right := R.Right * ScaleX + ShiftX;
1130 Bottom := R.Bottom * ScaleY + ShiftY;
1131 end;
1132 end
1133 else
1134 Result := R;
1135end;
1136
1137procedure TPositionedLayer.SetLocation(const Value: TFloatRect);
1138begin
1139 Changing;
1140 DoSetLocation(Value);
1141 Changed;
1142end;
1143
1144procedure TPositionedLayer.SetScaled(Value: Boolean);
1145begin
1146 if Value <> FScaled then
1147 begin
1148 Changing;
1149 FScaled := Value;
1150 Changed;
1151 end;
1152end;
1153
1154{ TBitmapLayer }
1155
1156procedure TBitmapLayer.BitmapAreaChanged(Sender: TObject; const Area: TRect; const Info: Cardinal);
1157var
1158 T: TRect;
1159 ScaleX, ScaleY: TFloat;
1160 Width: Integer;
1161begin
1162 if Bitmap.Empty then Exit;
1163
1164 if Assigned(FLayerCollection) and ((FLayerOptions and LOB_NO_UPDATE) = 0) then
1165 begin
1166 with GetAdjustedLocation do
1167 begin
1168 { TODO : Optimize me! }
1169 ScaleX := (Right - Left) / FBitmap.Width;
1170 ScaleY := (Bottom - Top) / FBitmap.Height;
1171
1172 T.Left := Floor(Left + Area.Left * ScaleX);
1173 T.Top := Floor(Top + Area.Top * ScaleY);
1174 T.Right := Ceil(Left + Area.Right * ScaleX);
1175 T.Bottom := Ceil(Top + Area.Bottom * ScaleY);
1176 end;
1177
1178 Width := Trunc(FBitmap.Resampler.Width) + 1;
1179 InflateArea(T, Width, Width);
1180
1181 Changed(T);
1182 end;
1183end;
1184
1185constructor TBitmapLayer.Create(ALayerCollection: TLayerCollection);
1186begin
1187 inherited;
1188 FBitmap := TBitmap32.Create;
1189 FBitmap.OnAreaChanged := BitmapAreaChanged;
1190end;
1191
1192function TBitmapLayer.DoHitTest(X, Y: Integer): Boolean;
1193var
1194 BitmapX, BitmapY: Integer;
1195 LayerWidth, LayerHeight: Integer;
1196begin
1197 Result := inherited DoHitTest(X, Y);
1198 if Result and AlphaHit then
1199 begin
1200 with GetAdjustedRect(FLocation) do
1201 begin
1202 LayerWidth := Round(Right - Left);
1203 LayerHeight := Round(Bottom - Top);
1204 if (LayerWidth < 0.5) or (LayerHeight < 0.5) then Result := False
1205 else
1206 begin
1207 // check the pixel alpha at (X, Y) position
1208 BitmapX := Round((X - Left) * Bitmap.Width / LayerWidth);
1209 BitmapY := Round((Y - Top) * Bitmap.Height / LayerHeight);
1210 if Bitmap.PixelS[BitmapX, BitmapY] and $FF000000 = 0 then Result := False;
1211 end;
1212 end;
1213 end;
1214end;
1215
1216destructor TBitmapLayer.Destroy;
1217begin
1218 FBitmap.Free;
1219 inherited;
1220end;
1221
1222procedure TBitmapLayer.Paint(Buffer: TBitmap32);
1223var
1224 SrcRect, DstRect, ClipRect, TempRect: TRect;
1225 ImageRect: TRect;
1226 LayerWidth, LayerHeight: TFloat;
1227begin
1228 if Bitmap.Empty then Exit;
1229 DstRect := MakeRect(GetAdjustedRect(FLocation));
1230 ClipRect := Buffer.ClipRect;
1231 GR32.IntersectRect(TempRect, ClipRect, DstRect);
1232 if GR32.IsRectEmpty(TempRect) then Exit;
1233
1234 SrcRect := MakeRect(0, 0, Bitmap.Width, Bitmap.Height);
1235 if Cropped and (LayerCollection.FOwner is TCustomImage32) and
1236 not (TImage32Access(LayerCollection.FOwner).PaintToMode) then
1237 begin
1238 with DstRect do
1239 begin
1240 LayerWidth := Right - Left;
1241 LayerHeight := Bottom - Top;
1242 end;
1243 if (LayerWidth < 0.5) or (LayerHeight < 0.5) then Exit;
1244 ImageRect := TCustomImage32(LayerCollection.FOwner).GetBitmapRect;
1245 GR32.IntersectRect(ClipRect, ClipRect, ImageRect);
1246 end;
1247 StretchTransfer(Buffer, DstRect, ClipRect, FBitmap, SrcRect,
1248 FBitmap.Resampler, FBitmap.DrawMode, FBitmap.OnPixelCombine);
1249end;
1250
1251procedure TBitmapLayer.SetBitmap(Value: TBitmap32);
1252begin
1253 FBitmap.Assign(Value);
1254end;
1255
1256procedure TBitmapLayer.SetCropped(Value: Boolean);
1257begin
1258 if Value <> FCropped then
1259 begin
1260 FCropped := Value;
1261 Changed;
1262 end;
1263end;
1264
1265
1266{ TRubberbandPassMouse }
1267
1268constructor TRubberbandPassMouse.Create(AOwner: TRubberbandLayer);
1269begin
1270 FOwner := AOwner;
1271 FEnabled := False;
1272 FToChild := False;
1273 FLayerUnderCursor := False;
1274 FCancelIfPassed := False;
1275end;
1276
1277function TRubberbandPassMouse.GetChildUnderCursor(X, Y: Integer): TPositionedLayer;
1278var
1279 Layer: TCustomLayer;
1280 Index: Integer;
1281begin
1282 Result := nil;
1283 for Index := FOwner.LayerCollection.Count - 1 downto 0 do
1284 begin
1285 Layer := FOwner.LayerCollection.Items[Index];
1286 if ((Layer.LayerOptions and LOB_MOUSE_EVENTS) > 0) and
1287 (Layer is TPositionedLayer) and Layer.HitTest(X, Y) then
1288 begin
1289 Result := TPositionedLayer(Layer);
1290 Exit;
1291 end;
1292 end;
1293end;
1294
1295
1296{ TRubberbandLayer }
1297
1298constructor TRubberbandLayer.Create(ALayerCollection: TLayerCollection);
1299begin
1300 inherited;
1301 FHandleFrame := clBlack32;
1302 FHandleFill := clWhite32;
1303 FHandles := [rhCenter, rhSides, rhCorners, rhFrame];
1304 FHandleSize := 3;
1305 FMinWidth := 10;
1306 FMinHeight := 10;
1307 FQuantized := 8;
1308 FLayerOptions := LOB_VISIBLE or LOB_MOUSE_EVENTS;
1309 SetFrameStipple([clWhite32, clWhite32, clBlack32, clBlack32]);
1310 FPassMouse := TRubberbandPassMouse.Create(Self);
1311 FFrameStippleStep := 1;
1312 FFrameStippleCounter := 0;
1313end;
1314
1315destructor TRubberbandLayer.Destroy;
1316begin
1317 FPassMouse.Free;
1318 inherited;
1319end;
1320
1321function TRubberbandLayer.DoHitTest(X, Y: Integer): Boolean;
1322begin
1323 if (Visible) then
1324 Result := (GetDragState(X, Y) <> dsNone)
1325 else
1326 Result := False;
1327end;
1328
1329procedure TRubberbandLayer.DoResizing(var OldLocation,
1330 NewLocation: TFloatRect; DragState: TRBDragState; Shift: TShiftState);
1331begin
1332 if Assigned(FOnResizing) then
1333 FOnResizing(Self, OldLocation, NewLocation, DragState, Shift);
1334end;
1335
1336procedure TRubberbandLayer.DoConstrain(var OldLocation,
1337 NewLocation: TFloatRect; DragState: TRBDragState; Shift: TShiftState);
1338begin
1339 if Assigned(FOnConstrain) then
1340 FOnConstrain(Self, OldLocation, NewLocation, DragState, Shift);
1341end;
1342
1343procedure TRubberbandLayer.DoSetLocation(const NewLocation: TFloatRect);
1344begin
1345 inherited;
1346 UpdateChildLayer;
1347end;
1348
1349function TRubberbandLayer.GetDragState(X, Y: Integer): TRBDragState;
1350var
1351 R: TRect;
1352 dh_center, dh_sides, dh_corners: Boolean;
1353 dl, dt, dr, db, dx, dy: Boolean;
1354 Sz: Integer;
1355const
1356 DragZone = 1;
1357begin
1358 Result := dsNone;
1359 Sz := Ceil(FHandleSize + DragZone);
1360 dh_center := rhCenter in FHandles;
1361 dh_sides := rhSides in FHandles;
1362 dh_corners := rhCorners in FHandles;
1363
1364 R := MakeRect(GetAdjustedRect(FLocation));
1365 with R do
1366 begin
1367 Dec(Right);
1368 Dec(Bottom);
1369 dl := Abs(Left - X) <= Sz;
1370 dr := Abs(Right - X) <= Sz;
1371 dx := Abs((Left + Right) div 2 - X) <= Sz;
1372 dt := Abs(Top - Y) <= Sz;
1373 db := Abs(Bottom - Y) <= Sz;
1374 dy := Abs((Top + Bottom) div 2 - Y) <= Sz;
1375 end;
1376
1377 if dr and db and dh_corners and not(rhNotBRCorner in FHandles) then Result := dsSizeBR
1378 else if dl and db and dh_corners and not(rhNotBLCorner in FHandles) then Result := dsSizeBL
1379 else if dr and dt and dh_corners and not(rhNotTRCorner in FHandles) then Result := dsSizeTR
1380 else if dl and dt and dh_corners and not(rhNotTLCorner in FHandles) then Result := dsSizeTL
1381 else if dr and dy and dh_sides and not(rhNotRightSide in FHandles) then Result := dsSizeR
1382 else if db and dx and dh_sides and not(rhNotBottomSide in FHandles) then Result := dsSizeB
1383 else if dl and dy and dh_sides and not(rhNotLeftSide in FHandles) then Result := dsSizeL
1384 else if dt and dx and dh_sides and not(rhNotTopSide in FHandles) then Result := dsSizeT
1385 else if dh_center and GR32.PtInRect(R, GR32.Point(X, Y)) then Result := dsMove;
1386end;
1387
1388procedure TRubberbandLayer.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1389var
1390 PositionedLayer: TPositionedLayer;
1391begin
1392 if FPassMouse.Enabled then
1393 begin
1394 if FPassMouse.ToLayerUnderCursor then
1395 PositionedLayer := FPassMouse.GetChildUnderCursor(X, Y)
1396 else
1397 PositionedLayer := ChildLayer;
1398
1399 if FPassMouse.ToChild and Assigned(ChildLayer) then
1400 begin
1401 ChildLayer.MouseDown(Button, Shift, X, Y);
1402 if FPassMouse.CancelIfPassed then
1403 Exit;
1404 end;
1405
1406 if (PositionedLayer <> ChildLayer) and Assigned(PositionedLayer) then
1407 begin
1408 PositionedLayer.MouseDown(Button, Shift, X, Y);
1409 if FPassMouse.CancelIfPassed then
1410 Exit;
1411 end;
1412 end;
1413
1414 if FIsDragging then Exit;
1415 SetDragState(GetDragState(X, Y), X, Y);
1416 inherited;
1417end;
1418
1419procedure TRubberbandLayer.MouseMove(Shift: TShiftState; X, Y: Integer);
1420const
1421 CURSOR_ID: array [TRBDragState] of TCursor = (crDefault, crDefault, crSizeWE,
1422 crSizeNS, crSizeWE, crSizeNS, crSizeNWSE, crSizeNESW, crSizeNESW, crSizeNWSE);
1423var
1424 Mx, My: TFloat;
1425 L, T, R, B, W, H: TFloat;
1426 Quantize: Boolean;
1427 ALoc, NewLocation: TFloatRect;
1428
1429 procedure IncLT(var LT, RB: TFloat; Delta, MinSize, MaxSize: TFloat);
1430 begin
1431 LT := LT + Delta;
1432 if RB - LT < MinSize then LT := RB - MinSize;
1433 if MaxSize >= MinSize then if RB - LT > MaxSize then LT := RB - MaxSize;
1434 end;
1435
1436 procedure IncRB(var LT, RB: TFloat; Delta, MinSize, MaxSize: TFloat);
1437 begin
1438 RB := RB + Delta;
1439 if RB - LT < MinSize then RB := LT + MinSize;
1440 if MaxSize >= MinSize then if RB - LT > MaxSize then RB := LT + MaxSize;
1441 end;
1442
1443begin
1444 if not FIsDragging then
1445 begin
1446 FDragState := GetDragState(X, Y);
1447 if FDragState = dsMove then
1448 Screen.Cursor := Cursor
1449 else
1450 Screen.Cursor := CURSOR_ID[FDragState];
1451 end
1452 else
1453 begin
1454 Mx := X - FMouseShift.X;
1455 My := Y - FMouseShift.Y;
1456 if Scaled then
1457 with Location do
1458 begin
1459 ALoc := GetAdjustedRect(FLocation);
1460 if GR32.IsRectEmpty(ALoc) then Exit;
1461 Mx := (Mx - ALoc.Left) / (ALoc.Right - ALoc.Left) * (Right - Left) + Left;
1462 My := (My - ALoc.Top) / (ALoc.Bottom - ALoc.Top) * (Bottom - Top) + Top;
1463 end;
1464
1465 with FOldLocation do
1466 begin
1467 L := Left;
1468 T := Top;
1469 R := Right;
1470 B := Bottom;
1471 W := R - L;
1472 H := B - T;
1473 end;
1474
1475 Quantize := (roQuantized in Options) and not (ssAlt in Shift);
1476
1477 if FDragState = dsMove then
1478 begin
1479 L := Mx;
1480 T := My;
1481 if Quantize then
1482 begin
1483 L := Round(L / FQuantized) * FQuantized;
1484 T := Round(T / FQuantized) * FQuantized;
1485 end;
1486 R := L + W;
1487 B := T + H;
1488 end
1489 else
1490 begin
1491 if FDragState in [dsSizeL, dsSizeTL, dsSizeBL] then
1492 begin
1493 IncLT(L, R, Mx - L, MinWidth, MaxWidth);
1494 if Quantize then
1495 L := Round(L / FQuantized) * FQuantized;
1496 end;
1497
1498 if FDragState in [dsSizeR, dsSizeTR, dsSizeBR] then
1499 begin
1500 IncRB(L, R, Mx - R, MinWidth, MaxWidth);
1501 if Quantize then
1502 R := Round(R / FQuantized) * FQuantized;
1503 end;
1504
1505 if FDragState in [dsSizeT, dsSizeTL, dsSizeTR] then
1506 begin
1507 IncLT(T, B, My - T, MinHeight, MaxHeight);
1508 if Quantize then
1509 T := Round(T / FQuantized) * FQuantized;
1510 end;
1511
1512 if FDragState in [dsSizeB, dsSizeBL, dsSizeBR] then
1513 begin
1514 IncRB(T, B, My - B, MinHeight, MaxHeight);
1515 if Quantize then
1516 B := Round(B / FQuantized) * FQuantized;
1517 end;
1518 end;
1519
1520 NewLocation := FloatRect(L, T, R, B);
1521
1522 if roConstrained in FOptions then
1523 DoConstrain(FOldLocation, NewLocation, FDragState, Shift);
1524
1525 if roProportional in FOptions then
1526 begin
1527 case FDragState of
1528 dsSizeB, dsSizeBR:
1529 NewLocation.Right := FOldLocation.Left + (FOldLocation.Right - FOldLocation.Left) * (NewLocation.Bottom - NewLocation.Top) / (FOldLocation.Bottom - FOldLocation.Top);
1530 dsSizeT, dsSizeTL:
1531 NewLocation.Left := FOldLocation.Right - (FOldLocation.Right - FOldLocation.Left) * (NewLocation.Bottom - NewLocation.Top) / (FOldLocation.Bottom - FOldLocation.Top);
1532 dsSizeR, dsSizeBL:
1533 NewLocation.Bottom := FOldLocation.Top + (FOldLocation.Bottom - FOldLocation.Top) * (NewLocation.Right - NewLocation.Left) / (FOldLocation.Right - FOldLocation.Left);
1534 dsSizeL, dsSizeTR:
1535 NewLocation.Top := FOldLocation.Bottom - (FOldLocation.Bottom - FOldLocation.Top) * (NewLocation.Right - NewLocation.Left) / (FOldLocation.Right - FOldLocation.Left);
1536 end;
1537 end;
1538
1539 DoResizing(FOldLocation, NewLocation, FDragState, Shift);
1540
1541 if (NewLocation.Left <> Location.Left) or
1542 (NewLocation.Right <> Location.Right) or
1543 (NewLocation.Top <> Location.Top) or
1544 (NewLocation.Bottom <> Location.Bottom) then
1545 begin
1546 Location := NewLocation;
1547 if Assigned(FOnUserChange) then
1548 FOnUserChange(Self);
1549 end;
1550 end;
1551end;
1552
1553procedure TRubberbandLayer.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1554var
1555 PositionedLayer: TPositionedLayer;
1556begin
1557 if FPassMouse.Enabled then
1558 begin
1559 if FPassMouse.ToLayerUnderCursor then
1560 PositionedLayer := FPassMouse.GetChildUnderCursor(X, Y)
1561 else
1562 PositionedLayer := ChildLayer;
1563
1564 if FPassMouse.ToChild and Assigned(ChildLayer) then
1565 begin
1566 ChildLayer.MouseUp(Button, Shift, X, Y);
1567 if FPassMouse.CancelIfPassed then
1568 Exit;
1569 end;
1570
1571 if (PositionedLayer <> ChildLayer) and Assigned(PositionedLayer) then
1572 begin
1573 PositionedLayer.MouseUp(Button, Shift, X, Y);
1574 if FPassMouse.CancelIfPassed then
1575 Exit;
1576 end;
1577 end;
1578
1579 FIsDragging := False;
1580 inherited;
1581end;
1582
1583procedure TRubberbandLayer.Notification(ALayer: TCustomLayer);
1584begin
1585 if ALayer = FChildLayer then
1586 FChildLayer := nil;
1587end;
1588
1589procedure TRubberbandLayer.DrawHandle(Buffer: TBitmap32; X, Y: TFloat);
1590var
1591 HandleRect: TRect;
1592begin
1593 // Coordinate specifies exact center of handle. I.e. center of
1594 // pixel if handle is odd number of pixels wide.
1595
1596 HandleRect.Left := Floor(X - FHandleSize);
1597 HandleRect.Right := HandleRect.Left + Ceil(FHandleSize*2);
1598 HandleRect.Top := Floor(Y - FHandleSize);
1599 HandleRect.Bottom := HandleRect.Top + Ceil(FHandleSize*2);
1600
1601 Buffer.FrameRectTS(HandleRect, FHandleFrame);
1602
1603 GR32.InflateRect(HandleRect, -1, -1);
1604 Buffer.FillRectTS(HandleRect, FHandleFill);
1605end;
1606
1607procedure TRubberbandLayer.Paint(Buffer: TBitmap32);
1608
1609var
1610 CenterX, CenterY: TFloat;
1611 R: TRect;
1612begin
1613 R := MakeRect(GetAdjustedRect(FLocation));
1614 with R do
1615 begin
1616 if rhFrame in FHandles then
1617 begin
1618 Buffer.SetStipple(FFrameStipplePattern);
1619 Buffer.StippleCounter := 0;
1620 Buffer.StippleStep := FFrameStippleStep;
1621 Buffer.StippleCounter := FFrameStippleCounter;
1622 Buffer.FrameRectTSP(Left, Top, Right, Bottom);
1623 end;
1624 if rhCorners in FHandles then
1625 begin
1626 if not(rhNotTLCorner in FHandles) then DrawHandle(Buffer, Left+0.5, Top+0.5);
1627 if not(rhNotTRCorner in FHandles) then DrawHandle(Buffer, Right-0.5, Top+0.5);
1628 if not(rhNotBLCorner in FHandles) then DrawHandle(Buffer, Left+0.5, Bottom-0.5);
1629 if not(rhNotBRCorner in FHandles) then DrawHandle(Buffer, Right-0.5, Bottom-0.5);
1630 end;
1631 if rhSides in FHandles then
1632 begin
1633 CenterX := (Left + Right) / 2;
1634 CenterY := (Top + Bottom) / 2;
1635 if not(rhNotTopSide in FHandles) then DrawHandle(Buffer, CenterX, Top+0.5);
1636 if not(rhNotLeftSide in FHandles) then DrawHandle(Buffer, Left+0.5, CenterY);
1637 if not(rhNotRightSide in FHandles) then DrawHandle(Buffer, Right-0.5, CenterY);
1638 if not(rhNotBottomSide in FHandles) then DrawHandle(Buffer, CenterX, Bottom-0.5);
1639 end;
1640 end;
1641end;
1642
1643procedure TRubberbandLayer.Quantize;
1644begin
1645 Location := FloatRect(
1646 Round(Location.Left / Quantized) * Quantized,
1647 Round(Location.Top / Quantized) * Quantized,
1648 Round(Location.Right / Quantized) * Quantized,
1649 Round(Location.Bottom / Quantized) * Quantized);
1650end;
1651
1652procedure TRubberbandLayer.SetChildLayer(Value: TPositionedLayer);
1653begin
1654 if Assigned(FChildLayer) then
1655 RemoveNotification(FChildLayer);
1656
1657 FChildLayer := Value;
1658 if Assigned(Value) then
1659 begin
1660 Location := Value.Location;
1661 Scaled := Value.Scaled;
1662 AddNotification(FChildLayer);
1663 end;
1664end;
1665
1666procedure TRubberbandLayer.SetDragState(const Value: TRBDragState);
1667begin
1668 SetDragState(Value, 0, 0);
1669end;
1670
1671procedure TRubberbandLayer.SetDragState(const Value: TRBDragState; const X, Y: Integer);
1672var
1673 ALoc: TFloatRect;
1674begin
1675 FDragState := Value;
1676 FIsDragging := FDragState <> dsNone;
1677
1678 if FIsDragging then
1679 begin
1680 FOldLocation := Location;
1681
1682 ALoc := GetAdjustedRect(FLocation);
1683
1684 case FDragState of
1685 dsMove: FMouseShift := FloatPoint(X - ALoc.Left, Y - ALoc.Top);
1686 else
1687 FMouseShift := FloatPoint(0, 0);
1688 end;
1689 end;
1690end;
1691
1692procedure TRubberbandLayer.SetHandleFill(Value: TColor32);
1693begin
1694 if Value <> FHandleFill then
1695 begin
1696 FHandleFill := Value;
1697 FLayerCollection.GDIUpdate;
1698 end;
1699end;
1700
1701procedure TRubberbandLayer.SetHandleFrame(Value: TColor32);
1702begin
1703 if Value <> FHandleFrame then
1704 begin
1705 FHandleFrame := Value;
1706 FLayerCollection.GDIUpdate;
1707 end;
1708end;
1709
1710procedure TRubberbandLayer.SetHandles(Value: TRBHandles);
1711begin
1712 if Value <> FHandles then
1713 begin
1714 FHandles := Value;
1715 FLayerCollection.GDIUpdate;
1716 end;
1717end;
1718
1719procedure TRubberbandLayer.SetHandleSize(Value: TFloat);
1720begin
1721 if Value < 1 then
1722 Value := 1;
1723 if Value <> FHandleSize then
1724 begin
1725 FHandleSize := Value;
1726 FLayerCollection.GDIUpdate;
1727 end;
1728end;
1729
1730procedure TRubberbandLayer.SetFrameStipple(const Value: Array of TColor32);
1731var
1732 L: Integer;
1733begin
1734 L := High(Value) + 1;
1735 SetLength(FFrameStipplePattern, L);
1736 MoveLongword(Value[0], FFrameStipplePattern[0], L);
1737end;
1738
1739procedure TRubberbandLayer.SetFrameStippleStep(const Value: TFloat);
1740begin
1741 if Value <> FFrameStippleStep then
1742 begin
1743 FFrameStippleStep := Value;
1744 FLayerCollection.GDIUpdate;
1745 end;
1746end;
1747
1748procedure TRubberbandLayer.UpdateChildLayer;
1749begin
1750 if Assigned(FChildLayer) then FChildLayer.Location := Location;
1751end;
1752
1753procedure TRubberbandLayer.SetFrameStippleCounter(const Value: TFloat);
1754begin
1755 if Value <> FFrameStippleCounter then
1756 begin
1757 FFrameStippleCounter := Value;
1758 FLayerCollection.GDIUpdate;
1759 end;
1760end;
1761
1762procedure TRubberbandLayer.SetLayerOptions(Value: Cardinal);
1763begin
1764 Changing;
1765 FLayerOptions := Value and not LOB_NO_UPDATE; // workaround for changed behaviour
1766 Changed;
1767end;
1768
1769procedure TRubberbandLayer.SetOptions(const Value: TRBOptions);
1770begin
1771 FOptions := Value;
1772end;
1773
1774procedure TRubberbandLayer.SetQuantized(const Value: Integer);
1775begin
1776 if Value < 1 then
1777 raise Exception.Create('Value must be larger than zero!');
1778
1779 FQuantized := Value;
1780end;
1781
1782end.
Note: See TracBrowser for help on using the repository browser.