lasarus_compotents/bgrabitmap/bgrabitmap/bgramseguibitmap.pas

// SPDX-License-Identifier: LGPL-3.0-linking-exception

{ Implementation of BGRABitmap for MSEgui }
unit BGRAMSEguiBitmap;
{ It should NOT be added to the **uses** clause. }

{$mode objfpc}{$H+}

interface

uses
  SysUtils, BGRAClasses, BGRAGraphics, BGRABitmapTypes, BGRADefaultBitmap,
  BGRAText, msebitmap;

type
  { Implementation of TBGRABitmap for MSEgui }
  TBGRAMSEguiBitmap = class(TBGRADefaultBitmap)
  protected
    procedure CopyDataToBitmap(AData: Pointer; AWidth,AHeight: integer; ALineOrder: TRawImageLineOrder; ABitmap: TBitmap);
    procedure RebuildBitmap; override;
    procedure DoLoadFromBitmap; override;
    function CreateDefaultFontRenderer: TBGRACustomFontRenderer; override;
    function LoadFromRawImage({%H-}ARawImage: TRawImage; {%H-}DefaultOpacity: byte;
      {%H-}AlwaysReplaceAlpha: boolean=False; {%H-}RaiseErrorOnInvalidPixelFormat: boolean
      =True): boolean; override;
    procedure FreeBitmap; override;
    procedure NotAvailable;
    procedure InternalAssignBitmapPixels(ASource: TBitmap);
    function GetCanvas: TCanvas; override;
  public
    procedure Assign(ASource: TPersistent); override;
    procedure AssignToBitmap(ADestination: TBitmap);
    destructor Destroy; override;
    procedure GetImageFromCanvas({%H-}CanvasSource: TCanvas; {%H-}x, {%H-}y: integer); override; //not available
    procedure DataDrawTransparent({%H-}ACanvas: TCanvas; {%H-}Rect: TRect; {%H-}AData: Pointer;
      {%H-}ALineOrder: TRawImageLineOrder; {%H-}AWidth, {%H-}AHeight: integer); override;
    procedure DataDrawOpaque({%H-}ACanvas: TCanvas; {%H-}Rect: TRect; {%H-}AData: Pointer;
      {%H-}ALineOrder: TRawImageLineOrder; {%H-}AWidth, {%H-}AHeight: integer); override;
    procedure TakeScreenshot({%H-}ARect: TRect); override; //not available
    procedure TakeScreenshotOfPrimaryMonitor; override; //not available
    procedure LoadFromDevice({%H-}DC: HDC); override; //not available
    procedure LoadFromDevice({%H-}DC: HDC; {%H-}ARect: TRect); override; //not available
  end;
  
type
  { Tracker of bitmap changes }
  TBitmapTracker = class(TMaskedBitmap)
  protected
    FUser: TBGRADefaultBitmap;
    procedure DoChange; override;
  public
    constructor Create(AUser: TBGRADefaultBitmap); overload;
  end;  

implementation

uses msegraphics, msegraphutils, math;

{ TBitmapTracker }

constructor TBitmapTracker.Create(AUser: TBGRADefaultBitmap);
begin
  FUser := AUser;
  inherited Create(bmk_rgb);
end;

procedure TBitmapTracker.DoChange;
begin
  if FUser <> nil then
    FUser.NotifyBitmapChange;
  inherited DoChange;
end;

{ TBGRAMSEguiBitmap }

procedure TBGRAMSEguiBitmap.CopyDataToBitmap(AData: Pointer; AWidth,AHeight: integer; ALineOrder: TRawImageLineOrder; ABitmap: TBitmap);
var
  ppix: PLongword;
  pbmp: PLongword;
  pmask: PByte;
  x,y,yBmp : integer;
  setMask: boolean;  
begin
  ABitmap.Size := Size(AWidth, AHeight);
  ppix := AData;
  pmask := nil;
  if ABitmap is TMaskedBitmap then
  begin  
    setMask := true;
    TMaskedBitmap(ABitmap).Masked := true;
    TMaskedBitmap(ABitmap).MaskKind := bmk_gray;  
  end else
    setMask := false;
  for y := 0 to Height-1 do
  begin
    if ALineOrder = riloTopToBottom then
      yBmp := y else yBmp := Height-1-y;
    pbmp := ABitmap.Scanline[yBmp];
    if setMask then pmask := TMaskedBitmap(ABitmap).Mask.Scanline[yBmp];
    for x := 0 to Width-1 do
    begin
      pbmp^ := ppix^ and $ffffff;
      if setMask then 
      begin
        pmask^ := ppix^ shr 24;
        inc(pmask);
      end;
      inc(ppix);
      inc(pbmp);
    end;
  end;
end;

procedure TBGRAMSEguiBitmap.RebuildBitmap;
begin
  if FBitmap = nil then
    FBitmap := TBitmapTracker.Create(self);

  CopyDataToBitmap(Data, Width, Height, LineOrder, FBitmap);
end;

procedure TBGRAMSEguiBitmap.InternalAssignBitmapPixels(ASource: TBitmap);
var 
  ppix,pbmp: PLongword;
  pmask: PByte;
  getMask: boolean;
  x,y,wm1: integer;
begin
  if ASource is TMaskedBitmap then
    getMask := TMaskedBitmap(ASource).Masked
    else getMask := false;
  wm1 := min(Width-1, ASource.Width-1);
  for y := 0 to min(Height-1, ASource.Height-1) do
  begin
    ppix := plongword(GetScanlineFast(y));
    pbmp := ASource.Scanline[y];
    if getMask then pmask := TMaskedBitmap(ASource).Mask.Scanline[y];
    for x := 0 to wm1 do
    begin
      if getMask then
      begin
        ppix^ := (pbmp^ and $ffffff) or (pmask^ shl 24); 
        inc(pmask);
      end else
        ppix^ := (pbmp^ and $ffffff) or $ff000000;
      inc(ppix);
      inc(pbmp);
    end;
  end;
end;

function TBGRAMSEguiBitmap.GetCanvas: TCanvas; 
begin
  result := inherited GetCanvas;
  NotifyBitmapChange;
end;

procedure TBGRAMSEguiBitmap.Assign(ASource: TPersistent); 
var bmp: TBitmap;
begin
  if ASource is TBitmap then
  begin
    bmp := TBitmap(ASource);
    SetSize(bmp.Width, bmp.Height);
    InternalAssignBitmapPixels(bmp);
    InvalidateBitmap;
  end else
    inherited Assign(ASource);
end;

procedure TBGRAMSEguiBitmap.AssignToBitmap(ADestination: TBitmap);
begin
  ADestination.Assign(Bitmap);
end;

procedure TBGRAMSEguiBitmap.DoLoadFromBitmap; 
begin
  if Assigned(FBitmap) then
    InternalAssignBitmapPixels(FBitmap);
end;

function TBGRAMSEguiBitmap.CreateDefaultFontRenderer: TBGRACustomFontRenderer;
begin
  result := TMSEFontRenderer.Create;
end;

function TBGRAMSEguiBitmap.LoadFromRawImage(ARawImage: TRawImage;
  DefaultOpacity: byte; AlwaysReplaceAlpha: boolean;
  RaiseErrorOnInvalidPixelFormat: boolean): boolean;
begin
  self.Assign(ARawImage);
  result := true;
end;

procedure TBGRAMSEguiBitmap.FreeBitmap;
begin
  FreeAndNil(FBitmap);
end;

procedure TBGRAMSEguiBitmap.NotAvailable;
begin
  raise exception.Create('Function not available with MSEgui');
end;

destructor TBGRAMSEguiBitmap.Destroy;
begin
  inherited Destroy;
end;

procedure TBGRAMSEguiBitmap.GetImageFromCanvas(CanvasSource: TCanvas; x,
  y: integer);
begin
  (Bitmap as TMaskedBitmap).Masked := false;
  Bitmap.Canvas.CopyArea(CanvasSource, MakeRect(x,y,Bitmap.Width,Bitmap.Height),
              Point(0,0));              
end;

procedure TBGRAMSEguiBitmap.DataDrawTransparent(ACanvas: TCanvas; Rect: TRect;
  AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
var
  bmp: TMaskedBitmap;
begin
  bmp := TMaskedBitmap.Create(bmk_rgb);
  CopyDataToBitmap(Data, Width, Height, ALineOrder, bmp);
  bmp.Paint(ACanvas, Rect);  
  bmp.Free;
end;

procedure TBGRAMSEguiBitmap.DataDrawOpaque(ACanvas: TCanvas; Rect: TRect;
  AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
var
  bmp: TBitmap;
begin
  bmp := TBitmap.Create(bmk_rgb);
  CopyDataToBitmap(AData, AWidth, AHeight, ALineOrder, bmp);
  bmp.Paint(ACanvas, Rect);  
  bmp.Free;
end;

procedure TBGRAMSEguiBitmap.TakeScreenshot(ARect: TRect);
begin
  NotAvailable;
end;

procedure TBGRAMSEguiBitmap.TakeScreenshotOfPrimaryMonitor;
begin
  NotAvailable;
end;

procedure TBGRAMSEguiBitmap.LoadFromDevice(DC: HDC);
begin
  NotAvailable;
end;

procedure TBGRAMSEguiBitmap.LoadFromDevice(DC: HDC; ARect: TRect);
begin
  NotAvailable;
end;

end.