bgraphoxo.pas

{ ***************************************************************************
 *                                                                          *
 *  This file is part of BGRABitmap library which is distributed under the  *
 *  modified LGPL.                                                          *
 *                                                                          *
 *  See the file COPYING.modifiedLGPL.txt, included in this distribution,   *
 *  for details about the copyright.                                        *
 *                                                                          *
 *  This program is distributed in the hope that it will be useful,         *
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of          *
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                    *
 *                                                                          *
 ************************* BGRABitmap library  ******************************

 - Drawing routines with transparency and antialiasing with Lazarus.
   Offers also various transforms.
 - These routines allow to manipulate 32bit images in BGRA format or RGBA
   format (depending on the platform).
 - This code is under modified LGPL (see COPYING.modifiedLGPL.txt).
   This means that you can link this library inside your programs for any purpose.
   Only the included part of the code must remain LGPL.

 - If you make some improvements to this library, please notify here:
   http://www.lazarus.freepascal.org/index.php/topic,12037.0.html

   ********************* Contact : Circular at operamail.com *******************


   ******************************* CONTRIBUTOR(S) ******************************
   - Edivando S. Santos Brasil | mailedivando@gmail.com
     (Compatibility with FPC ($Mode objfpc/delphi) and delphi VCL 11/2018)

   ***************************** END CONTRIBUTOR(S) *****************************}


Unit BGRAPhoxo;

{$i bgrabitmap.inc}{$H+}

interface

uses
  {$IFNDEF FPC}Types, GraphType, BGRAGraphics,{$ENDIF} BGRATypes, BGRABitmapTypes, FPImage, BGRALayers, BGRABitmap, Classes, SysUtils, BMPcomn;

type
  TPhoxoHeaderMagic = packed array[1..4] of Char; //@{$IFDEF FPC}Char{$ELSE}AnsiChar{$ENDIF};

const
  PhoxoHeaderMagic : TPhoxoHeaderMagic = 'oXo ';
  PhoxoBlock_CanvasSize = 1;
  PhoxoBlock_Layer = 2;
  PhoxoBlock_TextLayer = 3;
  PhoxoBlock_DPI = 4;
  PhoxoBlock_LayerCaption = 5;
  PhoxoBlock_LazPaintBlendMode = 128;
  PhoxoBlock_EndOfFile = 255;

type
  TPhoxoHeader = packed record
    magic: TPhoxoHeaderMagic;
    version: BGRALongWord;
  end;

  TPhoxoBlockHeader = packed record
    blockType : BGRALongWord;
    blockSize : BGRALongWord;
  end;

  TPhoxoLayerHeader = packed record
    layerVisible: BGRALongWord;
    layerLimited: BGRALongWord;
    opacityPercent: BGRALongWord;
    bmpHeader: TBitMapInfoHeader;
    redMask,greenMask,blueMask: BGRALongWord;
  end;

  { TBGRAPhoxoDocument }

  TBGRAPhoxoDocument = class(TBGRALayeredBitmap)
  private
    FDPIX,FDPIY: integer;
  protected
    function GetMimeType: string; override;
    procedure AddLayerFromPhoxoData(const ABlockHeader: TPhoxoBlockHeader; ABlockData: PByte);
  public
    constructor Create; overload; override;
    constructor Create(AWidth, AHeight: integer); overload; override;
    procedure LoadFromStream(AStream: TStream); override;
    procedure LoadFromFile(const filenameUTF8: string); override;
    procedure SaveToFile(const filenameUTF8: string); override;
    procedure SaveToStream(AStream: TStream); override;
    class function CheckFormat(Stream: TStream; ARestorePosition: boolean): boolean;
    class function ReadBlock(Stream: TStream; out AHeader: TPhoxoBlockHeader; out ABlockData: PByte): boolean;
    property DPIX: integer read FDPIX;
    property DPIY: integer read FDPIY;
  end;

  { TBGRAReaderOXO }

  TBGRAReaderOXO = class(TFPCustomImageReader)
  private
    FWidth,FHeight,FNbLayers: integer;
    FDPIX,FDPIY: integer;
  protected
    function InternalCheck(Stream: TStream): boolean; override;
    procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
  public
    property Width: integer read FWidth;
    property Height: integer read FHeight;
    property NbLayers: integer read FNbLayers;
    property DPIX: integer read FDPIX;
    property DPIY: integer read FDPIY;
  end;

  { TBGRAWriterOXO }

  TBGRAWriterOXO = class(TFPCustomImageWriter)
    protected
      procedure InternalWrite (Str:TStream; Img:TFPCustomImage); override;
  end;

procedure RegisterPhoxoFormat;

implementation

uses BGRAUTF8 {$IFDEF FPC},LazUTF8{$ENDIF};

var AlreadyRegistered: boolean;

function ComputeRowStride(AWidth,ABitsPerPixel: BGRALongWord): BGRALongWord;
begin
  result := ((AWidth * ABitsPerPixel + 31) div 32)*4;
end;

procedure SwapLayerHeaderIfNeeded(var ALayerHeader: TPhoxoLayerHeader);
begin
  with ALayerHeader do
  begin
    {$IFNDEF BDS}layerVisible := LEtoN(layerVisible);{$ENDIF}
    {$IFNDEF BDS}layerLimited := LEtoN(layerLimited);{$ENDIF}
    {$IFNDEF BDS}opacityPercent := LEtoN(opacityPercent);{$ENDIF}
    {$IFNDEF ENDIAN_LITTLE}SwapBMPInfoHeader(bmpHeader);{$ENDIF}
  end;
end;

procedure RegisterPhoxoFormat;
begin
  if AlreadyRegistered then exit;
  ImageHandlers.RegisterImageReader ('PhoXo', 'oXo', TBGRAReaderOXO);
  RegisterLayeredBitmapReader('oXo', TBGRAPhoxoDocument);
  RegisterLayeredBitmapWriter('oXo', TBGRAPhoxoDocument);
  DefaultBGRAImageReader[ifPhoxo] := TBGRAReaderOXO;
  DefaultBGRAImageWriter[ifPhoxo] := TBGRAWriterOXO;
  AlreadyRegistered:= True;
end;

{ TBGRAWriterOXO }

procedure TBGRAWriterOXO.InternalWrite(Str: TStream; Img: TFPCustomImage);
var doc: TBGRAPhoxoDocument;
  tempBmp: TBGRABitmap;
  x,y: integer;
begin
  doc := TBGRAPhoxoDocument.Create;
  if Img is TBGRABitmap then doc.AddLayer(Img as TBGRABitmap) else
  begin
    tempBmp := TBGRABitmap.Create(img.Width,img.Height);
    for y := 0 to Img.Height-1 do
      for x := 0 to img.Width-1 do
        tempBmp.SetPixel(x,y, FPColorToBGRA(img.Colors[x,y]));
    doc.AddOwnedLayer(tempBmp);
  end;
  doc.SaveToStream(Str);
  doc.Free;
end;

{ TBGRAReaderOXO }

function TBGRAReaderOXO.InternalCheck(Stream: TStream): boolean;
begin
  result := TBGRAPhoxoDocument.CheckFormat(Stream,True);
end;

procedure TBGRAReaderOXO.InternalRead(Stream: TStream; Img: TFPCustomImage);
var layeredImage: TBGRAPhoxoDocument;
  flat: TBGRABitmap;
  x,y: integer;
begin
  FWidth := 0;
  FHeight:= 0;
  FNbLayers:= 0;
  FDPIX := 0;
  FDPIY := 0;
  layeredImage := TBGRAPhoxoDocument.Create;
  try
    layeredImage.LoadFromStream(Stream);
    flat := layeredImage.ComputeFlatImage;
    try
      FWidth:= layeredImage.Width;
      FHeight:= layeredImage.Height;
      FNbLayers:= layeredImage.NbLayers;
      FDPIX := layeredImage.DPIX;
      FDPIY := layeredImage.DPIY;
      if Img is TBGRACustomBitmap then
        TBGRACustomBitmap(img).Assign(flat)
      else
      begin
        Img.SetSize(flat.Width,flat.Height);
        for y := 0 to flat.Height-1 do
          for x := 0 to flat.Width-1 do
            Img.Colors[x,y] := BGRAToFPColor(flat.GetPixel(x,y));
      end;
    finally
      flat.free;
    end;
  finally
    layeredImage.Free;
  end;
end;

{ TBGRAPhoxoDocument }

function TBGRAPhoxoDocument.GetMimeType: string;
begin
  Result:= 'image/phoxo';
end;

procedure TBGRAPhoxoDocument.AddLayerFromPhoxoData(
  const ABlockHeader: TPhoxoBlockHeader; ABlockData: PByte);
var
  layerHeader: TPhoxoLayerHeader;
  rawImageSize: BGRALongWord;
  rowStride: BGRALongWord;
  remaining: BGRALongWord;
  bmp: TBGRABitmap;
  layerIndex,y,x: integer;
  pSrc: PByte;
  pDest: PBGRAPixel;
begin
  remaining := ABlockHeader.blockSize;
  if remaining < sizeof(TPhoxoLayerHeader) then
    raise EFormatError.Create('Block too small');
  move(ABlockData^, {%H-}layerHeader, sizeof(layerHeader));
  inc(ABlockData, sizeof(layerHeader));
  dec(remaining, sizeof(layerHeader));
  SwapLayerHeaderIfNeeded(layerHeader);

  if layerHeader.bmpHeader.Compression <> BI_RGB then raise
    EFormatError.Create('Compression not supported');
  if (layerHeader.bmpHeader.Width < 0) or (layerHeader.bmpHeader.Height < 0) then
    raise EFormatError.Create('Invalid image size');
  if BGRAInt64(layerHeader.bmpHeader.Width)*layerHeader.bmpHeader.Height > maxLongint div 4 then
    raise EOutOfMemory.Create('Image too big');
  rowStride := ComputeRowStride(layerHeader.bmpHeader.Width,layerHeader.bmpHeader.BitCount);
  rawImageSize := rowStride * layerHeader.bmpHeader.Height;

  if rawImageSize > remaining then
     raise EFormatError.Create('Invalid image size');

  bmp := TBGRABitmap.Create(layerHeader.bmpHeader.Width, layerHeader.bmpHeader.Height);
  layerIndex := AddOwnedLayer(bmp, (layerHeader.opacityPercent*255 + 50) div 100);
  LayerVisible[layerIndex] := (layerHeader.layerVisible = 1);

  case layerHeader.bmpHeader.BitCount of
    8: begin
      for y := bmp.Height-1 downto 0 do
        begin
          pSrc := ABlockData + (bmp.Height-1 - y)*rowStride;
          pDest := bmp.ScanLine[y];
          for x := bmp.Width-1 downto 0 do
          begin
            pDest^ := BGRA(pSrc^,pSrc^,pSrc^);
            inc(pDest);
            inc(pSrc,3);
          end;
        end;
    end;
    24: begin
      for y := bmp.Height-1 downto 0 do
        begin
          pSrc := ABlockData + (bmp.Height-1 - y)*rowStride;
          pDest := bmp.ScanLine[y];
          for x := bmp.Width-1 downto 0 do
          begin
            pDest^ := BGRA((pSrc+2)^,(pSrc+1)^,pSrc^);
            inc(pDest);
            inc(pSrc,3);
          end;
        end;
    end;
    32: begin
      move(ABlockData^, bmp.Data^, sizeof(TBGRAPixel)*bmp.NbPixels);
      if bmp.LineOrder = riloTopToBottom then bmp.VerticalFlip;
      if TBGRAPixel_RGBAOrder then bmp.SwapRedBlue;
    end;
  else
    raise EFormatError.Create('Unsupported bit depth');
  end;

  inc(ABlockData, rawImageSize);
  dec(remaining, rawImageSize);
  if remaining >= 8 then
  begin
    LayerOffset[layerIndex] := Point({$IFNDEF BDS}LEtoN{$ENDIF}(PLongInt(ABlockData)^),{$IFNDEF BDS}LEtoN{$ENDIF}((PLongInt(ABlockData)+1)^));
    inc(ABlockData, 8);
    dec(remaining, 8);
  end;
end;

constructor TBGRAPhoxoDocument.Create;
begin
  inherited Create;
  RegisterPhoxoFormat;
end;

constructor TBGRAPhoxoDocument.Create(AWidth, AHeight: integer);
begin
  inherited Create(AWidth, AHeight);
  RegisterPhoxoFormat;
end;

procedure TBGRAPhoxoDocument.LoadFromStream(AStream: TStream);
var blockHeader: TPhoxoBlockHeader;
    blockData: PByte;
    wCaption: widestring;
    i: Integer;
begin
  if not CheckFormat(AStream,False) then
    raise EFormatError.Create('File header is invalid');
  Clear;
  FDPIX := 0;
  FDPIY := 0;
  blockData := nil;
  repeat
    if not ReadBlock(AStream, blockHeader,blockData) then
    begin
      if NbLayers = 0 then
        raise EFormatError.Create('Error reading block from file')
      else
        break;
    end;
    try
      case blockHeader.blockType of
        PhoxoBlock_CanvasSize:
          begin
            if blockHeader.blockSize < 8 then raise EFormatError.Create('Block too small');
            SetSize({$IFNDEF BDS}LEtoN{$ENDIF}(PBGRALongWord(blockData)^),{$IFNDEF BDS}LEtoN{$ENDIF}((PBGRALongWord(blockData)+1)^));
          end;
        PhoxoBlock_DPI:
          begin
            if blockHeader.blockSize >= 8 then
            begin
              FDPIX := {$IFNDEF BDS}LEtoN{$ENDIF}(PBGRALongWord(blockData)^);
              FDPIY := {$IFNDEF BDS}LEtoN{$ENDIF}((PBGRALongWord(blockData)+1)^);
            end;
          end;
        PhoxoBlock_Layer, PhoxoBlock_TextLayer:
          AddLayerFromPhoxoData(blockHeader,blockData);
        PhoxoBlock_LayerCaption:
          begin
            if (blockHeader.blockSize >= 2) and (NbLayers > 0) then
            begin
              setlength(wCaption, blockHeader.blockSize div 2);
              for i := 1 to length(wCaption) do
                BGRAWord(wCaption[i]) := {$IFNDEF BDS}LEtoN{$ENDIF}((PBGRAWord(blockData)+i-1)^);
              if wCaption[1] = #1 then Delete(wCaption,1,1);
              LayerName[NbLayers-1] := UTF8Encode(wCaption);

            end;
          end;
        PhoxoBlock_LazPaintBlendMode:
          begin
            if (blockHeader.blockSize >= 2) and (NbLayers > 0) then
            begin
              setlength(wCaption, blockHeader.blockSize div 2);
              for i := 1 to length(wCaption) do
                BGRAWord(wCaption[i]) := {$IFNDEF BDS}LEtoN{$ENDIF}((PBGRAWord(blockData)+i-1)^);
              BlendOperation[NbLayers-1] := StrToBlendOperation(UTF8Encode(wCaption));
            end;
          end;
      end;
    finally
      FreeMem(blockData);
    end;
  until blockHeader.blockType = PhoxoBlock_EndOfFile;
end;

procedure TBGRAPhoxoDocument.LoadFromFile(const filenameUTF8: string);
var AStream: TFileStreamUTF8;
begin
  AStream := TFileStreamUTF8.Create(filenameUTF8,fmOpenRead or fmShareDenyWrite);
  try
    LoadFromStream(AStream);
  finally
    AStream.Free;
  end;
end;

procedure TBGRAPhoxoDocument.SaveToFile(const filenameUTF8: string);
var AStream: TFileStreamUTF8;
begin
  AStream := TFileStreamUTF8.Create(filenameUTF8,fmCreate or fmShareDenyWrite);
  try
    SaveToStream(AStream);
  finally
    AStream.Free;
  end;
end;

procedure TBGRAPhoxoDocument.SaveToStream(AStream: TStream);

  procedure WriteFileHeader;
  var fileHeader: TPhoxoHeader;
  begin
    fileHeader.magic := PhoxoHeaderMagic;
    fileHeader.version := 1;
    {$IFNDEF BDS}fileHeader.version := NtoLE(fileHeader.version);{$ENDIF}
    AStream.WriteBuffer(fileHeader, sizeof(fileHeader));
  end;

  procedure WriteBlockHeader(blockType: BGRALongWord; blockSize: BGRALongWord);
  var blockHeader: TPhoxoBlockHeader;
  begin
    blockHeader.blockType := {$IFNDEF BDS}NtoLE{$ENDIF}(blockType);
    blockHeader.blockSize := {$IFNDEF BDS}NtoLE{$ENDIF}(blockSize);
    AStream.WriteBuffer(blockHeader, sizeof(blockHeader));
  end;

  procedure WriteLongInt(value: BGRALongInt);
  begin
    {$IFNDEF BDS}value := NtoLE(value);{$ENDIF}
    AStream.WriteBuffer(value, sizeof(value));
  end;

  procedure WriteLayer(index: integer);
  var wCaption: widestring;
      pCaption: PBGRAWord;

      layerHeader: TPhoxoLayerHeader;
      rowStride: BGRALongWord;

      temp,pdest: PByte;
      i,x,y: integer;
      psrc: PBGRAPixel;
  begin
    if LayerVisible[index] then
      layerHeader.layerVisible := 1
    else
      layerHeader.layerVisible := 0;
    layerHeader.layerLimited:= 0;
    layerHeader.opacityPercent := (LayerOpacity[index]*100 + 127) div 255;
    with layerHeader.bmpHeader do
    begin
      Size := $28;
      Width := self.LayerBitmap[index].Width;
      Height := self.LayerBitmap[index].Height;
      Planes := 1;
      BitCount := 32; //24-bit does not seem to be supported
      Compression := BI_RGB;
      SizeImage := 0;
      XPelsPerMeter := 0;
      YPelsPerMeter := 0;
      ClrUsed := 0;
      ClrImportant := 0;
    end;
    layerHeader.redMask := 0;
    layerHeader.greenMask := 0;
    layerHeader.blueMask := 0;

    rowStride := ComputeRowStride(layerHeader.bmpHeader.Width, layerHeader.bmpHeader.BitCount);

    WriteBlockHeader(PhoxoBlock_Layer, sizeof(layerHeader) + rowStride*layerHeader.bmpHeader.Height + sizeof(TPoint));
    SwapLayerHeaderIfNeeded(layerHeader);
    AStream.WriteBuffer(layerHeader,sizeof(layerHeader));
    SwapLayerHeaderIfNeeded(layerHeader);

    case layerHeader.bmpHeader.BitCount of
      32: begin
            if TBGRAPixel_RGBAOrder then self.LayerBitmap[index].SwapRedBlue;
            for y := self.LayerBitmap[index].Height-1 downto 0 do
              AStream.WriteBuffer(self.LayerBitmap[index].ScanLine[y]^, rowStride);
            if TBGRAPixel_RGBAOrder then self.LayerBitmap[index].SwapRedBlue;
          end;
      24: begin
            GetMem(temp, rowStride);
            fillchar(temp^, rowStride, 0);
            try
              for y := self.LayerBitmap[index].Height-1 downto 0 do
              begin
                psrc := self.LayerBitmap[index].ScanLine[y];
                pdest := temp;
                for x := self.LayerBitmap[index].Width-1 downto 0 do
                begin
                  pdest^ := psrc^.blue; inc(pdest);
                  pdest^ := psrc^.green; inc(pdest);
                  pdest^ := psrc^.red; inc(pdest);
                  inc(psrc);
                end;
                AStream.WriteBuffer(temp^, rowstride);
              end;
            finally
              FreeMem(temp);
            end;
          end
      else
        raise exception.Create('Internal error');
      end;

    WriteLongInt(LayerOffset[index].X);
    WriteLongInt(LayerOffset[index].Y);

    if LayerName[index]<>'' then
    begin
      {$IFDEF FPC}
      wCaption := UTF8ToUTF16(LayerName[index]);
      {$ELSE}//#
      wCaption := LayerName[index];
      {$ENDIF}
      WriteBlockHeader(PhoxoBlock_LayerCaption, length(wCaption)*2);
      getmem(pCaption, length(wCaption)*2);
      try
        for i := 1 to length(wCaption) do
          (pCaption+i-1)^ := {$IFNDEF BDS}NtoLE{$ENDIF}(BGRAWord(wCaption[i]));
        AStream.WriteBuffer(pCaption^, length(wCaption)*2);
      finally
        freemem(pCaption);
      end;
    end;

    if BlendOperation[index] <> boTransparent then
    begin
      {$IFDEF FPC}
      wCaption := UTF8ToUTF16(BlendOperationStr[BlendOperation[index]]);
      {$ELSE}
      wCaption := BlendOperationStr[BlendOperation[index]];
      {$ENDIF}
      WriteBlockHeader(PhoxoBlock_LazPaintBlendMode, length(wCaption)*2);
      getmem(pCaption, length(wCaption)*2);
      try
        for i := 1 to length(wCaption) do
          (pCaption+i-1)^ := {$IFNDEF BDS}NtoLE{$ENDIF}(BGRAWord(wCaption[i]));
        AStream.WriteBuffer(pCaption^, length(wCaption)*2);
      finally
        freemem(pCaption);
      end;
    end;
  end;

var
  i: Integer;
begin
  WriteFileHeader;

  WriteBlockHeader(PhoxoBlock_CanvasSize, 8);
  WriteLongInt(Width);
  WriteLongInt(Height);

  if (DPIX <> 0) and (DPIY <> 0) then
  begin
    WriteBlockHeader(PhoxoBlock_DPI, 8);
    WriteLongInt(DPIX);
    WriteLongInt(DPIY);
  end;

  for i := 0 to NbLayers-1 do
    WriteLayer(i);

  WriteBlockHeader(PhoxoBlock_EndOfFile,0);
end;

class function TBGRAPhoxoDocument.CheckFormat(Stream: TStream; ARestorePosition: boolean): boolean;
var header: TPhoxoHeader;
  oldPos: BGRAInt64;
begin
  oldPos := Stream.Position;
  if Stream.Read({%H-}header,sizeof(header))<>sizeof(header) then
    result := false else
  begin
    {$IFNDEF BDS}header.version:= LEtoN(header.version);{$ENDIF}
    if (header.magic <> PhoxoHeaderMagic) or (header.version <> 1) then
      result := false
    else
      result := true;
  end;
  if ARestorePosition then Stream.Position:= oldPos;
end;

class function TBGRAPhoxoDocument.ReadBlock(Stream: TStream; out
  AHeader: TPhoxoBlockHeader; out ABlockData: PByte): boolean;
begin
  ABlockData := nil;
  if Stream.Read({%H-}AHeader,sizeof(AHeader)) <> sizeof(AHeader) then
  begin
    AHeader.blockType := 0;
    AHeader.blockSize := 0;
    result := false;
    exit;
  end;
  {$IFNDEF BDS}AHeader.blockType := LEtoN(AHeader.blockType);{$ENDIF}
  {$IFNDEF BDS}AHeader.blockSize := LEtoN(AHeader.blockSize);{$ENDIF}
  if Stream.Position + AHeader.blockSize > Stream.Size then
  begin
    AHeader.blockSize := 0;
    result := false;
    exit;
  end;
  GetMem(ABlockData, AHeader.blockSize);
  if Stream.Read(ABlockData^, AHeader.blockSize) <> AHeader.blockSize then
  begin
    FreeMem(ABlockData);
    AHeader.blockSize := 0;
    result := false;
    exit;
  end;
  result := true;
end;

end.