Load static PNG image (gray, 8- 16- 24- 32-bit, no animation, no interlace)

png.pas

function LoadPNG(const Stream: TStream; out Data: PByteArray; out Width, Height: LongInt): Boolean;
const
  IHDR = $52444849;
  IDAT = $54414449;
  IEND = $444E4549;
  PLTE = $45544C50;
  tRNS = $534E5274;
var
  i, j : LongInt;
  Bits : Byte;
  BPP  : Byte;
  BPL  : LongInt;
  ColorType : Byte;
  Interlace : Byte;
  ChunkSize : LongInt;
  ChunkName : LongWord;
  Size    : LongInt;
  Pos     : LongInt;
  Prev    : PByteArray;
  Buffer  : PByteArray;
  CData   : PByteArray;
  Palette : array [0..256 * 3 - 1] of Byte;
  Trans   : array [0..255] of Byte;
  DStream : TDecompressor;  // https://gist.github.com/XProger/3527690ee5673b33b4c3
  CurBit   : Byte;
  PalWord  : Word;
  CurByte  : LongInt;
  PalIdx   : Byte;

  function Paeth(A, B, C: LongInt): LongInt;
  var
    P, PA, PB, PC : LongInt;
  begin
    P := A + B - C;
    PA := Abs(P - A);
    PB := Abs(P - B);
    PC := Abs(P - C);
    if (PA <= PB) and (PA <= PC) then
      Result := A
    else
      if PB <= PC then
        Result := B
      else
        Result := C;
  end;

  procedure Filter(ID: LongInt; Source, Dest, Prev: PByteArray);
  var
    i : LongInt;
  begin
    case ID of
      0 : // no filter
        Move(Source^, Dest^, BPL);
      1 : // sub filter
        begin
          Move(Source^, Dest^, BPP);
          for i := BPP to BPL - 1 do
            Dest^[i] := (Source^[i] + Dest^[i - BPP]);
        end;
      2 : // up filter
        for i := 0 to BPL - 1 do
          Dest^[i] := (Source^[i] + Prev^[i]);
      3 : // average filter
        begin
          for i := 0 to BPP - 1 do
            Dest^[i] := (Source^[i] + Prev^[i] shr 1);
          for i := BPP to BPL - 1 do
            Dest^[i] := (Source^[i] + (Dest^[i - BPP] + Prev^[i]) shr 1);
        end;
      4 : // paeth filter
        begin
          for i := 0 to BPP - 1 do
            Dest^[i] := (Source^[i] + Paeth(0, Prev^[i], 0));
          for i := BPP to BPL - 1 do
            Dest^[i] := Source^[i] + Paeth(Dest^[i - BPP], Prev^[i], Prev^[i - BPP]);
        end;
    end;
  end;

begin
  Result := False;
  if Stream.Size < 8 then
    Exit;
  Pos  := 0;
  Buffer := nil;
  Bits := 0;
  ColorType := 0;
  Interlace := 0;
  Stream.Position := Stream.Position + 8;
  DStream := TDecompressor.Create;
// read chunks
  while Stream.Position < Stream.Size do
  begin
    ChunkSize := SwapInt32(Stream.ReadUInt32);
    Stream.Read(ChunkName, SizeOf(ChunkName));
    case ChunkName of
      IHDR : // Image Header
        begin
          Width     := SwapInt32(Stream.ReadUInt32);
          Height    := SwapInt32(Stream.ReadUInt32);
          Bits      := Stream.ReadUInt8;
          ColorType := Stream.ReadUInt8;
          Stream.Position := Stream.Position + 2;
          Interlace := Stream.ReadUInt8;

        // unsupported formats
          if (Bits > 8) then
          begin
            DStream.Free;
            Exit;
          end;

          case ColorType of
            2 : i := 3;
            4 : i := 2;
            6 : i := 4;
          else
            i := 1;
          end;

          BPP := (Bits + 7) div 8 * i;
          BPL := (Width * Bits + 7) div 8 * i;
          Size := BPL * Height;
          Data   := GetMemory(Size);
          Buffer := GetMemory(Size + Height);
          FillChar(Trans, SizeOf(Trans), $FF);
        end;
      PLTE : // Palette
        Stream.Read(Palette, ChunkSize);
      tRNS : // Transparency info
        Stream.Read(Trans, ChunkSize);
      IDAT : // Compressed image data part
        begin
          CData := GetMemory(ChunkSize);
          Stream.Read(CData^, ChunkSize);
          Inc(Pos, DStream.ReadBlock(@CData[2], @Buffer[Pos]));
          FreeMemory(CData);
        end;
    else
      Stream.Position := Stream.Position + ChunkSize;
    end;
    Stream.Position := Stream.Position + 4; // Chunk CRC
    if ChunkName = IEND then
      break;
  end;
  DStream.Free;

  if Buffer <> nil then
  begin
  // decode image lines
    if Interlace = 0 then
    begin
      Prev := GetMemory(BPL);
      FillChar(Prev^, BPL, 0);
      for i := 0 to Height - 1 do
      begin
        Filter(Buffer^[i * (BPL + 1)], @Buffer^[i * (BPL + 1) + 1], @Data^[(Height - i - 1) * BPL], Prev);
        if i = 0 then
          FreeMemory(Prev);
        Prev := @Data^[(Height - i - 1) * BPL];
      end;
      Result := True;
    end else
    begin
      FreeMemory(Buffer);
      FreeMemory(Data);
      Exit;
    end;
    FreeMemory(Buffer);

  // convert to RGBA
    if ColorType <> 6 then
    begin
      Buffer := GetMemory(Width * Height * 4);
      case ColorType of
        0 : // Grayscale
          for i := 0 to Width * Height - 1 do
          begin
            Buffer^[i * 4 + 0] := Data^[i];
            Buffer^[i * 4 + 1] := Data^[i];
            Buffer^[i * 4 + 2] := Data^[i];
            Buffer^[i * 4 + 3] := Trans[0];
          end;
        2 : // Truecolor RGB
          for i := 0 to Width * Height - 1 do
          begin
            Buffer^[i * 4 + 0] := Data^[i * 3 + 2];
            Buffer^[i * 4 + 1] := Data^[i * 3 + 1];
            Buffer^[i * 4 + 2] := Data^[i * 3 + 0];
            Buffer^[i * 4 + 3] := Trans[0];
          end;
        3 : // Indexed color
          begin
            CurByte := 0;
            PalWord := 0;
            for j := 0 to Height - 1 do
            begin
              CurBit := 8;
              for i := 0 to Width - 1 do
              begin
                if CurBit > 7 then
                begin
                  CurBit := CurBit - 8;
                  if i < Width - 1 then
                    PalWord := Data^[CurByte] or (Data^[CurByte + 1] shl 8)
                  else
                    PalWord := Data^[CurByte];
                  Inc(CurByte);
                end;
                PalIdx := (PalWord shr (8 - Bits - CurBit)) and not ($FFFF shl Bits);
                CurBit := CurBit + Bits;

                Buffer^[(j * Width + i) * 4 + 0] := Palette[PalIdx * 3 + 2];
                Buffer^[(j * Width + i) * 4 + 1] := Palette[PalIdx * 3 + 1];
                Buffer^[(j * Width + i) * 4 + 2] := Palette[PalIdx * 3 + 0];
                Buffer^[(j * Width + i) * 4 + 3] := Trans[PalIdx];
              end;
            end;
          end;
        4 : // Grayscale with Alpha
          for i := 0 to Width * Height - 1 do
          begin
            Buffer^[i * 4 + 0] := Data^[i * 2 + 0];
            Buffer^[i * 4 + 1] := Data^[i * 2 + 0];
            Buffer^[i * 4 + 2] := Data^[i * 2 + 0];
            Buffer^[i * 4 + 3] := Data^[i * 2 + 1];
          end;
      end;
      FreeMemory(Data);
      Data := Buffer;
    end;
  // Swap RGBA -> BGRA (if image is Truecolor with Alpha)
    if ColorType = 6 then
      for i := 0 to Height - 1 do
        RGBA2BGRA(Width, @Data^[i * Width * 4]);
  end;
end;

function SwapInt32(const Value: LongWord): LongWord; assembler;
asm
  bswap eax
end;

procedure RGBA2BGRA(Width: LongInt; Data: PByteArray);
var
  i : LongInt;
  t : Byte;
begin
  for i := 0 to Width - 1 do
  begin
    t := Data^[i * 4];
    Data^[i * 4]     := Data^[i * 4 + 2];
    Data^[i * 4 + 2] := t;
  end;
end;