pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

LazMapViewer: Draw Point-of-interest image. Fix drawing of transparent bitmaps. Remove LCLDrawer from demo (not working).

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6933 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2019-05-21 22:00:33 +00:00
parent ae1719d0a3
commit c67022ccfa
8 changed files with 399 additions and 57 deletions
Download Patch File Download Diff File Expand all files Collapse all files

110
components/lazmapviewer/source/addons/rgbgraphics_drawingengine/mvde_rgbgraphics.pas
View File

@@ -42,6 +42,8 @@ type
public
destructor Destroy; override;
procedure CreateBuffer(AWidth, AHeight: Integer); override;
procedure DrawBitmap(X, Y: Integer; ABitmap: TCustomBitmap;
UseAlphaChannel: Boolean); override;
procedure DrawLazIntfImage(X, Y: Integer; AImg: TLazIntfImage); override;
procedure Ellipse(X1, Y1, X2, Y2: Integer); override;
procedure FillRect(X1, Y1, X2, Y2: Integer); override;
@@ -59,7 +61,7 @@ procedure Register;
implementation
uses
GraphType, FPImage,
GraphType, LCLType, FPImage,
mvTypes;
procedure Register;
@@ -79,6 +81,36 @@ begin
FBuffer := TRGB32Bitmap.Create(AWidth, AHeight);
end;
procedure TMvRGBGraphicsDrawingEngine.DrawBitmap(X,Y: Integer;
ABitmap: TCustomBitmap; UseAlphaChannel: Boolean);
var
intfImg: TLazIntfImage;
i, j: Integer;
cimg, cbuf: TFPColor;
alpha: Double;
begin
intfImg := ABitmap.CreateIntfImage;
try
if UseAlphaChannel then begin
for j := 0 to intfImg.Height - 1 do
for i := 0 to intfImg.Width - 1 do begin
cimg := intfImg.Colors[i, j];
alpha := cimg.Alpha / word($FFFF);
cbuf := TColorToFPColor(FBuffer.Canvas.GetColor(i + X, j + Y));
cbuf.Red := Round(alpha * cimg.Red + (1 - alpha) * cbuf.Red);
cbuf.Green := Round(alpha * cimg.Green + (1 - alpha) * cbuf.Green);
cbuf.Blue := Round(alpha * cimg.Blue + (1 - alpha) * cbuf.Blue);
FBuffer.Canvas.SetColor(i + X, j + Y, FPColorToTColor(cbuf));
end;
end else
for j := 0 to intfImg.Height - 1 do
for i := 0 to intfImg.Width - 1 do
FBuffer.Canvas.SetColor(i + X, j + Y, FPColorToTColor(intfImg.Colors[i, j]));
finally
intfimg.Free;
end;
end;
procedure TMvRGBGraphicsDrawingEngine.DrawLazIntfImage(X, Y: Integer;
AImg: TLazIntfImage);
//http://mantis.freepascal.org/view.php?id=27144
@@ -235,6 +267,7 @@ begin
end;
end;
(*
procedure TMvRGBGraphicsDrawingEngine.TextOut(X, Y: Integer; const AText: String);
var
bmp: TBitmap;
@@ -286,6 +319,81 @@ begin
bmp.Free;
end;
end;
*)
procedure TMvRGBGraphicsDrawingEngine.TextOut(X, Y: Integer; const AText: String);
var
bmp: TBitmap;
ex: TSize;
img: TLazIntfImage;
i, j: Integer;
c: TColor;
fc, tc: TFPColor;
intens, intens0: Int64;
alpha: Double;
hb, hm: HBitmap;
begin
if (AText = '') then
exit;
bmp := TBitmap.Create;
try
bmp.PixelFormat := pf32Bit;
bmp.SetSize(1, 1);
bmp.Canvas.Font.Name := FFontName;
bmp.Canvas.Font.Size := FFontSize;
bmp.Canvas.Font.Style := FFontStyle;
bmp.Canvas.Font.Color := FFontColor;
ex := bmp.Canvas.TextExtent(AText);
bmp.SetSize(ex.CX, ex.CY);
if GetBrushStyle <> bsClear then begin
bmp.Canvas.Brush.Color := GetBrushColor;
bmp.Canvas.FillRect(0, 0, bmp.Width, bmp.Height);
bmp.Canvas.TextOut(0, 0, AText);
DrawBitmap(X, Y, bmp, false);
end else
begin
if FFontColor = clWhite then
bmp.Canvas.Brush.Color := clBlack
else
bmp.Canvas.Brush.Color := clWhite;
bmp.Canvas.FillRect(0, 0, bmp.Width, bmp.Height);
bmp.Canvas.TextOut(0, 0, AText);
img := bmp.CreateIntfImage;
try
fc := TColorToFPColor(bmp.Canvas.Font.Color);
intens0 := (fc.Red + fc.Green + fc.Blue);
for j := 0 to img.Height - 1 do
for i := 0 to img.Width - 1 do begin
c := bmp.Canvas.Pixels[i, j];
tc := TColorToFPColor(c);
if c = bmp.Canvas.Brush.Color then
tc.Alpha := alphaTransparent
else if c = FFontColor then
tc.Alpha := alphaOpaque
else begin
intens := tc.Red + tc.Green + tc.Blue;
if intens0 = 0 then
alpha := (3 * alphaopaque - intens) / (3 * alphaOpaque - intens0)
else
alpha := intens / intens0;
tc.Alpha := round(alphaOpaque * alpha);
end;
img.Colors[i, j] := tc;
end;
img.CreateBitmaps(hb, hm);
bmp.Handle := hb;
bmp.MaskHandle := hm;
DrawBitmap(X, Y, bmp, true);
finally
img.Free;
end;
end;
finally
bmp.Free;
end;
end;
end.

100
components/lazmapviewer/source/mvde_intfgraphics.pas
View File

@@ -40,6 +40,8 @@ type
public
destructor Destroy; override;
procedure CreateBuffer(AWidth, AHeight: Integer); override;
procedure DrawBitmap(X, Y: Integer; ABitmap: TCustomBitmap;
UseAlphaChannel: Boolean); override;
procedure DrawLazIntfImage(X, Y: Integer; AImg: TLazIntfImage); override;
procedure Ellipse(X1, Y1, X2, Y2: Integer); override;
procedure FillRect(X1, Y1, X2, Y2: Integer); override;
@@ -55,6 +57,7 @@ type
implementation
uses
LCLType,
FPImgCanv, GraphType;
{$IF Laz_FullVersion < 1090000}
@@ -137,6 +140,7 @@ begin
rawImg.Description.Init_BPP32_A8R8G8B8_BIO_TTB(AWidth, AHeight);
{$ELSE}
rawImg.Description.Init_BPP32_B8G8R8_BIO_TTB(AWidth, AHeight);
// rawImg.Description.Init_BPP32_B8G8R8A8_BIO_TTB(AWidth, AHeight);
{$ENDIF}
rawImg.CreateData(True);
ABuffer := TLazIntfImage.Create(rawImg, true);
@@ -145,6 +149,36 @@ begin
ACanvas.FillRect(0, 0, AWidth, AHeight);
end;
procedure TMvIntfGraphicsDrawingEngine.DrawBitmap(X, Y: Integer;
ABitmap: TCustomBitmap; UseAlphaChannel: Boolean);
var
intfImg: TLazIntfImage;
i, j: Integer;
cimg, cbuf: TFPColor;
alpha: Double;
begin
intfImg := ABitmap.CreateIntfImage;
try
if UseAlphaChannel then begin
for j := 0 to intfImg.Height - 1 do
for i := 0 to intfImg.Width - 1 do begin
cimg := intfImg.Colors[i, j];
alpha := cimg.Alpha / word($FFFF);
cbuf := FBuffer.Colors[i + X, j + Y];
cbuf.Red := Round(alpha * cimg.Red + (1 - alpha) * cbuf.Red);
cbuf.Green := Round(alpha * cimg.Green + (1 - alpha) * cbuf.Green);
cbuf.Blue := Round(alpha * cimg.Blue + (1 - alpha) * cbuf.Blue);
FBuffer.Colors[i + X, j + Y] := cbuf;
end;
end else
for j := 0 to intfImg.Height - 1 do
for i := 0 to intfImg.Width - 1 do
FBuffer.Colors[i + X, j + Y] := intfImg.Colors[i, j];
finally
intfimg.Free;
end;
end;
procedure TMvIntfGraphicsDrawingEngine.DrawLazIntfImage(X, Y: Integer;
AImg: TLazIntfImage);
begin
@@ -323,9 +357,12 @@ var
bmp: TBitmap;
ex: TSize;
img: TLazIntfImage;
brClr: TFPColor;
imgClr: TFPColor;
i, j: Integer;
hb, hm: HBitmap;
c: TColor;
fc, tc: TFPColor;
intens, intens0: Int64;
alpha: Double;
begin
if (FCanvas = nil) or (AText = '') then
exit;
@@ -340,28 +377,49 @@ begin
bmp.Canvas.Font.Color := FFontColor;
ex := bmp.Canvas.TextExtent(AText);
bmp.SetSize(ex.CX, ex.CY);
bmp.Canvas.Brush.Color := GetBrushColor;
if GetBrushStyle = bsClear then
bmp.Canvas.Brush.Style := bsSolid
else
bmp.Canvas.Brush.Style := GetBrushStyle;
bmp.Canvas.FillRect(0, 0, bmp.Width, bmp.Height);
bmp.Canvas.TextOut(0, 0, AText);
img := bmp.CreateIntfImage;
try
if GetBrushStyle = bsClear then begin
brClr := TColorToFPColor(GetBrushColor);
if GetBrushStyle <> bsClear then begin
bmp.Canvas.Brush.Color := GetBrushColor;
bmp.Canvas.FillRect(0, 0, bmp.Width, bmp.Height);
bmp.Canvas.TextOut(0, 0, AText);
DrawBitmap(X, Y, bmp, false);
end else
begin
if FFontColor = clWhite then
bmp.Canvas.Brush.Color := clBlack
else
bmp.Canvas.Brush.Color := clWhite;
bmp.Canvas.FillRect(0, 0, bmp.Width, bmp.Height);
bmp.Canvas.TextOut(0, 0, AText);
img := bmp.CreateIntfImage;
try
fc := TColorToFPColor(bmp.Canvas.Font.Color);
intens0 := (fc.Red + fc.Green + fc.Blue);
for j := 0 to img.Height - 1 do
for i := 0 to img.Width - 1 do begin
imgClr := img.Colors[i, j];
if (imgClr.Red = brClr.Red) and (imgClr.Green = brClr.Green) and (imgClr.Blue = brClr.Blue) then
Continue;
FCanvas.Colors[X + i, Y + j] := imgClr;
c := bmp.Canvas.Pixels[i, j];
tc := TColorToFPColor(c);
if c = bmp.Canvas.Brush.Color then
tc.Alpha := alphaTransparent
else if c = FFontColor then
tc.Alpha := alphaOpaque
else begin
intens := tc.Red + tc.Green + tc.Blue;
if intens0 = 0 then
alpha := (3 * alphaopaque - intens) / (3 * alphaOpaque - intens0)
else
alpha := intens / intens0;
tc.Alpha := round(alphaOpaque * alpha);
end;
img.Colors[i, j] := tc;
end;
end else
FCanvas.Draw(X, Y, img);
finally
img.Free;
img.CreateBitmaps(hb, hm);
bmp.Handle := hb;
bmp.MaskHandle := hm;
DrawBitmap(X, Y, bmp, true);
finally
img.Free;
end;
end;
finally
bmp.Free;

8
components/lazmapviewer/source/mvde_lcl.pas
View File

@@ -32,6 +32,8 @@ type
public
destructor Destroy; override;
procedure CreateBuffer(AWidth, AHeight: Integer); override;
procedure DrawBitmap(X, Y: Integer; ABitmap: TCustomBitmap;
UseAlphaChannel: Boolean); override;
procedure DrawLazIntfImage(X, Y: Integer; AImg: TLazIntfImage); override;
procedure Ellipse(X1, Y1, X2, Y2: Integer); override;
procedure FillRect(X1, Y1, X2, Y2: Integer); override;
@@ -62,6 +64,12 @@ begin
FBuffer.SetSize(AWidth, AHeight);
end;
procedure TMvLCLDrawingEngine.DrawBitmap(X, Y: Integer; ABitmap: TCustomBitmap;
UseAlphaChannel: Boolean);
begin
FBuffer.Canvas.Draw(X, Y, ABitmap);
end;
procedure TMvLCLDrawingEngine.DrawLazIntfImage(X, Y: Integer;
AImg: TLazIntfImage);
var

2
components/lazmapviewer/source/mvdrawingengine.pas
View File

@@ -29,6 +29,8 @@ type
public
procedure CreateBuffer(AWidth, AHeight: Integer); virtual; abstract;
procedure DrawBitmap(X, Y: Integer; ABitmap: TCustomBitmap;
UseAlphaChannel: Boolean); virtual; abstract;
procedure DrawLazIntfImage(X, Y: Integer; AImg: TLazIntfImage); virtual; abstract;
procedure Ellipse(X1, Y1, X2, Y2: Integer); virtual; abstract;
procedure FillRect(X1, Y1, X2, Y2: Integer); virtual; abstract;

82
components/lazmapviewer/source/mvmapviewer.pas
View File

@@ -45,6 +45,7 @@ Type
FGPSItems: TGPSObjectList;
FInactiveColor: TColor;
FPOIImage: TBitmap;
FPOITextBgColor: TColor;
FOnDrawGpsPoint: TDrawGpsPointEvent;
FDebugTiles: Boolean;
FDefaultTrackColor: TColor;
@@ -66,10 +67,11 @@ Type
function GetOnZoomChange: TNotifyEvent;
function GetUseThreads: boolean;
function GetZoom: integer;
function IsCachePathStored: Boolean;
function IsFontStored: Boolean;
procedure SetActive(AValue: boolean);
procedure SetCacheOnDisk(AValue: boolean);
procedure SetCachePath({%H-}AValue: String);
procedure SetCachePath(AValue: String);
procedure SetCenter(AValue: TRealPoint);
procedure SetDebugTiles(AValue: Boolean);
procedure SetDefaultTrackColor(AValue: TColor);
@@ -82,9 +84,12 @@ Type
procedure SetOnCenterMove(AValue: TNotifyEvent);
procedure SetOnChange(AValue: TNotifyEvent);
procedure SetOnZoomChange(AValue: TNotifyEvent);
procedure SetPOIImage(AValue: TBitmap);
procedure SetPOITextBgColor(AValue: TColor);
procedure SetUseThreads(AValue: boolean);
procedure SetZoom(AValue: integer);
procedure UpdateFont(Sender: TObject);
procedure UpdateImage(Sender: TObject);
protected
AsyncInvalidate : boolean;
@@ -123,10 +128,10 @@ Type
property Engine: TMapViewerEngine read FEngine;
property GPSItems: TGPSObjectList read FGPSItems;
published
property Active: boolean read FActive write SetActive;
property Active: boolean read FActive write SetActive default false;
property Align;
property CacheOnDisk: boolean read GetCacheOnDisk write SetCacheOnDisk;
property CachePath: String read GetCachePath write SetCachePath;
property CacheOnDisk: boolean read GetCacheOnDisk write SetCacheOnDisk default true;
property CachePath: String read GetCachePath write SetCachePath stored IsCachePathStored;
property DebugTiles: Boolean read FDebugTiles write SetDebugTiles default false;
property DefaultTrackColor: TColor read FDefaultTrackColor write SetDefaultTrackColor default clRed;
property DefaultTrackWidth: Integer read FDefaultTrackWidth write SetDefaultTrackWidth default 1;
@@ -134,11 +139,12 @@ Type
property DrawingEngine: TMvCustomDrawingEngine read GetDrawingEngine write SetDrawingEngine;
property Font: TFont read FFont write SetFont stored IsFontStored;
property Height default 150;
property InactiveColor: TColor read FInactiveColor write SetInactiveColor;
property InactiveColor: TColor read FInactiveColor write SetInactiveColor default clWhite;
property MapProvider: String read GetMapProvider write SetMapProvider;
property POIImage: TBitmap read FPOIImage write FPOIImage;
property POIImage: TBitmap read FPOIImage write SetPOIImage;
property POITextBgColor: TColor read FPOITextBgColor write SetPOITextBgColor default clNone;
property PopupMenu;
property UseThreads: boolean read GetUseThreads write SetUseThreads;
property UseThreads: boolean read GetUseThreads write SetUseThreads default false;
property Width default 150;
property Zoom: integer read GetZoom write SetZoom;
property OnCenterMove: TNotifyEvent read GetOnCenterMove write SetOnCenterMove;
@@ -156,7 +162,8 @@ Type
implementation
uses
GraphType, mvJobQueue, mvExtraData, mvDLEFpc, mvDE_IntfGraphics;
GraphType, Types,
mvJobQueue, mvExtraData, mvDLEFpc, mvDE_IntfGraphics;
type
@@ -333,6 +340,11 @@ begin
result := Engine.Zoom;
end;
function TMapView.IsCachePathStored: Boolean;
begin
Result := not SameText(CachePath, 'cache/');
end;
function TMapView.IsFontStored: Boolean;
begin
Result := SameText(FFont.Name, 'default') and (FFont.Size = 0) and
@@ -346,7 +358,7 @@ end;
procedure TMapView.SetCachePath(AValue: String);
begin
Engine.CachePath := CachePath;
Engine.CachePath := AValue; //CachePath;
end;
procedure TMapView.SetCenter(AValue: TRealPoint);
@@ -434,6 +446,20 @@ begin
Engine.OnZoomChange := AValue;
end;
procedure TMapView.SetPOIImage(AValue: TBitmap);
begin
if FPOIImage = AValue then exit;
FPOIImage := AValue;
Engine.Redraw;
end;
procedure TMapView.SetPOITextBgColor(AValue: TColor);
begin
if FPOITextBgColor = AValue then exit;
FPOITextBgColor := AValue;
Engine.Redraw;
end;
procedure TMapView.SetUseThreads(AValue: boolean);
begin
Engine.UseThreads := aValue;
@@ -575,8 +601,10 @@ end;
procedure TMapView.DrawPt(const Area: TRealArea; aPOI: TGPSPoint);
var
PT: TPoint;
Pt: TPoint;
PtColor: TColor;
extent: TSize;
s: String;
begin
if Assigned(FOnDrawGpsPoint) then begin
FOnDrawGpsPoint(Self, DrawingEngine, aPOI);
@@ -590,11 +618,28 @@ begin
if aPOI.ExtraData.inheritsFrom(TDrawingExtraData) then
PtColor := TDrawingExtraData(aPOI.ExtraData).Color;
end;
DrawingEngine.PenColor := ptColor;
DrawingEngine.Line(Pt.X, Pt.Y - 5, Pt.X, Pt.Y + 5);
DrawingEngine.Line(Pt.X - 5, Pt.Y, Pt.X + 5, Pt.Y);
// Buffer.Draw();
// Draw point marker
if Assigned(FPOIImage) and not (FPOIImage.Empty) then
DrawingEngine.DrawBitmap(Pt.X - FPOIImage.Width div 2, Pt.Y - FPOIImage.Height, FPOIImage, true)
else begin
DrawingEngine.PenColor := ptColor;
DrawingEngine.Line(Pt.X, Pt.Y - 5, Pt.X, Pt.Y + 5);
DrawingEngine.Line(Pt.X - 5, Pt.Y, Pt.X + 5, Pt.Y);
Pt.Y := Pt.Y + 5;
end;
// Draw point text
s := aPOI.Name;
if FPOITextBgColor = clNone then
DrawingEngine.BrushStyle := bsClear
else begin
DrawingEngine.BrushStyle := bsSolid;
DrawingEngine.BrushColor := FPOITextBgColor;
s := ' ' + s + ' ';
end;
extent := DrawingEngine.TextExtent(s);
DrawingEngine.Textout(Pt.X - extent.CX div 2, Pt.Y + 5, s);
end;
procedure TMapView.CallAsyncInvalidate;
@@ -710,11 +755,16 @@ begin
FFont.Style := [];
FFont.Color := clBlack;
FFont.OnChange := @UpdateFont;
FPOIImage := TBitmap.Create;
FPOIImage.OnChange := @UpdateImage;
FPOITextBgColor := clNone;
end;
destructor TMapView.Destroy;
begin
FFont.Free;
FreeAndNil(FPOIImage);
FreeAndNil(FGPSItems);
inherited Destroy;
end;
@@ -824,6 +874,10 @@ begin
Engine.Redraw;
end;
procedure TMapView.UpdateImage(Sender: TObject);
begin
Engine.Redraw;
end;
end.