unit Bitmap;

{ define bmp_usegraph if you don't have VgaMem
}

{ Unit Bitmap, Copr. 1994,96 Matthias K"oppe

  Translate a device-independent bitmap, loaded by LoadBitmap or
  LoadBitmapFile, into an image, which can be drawn by PutImage.

  Supported video modes		Supported bitmaps
  * 16-color modes		* monochrome bitmaps
  * 256-color modes		* 16-color bitmaps
				* 256-color bitmaps
				* 24-bit bitmaps

  Call BitmapToImage, and a nearest-color mapping table will be used.
  This is created by analyzing the bitmap's and the device's palette.

  Call BitmapToImageWithUserPalette if you want to use a user-defined
  mapping table. Set UserPalette nil for using an original map with
  color bitmaps, or the Color/BkColor variables with monochrome bitmaps.

  Instead of Graph's PutImage procedure, we recommend using the
  one implemented in our VgaMem unit: It performs correct clipping.

  $Id: bitmap.pas 1.3 1999/02/09 11:13:27 mkoeppe Exp $
 
  This library is free software; you can redistribute it and/or
  modify it under the terms of the GNU Library General Public
  License as published by the Free Software Foundation; either
  version 2 of the License, or (at your option) any later version.

  This library 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.  See the GNU
  Library General Public License for more details.

  You should have received a copy of the GNU Library General Public
  License along with this library; if not, write to the Free
  Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

}

interface

{$ifdef Windows}
uses WinTypes;
{$else}
uses WinRes;
{$endif}

var
  Color, BkColor: Word;

const
  ColorWeights: TRGBTriple = (rgbtBlue: 1; rgbtGreen: 1; rgbtRed: 1);

{ Bitmap functions
}

function BitmapToImage(ABitmap: PBitmap): pointer;
function BitmapToImageWithUserPalette(ABitmap: PBitmap;
  UserPalette: pointer): pointer;
procedure AddDevicePalette(ABitmap: PBitmap);

{ Palette functions
}

type
  TColorRef = LongInt;

function GetNearestPaletteIndex(Color: TColorRef): Word;
function RGB(Red, Green, Blue: Byte): TColorRef;

{$ifndef Windows}
var
  DevicePalette: array[0..255] of TRGBTriple;
  sDevicePalette: Word;
const
  LookupTable: pointer = nil;

{ Low-level functions
}

procedure SetTable(Table: Word);
procedure CalcDevicePalette;
function Init24BitMapper: Boolean;
procedure Done24BitMapper;

{$ifdef bmp_usegraph}
procedure FreeImage(Image: pointer);
{$endif}
{$endif}

implementation { 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴 }

{$ifdef Windows}
{$i bmpw.pas}
{$else}

{$ifdef bmp_usegraph}
uses Graph, Objects, Memory;	{ for ImageSize/Stream }

procedure FreeImage(Image: pointer);
begin
  with PImage(Image)^ do
    FreeMem(Image, ImageSize(0, 0, imSizeXm1, imSizeYm1))
end;

{$else}
uses Gr, VgaMem, Objects, Memory;	{ for Notification/ImageSize/Stream }

var
  NextNotify: TNotifyProc;

function NotifyBitmap(Notice: Word; Info: LongInt): LongInt; {$ifndef FPK}far;{$endif}
Begin
  case Notice of
    gnpInitGraphics:
      begin
	SetTable(grFlags);
	CalcDevicePalette;
      end;
    gnpCloseGraphics:
      begin
	SetTable(0);
	Done24bitMapper;
      end;
    gnpPalette:
      CalcDevicePalette;
  end;
  NotifyBitmap := DefaultNotify(Notice, Info, NotifyBitmap, NextNotify, 20);
End;

{$endif}

{ Low-level bitmap functions 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}
var
  Bmp2ImgRowProc: Word;
  TheTable: Word;

procedure Bmp2ImgRow_16; near; external;
procedure Bmp2ImgRow_256; near; external;

procedure DoBitmapToImage(ABitmap: PBitmap; Image: pointer;
  Palette: pointer); near; external;

{$L bmp.obj (bmp.asm) }

{ Low-level palette functions 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}
var
  GetDevPalProc: Word;

procedure GetDevPal_16; near; external;
procedure GetDevPal_256; near; external;

function GetDevicePalette(var Palette): Integer; near; external;
procedure DoCalcPalette(var BmpPal; Count, EntrySize: Word;
  var PalBuf); near; external;
procedure LookupPalette(var BmpPal; Count, EntrySize: Word;
  var PalBuf); near; external;

{$L palette.obj (palette.asm) }

procedure TripleToQuad(var Triple, Quad; Count: Word); near; external;

{$L wrespal.obj (wrespal.asm) }

{ 컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴
}

procedure CalcDevicePalette;
begin
  sDevicePalette := GetDevicePalette(DevicePalette)
end;

function PrepareImage(SrcBmp: PBitmap): pointer;
var
  Image: PImage;
  size: LongInt;
begin
  Image := nil;
  with SrcBmp^ do
  begin
    size := ImageSize(0, 0, bmWidth-1, abs(bmHeight)-1);
    If size <> 0
    then begin		{ small image }
      Image := MemAlloc(size);
      If Image <> nil then
      with Image^ do
      begin
	imSizeXm1 := bmWidth - 1;
	imSizeYm1 := abs(bmHeight) - 1;
      end
    end
  end;
  PrepareImage := Image
end;

function Init24BitMapper: Boolean;
var
  Row: array[0..15, 0..15] of TRGBTriple;
  p: pointer;
  aR, aG, aB: Integer;
begin
  Init24Bitmapper := false;
  LookupTable := MemAlloc(16*16*16);
  If LookupTable = nil then Exit;
  p := LookupTable;
  For aR := 0 to 15 do
  begin
    For aG := 0 to 15 do
      For aB := 0 to 15 do
	with Row[aG, aB] do
	begin
	  rgbtRed := aR shl 4;
	  rgbtGreen := aG shl 4;
	  rgbtBlue := aB shl 4
	end;
    DoCalcPalette(Row, 16*16, SizeOf(TRGBTriple), p^);
    Inc(PtrRec(p).Ofs, 16*16);
  end;
  Init24Bitmapper := true;
end;

procedure Done24BitMapper;
begin
  If LookupTable <> nil
  then begin
    FreeMem(LookupTable, 16*16*16);
    LookupTable := nil
  end
end;

function Calc24(Source: PBitmap; Dest: pointer): Boolean;
var
  p: pointer;
  i: Integer;
begin
  Calc24 := false;
  If (LookUpTable = nil) and not Init24BitMapper then Exit;
  with Source^ do
  begin
    p := bmBits;
    Inc(PtrRec(p).Ofs, (abs(bmHeight) - 1) * bmWidthBytes);
    For i := 1 to abs(bmHeight) do
    begin
      {DoCalcPalette}LookUpPalette(p^, bmWidth, SizeOf(TRGBTriple), Dest^);
      Dec(PtrRec(p).Ofs, bmWidthBytes);
      Inc(PtrRec(Dest).Ofs, bmWidth)
    end;
  end;
  Calc24 := true
end;

function BitmapToImageWithUserPalette(ABitmap: PBitmap;
  UserPalette: pointer): pointer;
var
  HelpBitmap: PBitmap;
  Image: pointer;
  BitmapChunk: pointer;
  i: Integer;
Begin
  BitmapToImageWithUserPalette := nil;
  If ABitmap = nil then Exit;
  with ABitmap^ do
  begin
    If bmChunks = 0
    then begin
      If bmBitsPixel = 24
      then begin
	If TheTable and 1 = 0
	then begin
	  BitmapChunk := MemAlloc(bmWidth * abs(bmHeight));
	  If BitmapChunk = nil then Exit;
	  New(HelpBitmap);
	  HelpBitmap^ := ABitmap^;
	  with HelpBitmap^ do
	  begin
	    bmBitsPixel := 8;
	    bmHeight := abs(bmHeight);
	    bmWidthBytes := bmWidth;
	    bmBits := BitmapChunk;
	    bmPalette := nil;
	    bmChunks := 0;
	  end;
	  If Calc24(ABitmap, BitmapChunk)
	  then Image := BitmapToImageWithUserPalette(HelpBitmap, nil)
	  else Image := nil;
	  DeleteBitmap(HelpBitmap);
	end
	else begin
	  Image := PrepareImage(ABitmap);
	  If Image <> nil
	  then begin
	    BitmapChunk := Image;
	    Inc(PtrRec(BitmapChunk).Ofs, 4);
	    Calc24(ABitmap, BitmapChunk);
	  end
	end
      end
      else begin
	Image := PrepareImage(ABitmap);
	If Image <> nil then
	  DoBitmapToImage(ABitmap, Image, UserPalette)
      end
    end
    else begin
      GetMem(Image, SizeOf(TImage) + (bmChunks - 1) * SizeOf(pointer));
      with PImage(Image)^ do
      begin
	imSizeXm1 := -1;
	imSizeYm1 := -1;
	imCount := bmChunks;
	BitmapChunk := bmBits;
	For i := bmChunks - 1 downto 0 do
	begin
	  imPtrs[i] :=
	    BitmapToImageWithUserPalette(PBitmap(BitmapChunk^), UserPalette);
	  Inc(PtrRec(BitmapChunk).Ofs, SizeOf(pointer))
	end
      end;
    end
  End;
  BitmapToImageWithUserPalette := Image
End;

function BitmapToImage(ABitmap: PBitmap): pointer;
var
  PalBuf: array[0..255] of Byte;
  Pal: pointer;
Begin
  If ABitmap = nil
  then begin
    BitmapToImage := nil;
    Exit
  end;
  Pal := nil;
  with ABitmap^ do
    If bmPalette <> nil then Begin
      DoCalcPalette(bmPalette^, 1 shl (bmBitsPixel * bmPlanes),
	SizeOf(TRGBQuad), PalBuf);
      Pal := @PalBuf
    End;
  BitmapToImage := BitmapToImageWithUserPalette(ABitmap, Pal)
End;

procedure AddDevicePalette(ABitmap: PBitmap);
var
  count: Word;
  p: pointer;
Begin
  If ABitmap = nil then Exit;
  with ABitmap^ do
    If bmPalette = nil then Begin
      count := 1 shl (bmBitsPixel * bmPlanes);
      GetMem(bmPalette, SizeOf(TRGBQuad) * count);
      If Count = 2 then Begin
	FillChar(bmPalette^, SizeOf(TRGBQuad) * 2, 0);
	Move(DevicePalette[BkColor], bmPalette^, SizeOf(TRGBTriple));
	p := bmPalette;
	Inc(PtrRec(p).Ofs, SizeOf(TRGBQuad));
	Move(DevicePalette[Color], p^,
	  SizeOf(TRGBTriple));
      End
      else TripleToQuad(DevicePalette, bmPalette^, Count)
    End
End;

function GetNearestPaletteIndex(Color: TColorRef): Word;
var
  Res: TColorRef;
Begin
  DoCalcPalette(Color, 1, 4, Res);
  GetNearestPaletteIndex := Res
End;

function RGB(Red, Green, Blue: Byte): TColorRef; assembler;
asm
	mov	al, Red
	mov	ah, Green
	mov	dl, Blue
	xor	dh, dh
end;

procedure SetTable(Table: Word);
Begin
  TheTable := Table;
  if Table and 1 = 0
  then Begin
    Bmp2ImgRowProc := Ofs(Bmp2ImgRow_16);
    GetDevPalProc := Ofs(GetDevPal_16);
    VirtualBitmapChunkSize := 32000;
  End
  else Begin
    Bmp2ImgRowProc := Ofs(Bmp2ImgRow_256);
    GetDevPalProc := Ofs(GetDevPal_256);
    VirtualBitmapChunkSize := 64000;
  End
End;

var
  oldBitmapLoadProc: TBitmapLoadProc;

function BmpBitmapLoad(var BitmapInfoHeader: TBitmapInfoHeader;
  var S: TStream; Size: LongInt; Palette: pointer;
  CreateImage: Boolean): pointer; {$ifndef FPK}far;{$endif}
var
  Bitmap: PBitmap;
  Image: pointer;
Begin
  Bitmap := oldBitmapLoadProc(BitmapInfoHeader, S, Size, Palette, false);
  If (Bitmap <> nil) and CreateImage then Begin
    Image := BitmapToImage(Bitmap);
    DeleteBitmap(Bitmap);
    BmpBitmapLoad := Image
  End
  else
    BmpBitmapLoad := Bitmap
End;

begin
  { Install WinRes' bitmap load procs
  }
  oldBitmapLoadProc := BitmapLoadProc;
  BitmapLoadProc := BmpBitmapLoad;
  { Install Gr's notification proc
  }
{$ifndef bmp_usegraph}
  InstallNotifyProc(GrNotifyProc, NotifyBitmap);
{$endif}
  { init
  }
  SetTable(0)
{$endif Windows}
end.
