unit Windows_BMP;

{$MODE OBJFPC}
{$M+}

// TODO maybe load the entire bitmap into memory at the beginning?
// TODO support RLE (RLE stream).

interface
uses type_fixes, loaders, classes, framebuffers;

type
  THeader = record
    Typ : TUINT16;
    Size : TUINT32; { not reliable. }
    _Reserved : TUINT32;
    ImageOffset : TUINT32; { from the beginning of the file. }
  end;

  TCompressionMode = (cmRGB, cmRLE8, cmRLE4, cmBitfields{unusual});
  TInformationHeader = record
    Size : TUINT32; // 40
    Width : TINT32;
    Height : TINT32; { +: bottom-up (usual); -: top-down. }
    PlaneCount : TUINT16; // 1. (PCX compat).
    BitCount : TUINT16; // 1,4,8,16,24,32. indexed: 1,4,8. Unusual: 16, 32.
    Compression : TCompressionMode;
    SizeImage : TUINT32; // size of image data or 0 (optional).
    PixelsPerMeterX : TInt32; // pixels per meter. most of the time: 0.
    PixelsPerMeterY : TInt32; // pixels per meter. most of the time: 0.
    UsedColorCount : TUInt32; // palette colors: 0 (max. count) or #entries.
    ImportantColorCount : TUInt32; // important palette colors: 0 (all), otherwise #entries.
  end;

  TBitfieldHeader = record
    RedMask : TUInt32; { set bits must be adjacent to each other in this field. No overlaps. }
    GreenMask : TUInt32; { set bits must be adjacent to each other in this field. No overlaps. }
    BlueMask : TUInt32; { set bits must be adjacent to each other in this field. No overlaps. }
    AlphaMask : TUInt32; // inofficial.
  end;

  { Color table UsedColorCount or 2 ** BitCount entries. }

  TPaletteEntry = record
    Blue, Green, Red, Zero : Byte;
  end;

  { offset #"ImageOffset": }
  // Image data. size for RGB = Width * EHHeight * BitCount / 8.
  // Compression = cmBitfields: each line aligned to DWORD.
  //               cmRGB: each line aligned to DWORD.

  // TODO actually use RLE decompressor?
  
  TWindowsBMPLoader = class(TInterfacedObject, ILoader, IInterface)
  private
    fStream : TStream;
    fBHeadersLoaded : TBoolean;
    fHeader : THeader;
    fInformationHeader : TInformationHeader;
    fBitfieldHeader : TBitfieldHeader;
    fRun : TRun;
    fBAllDone : Boolean;
    fInitialPosition : TINT64;
    fBTopToBottom : Boolean;
    fPixmapInfo : IPixmapInfo;
    fPixmapInfoR : TPixmapInfo;
  protected
    function GetHeaders : IPixmapInfo;
  published
    constructor Create(aStream : TStream);
    property Headers : IPixmapInfo read GetHeaders;
    function NextRun : TRun;
  protected
    procedure LoadHeaders;
  public
    destructor Destroy; override;
  end;

implementation
uses sysutils, colors, integer_maths;

constructor TWindowsBMPLoader.Create(aStream : TStream);
begin
  fStream := aStream;
  fBHeadersLoaded := False;
  fBAllDone := False;
  fRun := nil;
  fBTopToBottom := False;
  fPixmapInfoR := TPixmapInfo.Create;
  fPixmapInfo := fPixmapInfoR;
end;

destructor TWindowsBMPLoader.Destroy;
begin
  FreeAndNil(fRun);
  inherited Destroy;
end;

function WrapPaletteEntry(aPaletteEntry : TPaletteEntry) : IColor; inline;
begin
  // FIXME do this.

  Result := nil;
end;


function Max(aA, aB : TUINT32) : TUINT32; inline;
begin
  if aA > aB then
    Result := aA
  else
    Result := aB;
end;

function IIFMask(aCondition : TBoolean; aTrueBranch : TUINT32; aFalseBranch : TUINT32) : TUINT32;
begin
  if aCondition then
    Result := aTrueBranch
  else
    Result := aFalseBranch;
end;

function IIFBFN(aCondition : TBoolean; aTrueBranch : TPixelBitfieldName; aFalseBranch : TPixelBitfieldName) : TPixelBitfieldName;
begin
  if aCondition then
    Result := aTrueBranch
  else
    Result := aFalseBranch;
end;

function CalculateBitfieldFromBMPHeader(const BMPH : TBitfieldHeader) : TPixelBitfield; inline;
var
  vIndex : Integer; // index into Result.
  vBitCount : Integer;
  vBigMask : TUINT32;
  vBitfieldEntryName : TPixelBitfieldName;
  vBitfieldEntryMask : TUINT32;
  vBitfieldEntryLog : TUINT16;
  vBitfieldEntryCount : TUINT16;
  vBRedDone : TBoolean = False;
  vBGreenDone : TBoolean = False;
  vBBlueDone : TBoolean = False;
  vOrderedBitfieldNames : array[0..2] of TPixelBitfieldName; { ordered by nearness to bit index 0 }
  vOrderedBitfieldMasks : array[0..2] of TUINT32;
  vOrderedBitfieldNamesIndex : Integer;
  vDoneBitCount : TUINT32;
begin
  for vIndex := 0 to High(Result) do begin
    Result[vIndex].Name := bnUnused;
    Result[vIndex].Count := 0;
  end;

  if ((BMPH.RedMask and BMPH.GreenMask) <> 0) or
     ((BMPH.RedMask and BMPH.BlueMask) <> 0) or
     ((BMPH.GreenMask and BMPH.BlueMask) <> 0) then
    raise EReadError.Create('Red/Green/Blue masks overlap.');

  if (BMPH.BlueMask < BMPH.GreenMask) and (BMPH.BlueMask < BMPH.RedMask) then begin
    // blue is smallest.
    vOrderedBitfieldNames[0] := bnBlue;
    vOrderedBitfieldMasks[0] := BMPH.BlueMask;

    // red and green remaining.

    if (BMPH.RedMask < BMPH.GreenMask) then begin
      vOrderedBitfieldNames[1] := bnRed;
      vOrderedBitfieldMasks[1] := BMPH.RedMask;

      vOrderedBitfieldNames[2] := bnGreen;
      vOrderedBitfieldMasks[2] := BMPH.GreenMask;
    end else begin
      vOrderedBitfieldNames[1] := bnGreen;
      vOrderedBitfieldMasks[1] := BMPH.GreenMask;

      vOrderedBitfieldNames[2] := bnRed;
      vOrderedBitfieldMasks[2] := BMPH.RedMask;
    end;
  end else if (BMPH.GreenMask < BMPH.BlueMask) and (BMPH.GreenMask < BMPH.RedMask) then begin
    // green is smallest.
    vOrderedBitfieldNames[0] := bnGreen;
    vOrderedBitfieldMasks[0] := BMPH.GreenMask;

    // red and blue remaining.
    if (BMPH.RedMask < BMPH.BlueMask) then begin
      vOrderedBitfieldNames[1] := bnRed;
      vOrderedBitfieldMasks[1] := BMPH.RedMask;

      vOrderedBitfieldNames[2] := bnBlue;
      vOrderedBitfieldMasks[2] := BMPH.BlueMask;
    end else begin
      vOrderedBitfieldNames[1] := bnBlue;
      vOrderedBitfieldMasks[1] := BMPH.BlueMask;

      vOrderedBitfieldNames[2] := bnRed;
      vOrderedBitfieldMasks[2] := BMPH.RedMask;
    end;
  end else begin
    // red is smallest.
    vOrderedBitfieldNames[0] := bnRed;
    vOrderedBitfieldMasks[0] := BMPH.RedMask;

    // green and blue remaining.
    if (BMPH.GreenMask < BMPH.BlueMask) then begin
      vOrderedBitfieldNames[1] := bnGreen;
      vOrderedBitfieldMasks[1] := BMPH.GreenMask;

      vOrderedBitfieldNames[2] := bnBlue;
      vOrderedBitfieldMasks[2] := BMPH.BlueMask;
    end else begin
      vOrderedBitfieldNames[1] := bnBlue;
      vOrderedBitfieldMasks[1] := BMPH.BlueMask;

      vOrderedBitfieldNames[2] := bnGreen;
      vOrderedBitfieldMasks[2] := BMPH.GreenMask;
    end;
  end;

  vBigMask := Max(Max(BMPH.GreenMask, BMPH.BlueMask), BMPH.RedMask);
  vBitCount := INTLOG2(vBigMask);

  vIndex := 0;

  vDoneBitCount := 0;
  for vOrderedBitfieldNamesIndex := 0 to High(vOrderedBitfieldNames) do begin
    vBitfieldEntryName := vOrderedBitfieldNames[vOrderedBitfieldNamesIndex];
    vBitfieldEntryMask := vOrderedBitfieldMasks[vOrderedBitfieldNamesIndex];
    vBitfieldEntryCount := CountBits(vBitfieldEntryMask);
    if vBitfieldEntryMask = 0 then
      raise EReadError.Create('Bitmask value of one of the member slots of the pixel bitfield declaration is 0.');

    vBitfieldEntryLog := INTLog2(vBitfieldEntryMask);

    { handle the unused bits. }

    // vBitfieldEntryLog .. vBitfieldEntryLog - vBitfieldEntryCount [..vDoneBitCount]

    if vDoneBitCount < vBitfieldEntryLog - vBitfieldEntryCount then begin // hole.
      Result[vIndex].Name := bnUnused;
      Result[vIndex].Count := vBitfieldEntryLog - vBitfieldEntryCount - vDoneBitCount;
      Inc(vDoneBitCount, Result[vIndex].Count);
      Inc(vIndex);
    end;

    { handle the used bits. }

    Result[vIndex].Name := vBitfieldEntryName;
    Result[vIndex].Count := vBitfieldEntryCount;
    Inc(vDoneBitCount, vBitfieldEntryCount);
    Inc(vIndex);
  end;
  // TODO fill up for the remaining unused bits?
end;

procedure TWindowsBMPLoader.LoadHeaders;
var
  vUsedColorCount : TUINT32;
  vPaletteEntry : TPaletteEntry;
  vPalette : TIColorArray;
  vPaletteI : Integer;
begin
  if fBHeadersLoaded then
    Exit;

  fInitialPosition := fStream.Position;

  fPixmapInfoR.Colorspace := csRGB;

  fStream.ReadBuffer(fHeader, Sizeof(fHeader));
  fStream.ReadBuffer(fInformationHeader, Sizeof(fInformationHeader));
  if fInformationHeader.Compression = cmBitfields then begin
    fStream.ReadBuffer(fBitfieldHeader, Sizeof(fBitfieldHeader));
  end else begin
    with fBitfieldHeader do begin
      RedMask := 0;
      GreenMask := 0;
      BlueMask := 0;
      AlphaMask := 0;
    end;

    // TODO check machine endianness and vary the bit fields accordingly.

    if fInformationHeader.Compression in [cmRGB, cmRLE8, cmRLE4] then begin
      case fInformationHeader.BitCount of
      1: { indexed } fPixmapInfoR.Colorspace := csIndexed;
      4: { indexed } fPixmapInfoR.Colorspace := csIndexed;
      8: { indexed } fPixmapInfoR.Colorspace := csIndexed;

      16: with fBitfieldHeader do begin
          RedMask   := $00007C00; // 5 bit.
          GreenMask := $000003E0; // 5 bit.
          BlueMask  := $0000001F; // 5 bit.
      end;
      24: with fBitfieldHeader do begin
          RedMask   := $00FF0000; // 8 bit.
          GreenMask := $0000FF00; // 8 bit.
          BlueMask  := $000000FF; // 8 bit.
      end;
      32: with fBitfieldHeader do begin
          RedMask   := $00FF0000; // 8 bit.
          GreenMask := $0000FF00; // 8 bit.
          BlueMask  := $000000FF; // 8 bit.
          AlphaMask := $FF000000; // 8 bit (Adobe Photoshop).
      end;
      else
        raise EReadError.Create(Format('BitCount is invalid (%d)', [fInformationHeader.BitCount]));
      end;
    end;
  end;

  if fPixmapInfoR.Colorspace = csIndexed then begin // read palette.
    vUsedColorCount := fInformationHeader.UsedColorCount;
    if vUsedColorCount = 0 then
      vUsedColorCount := 1 shl fInformationHeader.BitCount;

    SetLength(vPalette, vUsedColorCount);

    if vUsedColorCount > 0 then
      for vPaletteI := 0 to vUsedColorCount - 1 do begin
        fStream.ReadBuffer(vPaletteEntry, Sizeof(vPaletteEntry));
        vPalette[vPaletteI] := WrapPaletteEntry(vPaletteEntry);
      end;
  end else begin // not indexed.
    if fInformationHeader.Compression in [cmRLE8, cmRLE4] then
      raise EReadError.Create('RLE compression is not allowed for Bitmaps with direct color.');
  end;

  fBTopToBottom := fInformationHeader.Height < 0;

  fPixmapInfoR.Width := fInformationHeader.Width;
  fPixmapInfoR.Height := Abs(fInformationHeader.Height);
  fPixmapInfoR.Palette := vPalette;
  fPixmapInfoR.PixelBitfield := CalculateBitfieldFromBMPHeader(fBitfieldHeader);

  fBHeadersLoaded := True;
end;

function TWindowsBMPLoader.NextRun : TRun;
var
  vCurrentPosition : TINT64;
  vJunkCount : TINT64;
  vY : Cardinal;
begin
  if not Assigned(fRun) then begin { first run }
    if fBAllDone then begin
      Result := nil;
      Exit;
    end;
    if not fBHeadersLoaded then
      LoadHeaders;

    vCurrentPosition := (fStream.Position - fInitialPosition);
    if fHeader.ImageOffset < vCurrentPosition then
      raise EReadError.Create('#"ImageOffset" in Bitmap is wrong.');

    vJunkCount := fHeader.ImageOffset - vCurrentPosition;
    SkipJunk(fStream, vJunkCount);

    if fInformationHeader.Height = 0 then begin
      fBAllDone := True;
      Result := nil;
      Exit;
    end;

    fRun := TRun.Create();

    if fBTopToBottom then
      vY := 0
    else
      vY := fInformationHeader.Height - 1;
  end else begin { next runs }
    if fBTopToBottom then begin
      vY := fRun.Y + 1;
      if vY >= -fInformationHeader.Height then begin { height is negative. }
        fBAllDone := True;
        Result := nil; // the end.
        Exit;
      end;
    end else begin
      if vY < 1 then begin
        fBAllDone := True;
        Result := nil; // the end.
        Exit;
      end;
      vY := fRun.Y - 1;
    end;
  end;


  // this point is reached only if there's something left to read.

  fRun.Y := vY;
  // TODO export Run data.

  //    WidthBytes = (bih.biWidth * bih.biBitCount + 31) / 32 * 4;
  // http://www.herdsoft.com/ti/davincie/imex3j8i.htm

  Result := fRun;
end;

function TWindowsBMPLoader.GetHeaders : IPixmapInfo;
begin
  if not fBHeadersLoaded then
    LoadHeaders;

  Result := fPixmapInfo;
end;

initialization

  assert(Sizeof(THeader) = 14);
  assert(Sizeof(TInformationHeader) = 40);
  assert(Sizeof(TBitFieldHeader) = 12);


end.