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