deccer

unit Unit2;

interface

uses
  Windows, Classes, Graphics, OpenGL;

type
  PPixel32 = ^TPixel32;
  TPixel32 = packed record
    R: byte;
    G: byte;
    B: byte;
    A: byte;
  end;

  PPixel32Array = ^TPixel32Array;
  TPixel32Array = array[0..MaxInt shr 3] of TPixel32;

type
  TBitmap32 = class
  private
    FData: PPixel32Array;
    FWidth: integer;
    FHeight: integer;
    FDataSize: integer;
    function GetScanLine(Row: integer): PPixel32Array;
    procedure SetHeight(const Value: integer);
    procedure SetWidth(Value: integer);
  public
    procedure AssignFromBitmap(const Source: TBitmap);
    constructor Create;
    destructor Destroy; override;
    function IsEmpty: boolean;
    procedure UploadOpenGLTexture(Target: GLEnum; TextureFormat: GLInt);
    property Data: PPixel32Array read FData;
    property DataSize: integer read FDataSize;
    property Height: integer read FHeight write SetHeight;
    property ScanLine[Row: integer]: PPixel32Array read GetScanLine;
    property Width: integer read FWidth write SetWidth;
  end;

implementation

procedure BGR24ToRGBA32(Source, Dest: pointer; PixelCount: integer);
begin
  while PixelCount > 0 do begin
    PChar(Dest)[0] := PChar(Source)[2];
    PChar(Dest)[1] := PChar(Source)[1];
    PChar(Dest)[2] := PChar(Source)[0];
    PChar(Dest)[3] := #255;
    dest := Pointer(Integer(Dest) + 4);
    Source := Pointer(Integer(Source) + 3);
    Dec(PixelCount);
  end;
end;

procedure TBitmap32.AssignFromBitmap(const Source: TBitmap);
var
  iRow: integer;
  iRowOffset: integer;
  pSource: PChar;
  pDest: PChar;

begin
  Assert(Source.PixelFormat = pf24bit);
  Assert((Source.Width and 3) = 0);
  FWidth := Source.Width;
  FHeight := Source.Height;
  FDataSize := FWidth * FHeight * 4;
  ReAllocMem(FData, FDataSize);
  if Height > 0 then begin
    pDest := @PChar(FData)[Width * 4 * (Height - 1)];
    if Height = 1 then begin
      BGR24ToRGBA32(Source.ScanLine[0], pDest, Width);
    end
    else begin
      pSource := Source.ScanLine[0];
      iRowOffset := Integer(Source.ScanLine[1]) - Integer(pSource);
      for iRow := 0 to Height - 1 do begin
        BGR24ToRGBA32(pSource, pDest, Width);
        Dec(pDest, Width * 4);
        Inc(pSource, iRowOffset);
      end;
    end;
  end;
end;

constructor TBitmap32.Create;
begin
  inherited Create;
end;

destructor TBitmap32.Destroy;
begin
  FreeMem(FData);
  inherited Destroy;
end;

function TBitmap32.GetScanLine(Row: integer): PPixel32Array;
begin
  Result := PPixel32Array(@FData[Row * Width]);
end;

function TBitmap32.IsEmpty: boolean;
begin
  Result := (Width = 0) or (Height = 0);
end;

procedure TBitmap32.UploadOpenGLTexture(Target: GLEnum; TextureFormat: GLInt);
var
  pBuffer: pointer;

begin
  pBuffer := Pointer(FData);
  glTexImage2d(Target, 0, TextureFormat, Width, Height, 0, GL_RGBA, GL_UNSIGNED_BYTE, pBuffer);
  FreeMem(pBuffer);
end;

procedure TBitmap32.SetHeight(const Value: integer);
begin
  if FHeight <> Value then begin
    Assert(Value >= 0);
    FHeight := Value;
    FDataSize := FWidth * FHeight * 4;
    ReallocMem(FData, FDataSize);
  end;
end;

procedure TBitmap32.SetWidth(Value: integer);
begin
  if (Value and 3) > 0 then
    Value := (Value and $FFFC) + 4;
  if FWidth <> Value then begin
    Assert(Value >= 0);
    FWidth := Value;
    FDataSize := FWidth * FHeight * 4;
    ReallocMem(FData, FDataSize);
  end;
end;

end.