Перейти к содержанию
Fire Monkey от А до Я

IVGSoft

Пользователи
 Профиль  Обзор контента

  • Постов

    61

  • Зарегистрирован

  • Посещение

  • Победитель дней

    6

 Тип контента 

Сообщения, опубликованные IVGSoft

    Обработка анимированных GIF по рецепту китайского коллеги

    в Анимация

    Опубликовано

    19 часов назад, Roma77751 сказал:

    так компилируется, но все все равно синее

    Не помню, чтобы с таким сталкивался. Возможно где-то ошибка в исходниках FMX. Похоже на то, что перепутаны местами каналы R и B

    Обработка анимированных GIF по рецепту китайского коллеги

    в Анимация

    Опубликовано

    В 23.11.2018 в 21:28, Roma77751 сказал:

    Доброго времени суток! в твоем коде делфя ругается на эту строчку

    "  MergeBitmap(aFrames[Index].Bitmap, aDisplay, aFrames[Index].Bitmap.Bounds, aFrames[Index].FPos.X, aFrames[Index].FPos.Y);"

    а конкретно на" aFrames[Index].Bitmap.Bounds"

    подскажи что не так плз...чет не могу разобраться

    Конкретней можно? Какую ошибку выдает? Какая версия Дельфи?

    Производительность отрисовки текста на мобильных платформах

    в Текст

    Опубликовано · Изменено пользователем IVGSoft

    17 минут назад, ENERGY сказал:

    Я отправил автору коммент с этим кодом. Ничего он не забил, последний коммент в блоге был в недавно.

    Хорошо. Пусть исправит, думаю это многим пригодится.

    А куда отправили? Сюда - http://www.raysoftware.cn/?p=559

    Обработка анимированных GIF по рецепту китайского коллеги

    в Анимация

    Опубликовано · Изменено пользователем IVGSoft

    12 часов назад, Вадим Смоленский сказал:

    Хорошо, если получится исправить. В моем-то проекте гифки самые простые, без прозрачности и черезстрочности, так что я ничего такого и не заметил.

    В конце концов получилось исправить. :)

    Для interlaced гифок проблема была вообще пустяковая. Одна строчка не в том месте. А вот для optimized все оказалось несколько сложней, но в итоге теперь все гифки отображаются правильно.

    Пользуйтесь на здоровье!

    FMX.GifUtils.zip

    Производительность отрисовки текста на мобильных платформах

    в Текст

    Опубликовано

    Может и так, но я уже поборол все эти проблемы. :) Наконец. Вот, держите!

    Испробовано на многих гифках.

    Спойлер 
    
unit FMX.GifUtils;

interface

uses
  System.Classes, System.SysUtils, System.Types, System.UITypes,
  FMX.Types, FMX.Objects, FMX.Graphics, System.Generics.Collections;

const
  alphaTransparent = $00;
  GifSignature: array [0 .. 2] of Byte = ($47, $49, $46); // GIF
  VerSignature87a: array [0 .. 2] of Byte = ($38, $37, $61); // 87a
  VerSignature89a: array [0 .. 2] of Byte = ($38, $39, $61); // 89a

  GIF_DISPOSAL_UNSPECIFIED = 0;
  GIF_DISPOSAL_LEAVE = 1;
  GIF_DISPOSAL_BACKGROUND = 2;
  GIF_DISPOSAL_PREVIOUS = 3;

type
  TGifVer = (verUnknow, ver87a, ver89a);

  TInternalColor = packed record
    case Integer of
      0:
        (

{$IFDEF BIGENDIAN}
          R, G, B, A: Byte;
{$ELSE}
          B, G, R, A: Byte;
{$ENDIF}
        );
      1:
        (Color: TAlphaColor;
        );
  end;

{$POINTERMATH ON}

  PInternalColor = ^TInternalColor;
{$POINTERMATH OFF}

  TGifRGB = packed record
    R: Byte;
    G: Byte;
    B: Byte;
  end;

  TGIFHeader = packed record
    Signature: array [0 .. 2] of Byte; // * Header Signature (always "GIF") */
    Version: array [0 .. 2] of Byte;   // * GIF format version("87a" or "89a") */
    // Logical Screen Descriptor
    ScreenWidth: word; // * Width of Display Screen in Pixels */
    ScreenHeight: word; // * Height of Display Screen in Pixels */
    Packedbit: Byte; // * Screen and Color Map Information */
    BackgroundColor: Byte; // * Background Color Index */
    AspectRatio: Byte; // * Pixel Aspect Ratio */
  end;

  TGifImageDescriptor = packed record
    Left: word; // * X position of image on the display */
    Top: word; // * Y position of image on the display */
    Width: word; // * Width of the image in pixels */
    Height: word; // * Height of the image in pixels */
    Packedbit: Byte; // * Image and Color Table Data Information */
  end;

  TGifGraphicsControlExtension = packed record
    BlockSize: Byte;  // * Size of remaining fields (always 04h) */
    Packedbit: Byte; // * Method of graphics disposal to use */
    DelayTime: word; // * Hundredths of seconds to wait	*/
    ColorIndex: Byte; // * Transparent Color Index */
    Terminator: Byte; // * Block Terminator (always 0) */
  end;

  TGifReader = class;

  TPalette = TArray<TInternalColor>;

  TGifFrameItem = class;

  TGifFrameList = TObjectList<TGifFrameItem>;
  { TGifReader }

  TGifReader = class(TObject)
  protected
    FHeader: TGIFHeader;
    FPalette: TPalette;
    FScreenWidth: Integer;
    FScreenHeight: Integer;
    FInterlace: Boolean;
    FBitsPerPixel: Byte;
    FBackgroundColorIndex: Byte;
    FResolution: Byte;
    FGifVer: TGifVer;

  public
    function Read(Stream: TStream; var AFrameList: TGifFrameList): Boolean;
      overload; virtual;
    function Read(FileName: string; var AFrameList: TGifFrameList): Boolean;
      overload; virtual;
    function ReadRes(Instance: THandle; ResName: string; ResType: PChar;
      var AFrameList: TGifFrameList): Boolean; overload; virtual;
    function ReadRes(Instance: THandle; ResId: Integer; ResType: PChar;
      var AFrameList: TGifFrameList): Boolean; overload; virtual;

    function Check(Stream: TStream): Boolean; overload; virtual;
    function Check(FileName: string): Boolean; overload; virtual;
  public
    constructor Create; virtual;
    destructor Destroy; override;

    property Header: TGIFHeader read FHeader;
    property ScreenWidth: Integer read FScreenWidth;
    property ScreenHeight: Integer read FScreenHeight;
    property Interlace: Boolean read FInterlace;
    property BitsPerPixel: Byte read FBitsPerPixel;
    property Background: Byte read FBackgroundColorIndex;
    property Resolution: Byte read FResolution;
    property GifVer: TGifVer read FGifVer;
  end;

  TGifFrameItem = class
    FDisposalMethod: Integer;
    FPos: TPoint;
    FTime: Integer;
    FDisbitmap: TBitmap;
    fBackColor : TalphaColor;
  public
    destructor Destroy; override;
    property Bitmap : TBitmap read FDisbitmap;
  end;

implementation

uses
  Math;

function swap16(x: UInt16): UInt16; inline;
begin
  Result := ((x and $FF) shl 8) or ((x and $FF00) shr 8);
end;

function swap32(x: UInt32): UInt32; inline;
begin
  Result := ((x and $FF) shl 24) or ((x and $FF00) shl 8) or
    ((x and $FF0000) shr 8) or ((x and $FF000000) shr 24);
end;

function LEtoN(Value: word): word; overload;
begin
  Result := swap16(Value);
end;

function LEtoN(Value: Dword): Dword; overload;
begin
  Result := swap32(Value);
end;

procedure MergeBitmap(const Source, Dest: TBitmap; SrcRect: TRect;
  DestX, DestY: Integer);
var
  I, J, MoveBytes: Integer;
  SrcData, DestData: TBitmapData;
  lpColorSrc, lpColorDst: PInternalColor;
begin

  With Dest do
  begin
    if Map(TMapAccess.Write, DestData) then
      try
        if Source.Map(TMapAccess.Read, SrcData) then
          try
            if SrcRect.Left < 0 then
            begin
              Dec(DestX, SrcRect.Left);
              SrcRect.Left := 0;
            end;
            if SrcRect.Top < 0 then
            begin
              Dec(DestY, SrcRect.Top);
              SrcRect.Top := 0;
            end;
            SrcRect.Right := Min(SrcRect.Right, Source.Width);
            SrcRect.Bottom := Min(SrcRect.Bottom, Source.Height);
            if DestX < 0 then
            begin
              Dec(SrcRect.Left, DestX);
              DestX := 0;
            end;
            if DestY < 0 then
            begin
              Dec(SrcRect.Top, DestY);
              DestY := 0;
            end;
            if DestX + SrcRect.Width > Width then
              SrcRect.Width := Width - DestX;
            if DestY + SrcRect.Height > Height then
              SrcRect.Height := Height - DestY;

            if (SrcRect.Left < SrcRect.Right) and (SrcRect.Top < SrcRect.Bottom)
            then
            begin
              MoveBytes := SrcRect.Width * SrcData.BytesPerPixel;
              for I := 0 to SrcRect.Height - 1 do
              begin
                lpColorSrc := SrcData.GetPixelAddr(SrcRect.Left,
                  SrcRect.Top + I);
                lpColorDst := DestData.GetPixelAddr(DestX, DestY + I);
                for J := 0 to SrcRect.Width - 1 do
                  if lpColorSrc[J].A <> 0 then
                  begin
                    lpColorDst[J] := lpColorSrc[J];
                  end;
              end;
            end;
          finally
            Source.Unmap(SrcData);
          end;
      finally
        Unmap(DestData);
      end;
  end;

end;

{ TGifReader }

function TGifReader.Read(FileName: string;
  var AFrameList: TGifFrameList): Boolean;
var
  fs: TFileStream;
begin
  Result := False;
  fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    Result := Read(fs, AFrameList);
  except

  end;
  fs.DisposeOf;
end;

function TGifReader.ReadRes(Instance: THandle; ResName: string; ResType: PChar;
  var AFrameList: TGifFrameList): Boolean;
var
  res: TResourceStream;
begin
  res := TResourceStream.Create(HInstance, ResName, ResType);
  Result := Read(res, AFrameList);
  res.DisposeOf;
end;

function TGifReader.ReadRes(Instance: THandle; ResId: Integer; ResType: PChar;
  var AFrameList: TGifFrameList): Boolean;
var
  res: TResourceStream;
begin
  res := TResourceStream.CreateFromID(HInstance, ResId, ResType);
  Result := Read(res, AFrameList);
  res.DisposeOf;
end;

function TGifReader.Read(Stream: TStream;
  var AFrameList: TGifFrameList): Boolean;
var
  LDescriptor: TGifImageDescriptor;
  LGraphicsCtrlExt: TGifGraphicsControlExtension;
  LIsTransparent: Boolean;
  LGraphCtrlExt: Boolean;
  LFrameWidth: Integer;
  LFrameHeight: Integer;
  LLocalPalette: TPalette;
  LScanLineBuf: TBytes;

  procedure ReadPalette(Stream: TStream; Size: Integer; var APalette: TPalette);
  Var
    RGBEntry: TGifRGB;
    I: Integer;
    c: TInternalColor;
  begin
    SetLength(APalette, Size);
    For I := 0 To Size - 1 Do
    Begin
      Stream.Read(RGBEntry, SizeOf(RGBEntry));
      With APalette[I] do
      begin
        R := RGBEntry.R or (RGBEntry.R shl 8);
        G := RGBEntry.G or (RGBEntry.G shl 8);
        B := RGBEntry.B or (RGBEntry.B shl 8);
        A := $FF;
      end;
    End;
  end;

  function ProcHeader: Boolean;
  var
    c: TInternalColor;
  begin
    Result := False;
    With FHeader do
    begin
      if (CompareMem(@Signature, @GifSignature, 3)) and
        (CompareMem(@Version, @VerSignature87a, 3)) or
        (CompareMem(@Version, @VerSignature89a, 3)) then
      begin
        FScreenWidth := FHeader.ScreenWidth;
        FScreenHeight := FHeader.ScreenHeight;

        FResolution := Packedbit and $70 shr 5 + 1;
        FBitsPerPixel := Packedbit and 7 + 1;
        FBackgroundColorIndex := BackgroundColor;
        if CompareMem(@Version, @VerSignature87a, 3) then
          FGifVer := ver87a
        else if CompareMem(@Version, @VerSignature89a, 3) then
          FGifVer := ver89a;
        Result := True;
      end
      else
        Raise Exception.Create('Unknown GIF image format');
    end;

  end;

  function ProcFrame: Boolean;
  var
    LineSize: Integer;
    LBackColorIndex: Integer;
  begin
    Result := False;
    With LDescriptor do
    begin
      LFrameWidth := Width;
      LFrameHeight := Height;
      FInterlace := ((Packedbit and $40) = $40);
    end;

    if LGraphCtrlExt then
    begin
      LIsTransparent := (LGraphicsCtrlExt.Packedbit and $01) <> 0;
      If LIsTransparent then
        LBackColorIndex := LGraphicsCtrlExt.ColorIndex;
    end
    else
    begin
      LIsTransparent := FBackgroundColorIndex <> 0;
      LBackColorIndex := FBackgroundColorIndex;
    end;
    LineSize := LFrameWidth * (LFrameHeight + 1);
    SetLength(LScanLineBuf, LineSize);

    If LIsTransparent then
    begin
      LLocalPalette[LBackColorIndex].A := alphaTransparent;
    end;

    Result := True;
  end;

  function ReadAndProcBlock(Stream: TStream): Byte;
  var
    Introducer, Labels, SkipByte: Byte;
  begin
    Stream.Read(Introducer, 1);
    if Introducer = $21 then
    begin
      Stream.Read(Labels, 1);
      Case Labels of
        $FE, $FF:
          // Comment Extension block or Application Extension block
          while True do
          begin
            Stream.Read(SkipByte, 1);
            if SkipByte = 0 then
              Break;
            Stream.Seek(Int64( SkipByte), soFromCurrent);
          end;
        $F9: // Graphics Control Extension block
          begin
            Stream.Read(LGraphicsCtrlExt, SizeOf(LGraphicsCtrlExt));
            LGraphCtrlExt := True;
          end;
        $01: // Plain Text Extension block
          begin
            Stream.Read(SkipByte, 1);
            Stream.Seek(Int64( SkipByte), soFromCurrent);
            while True do
            begin
              Stream.Read(SkipByte, 1);
              if SkipByte = 0 then
                Break;
              Stream.Seek(Int64( SkipByte), soFromCurrent);
            end;
          end;
      end;
    end;
    Result := Introducer;
  end;

  function ReadScanLine(Stream: TStream; AScanLine: PByte): Boolean;
  var
    OldPos, UnpackedSize, PackedSize: longint;
    I: Integer;
    Data, Bits, Code: Cardinal;
    SourcePtr: PByte;
    InCode: Cardinal;

    CodeSize: Cardinal;
    CodeMask: Cardinal;
    FreeCode: Cardinal;
    OldCode: Cardinal;
    Prefix: array [0 .. 4095] of Cardinal;
    Suffix, Stack: array [0 .. 4095] of Byte;
    StackPointer: PByte;
    Target: PByte;
    DataComp: TBytes;
    B, FInitialCodeSize, FirstChar: Byte;
    ClearCode, EOICode: word;
  begin
    DataComp := nil;
    try
      try
        Stream.Read(FInitialCodeSize, 1);
        OldPos := Stream.Position;
        PackedSize := 0;
        Repeat
          Stream.Read(B, 1);
          if B > 0 then
          begin
            Inc(PackedSize, B);
            Stream.Seek(Int64(B), soFromCurrent);
            CodeMask := (1 shl CodeSize) - 1;
          end;
        until B = 0;
        SetLength(DataComp, 2 * PackedSize);
        SourcePtr := @DataComp[0];
        Stream.Position := OldPos;
        Repeat
          Stream.Read(B, 1);
          if B > 0 then
          begin
            Stream.ReadBuffer(SourcePtr^, B);
            Inc(SourcePtr, B);
          end;
        until B = 0;

        SourcePtr := @DataComp[0];
        Target := AScanLine;
        CodeSize := FInitialCodeSize + 1;
        ClearCode := 1 shl FInitialCodeSize;
        EOICode := ClearCode + 1;
        FreeCode := ClearCode + 2;
        OldCode := 4096;
        CodeMask := (1 shl CodeSize) - 1;
        UnpackedSize := LFrameWidth * LFrameHeight;
        for I := 0 to ClearCode - 1 do
        begin
          Prefix[I] := 4096;
          Suffix[I] := I;
        end;
        StackPointer := @Stack;
        FirstChar := 0;
        Data := 0;
        Bits := 0;
        while (UnpackedSize > 0) and (PackedSize > 0) do
        begin
          Inc(Data, SourcePtr^ shl Bits);
          Inc(Bits, 8);
          while Bits >= CodeSize do
          begin
            Code := Data and CodeMask;
            Data := Data shr CodeSize;
            Dec(Bits, CodeSize);
            if Code = EOICode then
              Break;
            if Code = ClearCode then
            begin
              CodeSize := FInitialCodeSize + 1;
              CodeMask := (1 shl CodeSize) - 1;
              FreeCode := ClearCode + 2;
              OldCode := 4096;
              Continue;
            end;
            if Code > FreeCode then
              Break;
            if OldCode = 4096 then
            begin
              FirstChar := Suffix[Code];
              Target^ := FirstChar;
              Inc(Target);
              Dec(UnpackedSize);
              OldCode := Code;
              Continue;
            end;
            InCode := Code;
            if Code = FreeCode then
            begin
              StackPointer^ := FirstChar;
              Inc(StackPointer);
              Code := OldCode;
            end;
            while Code > ClearCode do
            begin
              StackPointer^ := Suffix[Code];
              Inc(StackPointer);
              Code := Prefix[Code];
            end;
            FirstChar := Suffix[Code];
            StackPointer^ := FirstChar;
            Inc(StackPointer);
            Prefix[FreeCode] := OldCode;
            Suffix[FreeCode] := FirstChar;
            if (FreeCode = CodeMask) and (CodeSize < 12) then
            begin
              Inc(CodeSize);
              CodeMask := (1 shl CodeSize) - 1;
            end;
            if FreeCode < 4095 then
              Inc(FreeCode);
            OldCode := InCode;
            repeat
              Dec(StackPointer);
              Target^ := StackPointer^;
              Inc(Target);
              Dec(UnpackedSize);
            until StackPointer = @Stack;
          end;
          Inc(SourcePtr);
          Dec(PackedSize);
        end;

      finally
        DataComp := nil;
      end;
    except

    end;
    Result := True;
  end;
  function WriteScanLine(var Img: TBitmap; AScanLine: PByte): Boolean;
  Var
    Row, Col: Integer;
    Pass, Every: Byte;
    P: PByte;
    function IsMultiple(NumberA, NumberB: Integer): Boolean;
    begin
      Result := (NumberA >= NumberB) and (NumberB > 0) and
        (NumberA mod NumberB = 0);
    end;

  var
    PLine: PInternalColor;
    Data: TBitmapData;
  begin
    Result := False;
    P := AScanLine;
    if Img.Map(TMapAccess.Write, Data) then
    begin
      try
        If FInterlace then
        begin
          For Pass := 1 to 4 do
          begin
            Case Pass of
              1:
                begin
                  Row := 0;
                  Every := 8;
                end;
              2:
                begin
                  Row := 4;
                  Every := 8;
                end;
              3:
                begin
                  Row := 2;
                  Every := 4;
                end;
              4:
                begin
                  Row := 1;
                  Every := 2;
                end;
            end;

            Repeat
              PLine := Data.GetScanline(Row);
              for Col := 0 to Img.Width - 1 do
              begin
                PLine[Col] := LLocalPalette[P^];
                Inc(P);
              end;
              Inc(Row, Every);
            until Row >= Img.Height;
          end;
        end
        else
        begin
          for Row := 0 to Img.Height - 1 do
          begin
            PLine := Data.GetScanline(Row);
            for Col := 0 to Img.Width - 1 do
            begin
              PLine[Col] := LLocalPalette[P^];
              Inc(P);
            end;
          end;
        end;
        Result := True;
      finally
        Img.Unmap(Data);
      end;
    end;
  end;

  procedure RenderFrame(const Index : integer; const aFrames : array of TGifFrameItem; const aDisplay : TBitmap);
  var
    I, First, Last: Integer;
  begin
    Last := Index;
    First := Max(0, Last);
    aDisplay.Clear(aFrames[Index].fBackColor);
    while First > 0 do
    begin
      if (fScreenWidth = aFrames[First].Bitmap.Width) and (fScreenHeight = aFrames[First].Bitmap.Height) then
      begin
        if (aFrames[First].FDisposalMethod = GIF_DISPOSAL_BACKGROUND) and (First < Last) then
          Break;
      end;
      Dec(First);
    end;

    for I := First to Last - 1 do
    begin
      case aFrames[I].FDisposalMethod of
        GIF_DISPOSAL_UNSPECIFIED,
        GIF_DISPOSAL_LEAVE:
          begin
            // Copy previous raw frame  onto screen
            MergeBitmap(aFrames[i].Bitmap, aDisplay, aFrames[i].Bitmap.Bounds,
                        aFrames[i].FPos.X, aFrames[i].FPos.Y);
          end;
        GIF_DISPOSAL_BACKGROUND:
          if (I > First) then
          begin
            // Restore background color
            aDisplay.ClearRect(TRectF.Create(aFrames[i].FPos.X, aFrames[i].FPos.Y,
                        aFrames[i].FPos.X + aFrames[i].Bitmap.Width,
                        aFrames[i].FPos.Y + aFrames[i].Bitmap.Height),
                        aFrames[i].fBackColor);
          end;
        GIF_DISPOSAL_PREVIOUS: ; // Do nothing - previous state is already on screen
      end;
    end;
    MergeBitmap(aFrames[Index].Bitmap, aDisplay, aFrames[Index].Bitmap.Bounds, aFrames[Index].FPos.X, aFrames[Index].FPos.Y);
  end;

var
  Introducer: Byte;
  ColorTableSize: Integer;
  tmp: TBitmap;
  LFrame: TGifFrameItem;
  FrameIndex: Integer;
  I: Integer;
  LBC : integer;
  LFrames : array of TGifFrameItem;
  rendered : array of TBitmap;
begin
  Result := False;
  if not Check(Stream) then
    Exit;
  AFrameList.Clear;
  FGifVer := verUnknow;
  FPalette := nil;
  LScanLineBuf := nil;
  try

    Stream.Position := 0;
    Stream.Read(FHeader, SizeOf(FHeader));

{$IFDEF BIGENDIAN}
    with FHeader do
    begin
      ScreenWidth := LEtoN(ScreenWidth);
      ScreenHeight := LEtoN(ScreenHeight);
    end;
{$ENDIF}
    if (FHeader.Packedbit and $80) = $80 then
    begin
      ColorTableSize := FHeader.Packedbit and 7 + 1;
      ReadPalette(Stream, 1 shl ColorTableSize, FPalette);
    end;
    if not ProcHeader then
      Exit;

    FrameIndex := 0;
    SetLength(LFrames, 0);
    while True do
    begin
      LLocalPalette := nil;
      Repeat
        Introducer := ReadAndProcBlock(Stream);
      until (Introducer in [$2C, $3B]);
      if Introducer = $3B then
        Break;

      Stream.Read(LDescriptor, SizeOf(LDescriptor));
{$IFDEF BIGENDIAN}
      with FDescriptor do
      begin
        Left := LEtoN(Left);
        Top := LEtoN(Top);
        Width := LEtoN(Width);
        Height := LEtoN(Height);
      end;
{$ENDIF}
      if (LDescriptor.Packedbit and $80) <> 0 then
      begin
        ColorTableSize := LDescriptor.Packedbit and 7 + 1;
        ReadPalette(Stream, 1 shl ColorTableSize, LLocalPalette);
      end
      else
      begin
        LLocalPalette := Copy(FPalette, 0, Length(FPalette));
      end;

      if not ProcFrame then
        Exit;
      LFrame := TGifFrameItem.Create;
      LFrame.FTime := 10 * LGraphicsCtrlExt.DelayTime;
      LFrame.FDisbitmap := TBitmap.Create(LFrameWidth, LFrameHeight);
      LFrame.FPos := Point(LDescriptor.Left, LDescriptor.Top);
      LFrame.FDisposalMethod := 7 and (LGraphicsCtrlExt.Packedbit shr 2);
      if not ReadScanLine(Stream, @LScanLineBuf[0]) then
        Exit;
      if not WriteScanLine(LFrame.FDisbitmap, @LScanLineBuf[0]) then
        Exit;
      if LGraphCtrlExt then
      begin
        LIsTransparent := (LGraphicsCtrlExt.Packedbit and $01) <> 0;
        If LIsTransparent then
          LBC := LGraphicsCtrlExt.ColorIndex
        else
          LBC := FBackgroundColorIndex;
      end
      else
        LBC := FBackgroundColorIndex;
      LFrame.fBackColor := LLocalPalette[LBC].Color;
      Inc(FrameIndex);
      SetLength(LFrames, FrameIndex);
      LFrames[FrameIndex - 1] := LFrame;
    end;
    SetLength(rendered, Length(LFrames));
    for I := 0 to Length(LFrames) - 1 do
    begin
      tmp := TBitmap.Create(FScreenWidth, FScreenHeight);
      RenderFrame(I, LFrames, tmp);
      rendered[i] := tmp;
    end;
    for I := 0 to Length(LFrames) - 1 do
    begin
      LFrames[i].Bitmap.Assign(rendered[i]);
      FreeAndNil(rendered[i]);
      AFrameList.Add(LFrames[i]);
    end;

    Result := True;
  finally
    LLocalPalette := nil;
    LScanLineBuf := nil;
    rendered := nil;
    LFrames := nil;
  end;
end;

function TGifReader.Check(Stream: TStream): Boolean;
var
  OldPos: Int64;
begin
  try
    OldPos := Stream.Position;
    Stream.Read(FHeader, SizeOf(FHeader));
    Result := (CompareMem(@FHeader.Signature, @GifSignature, 3)) and
      (CompareMem(@FHeader.Version, @VerSignature87a, 3)) or
      (CompareMem(@FHeader.Version, @VerSignature89a, 3));
    Stream.Position := OldPos;
  except
    Result := False;
  end;
end;

function TGifReader.Check(FileName: string): Boolean;
var
  fs: TFileStream;
begin
  Result := False;
  fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    Result := Check(fs);
  except

  end;
  fs.DisposeOf;
end;

constructor TGifReader.Create;
begin
  inherited Create;

end;

destructor TGifReader.Destroy;
begin

  inherited Destroy;
end;

{ TGifFrameItem }

destructor TGifFrameItem.Destroy;
begin
  if FDisbitmap <> nil then
  begin
    FDisbitmap.DisposeOf;
    FDisbitmap := nil;
  end;
  inherited Destroy;
end;

end.

     

     

    Производительность отрисовки текста на мобильных платформах

    в Текст

    Опубликовано

    Кстати, обнаружилось еще пару багов в китайской либе для анимированных гифок... :(

    Вроде бы устранил.

    Вот листинг :

    Спойлер 
    
unit FMX.GifUtils;

interface

uses
  System.Classes, System.SysUtils, System.Types, System.UITypes,
  FMX.Types, FMX.Objects, FMX.Graphics, System.Generics.Collections;

const
  alphaTransparent = $00;
  GifSignature: array [0 .. 2] of Byte = ($47, $49, $46); // GIF
  VerSignature87a: array [0 .. 2] of Byte = ($38, $37, $61); // 87a
  VerSignature89a: array [0 .. 2] of Byte = ($38, $39, $61); // 89a

  GIF_DISPOSAL_UNSPECIFIED = 0;
  GIF_DISPOSAL_LEAVE = 1;
  GIF_DISPOSAL_BACKGROUND = 2;
  GIF_DISPOSAL_PREVIOUS = 3;

type
  TGifVer = (verUnknow, ver87a, ver89a);

  TInternalColor = packed record
    case Integer of
      0:
        (

{$IFDEF BIGENDIAN}
          R, G, B, A: Byte;
{$ELSE}
          B, G, R, A: Byte;
{$ENDIF}
        );
      1:
        (Color: TAlphaColor;
        );
  end;

{$POINTERMATH ON}

  PInternalColor = ^TInternalColor;
{$POINTERMATH OFF}

  TGifRGB = packed record
    R: Byte;
    G: Byte;
    B: Byte;
  end;

  TGIFHeader = packed record
    Signature: array [0 .. 2] of Byte;
    // * Header Signature (always "GIF") */
    Version: array [0 .. 2] of Byte;
    // * GIF format version("87a" or "89a") */
    // Logical Screen Descriptor
    ScreenWidth: word; // * Width of Display Screen in Pixels */
    ScreenHeight: word; // * Height of Display Screen in Pixels */
    Packedbit: Byte; // * Screen and Color Map Information */
    BackgroundColor: Byte; // * Background Color Index */
    AspectRatio: Byte; // * Pixel Aspect Ratio */
  end;

  TGifImageDescriptor = packed record
    Left: word;
    // * X position of image on the display */
    Top: word; // * Y position of image on the display */
    Width: word; // * Width of the image in pixels */
    Height: word; // * Height of the image in pixels */
    Packedbit: Byte; // * Image and Color Table Data Information */
  end;

  TGifGraphicsControlExtension = packed record
    BlockSize: Byte;
    // * Size of remaining fields (always 04h) */
    Packedbit: Byte; // * Method of graphics disposal to use */
    DelayTime: word; // * Hundredths of seconds to wait	*/
    ColorIndex: Byte; // * Transparent Color Index */
    Terminator: Byte; // * Block Terminator (always 0) */
  end;

  TGifReader = class;

  TPalette = TArray<TInternalColor>;

  TGifFrameItem = class;

  TGifFrameList = TObjectList<TGifFrameItem>;
  { TGifReader }

  TGifReader = class(TObject)
  protected
    FHeader: TGIFHeader;
    FPalette: TPalette;
    FScreenWidth: Integer;
    FScreenHeight: Integer;
    FInterlace: Boolean;
    FBitsPerPixel: Byte;
    FBackgroundColorIndex: Byte;
    FResolution: Byte;
    FGifVer: TGifVer;

  public
    function Read(Stream: TStream; var AFrameList: TGifFrameList): Boolean;
      overload; virtual;
    function Read(FileName: string; var AFrameList: TGifFrameList): Boolean;
      overload; virtual;
    function ReadRes(Instance: THandle; ResName: string; ResType: PChar;
      var AFrameList: TGifFrameList): Boolean; overload; virtual;
    function ReadRes(Instance: THandle; ResId: Integer; ResType: PChar;
      var AFrameList: TGifFrameList): Boolean; overload; virtual;

    function Check(Stream: TStream): Boolean; overload; virtual;
    function Check(FileName: string): Boolean; overload; virtual;
  public
    constructor Create; virtual;
    destructor Destroy; override;

    property Header: TGIFHeader read FHeader;
    property ScreenWidth: Integer read FScreenWidth;
    property ScreenHeight: Integer read FScreenHeight;
    property Interlace: Boolean read FInterlace;
    property BitsPerPixel: Byte read FBitsPerPixel;
    property Background: Byte read FBackgroundColorIndex;
    property Resolution: Byte read FResolution;
    property GifVer: TGifVer read FGifVer;
  end;

  TGifFrameItem = class
    FDisposalMethod: Integer;
    FPos: TPoint;
    FTime: Integer;
    FDisbitmap: TBitmap;
  public
    destructor Destroy; override;
    property Bitmap : TBitmap read FDisbitmap;
  end;

implementation

uses
  Math;

function swap16(x: UInt16): UInt16; inline;
begin
  Result := ((x and $FF) shl 8) or ((x and $FF00) shr 8);
end;

function swap32(x: UInt32): UInt32; inline;
begin
  Result := ((x and $FF) shl 24) or ((x and $FF00) shl 8) or
    ((x and $FF0000) shr 8) or ((x and $FF000000) shr 24);
end;

function LEtoN(Value: word): word; overload;
begin
  Result := swap16(Value);
end;

function LEtoN(Value: Dword): Dword; overload;
begin
  Result := swap32(Value);
end;

procedure MergeBitmap(const Source, Dest: TBitmap; SrcRect: TRect;
  DestX, DestY: Integer);
var
  I, J, MoveBytes: Integer;
  SrcData, DestData: TBitmapData;
  lpColorSrc, lpColorDst: PInternalColor;
begin

  With Dest do
  begin
    if Map(TMapAccess.Write, DestData) then
      try
        if Source.Map(TMapAccess.Read, SrcData) then
          try
            if SrcRect.Left < 0 then
            begin
              Dec(DestX, SrcRect.Left);
              SrcRect.Left := 0;
            end;
            if SrcRect.Top < 0 then
            begin
              Dec(DestY, SrcRect.Top);
              SrcRect.Top := 0;
            end;
            SrcRect.Right := Min(SrcRect.Right, Source.Width);
            SrcRect.Bottom := Min(SrcRect.Bottom, Source.Height);
            if DestX < 0 then
            begin
              Dec(SrcRect.Left, DestX);
              DestX := 0;
            end;
            if DestY < 0 then
            begin
              Dec(SrcRect.Top, DestY);
              DestY := 0;
            end;
            if DestX + SrcRect.Width > Width then
              SrcRect.Width := Width - DestX;
            if DestY + SrcRect.Height > Height then
              SrcRect.Height := Height - DestY;

            if (SrcRect.Left < SrcRect.Right) and (SrcRect.Top < SrcRect.Bottom)
            then
            begin
              MoveBytes := SrcRect.Width * SrcData.BytesPerPixel;
              for I := 0 to SrcRect.Height - 1 do
              begin
                lpColorSrc := SrcData.GetPixelAddr(SrcRect.Left,
                  SrcRect.Top + I);
                lpColorDst := DestData.GetPixelAddr(DestX, DestY + I);
                for J := 0 to SrcRect.Width - 1 do
                  if lpColorSrc[J].A <> 0 then
                  begin
                    lpColorDst[J] := lpColorSrc[J];
                  end;
              end;
            end;
          finally
            Source.Unmap(SrcData);
          end;
      finally
        Unmap(DestData);
      end;
  end;

end;

{ TGifReader }

function TGifReader.Read(FileName: string;
  var AFrameList: TGifFrameList): Boolean;
var
  fs: TFileStream;
begin
  Result := False;
  fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    Result := Read(fs, AFrameList);
  except

  end;
  fs.DisposeOf;
end;

function TGifReader.ReadRes(Instance: THandle; ResName: string; ResType: PChar;
  var AFrameList: TGifFrameList): Boolean;
var
  res: TResourceStream;
begin
  res := TResourceStream.Create(HInstance, ResName, ResType);
  Result := Read(res, AFrameList);
  res.DisposeOf;
end;

function TGifReader.ReadRes(Instance: THandle; ResId: Integer; ResType: PChar;
  var AFrameList: TGifFrameList): Boolean;
var
  res: TResourceStream;
begin
  res := TResourceStream.CreateFromID(HInstance, ResId, ResType);
  Result := Read(res, AFrameList);
  res.DisposeOf;
end;

function TGifReader.Read(Stream: TStream;
  var AFrameList: TGifFrameList): Boolean;
var
  LDescriptor: TGifImageDescriptor;
  LGraphicsCtrlExt: TGifGraphicsControlExtension;
  LIsTransparent: Boolean;
  LGraphCtrlExt: Boolean;
  LFrameWidth: Integer;
  LFrameHeight: Integer;
  LLocalPalette: TPalette;
  LScanLineBuf: TBytes;

  procedure ReadPalette(Stream: TStream; Size: Integer; var APalette: TPalette);
  Var
    RGBEntry: TGifRGB;
    I: Integer;
    c: TInternalColor;
  begin
    SetLength(APalette, Size);
    For I := 0 To Size - 1 Do
    Begin
      Stream.Read(RGBEntry, SizeOf(RGBEntry));
      With APalette[I] do
      begin
        R := RGBEntry.R or (RGBEntry.R shl 8);
        G := RGBEntry.G or (RGBEntry.G shl 8);
        B := RGBEntry.B or (RGBEntry.B shl 8);
        A := $FF;
      end;
    End;
  end;

  function ProcHeader: Boolean;
  var
    c: TInternalColor;
  begin
    Result := False;
    With FHeader do
    begin
      if (CompareMem(@Signature, @GifSignature, 3)) and
        (CompareMem(@Version, @VerSignature87a, 3)) or
        (CompareMem(@Version, @VerSignature89a, 3)) then
      begin
        FScreenWidth := FHeader.ScreenWidth;
        FScreenHeight := FHeader.ScreenHeight;

        FResolution := Packedbit and $70 shr 5 + 1;
        FBitsPerPixel := Packedbit and 7 + 1;
        FBackgroundColorIndex := BackgroundColor;
        if CompareMem(@Version, @VerSignature87a, 3) then
          FGifVer := ver87a
        else if CompareMem(@Version, @VerSignature89a, 3) then
          FGifVer := ver89a;
        Result := True;
      end
      else
        Raise Exception.Create('Unknown GIF image format');
    end;

  end;

  function ProcFrame: Boolean;
  var
    LineSize: Integer;
    LBackColorIndex: Integer;
  begin
    Result := False;
    With LDescriptor do
    begin
      LFrameWidth := Width;
      LFrameHeight := Height;
      FInterlace := ((Packedbit and $40) = $40);
    end;

    if LGraphCtrlExt then
    begin
      LIsTransparent := (LGraphicsCtrlExt.Packedbit and $01) <> 0;
      If LIsTransparent then
        LBackColorIndex := LGraphicsCtrlExt.ColorIndex;
    end
    else
    begin
      LIsTransparent := FBackgroundColorIndex <> 0;
      LBackColorIndex := FBackgroundColorIndex;
    end;
    LineSize := LFrameWidth * (LFrameHeight + 1);
    SetLength(LScanLineBuf, LineSize);

    If LIsTransparent then
    begin
      LLocalPalette[LBackColorIndex].A := alphaTransparent;
    end;
    Result := True;
  end;

  function ReadAndProcBlock(Stream: TStream): Byte;
  var
    Introducer, Labels, SkipByte: Byte;
  begin
    Stream.Read(Introducer, 1);
    if Introducer = $21 then
    begin
      Stream.Read(Labels, 1);
      Case Labels of
        $FE, $FF:
          // Comment Extension block or Application Extension block
          while True do
          begin
            Stream.Read(SkipByte, 1);
            if SkipByte = 0 then
              Break;
            Stream.Seek(Int64( SkipByte), soFromCurrent);
          end;
        $F9: // Graphics Control Extension block
          begin
            Stream.Read(LGraphicsCtrlExt, SizeOf(LGraphicsCtrlExt));
            LGraphCtrlExt := True;
          end;
        $01: // Plain Text Extension block
          begin
            Stream.Read(SkipByte, 1);
            Stream.Seek(Int64( SkipByte), soFromCurrent);
            while True do
            begin
              Stream.Read(SkipByte, 1);
              if SkipByte = 0 then
                Break;
              Stream.Seek(Int64( SkipByte), soFromCurrent);
            end;
          end;
      end;
    end;
    Result := Introducer;
  end;

  function ReadScanLine(Stream: TStream; AScanLine: PByte): Boolean;
  var
    OldPos, UnpackedSize, PackedSize: longint;
    I: Integer;
    Data, Bits, Code: Cardinal;
    SourcePtr: PByte;
    InCode: Cardinal;

    CodeSize: Cardinal;
    CodeMask: Cardinal;
    FreeCode: Cardinal;
    OldCode: Cardinal;
    Prefix: array [0 .. 4095] of Cardinal;
    Suffix, Stack: array [0 .. 4095] of Byte;
    StackPointer: PByte;
    Target: PByte;
    DataComp: TBytes;
    B, FInitialCodeSize, FirstChar: Byte;
    ClearCode, EOICode: word;
  begin
    DataComp := nil;
    try
      try
        Stream.Read(FInitialCodeSize, 1);
        OldPos := Stream.Position;
        PackedSize := 0;
        Repeat
          Stream.Read(B, 1);
          if B > 0 then
          begin
            Inc(PackedSize, B);
            Stream.Seek(Int64(B), soFromCurrent);
            CodeMask := (1 shl CodeSize) - 1;
          end;
        until B = 0;
        SetLength(DataComp, 2 * PackedSize);
        SourcePtr := @DataComp[0];
        Stream.Position := OldPos;
        Repeat
          Stream.Read(B, 1);
          if B > 0 then
          begin
            Stream.ReadBuffer(SourcePtr^, B);
            Inc(SourcePtr, B);
          end;
        until B = 0;

        SourcePtr := @DataComp[0];
        Target := AScanLine;
        CodeSize := FInitialCodeSize + 1;
        ClearCode := 1 shl FInitialCodeSize;
        EOICode := ClearCode + 1;
        FreeCode := ClearCode + 2;
        OldCode := 4096;
        CodeMask := (1 shl CodeSize) - 1;
        UnpackedSize := LFrameWidth * LFrameHeight;
        for I := 0 to ClearCode - 1 do
        begin
          Prefix[I] := 4096;
          Suffix[I] := I;
        end;
        StackPointer := @Stack;
        FirstChar := 0;
        Data := 0;
        Bits := 0;
        while (UnpackedSize > 0) and (PackedSize > 0) do
        begin
          Inc(Data, SourcePtr^ shl Bits);
          Inc(Bits, 8);
          while Bits >= CodeSize do
          begin
            Code := Data and CodeMask;
            Data := Data shr CodeSize;
            Dec(Bits, CodeSize);
            if Code = EOICode then
              Break;
            if Code = ClearCode then
            begin
              CodeSize := FInitialCodeSize + 1;
              CodeMask := (1 shl CodeSize) - 1;
              FreeCode := ClearCode + 2;
              OldCode := 4096;
              Continue;
            end;
            if Code > FreeCode then
              Break;
            if OldCode = 4096 then
            begin
              FirstChar := Suffix[Code];
              Target^ := FirstChar;
              Inc(Target);
              Dec(UnpackedSize);
              OldCode := Code;
              Continue;
            end;
            InCode := Code;
            if Code = FreeCode then
            begin
              StackPointer^ := FirstChar;
              Inc(StackPointer);
              Code := OldCode;
            end;
            while Code > ClearCode do
            begin
              StackPointer^ := Suffix[Code];
              Inc(StackPointer);
              Code := Prefix[Code];
            end;
            FirstChar := Suffix[Code];
            StackPointer^ := FirstChar;
            Inc(StackPointer);
            Prefix[FreeCode] := OldCode;
            Suffix[FreeCode] := FirstChar;
            if (FreeCode = CodeMask) and (CodeSize < 12) then
            begin
              Inc(CodeSize);
              CodeMask := (1 shl CodeSize) - 1;
            end;
            if FreeCode < 4095 then
              Inc(FreeCode);
            OldCode := InCode;
            repeat
              Dec(StackPointer);
              Target^ := StackPointer^;
              Inc(Target);
              Dec(UnpackedSize);
            until StackPointer = @Stack;
          end;
          Inc(SourcePtr);
          Dec(PackedSize);
        end;

      finally
        DataComp := nil;
      end;
    except

    end;
    Result := True;
  end;
  function WriteScanLine(var Img: TBitmap; AScanLine: PByte): Boolean;
  Var
    Row, Col: Integer;
    Pass, Every: Byte;
    P: PByte;
    function IsMultiple(NumberA, NumberB: Integer): Boolean;
    begin
      Result := (NumberA >= NumberB) and (NumberB > 0) and
        (NumberA mod NumberB = 0);
    end;

  var
    PLine: PInternalColor;
    Data: TBitmapData;
  begin
    Result := False;
    P := AScanLine;
    if Img.Map(TMapAccess.Write, Data) then
    begin
      try
        If FInterlace then
        begin
          For Pass := 1 to 4 do
          begin
            Case Pass of
              1:
                begin
                  Row := 0;
                  Every := 8;
                end;
              2:
                begin
                  Row := 4;
                  Every := 8;
                end;
              3:
                begin
                  Row := 2;
                  Every := 4;
                end;
              4:
                begin
                  Row := 1;
                  Every := 2;
                end;
            end;
            PLine := Data.GetScanline(Row);
            Repeat
              for Col := 0 to Img.Width - 1 do
              begin
                PLine[Col] := LLocalPalette[P^];
                Inc(P);
              end;
              Inc(Row, Every);
            until Row >= Img.Height;
          end;
        end
        else
        begin
          for Row := 0 to Img.Height - 1 do
          begin
            PLine := Data.GetScanline(Row);
            for Col := 0 to Img.Width - 1 do
            begin
              PLine[Col] := LLocalPalette[P^];
              Inc(P);
            end;
          end;
        end;
        Result := True;
      finally
        Img.Unmap(Data);
      end;
    end;
  end;

var
  Introducer: Byte;
  ColorTableSize: Integer;
  tmp: TBitmap;
  LFrame: TGifFrameItem;
  FrameIndex: Integer;
  I: Integer;
  LBC : integer;
begin
  Result := False;
  if not Check(Stream) then
    Exit;
  AFrameList.Clear;
  FGifVer := verUnknow;
  FPalette := nil;
  LScanLineBuf := nil;
  try

    Stream.Position := 0;
    Stream.Read(FHeader, SizeOf(FHeader));

{$IFDEF BIGENDIAN}
    with FHeader do
    begin
      ScreenWidth := LEtoN(ScreenWidth);
      ScreenHeight := LEtoN(ScreenHeight);
    end;
{$ENDIF}
    if (FHeader.Packedbit and $80) = $80 then
    begin
      ColorTableSize := FHeader.Packedbit and 7 + 1;
      ReadPalette(Stream, 1 shl ColorTableSize, FPalette);
    end;

    if not ProcHeader then
      Exit;

    FrameIndex := 0;
    while True do
    begin
      LLocalPalette := nil;
      Repeat
        Introducer := ReadAndProcBlock(Stream);
      until (Introducer in [$2C, $3B]);
      if Introducer = $3B then
        Break;

      Stream.Read(LDescriptor, SizeOf(LDescriptor));
{$IFDEF BIGENDIAN}
      with FDescriptor do
      begin
        Left := LEtoN(Left);
        Top := LEtoN(Top);
        Width := LEtoN(Width);
        Height := LEtoN(Height);
      end;
{$ENDIF}
      if (LDescriptor.Packedbit and $80) <> 0 then
      begin
        ColorTableSize := LDescriptor.Packedbit and 7 + 1;
        ReadPalette(Stream, 1 shl ColorTableSize, LLocalPalette);
      end
      else
      begin
        LLocalPalette := Copy(FPalette, 0, Length(FPalette));
      end;

      if not ProcFrame then
        Exit;
      LFrame := TGifFrameItem.Create;
      LFrame.FTime := 10 * LGraphicsCtrlExt.DelayTime;
      LFrame.FDisbitmap := TBitmap.Create(FScreenWidth, FScreenHeight);
      tmp := TBitmap.Create(LFrameWidth, LFrameHeight);
      LFrame.FPos := Point(LDescriptor.Left, LDescriptor.Top);
      LFrame.FDisposalMethod := 7 and (LGraphicsCtrlExt.Packedbit shr 2);
      if (LFrameWidth <> FScreenWidth) or (LFrameHeight <> FScreenHeight) then
        LFrame.FDisposalMethod := GIF_DISPOSAL_LEAVE;
      if not ReadScanLine(Stream, @LScanLineBuf[0]) then
        Exit;
      if not WriteScanLine(tmp, @LScanLineBuf[0]) then
        Exit;
      if LGraphCtrlExt then
      begin
        LIsTransparent := (LGraphicsCtrlExt.Packedbit and $01) <> 0;
        If LIsTransparent then
          LBC := LGraphicsCtrlExt.ColorIndex
        else
          LBC := FBackgroundColorIndex;
      end
      else
        LBC := FBackgroundColorIndex;
      if FrameIndex = 0 then
      begin
        LFrame.FDisbitmap.Clear(LLocalPalette[LBC].Color);
        MergeBitmap(tmp, LFrame.FDisbitmap, Bounds(0, 0, LFrameWidth,
          LFrameHeight), LFrame.FPos.x, LFrame.FPos.Y);
      end
      else
      begin

        case AFrameList[AFrameList.Count - 1].FDisposalMethod of
          GIF_DISPOSAL_UNSPECIFIED,
          GIF_DISPOSAL_LEAVE:
            begin
              LFrame.FDisbitmap.CopyFromBitmap(AFrameList[AFrameList.Count - 1]
                .FDisbitmap);
              MergeBitmap(tmp, LFrame.FDisbitmap, Bounds(0, 0, LFrameWidth,
                LFrameHeight), LFrame.FPos.x, LFrame.FPos.Y);
            end;
          GIF_DISPOSAL_BACKGROUND:
            begin
              LFrame.FDisbitmap.Clear(LLocalPalette[LBC].Color);

              MergeBitmap(tmp, LFrame.FDisbitmap, Bounds(0, 0, LFrameWidth,
                LFrameHeight), LFrame.FPos.x, LFrame.FPos.Y);
            end;
          GIF_DISPOSAL_PREVIOUS:
            begin

              for I := AFrameList.Count - 1 downto 0 do
              begin
                if (AFrameList[I].FDisposalMethod = GIF_DISPOSAL_BACKGROUND)
                then
                  Break;
              end;
              if I < 0 then
                I := 0;

              LFrame.FDisbitmap.CopyFromBitmap(AFrameList[I].FDisbitmap);

              MergeBitmap(tmp, LFrame.FDisbitmap, Bounds(0, 0, LFrameWidth,
                LFrameHeight), LFrame.FPos.x, LFrame.FPos.Y);
            end;
          4 .. 7:
            begin
            end;
        end;

      end;
      AFrameList.Add(LFrame);
      tmp.DisposeOf;
      Inc(FrameIndex);
    end;
    Result := True;
  finally
    LLocalPalette := nil;
    LScanLineBuf := nil;
  end;
end;

function TGifReader.Check(Stream: TStream): Boolean;
var
  OldPos: Int64;
begin
  try
    OldPos := Stream.Position;
    Stream.Read(FHeader, SizeOf(FHeader));
    Result := (CompareMem(@FHeader.Signature, @GifSignature, 3)) and
      (CompareMem(@FHeader.Version, @VerSignature87a, 3)) or
      (CompareMem(@FHeader.Version, @VerSignature89a, 3));
    Stream.Position := OldPos;
  except
    Result := False;
  end;
end;

function TGifReader.Check(FileName: string): Boolean;
var
  fs: TFileStream;
begin
  Result := False;
  fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    Result := Check(fs);
  except

  end;
  fs.DisposeOf;
end;

constructor TGifReader.Create;
begin
  inherited Create;

end;

destructor TGifReader.Destroy;
begin

  inherited Destroy;
end;

{ TGifFrameItem }

destructor TGifFrameItem.Destroy;
begin
  if FDisbitmap <> nil then
  begin
    FDisbitmap.DisposeOf;
    FDisbitmap := nil;
  end;
  inherited Destroy;
end;

end.

     

     

    Производительность отрисовки текста на мобильных платформах

    в Текст

    Опубликовано

    Добрый день сообществу!

    Выкладываю на суд первый релизик :)

    Для создания паков со смайлами служит небольшая утилитка. Пока она позволяет только импортировать смайлы из гифок.

    IVG.Chatting.zip

    Производительность отрисовки текста на мобильных платформах

    в Текст

    Опубликовано

    10 часов назад, asviridenkov сказал:

    Можно и так считать. Разница в том, что одно решение сильно более универсальное, может отображать что угодно и оформление меняется через CSS как угодно, без написания кода.

    Александр, я Вас прекрасно понимаю. Вы вложили много труда в свой продукт и хотите его продвигать. У Вас замечательный продукт, но мне не нужен весь функционал. А платить 340$ лишь за часть функционала я не готов.

    Желаю Вам удачи в продвижении Вашего, несомненно, прекрасного и интересного продукта! Но давайте не будем разводить оффтоп.

    Обработка анимированных GIF по рецепту китайского коллеги

    в Анимация

    Опубликовано

    В 04.05.2018 в 12:57, Вадим Смоленский сказал:

    GIF_DISPOSAL_BACKGROUND: // 恢复到背景色 (Revert to background color) begin LFrame.FDisbitmap.Clear (LLocalPalette[FBackgroundColorIndex].Color); MergeBitmap(tmp, LFrame.FDisbitmap, Bounds(0, 0, LFrameWidth, LFrameHeight), LFrame.FPos.x, LFrame.FPos.Y); end;

    В этом участке кода есть одна маленькая ошибка. Иногда это приводит к тому, что на некоторых кадрах теряется прозрачность.

    Я заменил на вот такое : 

    GIF_DISPOSAL_BACKGROUND:
	begin
	  LFrame.FDisbitmap.Clear(LLocalPalette[LGraphicsCtrlExt.ColorIndex].Color);
	  MergeBitmap(tmp, LFrame.FDisbitmap, Bounds(0, 0, LFrameWidth, LFrameHeight), LFrame.FPos.x, LFrame.FPos.Y);
	end;

     

    Производительность отрисовки текста на мобильных платформах

    в Текст

    Опубликовано

    3 часа назад, asviridenkov сказал:

    В составе HCL есть пример чата со смайлами, rich текстом, ссылками, картинками, автоматической конвертацией ссылок на картинки или на google maps в preview и т.д.. Канвасы там тоже нативные используются.

    Это все замечательно, но чем оно мне поможет? :) 

    Производительность отрисовки текста на мобильных платформах

    в Текст

    Опубликовано · Изменено пользователем IVGSoft

    15 минут назад, Barbanel сказал:

    Не зацикливайтесь сейчас на смайлах, делайте итеративно.
    До релиза сойдет вставлять в мемо.текст bb-code или нечто подобное, а уже на канве выводить в этом месте смайл.
    Сделайте релиз и потом уже постепенно прикручивайте плюшки типа смайлов в мемо.
    Все имхо.

    Да я не зацикливаюсь. :) Смайлы в чате автоматически конвертируются из мнемоник в графику.

    Спойлер 
    
  ISmile = interface
  ['{809B9246-71D8-4DE9-A559-2BB91ABD9CBE}']
    procedure SetSprites(const Value : TBitmap);
    function GetSpritesCount: integer;
    function GetSprites: TBitmap;
    procedure SetSpritesCount(const Value: integer);
    procedure SetWidth(const Value: integer);
    procedure SetHeight(const Value: integer);
    function GetHeight: integer;
    function GetWidth: integer;
    procedure SetX(const Value : single);
    procedure SetY(const Value : single);
    function GetX: single;
    function GetY: single;
    function GetCurrentFrame: TBitmap;
    function GetFrame: TBitmap;
    function GetMnemonic: string;
    procedure SetMnemonic(const Value: string);

    function Clone: ISmile;

    property CurrentFrame : TBitmap read GetCurrentFrame;
    property Frame : TBitmap read GetFrame;
    property Sprites : TBitmap read GetSprites write SetSprites;
    property SpritesCount : integer read GetSpritesCount write SetSpritesCount;
    property Width : integer read GetWidth write SetWidth;
    property Height : integer read GetHeight write SetHeight;
    property Mnemonic : string read GetMnemonic write SetMnemonic;
    //position related to message
    property X : single read GetX write SetX;
    property Y : single read GetY write SetY;
  end;


procedure TChatMessageObj.EstimateSize;
var
  lSymW, mW : single;
  k : integer;
  lMsg : string;
  link : IChatURL;

  procedure EstimateInternal(const aSymWidth : single);
  var
    lTxt, lexeme : string;
    lines : TStringList;
    line : TMessageLine;
    obj : TLineObject;
    x, y, maxw : single;
    maxCol, lc, i, j, sp : integer;
    smile : ISmile;
    lTxtLayout : TTextLayout;
  begin
    lTxtLayout := TTextLayoutManager.DefaultTextLayout.Create(nil);
    lTxtLayout.BeginUpdate;
    lTxtLayout.WordWrap := false;
    lTxtLayout.TopLeft := TPointF.Zero;
    lTxtLayout.Trimming := TTextTrimming.None;
    lTxtLayout.MaxSize := TPointF.Create(65536, 65536);
    lTxtLayout.Font.Assign(fFont);
    lTxtLayout.Font.Size := fFont.Size;
    lTxtLayout.EndUpdate;
    lTxt := lMsg;
    for I := 0 to fLines.Count - 1 do
      fLines[i].Free;
    fLines.Clear;
    maxCol := round(fMaxSize.X / aSymWidth);
    lTxt := WrapMessage(lMsg, maxCol);
    lTxt := StringReplace(lTxt, sLineBreak + sLineBreak, sLineBreak, [rfReplaceAll]);
    lc := 0;
    lines := TStringList.Create;
    lines.Text := lTxt;
    lc := lines.Count;
    y := 0;
    maxw := 0;
    fSmiles.Clear;
    for I := 0 to lc - 1 do
    begin
      x := 0;
      line := TMessageLine.Create;
      line.X := x;
      line.Y := y;
      lTxt := lines[i];
      repeat
        sp := FindFirstSmile(lTxt, smile);
        obj.X := x;
        obj.Y := y;
        if sp <> 0 then
        begin
          lexeme := lTxt;
          Delete(lexeme, sp, Length(lTxt) - sp + 1);
          obj.IsText := true;
          obj.Text := lexeme;
          lTxtLayout.Text := lexeme;
          obj.Width := lTxtLayout.TextRect.Width;
          obj.Height := lTxtLayout.TextRect.Height;
          Delete(lTxt, 1, Length(lexeme));
          Delete(lTxt, 1, smile.Mnemonic.Length);
          line.Width := line.Width + obj.Width;
          if line.Height < fLineHeight then
            line.Height := fLineHeight;
          x := x + obj.Width;
          line.Objects.Add(obj);
          smile.X := x;
          smile.Y := y + 5;
          obj.Smile := nil;
          obj.IsText := false;
          obj.Text := '';
          obj.Smile := smile;
          obj.Width := smile.Width;
          obj.Height := smile.Height;
          obj.X := x;
          line.Width := line.Width + obj.Width;
          if line.Height < smile.Height then
            line.Height := smile.Height;
          line.Objects.Add(obj);
          fSmiles.Add(smile);
        end
        else
        begin
          obj.IsText := true;
          obj.Text := lTxt;
          lTxtLayout.Text := lTxt;
          obj.Width := lTxtLayout.TextRect.Width;
          if line.Height < fLineHeight then
            line.Height := fLineHeight;
          line.Objects.Add(obj);
          line.Width := line.Width + obj.Width;
        end;
        x := x + obj.Width;
        if x > maxw then
          maxw := x;
      until sp = 0;
      fLines.Add(line);
      y := y + line.Height + 5;
    end;
    for I := 0 to fLines.Count - 1 do
      for j := 0 to fLines[i].Objects.Count - 1 do
      begin
        obj := fLines[i].Objects[j];
        if not obj.IsText then
          obj.Smile.Y := obj.Y + fLines[i].Height - obj.Smile.Height + 5;
        fLines[i].Objects[j] := obj;
      end;
    fMsgSize.Width := maxw;
    fMsgSize.Height := y;
    FreeAndNil(lines);
    FreeAndNil(lTxtLayout);
  end;
begin
  if fMsg = '' then Exit;
  //extract links here
  fLinks.Clear;
  lMsg := fMsg;
  k := 0;
  fHaveURL := false;
  repeat
    if IsURL(lMsg) then
    begin
      link := TMessageLink.Create;
      link.MaxWidth := fMaxSize.X;
      link.Font := fFont;
      link.URL := ExtractURL(lMsg, '');
      fLinks.Add(link);
      fHaveURL := true;
    end;
  until not IsURL(lMsg);
  //estimate size without links
  lSymW := fAvgSymWidth;
  repeat
    EstimateInternal(lSymW);
    lSymW := lSymW + 0.75;
  until fMsgSize.Width <= fMaxSize.X;
  //place links
  if fLinks.Count > 0 then
  begin
    mW := 0;
    fMsgSize.Height := fMsgSize.Height + fLineHeight + 5;
    fLinksRect := TRectF.Create(0, fMsgSize.Height, 0, fMsgSize.Height);

    for k := 0 to fLinks.Count - 1 do
    begin
      fLinks[k].Position := TPointF.Create(0, fMsgSize.Height);
      if fLinks[k].Width > mW then
        mW := fLinks[k].Width;
      fMsgSize.Height := fMsgSize.Height + fLinks[k].Height;
      fLinksRect.Bottom := fLinksRect.Bottom + fLinks[k].Height;
    end;
    fLinksRect.Right := mW;
    fMsgSize.Width := Max(mW, fMsgSize.Width);
  end;
end;

function TChatMessageObj.FindFirstSmile(const aStr: string; out aSmile : ISmile): integer;
begin
  Result := 0;
  if Assigned(fSmileProvider) then
    Result := fSmileProvider.ScanForSmile(aStr, aSmile)
  else
    aSmile := nil;
end;

     

     

    Производительность отрисовки текста на мобильных платформах

    в Текст

    Опубликовано · Изменено пользователем IVGSoft

    Сообщения чата представлены вот таким интерфейсом

    Спойлер 
    
fMessages : TList<IChatMessage>;
  
  IChatMessage = interface
  ['{8513A7CE-C16C-44D6-BE4A-B06973F9A969}']
    function GetBackColor: TAlphaColor;
    function GetBubbleSize: TSizeF;
    function GetID: integer;
    function GetIsMy: boolean;
    function GetMsg: string;
    function GetMsgPos: TPointF;
    function GetMsgSize: TSizeF;
    function GetTxtColor: TAlphaColor;
    function GetUser: string;
    function GetUserNameHeight: single;
    function GetFont: TFont;
    function GetMaxSize: TPointF;
    function GetSmiles: TList<ISmile>;
    function GetLinks: TList<IChatURL>;
    function GetHasSmiles: boolean;
    function GetHasURL: boolean;
    function GetSmileProvider: ISmileProvider;
    function GetSelected: boolean;
    procedure SetBackColor(const Value: TAlphaColor);
    procedure SetBubbleSize(const Value: TSizeF);
    procedure SetID(const Value: integer);
    procedure SetIsMy(const Value: boolean);
    procedure SetMsg(const Value: string);
    procedure SetMsgPos(const Value: TPointF);
    procedure SetMsgSize(const Value: TSizeF);
    procedure SetTxtColor(const Value: TAlphaColor);
    procedure SetUser(const Value: string);
    procedure SetUserNameHeight(const Value: single);
    procedure SetFont(const Value: TFont);
    procedure SetMaxSize(const Value: TPointF);
    procedure SetAvgSymWidth(const Value: single);
    procedure SetLineHeight(const Value: single);
    procedure SetSmileProvider(const Value: ISmileProvider);
    procedure SetSelected(const Value : boolean);

    function IsPointInMessage(const aPoint : TPointF): boolean;
    function GetLinkByPoint(const aPoint : TPointF): IChatURL;
    procedure RenderMessage(const aRect, aClipRect : TRectF; const aCanvas : INativeCanvas);

    property Msg : string read GetMsg write SetMsg;
    property User : string read GetUser write SetUser;
    property ID : integer read GetID write SetID;
    property IsMy : boolean read GetIsMy write SetIsMy;
    property BubbleSize : TSizeF read GetBubbleSize write SetBubbleSize;
    property MsgSize : TSizeF read GetMsgSize write SetMsgSize;
    property MsgPos : TPointF read GetMsgPos write SetMsgPos;
    property UserNameHeight : single read GetUserNameHeight write SetUserNameHeight;
    property BackColor : TAlphaColor read GetBackColor write SetBackColor;
    property TxtColor : TAlphaColor read GetTxtColor write SetTxtColor;
    property MaxSize : TPointF read GetMaxSize write SetMaxSize;
    property Font : TFont read GetFont write SetFont;
    property Smiles : TList<ISmile> read GetSmiles;
    property Links : TList<IChatURL> read GetLinks;
    property HasSmiles : boolean read GetHasSmiles;
    property HasURL : boolean read GetHasURL;
    property AvgSymWidth : single write SetAvgSymWidth;
    property LineHeight : single write SetLineHeight;
    property SmileProvider : ISmileProvider read GetSmileProvider write SetSmileProvider;
    property Selected : boolean read GetSelected write SetSelected;
  end;

     

     

    Производительность отрисовки текста на мобильных платформах

    в Текст

    Опубликовано · Изменено пользователем IVGSoft

    Да, пожалуйста! :) Не уверен на сколько это поможет сообществу.

    Спойлер

      

    
procedure TIVGChatViewer.Paint;
var
  r : TRectF;
  ss : TCanvasSaveState;
  nCanvas : INativeCanvas;
begin
  inherited;
  if csDesigning in ComponentState then
  begin
    r := ClipRect;
    r.Inflate(-1, -1);
    Canvas.BeginScene;
    Canvas.Stroke.Dash := TStrokeDash.Dash;
    Canvas.Stroke.Color := claBlack;
    Canvas.DrawRect(r, 0, 0, [TCorner.TopLeft, TCorner.TopRight, TCorner.BottomLeft, TCorner.BottomRight], 1);
    Canvas.Font.Size := 16;
    Canvas.Fill.Color := claBlack;
    Canvas.FillText(r, Name, false, 1, [], TTextAlign.Center, TTextAlign.Center);
    Canvas.EndScene;
    Exit;
  end;


  if Assigned(Canvas) then begin
    ss := Canvas.SaveState;
    begin
      fMessagesToShow.Clear;
      nCanvas := Canvas.ToNativeCanvas(TDrawMethod.Native);
      nCanvas.Font.Assign(Canvas.Font);
      nCanvas.NativeDraw(LocalRect, procedure
        var
          i : integer;
          canBreak : boolean;
        begin
          canBreak := false;
          for I := fMessages.Count - 1 downto 0 do
            if IsMessageInViewport(fMessages[i]) then
            begin
              canBreak := true;
              r.Top := fMessages[i].MsgPos.Y - fViewPort;
              r.Bottom := r.Top + fMessages[i].BubbleSize.Height;
              r.Left := fMessages[i].MsgPos.X;
              r.Right := fMessages[i].MsgPos.X + fMessages[i].BubbleSize.Width;
              nCanvas.Fill.Color := fMessages[i].BackColor;
              PaintBubble(r, fMessages[i].IsMy, fMessages[i].Selected, nCanvas);
              if fMessages[i].IsMy then
                r.Left := r.Left + 5
              else
                r.Left := r.Left + 15;
              r.Right := r.Left + fMessages[i].MsgSize.Width;
              r.Bottom := r.Top + fMessages[i].UserNameHeight;
              nCanvas.Font.Assign(fHeaderFont);
              nCanvas.Fill.Color := claWhite;
              nCanvas.FillText(r, fMessages[i].User, false, 1, [], TTextAlign.Leading, TTextAlign.Trailing);
              r.Top := r.Bottom + 5;
              r.Left := r.Left + 5;
              r.Right := r.Left + fMessages[i].MsgSize.Width;
              r.Bottom := r.Top + fMessages[i].MsgSize.Height;
              nCanvas.Font.Style := nCanvas.Font.Style - [TFontStyle.fsBold];
              nCanvas.Fill.Color := fMessages[i].TxtColor;
              fMessages[i].RenderMessage(r, ClipRect, nCanvas);
              fMessagesToShow.Add(fMessages[i]);
            end
            else
              if canBreak then
                Break;
          for i := 0 to fMessagesToShow.Count - 1 do
            PaintSmiles(fMessagesToShow[i], nCanvas, fAniEnabled);
        end);
    end;
    Canvas.RestoreState(ss);
  end;
  fAniEnabled := true;
end;
    В 11.06.2018 в 19:16, ENERGY сказал:

    Т.е. вы отрисовываете текст на битмапе через nativeDraw , а затем его отображаете?

    Нет, сразу через NativeDraw. Оно само на битмапе рисует.

    Производительность отрисовки текста на мобильных платформах

    в Текст

    Опубликовано

    Промежуточный итог. Переписал компонент используя нативный канвас для отрисовки. Скорость на Андроиде на порядок выше. Никаких тормозов.

    Макс, еще раз большое спасибо за наводку! :)

×
×
  • Создать...