Draw a stretched and rotated image on TCanvas - delphi

Question

i am trying to draw a rotated bitmap on a TImage canvas at some specified points, what i tried so far is i rotated the bitmap and then used stretched draw but i am not getting the results i want, the scenario goes like this
I map 4 points on a TImage canvas with mouse clicks and get its angle, the angle can be 0, 45, 90 anything, something like in the image i have attached
Now what i need is to draw another bitmap rotated and stretched on these points, i am having a hard time figuring this thing out
Regards

Answer 1

Many years ago, when stars was brighter and girls was younger, i wrote this code for unknown reason. It is VCL compatible, but can be adopter in order to be used in both VCL/FMX. It is simple class to draw arbitrary rectangle from bitmap to arbitrary rectangle at destination DC (so it could be bitmap or something else). It can paint destination picture with bilinear interpolation, then result looks not so ugly as with simple stretching. Maybe it can be useful for someone.
unit uBMPUtils;
interface
uses
windows, graphics, math, sysutils;
type
PIntegers = ^TIntegers;
TIntegers = array[0..high(integer) div sizeof(integer) - 16] of integer;
TDrawLine = procedure( pixelSize : integer;
var src;
srcLineAdd : integer;
src_x1, src_y1, src_x2, src_y2 : integer;
var dst;
dstLen : integer) of object;
TDrawMode = (dmSimple, dmBilinear);
TBitmapDrawer = class
protected
tmp : TBitmap;
koefs : array[0..4096*4-1] of integer; // addr(Ux, Vy) = 4 * ( (trunc(Ux*16) << 6) + trunc(Vy*16) )
calculated : boolean;
DrawModeFlag : TDrawMode;
DrawLine : TDrawLine;
procedure precalculate; // precalculate koefs for fast bilinear interpolation
procedure drawLineSimple( pixelSize : integer;
var src;
srcLineAdd : integer;
src_x1, src_y1, src_x2, src_y2 : integer;
var dst;
dstLen : integer);
procedure drawLineBilinear( pixelSize : integer;
var src;
srcLineAdd : integer;
src_x1, src_y1, src_x2, src_y2 : integer;
var dst;
dstLen : integer);
procedure setDrawMode(m : TDrawMode);
public
constructor Create;
destructor Destroy; override;
procedure DrawTriangle(src : TBitmap; // source bitmap (pf24 or pf32!)
dst_dc : cardinal; // destination DC
dstRect : TRect; // limiting rect for output
A1, A2, A3, // arbitrary rectange at Src bitmap
B1, B2, B3 : TPoint); // arbitrary rectange at DST_DC device
procedure DrawRectangle(src : TBitmap; // source bitmap (pf24 or pf32!)
dst_dc : cardinal; // destination DC
dstRect : TRect; // limiting rect for output
A1, A2, A3, A4, // arbitrary rectange at Src bitmap
B1, B2, B3, B4 : TPoint); // arbitrary rectange at DST_DC device
property DrawMode: TDrawMode read DrawModeFlag write setDrawMode; // Default: dmBilinear
end;
implementation
function HorAtLine(var x : integer; y, x1,y1,x2,y2 : integer):boolean;
begin
if y1 = y2 then result := false else
begin
result := (y >= y1) and (y <= y2) or (y >= y2) and (y <= y1);
if result then x := x1 + (x2 - x1) * (y - y1) div (y2 - y1);
end;
end;
procedure LineProportion(var src_x, src_y : integer;
src_x1, src_y1, src_x2, src_y2 : integer;
dst_x, dst_y : integer;
dst_x1, dst_y1, dst_x2, dst_y2 : integer);
begin
if abs(dst_x2 - dst_x1) > abs(dst_y2 - dst_y1) then begin // proportions form Y
src_x := src_x1 + (src_x2 - src_x1) * (dst_x - dst_x1) div (dst_x2 - dst_x1);
src_y := src_y1 + (src_y2 - src_y1) * (dst_x - dst_x1) div (dst_x2 - dst_x1);
end else begin
src_x := src_x1 + (src_x2 - src_x1) * (dst_y - dst_y1) div (dst_y2 - dst_y1);
src_y := src_y1 + (src_y2 - src_y1) * (dst_y - dst_y1) div (dst_y2 - dst_y1);
end;
end;
// ---------------------------------------------- TBitmapDrawer --------------------------------------------------------
procedure TBitmapDrawer.precalculate;
var
n, u, v : integer;
Uf, Vf, k1,k2,k3,k4 : double;
begin
calculated := true;
for V := 0 to 63 do
for U := 0 to 63 do
begin
Uf := U / 64;
Vf := V / 64;
k1 := (1 - Uf) * (1 - Vf);
k2 := Uf * (1 - Vf);
k3 := (1 - Uf) * Vf;
k4 := Uf * Vf;
n := ((U shl 6) + V) * 4;
koefs[n] := trunc(k1*65536);
koefs[n+1] := trunc(k2*65536);
koefs[n+2] := trunc(k3*65536);
koefs[n+3] := trunc(k4*65536);
end;
end;
constructor TBitmapDrawer.create;
begin
inherited create;
tmp := TBitmap.create;
tmp.Height := 1;
drawMode := dmBilinear;
precalculate;
end;
destructor TBitmapDrawer.Destroy;
begin
FreeandNil(tmp);
inherited;
end;
procedure TBitmapDrawer.DrawRectangle(src : TBitmap;
dst_dc : cardinal;
dstRect : TRect;
A1, A2, A3, A4,
B1, B2, B3, B4 : TPoint);
begin
DrawTriangle(src, dst_dc, dstRect, A1, A2, A3, B1, B2, B3);
DrawTriangle(src, dst_dc, dstRect, A1, A3, A4, B1, B3, B4);
end;
procedure TBitmapDrawer.DrawTriangle(src : TBitmap;
dst_dc : cardinal;
dstRect : TRect;
A1, A2, A3,
B1, B2, B3 : TPoint);
var
pixelSize, srcAdd, left_x, left_y, right_x, right_y: integer;
minx, maxx, x, y, top, bottom : integer;
pb : pointer;
begin
if src.height > 1 then srcAdd := integer(PAnsiChar(src.scanline[1]) - PAnsiChar(src.scanline[0])) else srcAdd := 0;
top := min(min(b1.y, b2.y), b3.y);
bottom := max(max(b1.y, b2.y), b3.y);
if (top > dstRect.Bottom) or (bottom < dstRect.Top) then exit;
if top < dstRect.Top then top := dstRect.Top;
if bottom > dstRect.Bottom then bottom := dstRect.Bottom;
case src.pixelFormat of
pf24bit : pixelsize := 3;
pf32bit : pixelsize := 4;
else raise exception.create('Error');
end;
if tmp.PixelFormat <> src.PixelFormat then tmp.PixelFormat := src.PixelFormat;
y := max(max(b1.X, b2.x), b3.x) - min(min(b1.X, b2.x), b3.x) + 1;
if (tmp.Width < y) then tmp.Width := y;
pb := tmp.scanline[0];
for y := top to bottom do // Y at destination picture
begin
minx := high(integer);
maxx := low(integer);
if HorAtLine(x,y, b1.X, b1.Y, b2.x, b2.Y) then
begin
if x < minx then begin
minx := x;
LineProportion(left_x, left_y, a1.X, a1.Y, a2.x, a2.Y, x,y, b1.X, b1.Y, b2.X, b2.Y);
end;
if x > maxx then begin
LineProportion(right_x, right_y, a1.X, a1.Y, a2.x, a2.Y, x,y, b1.X, b1.Y, b2.X, b2.Y);
maxx := x;
end;
end;
if HorAtLine(x,y, b2.X, b2.Y, b3.x, b3.Y) then
begin
if x < minx then begin
minx := x;
LineProportion(left_x, left_y, a2.X, a2.Y, a3.x, a3.Y, x,y, b2.X, b2.Y, b3.X, b3.Y);
end;
if x > maxx then begin
LineProportion(right_x, right_y, a2.X, a2.Y, a3.x, a3.Y, x,y, b2.X, b2.Y, b3.X, b3.Y);
maxx := x;
end;
end;
if HorAtLine(x,y, b3.X, b3.Y, b1.x, b1.Y) then
begin
if x < minx then begin
minx := x;
LineProportion(left_x, left_y, a3.X, a3.Y, a1.x, a1.Y, x,y, b3.X, b3.Y, b1.X, b1.Y);
end;
if x > maxx then begin
LineProportion(right_x, right_y, a3.X, a3.Y, a1.x, a1.Y, x,y, b3.X, b3.Y, b1.X, b1.Y);
maxx := x;
end;
end;
if minx > maxx then continue;
// destination line (minx, y) - (maxx, y) - now we can find it at source picture
drawLine(pixelSize, src.ScanLine[0]^, srcAdd, left_x, left_y, right_x, right_y, pb^, maxx - minx + 1);
bitblt(dst_dc, minx, y, maxx-minx+1, 1, tmp.Canvas.Handle, 0,0, srccopy);
end;
end;
procedure TBitmapDrawer.drawLineSimple( pixelSize : integer;
var src;
srcLineAdd : integer;
src_x1, src_y1, src_x2, src_y2 : integer;
var dst;
dstLen : integer);
var
dst_ptr : PAnsiChar;
i, px, py : integer;
begin
dst_ptr := #dst;
px := (src_x2 - src_x1) * 65536 div dstLen;
py := (src_y2 - src_y1) * 65536 div dstLen;
src_x1 := src_x1 * 65536;
src_y1 := src_y1 * 65536;
for i := 0 to dstLen - 1 do
begin
pinteger(dst_ptr)^ := pinteger( PAnsiChar(#src) +
((src_y1 + i * py) shr 16) * srcLineAdd +
((src_x1 + i * px) shr 16) * pixelSize
)^;
inc(dst_ptr, pixelSize);
end;
end;
procedure TBitmapDrawer.drawLineBilinear( pixelSize : integer;
var src;
srcLineAdd : integer;
src_x1, src_y1, src_x2, src_y2 : integer;
var dst;
dstLen : integer);
var
src_ptr, dst_ptr : PAnsiChar;
u,v,Uf,Vf : integer;
i : integer;
k : PIntegers;
c1,c2,c3,c4 : TColor;
begin
dst_ptr := #dst;
for i := 0 to dstLen - 1 do
begin
u := src_x1 + i * (src_x2 - src_x1) div dstLen;
v := src_y1 + i * (src_y2 - src_y1) div dstLen;
Uf := (src_x1 + i * (src_x2 - src_x1) * 64 div dstLen) and $3f;
Vf := (src_y1 + i * (src_y2 - src_y1) * 64 div dstLen) and $3f;
k := #koefs[4*((Uf shl 6) + Vf)];
src_ptr := PAnsiChar(#src) + v * srcLineAdd + u * pixelSize;
c1 := pinteger(src_ptr)^;
c2 := pinteger(src_ptr + 4)^;
c3 := pinteger(src_ptr + srcLineAdd)^;
c4 := pinteger(src_ptr + srcLineAdd + 4)^;
pinteger(dst_ptr)^ :=
( (c1 and $FF)*k[0] shr 16 +
(c2 and $FF)*k[1] shr 16 +
(c3 and $FF)*k[2] shr 16 +
(c4 and $FF)*k[3] shr 16 )
or
( ((c1 shr 8) and $FF)*k[0] shr 16 +
((c2 shr 8) and $FF)*k[1] shr 16 +
((c3 shr 8) and $FF)*k[2] shr 16 +
((c4 shr 8) and $FF)*k[3] shr 16 ) shl 8
or
( ((c1 shr 16) and $FF)*k[0] shr 16 +
((c2 shr 16) and $FF)*k[1] shr 16 +
((c3 shr 16) and $FF)*k[2] shr 16 +
((c4 shr 16) and $FF)*k[3] shr 16 ) shl 16
or $02000000;
inc(dst_ptr, pixelSize);
end;
end;
procedure TBitmapDrawer.setDrawMode(m: TDrawMode);
begin
drawModeFlag := m;
case drawModeFlag of
dmSimple : drawLine := drawLineSimple;
dmBilinear : drawLine := drawLineBilinear;
end;
end;
end.

Answer 2

I finally got the desired output using Projective transformation method in Graphics32 http://graphics32.org/wiki/