1 // SPDX-License-Identifier: GPL-3.0-only
2 unit UToolDeformationGrid;
3 
4 {$mode objfpc}{$H+}
5 
6 interface
7 
8 uses
9   Classes, Types, Math, SysUtils, utool, BGRABitmapTypes, BGRABitmap, UImage,
10   UImageType, ULayerAction, LCVectorialFill;
11 
12 type
13 
14   { TToolDeformationGrid }
15 
16   TToolDeformationGrid = class(TGenericTool)
17   private
18     FCurrentBounds,FMergedBounds: TRect;
19     procedure ReleaseGrid;
ToolDeformationGridNeedednull20     function ToolDeformationGridNeeded: boolean;
21     procedure ValidateDeformationGrid;
22   protected
23     deformationGridNbX,deformationGridNbY,deformationGridX,deformationGridY: integer;
24     deformationGridMoving: boolean;
25     deformationOrigin: TPointF;
26     DoingDeformation: boolean;
27     deformationGrid: array of array of TPointF;
28     deformationGridTexCoord: array of array of TPointF;
GetPointAtnull29     function GetPointAt(const ptF: TPointF; var x,y: integer): boolean;
DoToolDownnull30     function DoToolDown({%H-}toolDest: TBGRABitmap; {%H-}pt: TPoint; ptF: TPointF;
31       {%H-}rightBtn: boolean): TRect; override;
DoToolMovenull32     function DoToolMove({%H-}toolDest: TBGRABitmap; {%H-}pt: TPoint; ptF: TPointF): Trect;
33       override;
DoToolKeyDownnull34     function DoToolKeyDown(var key: Word): TRect; override;
GetIsSelectingToolnull35     function GetIsSelectingTool: boolean; override;
DoToolUpdatenull36     function DoToolUpdate({%H-}toolDest: TBGRABitmap): TRect; override;
37   public
38     constructor Create(AManager: TToolManager); override;
ToolUpnull39     function ToolUp: TRect; override;
GetContextualToolbarsnull40     function GetContextualToolbars: TContextualToolbars; override;
Rendernull41     function Render(VirtualScreen: TBGRABitmap; {%H-}VirtualScreenWidth, {%H-}VirtualScreenHeight: integer; BitmapToVirtualScreen: TBitmapToVirtualScreenFunction): TRect; override;
ToolCommandnull42     function ToolCommand(ACommand: TToolCommand): boolean; override;
ToolProvideCommandnull43     function ToolProvideCommand(ACommand: TToolCommand): boolean; override;
44     destructor Destroy; override;
45   end;
46 
47   { TToolTextureMapping }
48 
49   TToolTextureMapping = class(TGenericTool)
50   private
51     class var FHintShowed: boolean;
52     FCurrentBounds: TRect;
53     FLastTexture: TBGRABitmap;
54     FTextureAfterAlpha: TBGRABitmap;
55     FAdaptedTexture: TBGRABitmap;
56     FCanReadaptTexture: boolean;
57     FHighQuality: boolean;
58     procedure ToolQuadNeeded;
59     procedure ValidateQuad; virtual;
60     procedure DrawQuad; virtual;
GetAdaptedTexturenull61     function GetAdaptedTexture: TBGRABitmap;
62     procedure UpdateBoundsMode(var ARectResult: TRect);
63 
64   protected
65     boundsMode: boolean;
66     quadDefined: boolean;
67     definingQuad: boolean;
68     quad: array of TPointF;
69     boundsPts: array of TPointF;
70     quadMovingIndex: integer;
71     quadMoving,quadMovingBounds: boolean;
72     quadMovingDelta: TPointF;
SnapIfNecessarynull73     function SnapIfNecessary(ptF: TPointF): TPointF;
DoToolDownnull74     function DoToolDown({%H-}toolDest: TBGRABitmap; {%H-}pt: TPoint; ptF: TPointF;
75       {%H-}rightBtn: boolean): TRect; override;
DoToolMovenull76     function DoToolMove({%H-}toolDest: TBGRABitmap; {%H-}pt: TPoint; ptF: TPointF): TRect;
77       override;
DoToolKeyDownnull78     function DoToolKeyDown(var key: Word): TRect; override;
DoToolKeyUpnull79     function DoToolKeyUp(var key: Word): TRect; override;
GetIsSelectingToolnull80     function GetIsSelectingTool: boolean; override;
GetTexturenull81     function GetTexture: TBGRABitmap; virtual;
GetTextureRepetitionnull82     function GetTextureRepetition: TTextureRepetition; virtual;
83     procedure OnTryStop({%H-}sender: TCustomLayerAction); override;
ComputeBoundsPointsnull84     function ComputeBoundsPoints: ArrayOfTPointF;
85     procedure PrepareBackground({%H-}toolDest: TBGRABitmap; AFirstTime: boolean); virtual;
DefaultTextureCenternull86     function DefaultTextureCenter: TPointF; virtual;
DoToolUpdatenull87     function DoToolUpdate({%H-}toolDest: TBGRABitmap): TRect; override;
GetStatusTextnull88     function GetStatusText: string; override;
GetAllowedBackFillTypesnull89     function GetAllowedBackFillTypes: TVectorialFillTypes; override;
90   public
91     constructor Create(AManager: TToolManager); override;
ToolUpnull92     function ToolUp: TRect; override;
GetContextualToolbarsnull93     function GetContextualToolbars: TContextualToolbars; override;
Rendernull94     function Render(VirtualScreen: TBGRABitmap; {%H-}VirtualScreenWidth, {%H-}VirtualScreenHeight: integer; BitmapToVirtualScreen: TBitmapToVirtualScreenFunction):TRect; override;
ToolProvideCommandnull95     function ToolProvideCommand(ACommand: TToolCommand): boolean; override;
ToolCommandnull96     function ToolCommand(ACommand: TToolCommand): boolean; override;
97     destructor Destroy; override;
98   end;
99 
100   { TToolLayerMapping }
101 
102   TToolLayerMapping = class(TToolTextureMapping)
103   protected
104     FTexture: TBGRABitmap;
105     FDefaultTextureCenter: TPointF;
106     FAlreadyDrawnOnce: boolean;
107     procedure PrepareTexture;
108     procedure PrepareBackground(toolDest: TBGRABitmap; {%H-}AFirstTime: boolean); override;
GetTexturenull109     function GetTexture: TBGRABitmap; override;
DefaultTextureCenternull110     function DefaultTextureCenter: TPointF; override;
GetTextureRepetitionnull111     function GetTextureRepetition: TTextureRepetition; override;
112     procedure ValidateQuad; override;
GetAllowedBackFillTypesnull113     function GetAllowedBackFillTypes: TVectorialFillTypes; override;
114   public
115     constructor Create(AManager: TToolManager); override;
GetContextualToolbarsnull116     function GetContextualToolbars: TContextualToolbars; override;
117     destructor Destroy; override;
118   end;
119 
120 implementation
121 
122 uses LCLType, ugraph, LCScaleDPI, LazPaintType, BGRAFillInfo, BGRATransform, Controls;
123 
124 { TToolLayerMapping }
125 
126 procedure TToolLayerMapping.PrepareTexture;
127 var src: TBGRABitmap;
128     bounds: TRect;
129 begin
130   if FTexture = nil then
131   begin
132     src := Action.BackupDrawingLayer;
133     bounds := src.GetImageBounds;
134     if IsRectEmpty(bounds) then
135       bounds := rect(0,0,1,1);
136     FTexture := src.GetPart(bounds) as TBGRABitmap;
137     FDefaultTextureCenter := PointF((bounds.Left+bounds.Right)/2-0.5,(bounds.Top+bounds.Bottom)/2-0.5);
138   end;
139 end;
140 
141 procedure TToolLayerMapping.PrepareBackground(toolDest: TBGRABitmap;
142   AFirstTime: boolean);
143 var
144   r: TRect;
145 begin
146   if not FAlreadyDrawnOnce then
147   begin
148     FAlreadyDrawnOnce := true;
149     r := toolDest.GetImageBounds;
150   end else
151     r := FCurrentBounds;
152 
153   toolDest.FillRect(r, BGRAPixelTransparent, dmSet);
154   Action.NotifyChange(toolDest, r);
155 end;
156 
TToolLayerMapping.GetTexturenull157 function TToolLayerMapping.GetTexture: TBGRABitmap;
158 begin
159   PrepareTexture;
160   result := FTexture;
161 end;
162 
TToolLayerMapping.DefaultTextureCenternull163 function TToolLayerMapping.DefaultTextureCenter: TPointF;
164 begin
165   PrepareTexture;
166   result := FDefaultTextureCenter;
167 end;
168 
TToolLayerMapping.GetTextureRepetitionnull169 function TToolLayerMapping.GetTextureRepetition: TTextureRepetition;
170 begin
171   if poRepeat in Manager.PerspectiveOptions then
172     Result:= trRepeatBoth;
173 end;
174 
175 procedure TToolLayerMapping.ValidateQuad;
176 begin
177   inherited ValidateQuad;
178   Manager.QueryExitTool;
179 end;
180 
TToolLayerMapping.GetAllowedBackFillTypesnull181 function TToolLayerMapping.GetAllowedBackFillTypes: TVectorialFillTypes;
182 begin
183   Result:= [vftSolid,vftGradient,vftTexture];
184 end;
185 
186 constructor TToolLayerMapping.Create(AManager: TToolManager);
187 begin
188   inherited Create(AManager);
189   ToolQuadNeeded;
190 end;
191 
GetContextualToolbarsnull192 function TToolLayerMapping.GetContextualToolbars: TContextualToolbars;
193 begin
194   Result:= [ctPerspective];
195 end;
196 
197 destructor TToolLayerMapping.Destroy;
198 begin
199   FreeAndNil(FTexture);
200   inherited Destroy;
201 end;
202 
203 { TToolTextureMapping }
204 
205 procedure TToolTextureMapping.ToolQuadNeeded;
206 var
207   tx,ty: single;
208   ratio,temp: single;
209   center: TPointF;
210 begin
211   if not quadDefined and (GetTexture <> nil) and (GetTexture.Width > 0) and (GetTexture.Height > 0) then
212   begin
213     tx := GetTexture.Width;
214     ty := GetTexture.Height;
215     ratio := 1;
216     if tx > Manager.Image.Width then
217       ratio := Manager.Image.Width/tx;
218     if ty > Manager.Image.Height then
219     begin
220       temp := Manager.Image.Height/ty;
221       if temp < ratio then ratio := temp;
222     end;
223     if ratio > 0 then
224     begin
225       setlength(quad,4);
226       center := DefaultTextureCenter;
227       quad[0] := PointF(round(center.x-tx*ratio/2+0.5)-0.5,round(center.y -ty*ratio/2 + 0.5)-0.5);
228       quad[1] := PointF(quad[0].x + tx*ratio,quad[0].y);
229       quad[2] := PointF(quad[1].x, quad[1].Y + ty*ratio);
230       quad[3] := PointF(quad[0].x, quad[2].y);
231       quadDefined:= true;
232       PrepareBackground(GetToolDrawingLayer, True);
233       DrawQuad;
234       Action.NotifyChange(GetToolDrawingLayer, FCurrentBounds);
235     end;
236   end;
237 end;
238 
239 procedure TToolTextureMapping.ValidateQuad;
240 begin
241   if quadDefined then
242   begin
243     if Manager.Image.Width*Manager.Image.Height <= 786432 then
244     begin
245       PrepareBackground(GetToolDrawingLayer,False);
246       FHighQuality := true;
247       FCanReadaptTexture:= true;
248       DrawQuad;
249       FCanReadaptTexture:= false;
250       FHighQuality := false;
251       Action.NotifyChange(GetToolDrawingLayer, FCurrentBounds);
252     end;
253     ValidateAction;
254     quadDefined := false;
255     quad := nil;
256     FLastTexture.FreeReference;
257     FLastTexture := nil;
258   end;
259 end;
260 
261 procedure TToolTextureMapping.DrawQuad;
262 const OversampleQuality = 2;
263 var
264   tex: TBGRABitmap;
265   persp: TBGRAPerspectiveScannerTransform;
266   dest: TBGRABitmap;
267   quadHQ: array of TPointF;
268   i: integer;
269   scanRepeat: TBGRABitmapScanner;
270   scan: IBGRAScanner;
271 
AlmostIntnull272   function AlmostInt(value: single): boolean;
273   begin
274     result := (value-round(value)) < 1e-6;
275   end;
276 
277 begin
278   if quadDefined then
279   begin
280     if (quad[1].y = quad[0].y) and (quad[3].x = quad[0].x) and (quad[2].x = quad[1].x) and (quad[3].y = quad[2].y) and
281       AlmostInt(quad[0].x+0.5) and AlmostInt(quad[0].y+0.5) and AlmostInt(quad[2].x+0.5) and AlmostInt(quad[2].y+0.5) and
282       (round(quad[2].x-quad[0].x) = GetTexture.Width) and (round(quad[2].y-quad[0].y) = GetTexture.Height) then
283        FHighQuality := false;
284 
285     tex := GetAdaptedTexture;
286     if tex <> nil then
287     begin
288 
289       if GetTextureRepetition <> trNone then
290         FCurrentBounds := rect(0,0,Manager.Image.Width,Manager.Image.Height)
291       else
292         FCurrentBounds := GetShapeBounds([quad[0],quad[1],quad[2],quad[3]],1);
293 
294       if FHighQuality then
295       begin
296         dest := TBGRABitmap.Create(FCurrentBounds.Width*OversampleQuality,FCurrentBounds.Height*OversampleQuality);
297         setlength(quadHQ, length(quad));
298         for i := 0 to high(quad) do quadHQ[i] := (quad[i]+PointF(0.5,0.5))*OversampleQuality - PointF(0.5,0.5) - PointF(FCurrentBounds.TopLeft)*OversampleQuality;
299       end
300       else
301       begin
302         dest := GetToolDrawingLayer;
303         quadHQ := quad;
304         dest.ClipRect := FCurrentBounds;
305       end;
306 
307       if GetTextureRepetition <> trNone then
308       begin
309         if GetTextureRepetition <> trRepeatBoth then
310         begin
311           scanRepeat := TBGRABitmapScanner.Create(tex,
312             GetTextureRepetition in [trRepeatX,trRepeatBoth],
313             GetTextureRepetition in [trRepeatY,trRepeatBoth], Point(0,0) );
314           scan := scanRepeat;
315         end else
316         begin
317           scanRepeat := nil;
318           scan := tex;
319         end;
320         persp := TBGRAPerspectiveScannerTransform.Create(scan,[PointF(-0.5,-0.5),PointF(tex.Width-0.5,-0.5),
321           PointF(tex.Width-0.5,tex.Height-0.5),PointF(-0.5,tex.Height-0.5)],quadHQ);
322         persp.IncludeOppositePlane := poTwoPlanes in Manager.PerspectiveOptions;
323         dest.FillRect(0,0,dest.Width,dest.Height,persp,dmDrawWithTransparency);
324         persp.Free;
325         scan := nil;
326         scanRepeat.Free;
327       end else
328       begin
329         dest.FillQuadPerspectiveMappingAntialias(quadHQ[0],quadHQ[1],quadHQ[2],quadHQ[3],tex,PointF(-0.5,-0.5),PointF(tex.Width-0.5,-0.5),
330           PointF(tex.Width-0.5,tex.Height-0.5),PointF(-0.5,tex.Height-0.5), rect(0,0,tex.Width,tex.Height));
331       end;
332 
333       if FHighQuality then
334       begin
335         BGRAReplace(dest, dest.Resample(dest.Width div OversampleQuality, dest.Height div OversampleQuality,rmSimpleStretch));
336         BGRAReplace(dest, dest.FilterSharpen(96/256));
337         GetToolDrawingLayer.PutImage(FCurrentBounds.Left,FCurrentBounds.Top,dest,dmDrawWithTransparency);
338         FreeAndNil(dest);
339       end else
340         dest.NoClip;
341     end;
342   end
343   else
344     FCurrentBounds := EmptyRect;
345 end;
346 
GetAdaptedTexturenull347 function TToolTextureMapping.GetAdaptedTexture: TBGRABitmap;
348 var tx,ty: integer;
349   precisionFactor: single;
350 begin
351   if GetTextureRepetition <> trNone then //cannot optimize size
352   begin
353     result := GetTexture;
354     exit;
355   end;
356 
357   if GetTexture = nil then
358   begin
359     result := nil;
360     exit;
361   end else
362   begin
363     if FHighQuality then precisionFactor := 3
364       else precisionFactor:= 1.5;
365     tx := ceil(Max(VectLen(quad[1]-quad[0]),VectLen(quad[2]-quad[3]))*precisionFactor);
366     ty := ceil(Max(VectLen(quad[2]-quad[1]),VectLen(quad[3]-quad[0]))*precisionFactor);
367     if tx < 1 then tx := 1;
368     if ty < 1 then ty := 1;
369     if tx > GetTexture.Width then tx := GetTexture.Width;
370     if ty > GetTexture.Height then ty := GetTexture.Height;
371 
372     if (tx = GetTexture.Width) and (ty = GetTexture.Height) then
373     begin
374       result := GetTexture;
375       exit;
376     end;
377 
378     if (FAdaptedTexture = nil) or FCanReadaptTexture then
379     begin
380       if (FAdaptedTexture <> nil) and ((FAdaptedTexture.Width <> tx) or (FAdaptedTexture.Height <> ty)) then
381         FreeAndNil(FAdaptedTexture);
382       if FAdaptedTexture = nil then
383       begin
384         GetTexture.ResampleFilter := rfLinear;
385         FAdaptedTexture := GetTexture.Resample(tx,ty,rmFineResample) as TBGRABitmap;
386       end;
387     end;
388     result := FAdaptedTexture;
389     exit;
390   end;
391 end;
392 
393 procedure TToolTextureMapping.UpdateBoundsMode(var ARectResult: TRect);
394 begin
395   if not boundsMode and not quadMoving and ([ssAlt, ssShift]*ShiftState <> []) then
396   begin
397     boundsMode := true;
398     boundsPts := ComputeBoundsPoints;
399     if IsRectEmpty(ARectResult) then
400       ARectResult := OnlyRenderChange;
401   end else
402   if boundsMode and not quadMoving and ([ssAlt, ssShift]*ShiftState = [])  then
403   begin
404     boundsMode := false;
405     boundsPts := ComputeBoundsPoints;
406     if IsRectEmpty(ARectResult) then
407       ARectResult := OnlyRenderChange;
408   end;
409 end;
410 
TToolTextureMapping.SnapIfNecessarynull411 function TToolTextureMapping.SnapIfNecessary(ptF: TPointF): TPointF;
412 begin
413   if not (ssSnap in ShiftState) then result := ptF else
414     result := PointF(round(ptF.X),round(ptF.Y));
415 end;
416 
DoToolDownnull417 function TToolTextureMapping.DoToolDown(toolDest: TBGRABitmap; pt: TPoint;
418   ptF: TPointF; rightBtn: boolean): TRect;
419 var
420   n: Integer;
421   curDist,minDist: single;
422   pts: array of TPointF;
423 begin
424   result := EmptyRect;
425   if rightBtn then exit;
426 
427   if not quadDefined then
428   begin
429     if not definingQuad then
430     begin
431       if GetTexture = nil then
432         Manager.ToolPopup(tpmNothingToBeDeformed)
433       else
434         begin
435           definingQuad := true;
436           setlength(quad,4);
437           quad[0] := ptF;
438           quad[1] := ptF;
439           quad[2] := ptF;
440           quad[3] := ptF;
441         end;
442     end;
443     exit;
444   end;
445 
446   UpdateBoundsMode(result);
447   if boundsMode then
448     pts := boundsPts
449   else
450     pts := quad;
451 
452   minDist := sqr(DoScaleX(10,OriginalDPI));
453   for n := 0 to high(pts) do
454   begin
455     curDist := sqr(ptF.x-pts[n].x)+sqr(ptF.y-pts[n].y);
456     if curDist < minDist then
457     begin
458       minDist := curDist;
459       quadMovingIndex := n;
460       quadMovingDelta := pts[n]-PtF;
461       quadMoving := True;
462       quadMovingBounds  := boundsMode;
463     end;
464   end;
465 
466   if not quadMoving and IsPointInPolygon(pts, ptF, true) then
467   begin
468     quadMovingIndex := -1;
469     quadMovingDelta := (quad[0]+quad[2])*0.5-ptF;
470     quadMoving := true;
471     quadMovingBounds  := boundsMode;
472   end;
473 end;
474 
NonZeronull475 function NonZero(AValue, ADefault: single): single;
476 begin
477   if AValue = 0 then result := ADefault
478   else result := AValue;
479 end;
480 
DoToolMovenull481 function TToolTextureMapping.DoToolMove(toolDest: TBGRABitmap; pt: TPoint;
482   ptF: TPointF): TRect;
483 var n: integer;
484   delta,prevSize,newSize: TPointF;
485   curBounds: array of TPointF;
486   ratioX,ratioY,ratio: single;
487   avgSize: single;
488 begin
489   if definingQuad then
490   begin
491     if ssShift in ShiftState then
492     begin
493       if (GetTexture <> nil) and (GetTexture.Height <> 0)
494         and (GetTexture.Width <> 0) then
495         ratio := GetTexture.Width/GetTexture.Height;
496 
497       newSize := ptF - quad[0];
498       avgSize := (abs(newSize.x)+abs(newSize.y))/2;
499       ptF.x := quad[0].x+avgSize*NonZero(sign(newSize.x),1)*ratio/((ratio+1)/2);
500       ptF.y := quad[0].y+avgSize*NonZero(sign(newSize.y),1)*1/((ratio+1)/2);
501     end;
502     quad[2] := ptF;
503     quad[1].x := ptF.x;
504     quad[3].y := ptF.y;
505     result := OnlyRenderChange;
506     exit;
507   end;
508 
509   result := EmptyRect;
510   if not FHintShowed then
511   begin
512     Manager.ToolPopup(tpmHoldKeysScaleMode, VK_SHIFT);
513     FHintShowed:= true;
514   end;
515   Manager.HintReturnValidates;
516   if quadMoving then
517   begin
518     if quadMovingIndex = -1 then
519     begin
520       delta := SnapIfNecessary(quadMovingDelta + ptF) - ((quad[0]+quad[2])*0.5);
521       for n := 0 to high(quad) do
522         quad[n] += delta;
523       if quadMovingBounds then boundsPts := ComputeBoundsPoints;
524     end
525     else
526     if quadMovingBounds then
527     begin
528       boundsPts[quadMovingIndex] := SnapIfNecessary(quadMovingDelta + ptF);
529       case quadMovingIndex of
530         0:begin
531           boundsPts[1].y := boundsPts[quadMovingIndex].y;
532           boundsPts[3].x := boundsPts[quadMovingIndex].x;
533         end;
534         1:begin
535           boundsPts[0].y := boundsPts[quadMovingIndex].y;
536           boundsPts[2].x := boundsPts[quadMovingIndex].x;
537         end;
538         2:begin
539           boundsPts[3].y := boundsPts[quadMovingIndex].y;
540           boundsPts[1].x := boundsPts[quadMovingIndex].x;
541         end;
542         3:begin
543           boundsPts[2].y := boundsPts[quadMovingIndex].y;
544           boundsPts[0].x := boundsPts[quadMovingIndex].x;
545         end;
546       end;
547       if ssShift in ShiftState then
548       begin
549         curBounds := ComputeBoundsPoints;
550         prevSize := curBounds[2]-curBounds[0];
551         newSize := boundsPts[2]-boundsPts[0];
552         if (abs(prevSize.x) > 1e-6) and (abs(prevSize.y) > 1e-6) then
553         begin
554           ratioX := abs(newSize.X/prevSize.X);
555           ratioY := abs(newSize.Y/prevSize.Y);
556           ratio := (ratioX+ratioY)/2;
557           newSize.X := abs(prevSize.X)*ratio*NonZero(Sign(newSize.X),1);
558           newSize.Y := abs(prevSize.Y)*ratio*NonZero(Sign(newSize.Y),1);
559           case quadMovingIndex of
560           0: boundsPts[0] := boundsPts[2]-newSize;
561           1: boundsPts[1] := boundsPts[3]+PointF(newSize.X,-newSize.Y);
562           2: boundsPts[2] := boundsPts[0]+newSize;
563           3: boundsPts[3] := boundsPts[1]+PointF(-newSize.X,newSize.Y);
564           end;
565           case quadMovingIndex of
566             0:begin
567               boundsPts[1].y := boundsPts[quadMovingIndex].y;
568               boundsPts[3].x := boundsPts[quadMovingIndex].x;
569             end;
570             1:begin
571               boundsPts[0].y := boundsPts[quadMovingIndex].y;
572               boundsPts[2].x := boundsPts[quadMovingIndex].x;
573             end;
574             2:begin
575               boundsPts[3].y := boundsPts[quadMovingIndex].y;
576               boundsPts[1].x := boundsPts[quadMovingIndex].x;
577             end;
578             3:begin
579               boundsPts[2].y := boundsPts[quadMovingIndex].y;
580               boundsPts[0].x := boundsPts[quadMovingIndex].x;
581             end;
582           end;
583         end;
584       end;
585     end
586     else
587       quad[quadMovingIndex] := SnapIfNecessary(quadMovingDelta + ptF);
588     PrepareBackground(toolDest,False);
589     DrawQuad;
590     result := FCurrentBounds;
591   end;
592   UpdateBoundsMode(result);
593 end;
594 
TToolTextureMapping.GetIsSelectingToolnull595 function TToolTextureMapping.GetIsSelectingTool: boolean;
596 begin
597   Result:= false;
598 end;
599 
GetTexturenull600 function TToolTextureMapping.GetTexture: TBGRABitmap;
601 begin
602   if (Manager.BackFill.Texture = nil) or (Manager.BackFill.Texture = FLastTexture) then
603   begin
604     if FTextureAfterAlpha <> nil then
605       result := FTextureAfterAlpha
606     else
607       result := FLastTexture;
608   end
609   else
610   begin
611     if (Manager.BackFill.Texture <> nil) and (Manager.BackFill.TextureOpacity <> 255) then
612     begin
613       FTextureAfterAlpha := Manager.BackFill.Texture.Duplicate as TBGRABitmap;
614       FTextureAfterAlpha.ApplyGlobalOpacity(Manager.BackFill.TextureOpacity);
615       result := FTextureAfterAlpha;
616     end else
617     begin
618       result := Manager.BackFill.Texture;
619       FreeAndNil(FTextureAfterAlpha);
620     end;
621     FLastTexture.FreeReference;
622     FLastTexture := Manager.BackFill.Texture.NewReference as TBGRABitmap;
623   end;
624 end;
625 
TToolTextureMapping.GetTextureRepetitionnull626 function TToolTextureMapping.GetTextureRepetition: TTextureRepetition;
627 begin
628   if Manager.BackFill.FillType = vftTexture then
629     result := Manager.BackFill.TextureRepetition
630   else
631     result := trNone;
632 end;
633 
634 procedure TToolTextureMapping.OnTryStop(sender: TCustomLayerAction);
635 begin
636   //nothing
637 end;
638 
TToolTextureMapping.ComputeBoundsPointsnull639 function TToolTextureMapping.ComputeBoundsPoints: ArrayOfTPointF;
640 var
641   minPt,maxPt: TPointF;
642   i: integer;
643 begin
644   if quadDefined then
645   begin
646     minPt := quad[low(quad)];
647     maxPt := quad[low(quad)];
648     for i := 1 to high(quad) do
649     begin
650       if quad[i].x < minPt.X then minPt.x := quad[i].x;
651       if quad[i].x > maxPt.X then maxPt.x := quad[i].x;
652       if quad[i].y < minPt.y then minPt.y := quad[i].y;
653       if quad[i].y > maxPt.y then maxPt.y := quad[i].y;
654     end;
655     result := PointsF([minPt, PointF(maxPt.X,minPt.Y), maxPt, PointF(MinPt.X,MaxPt.Y)]);
656   end else
657     result := nil;
658 end;
659 
660 procedure TToolTextureMapping.PrepareBackground(toolDest: TBGRABitmap;
661   AFirstTime: boolean);
662 begin
663   if not AFirstTime then RestoreBackupDrawingLayer;
664 end;
665 
TToolTextureMapping.DefaultTextureCenternull666 function TToolTextureMapping.DefaultTextureCenter: TPointF;
667 begin
668   result := PointF(Manager.Image.Width/2-0.5-LayerOffset.X,Manager.Image.Height/2-0.5-LayerOffset.Y);
669 end;
670 
DoToolUpdatenull671 function TToolTextureMapping.DoToolUpdate(toolDest: TBGRABitmap): TRect;
672 begin
673   if quadDefined then
674   begin
675     PrepareBackground(GetToolDrawingLayer,False);
676     DrawQuad;
677     result := FCurrentBounds;
678   end
679     else
680       result := EmptyRect;
681 end;
682 
GetStatusTextnull683 function TToolTextureMapping.GetStatusText: string;
684 var
685   i: Integer;
686 begin
687   result := '';
688   for i := 0 to high(quad) do
689   begin
690     if i > 0 then result += '|';
691     result += 'x'+inttostr(i+1)+' = '+inttostr(round(quad[i].x+0.5))+'|'+
692        'y'+inttostr(i+1)+' = '+inttostr(round(quad[i].y+0.5));
693   end;
694 end;
695 
GetAllowedBackFillTypesnull696 function TToolTextureMapping.GetAllowedBackFillTypes: TVectorialFillTypes;
697 begin
698   Result:= [vftTexture];
699 end;
700 
701 constructor TToolTextureMapping.Create(AManager: TToolManager);
702 begin
703   inherited Create(AManager);
704   FCurrentBounds := EmptyRect;
705   FHighQuality:= False;
706   FLastTexture := nil;
707   quadDefined:= false;
708   definingQuad:= false;
709 end;
710 
DoToolKeyDownnull711 function TToolTextureMapping.DoToolKeyDown(var key: Word): TRect;
712 begin
713   result := EmptyRect;
714 
715   if Key = VK_RETURN then
716   begin
717     if quadDefined then
718     begin
719       ValidateQuad;
720       result := EmptyRect;
721       key := 0;
722     end;
723   end else
724   if Key = VK_ESCAPE then
725   begin
726     if quadDefined then
727     begin
728       CancelActionPartially;
729       result := OnlyRenderChange;
730       manager.QueryExitTool;
731       key := 0;
732     end;
733   end else
734   if (Key = VK_SHIFT) or (Key = VK_MENU) then
735     UpdateBoundsMode(result);
736 end;
737 
TToolTextureMapping.DoToolKeyUpnull738 function TToolTextureMapping.DoToolKeyUp(var key: Word): TRect;
739 begin
740   Result:= EmptyRect;
741   if (Key = VK_SHIFT) or (Key = VK_MENU) then
742     UpdateBoundsMode(result);
743 end;
744 
ToolUpnull745 function TToolTextureMapping.ToolUp: TRect;
746 var prevSize,newSize: TPointF;
747   oldBounds: array of TPointF;
748   i: integer;
749   redraw: boolean;
750 begin
751   if definingQuad then
752   begin
753     definingQuad:= false;
754     quadDefined:= true;
755     PrepareBackground(GetToolDrawingLayer,False);
756     FCanReadaptTexture:= true;
757     DrawQuad;
758     FCanReadaptTexture:= false;
759     result := FCurrentBounds;
760     exit;
761   end;
762   if quadMoving then
763   begin
764     redraw := GetTextureRepetition = trNone;
765     if quadMovingBounds then
766     begin
767       oldBounds := ComputeBoundsPoints;
768       prevSize := oldBounds[2]-oldBounds[0];
769       newSize := boundsPts[2]-boundsPts[0];
770       if (abs(newSize.x) > 1e-6) and (abs(newSize.y) > 1e-6) and
771         (abs(prevSize.x) > 1e-6) and (abs(prevSize.y) > 1e-6) then
772       begin
773         for i := low(quad) to high(quad) do
774         begin
775           quad[i] -= oldBounds[0];
776           quad[i].x *= newSize.X/prevSize.X;
777           quad[i].y *= newSize.Y/prevSize.Y;
778           quad[i] += boundsPts[0];
779         end;
780       end;
781       quadMovingBounds := false;
782       boundsPts := ComputeBoundsPoints;
783       redraw := true;
784     end;
785     if redraw then
786     begin
787       PrepareBackground(GetToolDrawingLayer,False);
788       FCanReadaptTexture:= true;
789       DrawQuad;
790       FCanReadaptTexture:= false;
791       result := FCurrentBounds;
792     end else
793       result := EmptyRect;
794     quadMoving := false;
795   end else
796     result := EmptyRect;
797 end;
798 
GetContextualToolbarsnull799 function TToolTextureMapping.GetContextualToolbars: TContextualToolbars;
800 begin
801   Result:= [ctBackFill,ctPerspective];
802 end;
803 
Rendernull804 function TToolTextureMapping.Render(VirtualScreen: TBGRABitmap;
805   VirtualScreenWidth, VirtualScreenHeight: integer; BitmapToVirtualScreen: TBitmapToVirtualScreenFunction): TRect;
806 
807   procedure DrawPoints(pts: array of TPointF; alpha: byte);
808   var curPt,nextPt: TPointF;
809       n: Integer;
810   begin
811     For n := 0 to high(pts) do
812     begin
813       curPt := BitmapToVirtualScreen(pts[n]);
814       nextPt := BitmapToVirtualScreen(pts[(n+1)mod length(pts)]);
815       NiceLine(VirtualScreen, curPt.X,curPt.Y,nextPt.x,nextPt.y,alpha);
816     end;
817     For n := 0 to high(pts) do
818     begin
819       curPt := BitmapToVirtualScreen(pts[n]);
820       result := RectUnion(result,NicePoint(VirtualScreen, curPt.X,curPt.Y,alpha));
821     end;
822   end;
823 
824 begin
825   result := EmptyRect;
826   if not quadDefined and not definingQuad then exit;
827   if boundsMode or quadMovingBounds then
828   begin
829     DrawPoints(quad,80);
830     DrawPoints(boundsPts,192);
831   end else
832     DrawPoints(quad,192);
833 end;
834 
TToolTextureMapping.ToolProvideCommandnull835 function TToolTextureMapping.ToolProvideCommand(ACommand: TToolCommand
836   ): boolean;
837 begin
838   case ACommand of
839     tcFinish: result := quadDefined;
840   else result := false;
841   end;
842 end;
843 
TToolTextureMapping.ToolCommandnull844 function TToolTextureMapping.ToolCommand(ACommand: TToolCommand): boolean;
845 begin
846   case ACommand of
847     tcFinish: if quadDefined then
848       begin
849         ValidateQuad;
850         result := true;
851       end  else
852         result := false;
853   else result := false;
854   end;
855 end;
856 
857 destructor TToolTextureMapping.Destroy;
858 begin
859   ValidateAction;
860   FLastTexture.FreeReference;
861   FreeAndNil(FTextureAfterAlpha);
862   FreeAndNil(FAdaptedTexture);
863   inherited Destroy;
864 end;
865 
866 { TToolDeformationGrid }
867 
TToolDeformationGrid.ToolDeformationGridNeedednull868 function TToolDeformationGrid.ToolDeformationGridNeeded: boolean;
869 var xb,yb: integer;
870     layer: TBGRABitmap;
871 begin
872   if (DeformationGrid = nil) then
873   begin
874     layer := GetToolDrawingLayer;
875     if layer = nil then
876     begin
877       result := false;
878       exit;
879     end;
880     deformationGridNbX:= Manager.DeformationGridNbX;
881     deformationGridNbY:= Manager.DeformationGridNbY;
882     SetLength(DeformationGrid, deformationGridNbY, deformationGridNbX);
883     SetLength(DeformationGridTexCoord, deformationGridNbY, deformationGridNbX);
884     for yb := 0 to deformationGridNbY-1 do
885       for xb := 0 to deformationGridNbX-1 do
886       begin
887         DeformationGridTexCoord[yb,xb] := PointF(xb/(deformationGridNbX-1)*layer.Width-0.5,
888                                                      yb/(deformationGridNbY-1)*layer.Height-0.5);
889         DeformationGrid[yb,xb] :=DeformationGridTexCoord[yb,xb];
890       end;
891   end;
892   result := true;
893 end;
894 
TToolDeformationGrid.ToolCommandnull895 function TToolDeformationGrid.ToolCommand(ACommand: TToolCommand): boolean;
896 begin
897   case ACommand of
898     tcFinish: if DoingDeformation then
899       begin
900         ValidateDeformationGrid;
901         result := true;
902       end
903       else result := false;
904   else result := false;
905   end;
906 end;
907 
ToolProvideCommandnull908 function TToolDeformationGrid.ToolProvideCommand(ACommand: TToolCommand
909   ): boolean;
910 begin
911   case ACommand of
912     tcFinish: result := DoingDeformation;
913   else result := false;
914   end;
915 end;
916 
917 destructor TToolDeformationGrid.Destroy;
918 begin
919   ValidateDeformationGrid;
920   inherited Destroy;
921 end;
922 
923 procedure TToolDeformationGrid.ReleaseGrid;
924 var
925   xb,yb: Integer;
926 begin
927   if DoingDeformation then
928   begin
929     ValidateAction;
930     DoingDeformation := false;
931     for yb := 0 to deformationGridNbY-2 do
932       for xb := 0 to deformationGridNbX-2 do
933         DeformationGridTexCoord[yb,xb] := DeformationGrid[yb,xb];
934   end;
935 end;
936 
937 procedure TToolDeformationGrid.ValidateDeformationGrid;
938 begin
939   if DoingDeformation then
940   begin
941     DeformationGrid := nil;
942     DeformationGridTexCoord := nil;
943     ValidateAction;
944     DoingDeformation := false;
945   end;
946 end;
947 
TToolDeformationGrid.GetPointAtnull948 function TToolDeformationGrid.GetPointAt(const ptF: TPointF; var x, y: integer): boolean;
949 var
950   yb, xb: Integer;
951   curDist, minDist: single;
952 begin
953   result := false;
954   minDist := sqr(SelectionMaxPointDistance);
955   for yb := 1 to deformationGridNbY-2 do
956     for xb := 1 to deformationGridNbX-2 do
957     begin
958       curDist := sqr(ptF.x-DeformationGrid[yb,xb].x) + sqr(ptF.y-DeformationGrid[yb,xb].y);
959       if curDist < minDist then
960       begin
961         minDist := curDist;
962         x := xb;
963         y := yb;
964         result := True;
965       end;
966     end;
967 end;
968 
DoToolDownnull969 function TToolDeformationGrid.DoToolDown(toolDest: TBGRABitmap; pt: TPoint;
970   ptF: TPointF; rightBtn: boolean): TRect;
971 begin
972   result := EmptyRect;
973   deformationGridX := 1;
974   deformationGridY := 1;
975   if DeformationGrid <> nil then
976   begin
977     if GetPointAt(ptF, deformationGridX, deformationGridY) then
978     begin
979       deformationGridMoving := True;
980       deformationOrigin := ptF;
981     end;
982   end;
983 end;
984 
TToolDeformationGrid.DoToolMovenull985 function TToolDeformationGrid.DoToolMove(toolDest: TBGRABitmap; pt: TPoint;
986   ptF: TPointF): Trect;
987 var xb,yb,NbX,NbY: integer;
988     gridDone: array of array of boolean;
989     layer,backupLayer : TBGRABitmap;
990     PreviousClipRect: TRect;
991     previousBounds: TRect;
992     gridMinX,gridMinY,gridMaxX,gridMaxY, dummyX, dummyY: integer;
993 
994   procedure AddToDeformationArea(xi,yi: integer);
995   var ptF: TPointF;
996       pix: TRect;
997   begin
998     if (xi >= 0) and (yi >= 0) and (xi < NbX) and (yi < NbY) then
999     begin
1000       ptF := deformationGrid[yi,xi];
1001       pix := rect(floor(ptF.X)-1,floor(ptF.Y)-1,ceil(ptF.X)+2,ceil(ptF.Y)+2);
1002       if IsRectEmpty(FCurrentBounds) then
1003         FCurrentBounds := pix
1004       else
1005         UnionRect(FCurrentBounds,FCurrentBounds,pix);
1006     end;
1007   end;
1008 
1009 begin
1010   result := EmptyRect;
1011   Manager.HintReturnValidates;
1012 
1013   if not deformationGridMoving then
1014   begin
1015     dummyX := 1;
1016     dummyY := 1;
1017     if GetPointAt(ptF, dummyX, dummyY) then
1018       Cursor := crHandPoint
1019       else Cursor := crDefault;
1020     exit;
1021   end;
1022   if Manager.DeformationGridMode = gmMovePointWithoutDeformation then
1023   begin
1024     ReleaseGrid;
1025     DeformationGrid[deformationGridY,deformationGridX] := PointF(
1026       DeformationGrid[deformationGridY,deformationGridX].X + ptF.X-deformationOrigin.X,
1027       DeformationGrid[deformationGridY,deformationGridX].Y + ptF.Y-deformationOrigin.Y);
1028     DeformationGridTexCoord[deformationGridY,deformationGridX] := DeformationGrid[deformationGridY,deformationGridX];
1029     result := OnlyRenderChange;
1030   end else
1031   begin
1032     if not DoingDeformation then
1033     begin
1034       FCurrentBounds := EmptyRect;
1035       DoingDeformation := True;
1036     end;
1037 
1038     layer := GetToolDrawingLayer;
1039     backupLayer := GetBackupLayerIfExists;
1040     NbX := deformationGridNbX;
1041     NbY := deformationGridNbY;
1042 
1043     DeformationGrid[deformationGridY,deformationGridX] := PointF(
1044       DeformationGrid[deformationGridY,deformationGridX].X + ptF.X-deformationOrigin.X,
1045       DeformationGrid[deformationGridY,deformationGridX].Y + ptF.Y-deformationOrigin.Y);
1046 
1047     previousBounds := FCurrentBounds;
1048     FCurrentBounds := EmptyRect;
1049     gridMinX := deformationGridX-1;
1050     if gridMinX < 0 then gridMinX := 0;
1051     gridMinY := deformationGridY-1;
1052     if gridMinY < 0 then gridMinY := 0;
1053     gridMaxX := deformationGridX+1;
1054     if gridMaxX > NbX-1 then gridMaxX := NbX-1;
1055     gridMaxY := deformationGridY+1;
1056     if gridMaxY > NbY-1 then gridMaxY := NbY-1;
1057     for yb := gridMinY to gridMaxY do
1058      for xb := gridMinX to gridMaxX do
1059          AddToDeformationArea(xb,yb);
1060     FMergedBounds := RectUnion(previousBounds,FCurrentBounds);
1061 
1062     gridMinX := 0;
1063     gridMinY := 0;
1064     gridMaxX := NbX-1;
1065     gridMaxY := NbY-1;
1066 
1067     //progressive drawing of deformation zones
1068     setlength(gridDone,NbY-1,NbX-1);
1069     for yb := gridMinY to gridMaxY-1 do
1070       for xb := gridMinX to gridMaxX-1 do
1071         gridDone[yb,xb] := false;
1072 
1073     if not IsRectEmpty(FMergedBounds) and (backupLayer <>nil) then
1074     begin
1075 
1076       PreviousClipRect := layer.ClipRect;
1077       layer.ClipRect := FMergedBounds;
1078       layer.FillRect(0,0,layer.Width,layer.Height,BGRAPixelTransparent,dmSet);
1079       //drawing zones that are not deformed
1080       for yb := gridMinY to gridMaxY-1 do
1081         for xb := gridMinX to gridMaxX-1 do
1082           if (DeformationGrid[yb,xb] = DeformationGridTexCoord[yb,xb]) and
1083              (DeformationGrid[yb,xb+1] = DeformationGridTexCoord[yb,xb+1]) and
1084              (DeformationGrid[yb+1,xb+1] = DeformationGridTexCoord[yb+1,xb+1]) and
1085              (DeformationGrid[yb+1,xb] = DeformationGridTexCoord[yb+1,xb]) then
1086           begin
1087             layer.FillPoly([DeformationGrid[yb,xb],DeformationGrid[yb,xb+1],
1088                   DeformationGrid[yb+1,xb+1],DeformationGrid[yb+1,xb]],backupLayer,dmDrawWithTransparency);
1089             gridDone[yb,xb] := true;
1090           end;
1091       //drawing zones that are concave
1092       for yb := gridMinY to gridMaxY-1 do
1093         for xb := gridMinX to gridMaxX-1 do
1094           if not gridDone[yb,xb] and
1095              not IsConvex([DeformationGrid[yb,xb],DeformationGrid[yb,xb+1],
1096                 DeformationGrid[yb+1,xb+1],DeformationGrid[yb+1,xb]]) then
1097           begin
1098             layer.FillQuadLinearMapping(DeformationGrid[yb,xb],DeformationGrid[yb,xb+1],
1099                   DeformationGrid[yb+1,xb+1],DeformationGrid[yb+1,xb],backupLayer,
1100                   DeformationGridTexCoord[yb,xb],DeformationGridTexCoord[yb,xb+1],DeformationGridTexCoord[yb+1,xb+1],
1101                   DeformationGridTexCoord[yb+1,xb],true, fcKeepCW);
1102             gridDone[yb,xb] := true;
1103           end;
1104       //drawing convex zones
1105       for yb := gridMinY to gridMaxY-1 do
1106         for xb := gridMinX to gridMaxX-1 do
1107           if not gridDone[yb,xb] and IsClockwise([DeformationGrid[yb,xb],DeformationGrid[yb,xb+1],
1108                 DeformationGrid[yb+1,xb+1],DeformationGrid[yb+1,xb]]) then
1109           layer.FillQuadLinearMapping(DeformationGrid[yb,xb],DeformationGrid[yb,xb+1],
1110                 DeformationGrid[yb+1,xb+1],DeformationGrid[yb+1,xb],backupLayer,
1111                 DeformationGridTexCoord[yb,xb],DeformationGridTexCoord[yb,xb+1],DeformationGridTexCoord[yb+1,xb+1],
1112                 DeformationGridTexCoord[yb+1,xb],true);
1113 
1114       layer.ClipRect := PreviousClipRect;
1115     end;
1116     result := FMergedBounds;
1117   end;
1118   deformationOrigin := ptF;
1119 end;
1120 
TToolDeformationGrid.GetIsSelectingToolnull1121 function TToolDeformationGrid.GetIsSelectingTool: boolean;
1122 begin
1123   Result:= false;
1124 end;
1125 
TToolDeformationGrid.DoToolUpdatenull1126 function TToolDeformationGrid.DoToolUpdate(toolDest: TBGRABitmap): TRect;
1127 begin
1128   if (deformationGridNbX <> Manager.DeformationGridNbX) or
1129      (deformationGridNbY <> Manager.DeformationGridNbY) then
1130   begin
1131     ReleaseGrid;
1132     DeformationGrid := nil;
1133     DeformationGridTexCoord := nil;
1134     deformationGridNbX:= 0;
1135     deformationGridNbY:= 0;
1136     Result:= OnlyRenderChange;
1137   end
1138   else
1139     result := EmptyRect;
1140 end;
1141 
1142 constructor TToolDeformationGrid.Create(AManager: TToolManager);
1143 begin
1144   inherited Create(AManager);
1145   deformationGridNbX:= 0;
1146   deformationGridNbY:= 0;
1147   DoingDeformation:= false;
1148 end;
1149 
Rendernull1150 function TToolDeformationGrid.Render(VirtualScreen: TBGRABitmap;
1151   VirtualScreenWidth, VirtualScreenHeight: integer; BitmapToVirtualScreen: TBitmapToVirtualScreenFunction): TRect;
1152 var curPt,rightPt,downPt: TPointF;
1153     xb,yb: Integer;
1154 begin
1155   result := EmptyRect;
1156   if not ToolDeformationGridNeeded then exit;
1157   for xb := 0 to deformationGridNbX-1 do
1158     for yb := 0 to deformationGridNbY-1 do
1159     begin
1160       curPt := BitmapToVirtualScreen(DeformationGrid[yb,xb]);
1161       if not deformationGridMoving or ((xb+1 >= deformationGridX) and (xb <= deformationGridX) and
1162         (yb >= deformationGridY-1) and (yb <= deformationGridY+1)) then
1163       begin
1164         if (xb < deformationGridNbX-1) and (yb > 0) and (yb < deformationGridNbY-1) then
1165         begin
1166           rightPt := BitmapToVirtualScreen(DeformationGrid[yb,xb+1]);
1167           if Assigned(VirtualScreen) then NiceLine(VirtualScreen, curPt.X,curPt.Y, rightPt.X,rightPt.Y);
1168           result := RectUnion(result,rect(floor(curPt.x)-1,floor(curPt.y)-1,
1169             ceil(curPt.x)+2,ceil(curPt.y)+2));
1170           result := RectUnion(result,rect(floor(rightPt.x)-1,floor(rightPt.y)-1,
1171             ceil(rightPt.x)+2,ceil(rightPt.y)+2));
1172         end;
1173       end;
1174       if not deformationGridMoving or ((xb >= deformationGridX-1) and (xb <= deformationGridX+1) and
1175         (yb+1 >= deformationGridY) and (yb <= deformationGridY)) then
1176       begin
1177         if (yb < deformationGridNbY-1) and (xb > 0) and (xb < deformationGridNbX-1) then
1178         begin
1179           downPt := BitmapToVirtualScreen(DeformationGrid[yb+1,xb]);
1180           if Assigned(virtualScreen) then NiceLine(VirtualScreen, curPt.X,curPt.Y, downPt.X,downPt.Y);
1181           result := RectUnion(result,rect(floor(curPt.x)-1,floor(curPt.y)-1,
1182             ceil(curPt.x)+2,ceil(curPt.y)+2));
1183           result := RectUnion(result,rect(floor(downPt.x)-1,floor(downPt.y)-1,
1184             ceil(downPt.x)+2,ceil(downPt.y)+2));
1185         end;
1186       end;
1187     end;
1188   for xb := 1 to deformationGridNbX-2 do
1189     for yb := 1 to deformationGridNbY-2 do
1190     begin
1191       if not deformationGridMoving or ((xb >= deformationGridX-1) and (xb <= deformationGridX+1) and
1192         (yb >= deformationGridY-1) and (yb <= deformationGridY+1)) then
1193       begin
1194         curPt := BitmapToVirtualScreen(DeformationGrid[yb,xb]);
1195         result := RectUnion(result,NicePoint(VirtualScreen, curPt.X,curPt.Y));
1196       end;
1197     end;
1198 end;
1199 
DoToolKeyDownnull1200 function TToolDeformationGrid.DoToolKeyDown(var key: Word): TRect;
1201 begin
1202   result := EmptyRect;
1203   if Key = VK_RETURN then
1204   begin
1205     if DoingDeformation then
1206     begin
1207       ValidateDeformationGrid;
1208       result := EmptyRect;
1209       manager.QueryExitTool;
1210       Key := 0;
1211     end;
1212   end else
1213   if Key = VK_ESCAPE then
1214   begin
1215     if DoingDeformation then
1216     begin
1217       CancelActionPartially;
1218       result := OnlyRenderChange;
1219       manager.QueryExitTool;
1220       Key := 0;
1221     end;
1222   end;
1223 end;
1224 
TToolDeformationGrid.ToolUpnull1225 function TToolDeformationGrid.ToolUp: TRect;
1226 begin
1227   if deformationGridMoving then
1228     result := OnlyRenderChange
1229   else
1230     Result:=EmptyRect;
1231   deformationGridMoving := false;
1232 end;
1233 
GetContextualToolbarsnull1234 function TToolDeformationGrid.GetContextualToolbars: TContextualToolbars;
1235 begin
1236   Result:= [ctDeformation];
1237 end;
1238 
1239 initialization
1240 
1241   RegisterTool(ptDeformation, TToolDeformationGrid);
1242   RegisterTool(ptTextureMapping, TToolTextureMapping);
1243   RegisterTool(ptLayerMapping, TToolLayerMapping);
1244 
1245 end.
1246 
1247