{The Delpi Games Creator - Beta 5
 --------------------------------
 Copyright 1996 John Pullen, Paul Bearne, Jeff Kurtz
 
 This unit is part of the freeware Delphi Games Creator. This unit is
 completely free to use for personal or commercial use. The code is
 supplied with no guarantees on performance or stabilibty and must be 
 used at your own risk.
} 

unit BmpUtil;

interface

uses Classes, SysUtils, Windows, Graphics;

type
  TEffect = (None,SlideRight,SlideLeft,SlideDown,SlideUp,ZoomOpen,
             Curtains,Shutters,Quarters,VerticalLines,HorizontalLines,
             UpDownLines,LeftRightLines,Scrollright,Scrollleft,ScrollUp,ScrollDown,
             Drip,HorizontalOpenOut,VerticalOpenOut,DiagonalTopLeft,DiagonalTopRight,
             DiagonalBottomleft,DiagonalBottomRight,VerticalStripes,HorizontalStripes,
             LargeVerticalStripes,LargeHorizontalStripes,FollowMe);
  //Color Match
  TColorMatch = (cmExact, cmAdd, cmNearest);

  //Image Bank Colour
  TImgLibColor = record
        Red: Byte;
        Green: Byte;
        Blue: Byte;
        Used: Boolean;
  end;

  //Image Structure
  TImgLibImage = record
       Width: Integer;
       Height: Integer;
       Name: String[8];
       Bits: PByte;
  end;
  PImgLibImage = ^TImgLibImage;
  TImgLibImageList = array[0..0] of TImgLibImage;
  PImgLibImageList = ^TImgLibImageList;

  //Intro Structure
  TIntroLibImage = record
       Effect:TEffect;
       Speed:Integer;
       Hold:Integer;
       Width: Integer;
       Height: Integer;
       Name: String[8];
       Bits: PByte;
  end;
  PIntroLibImage = ^TIntroLibImage;
  TIntroLibImageList = array[0..0] of TIntroLibImage;
  PIntroLibImageList = ^TIntroLibImageList;

  //Image Bank Palette
  TImgLibPalette = array[0..255] of TImgLibColor;

  //Image Library Header Structure
  TImgLibHeader = record
       IDent: array[0..3] of Char;
       ImageCount: Integer;
       TransparentColor: Integer;
       Palette: TImgLibPalette;
  end;

  //T256Palette Entry
  T256PaletteEntry = array[0..255] of TPaletteEntry;


// Function Prototypes
//====================

//Calculate Width in bytes of image (image width must be alligned to DWORD boundry)
function WidthBytes(w: Integer): Integer;

//Load and create DIB returning a pointer to the BmpInfoHeader and Bits
procedure LoadDIB256(FileName: String; var BmpInfo: PBitMapInfo; var Bits: PByte;
             var HeaderSize, ImageSize: Integer);

//Create a DIB using Bits Bits and Bitmap info provided updating the Supplied bitmap
//procedure CreateDIB256(Can: TCanvas; BmpInfo: PBitmapInfo; Bits: PByte);

//Return the index of the colour in the specified palette.
function GetPaletteIndex(var ImgPalette: TImgLibPalette; ImgColor: TImgLibColor;
                         var Match: TColorMatch): Byte;

//Clear the specified palette to a black palette adding system colors if specified
procedure ClearPalette(var ImgPalette: TImgLibPalette; AddSysCols: Boolean);

//Create Palette from Bitmap Info Header
function PaletteFromBmpInfo(BmpInfo: PBitmapInfo): HPalette;

//Create a DIB from the specified bits and bitmap info. Assign to TBitmap
procedure CreateDIB256(Bmp: TBitmap; BmpInfo: PBitmapInfo; Bits: PByte);

//Get Nearest Color from Palette
function GetNearestRGB(var Palette: TImgLibPalette; Color: TImgLibColor): Byte;

//Draw Palette
procedure DrawPalette(Canvas: TCanvas; x, y, w: Integer; var Palette: TImgLibPalette);

//Convert and Image Lib Palette to a Bitmap Info Palette
procedure BmpInfoToImgLibPal(var Palette: TImgLibPalette; BmpInfo: PBitmapInfo);

//Convert and Bitmap Info Palette to ImageLib Palette
procedure ImgLibPalToBmpInfo(var Palette: TImgLibPalette; BmpInfo: PBitmapInfo);

//Flip bits for bottom up images
procedure FlipBits(Bits: PByte; WBytes, Height: Integer);

implementation

//function implementation
//=======================

//Calculate Width in bytes of image (image width must be alligned to DWORD boundry)
function WidthBytes(w: Integer): Integer;
begin
     Result := (((w * 8) + 31) div 32) * 4;
end;

//CreateDIB From File
procedure LoadDIB256(FileName: String; var BmpInfo: PBitMapInfo; var Bits: PByte;
             var HeaderSize, ImageSize: Integer);
var
   Stream: TFileStream;
   Header: TBitmapFileHeader;
   NbrCols: Integer;
   BmpHeight: Integer;
   BmpWidth: Integer;
begin
     //Initialise and open file
     Stream := TFileStream.Create(FileName, fmOpenRead);
     try
        //Read file Header
        Stream.ReadBuffer(Header, SizeOf(Header));
        if Header.bfType <> $4D42 then
           raise Exception.Create('Not a valid bitmap file');
        //Allocate memory for Bitmapinfoheader
        HeaderSize := SizeOf(TBitmapInfo) + (256 * SizeOf(TRGBQuad));
        BmpInfo := AllocMem(HeaderSize);
        if BmpInfo = nil then
           raise Exception.Create('Could not allocate memory for TBitmapInfo');
        try
           //Read bitmap info header and validate
           Stream.ReadBuffer(BmpInfo^, SizeOf(TBitmapInfoHeader));
           if BmpInfo^.bmiHeader.biBitCount <> 8 then
              raise Exception.Create('The image must be an 8bpp (256 color) image');
           if BmpInfo^.bmiHeader.biCompression <> BI_RGB then
              raise Exception.Create('The image must be uncompressed (RGB encoded)');
           NbrCols := BmpInfo^.bmiHeader.biClrUsed;
           if NbrCols = 0 then
              NbrCols := 256;
           BmpWidth := WidthBytes(BmpInfo^.bmiHeader.biWidth);
           BmpHeight := Abs(BmpInfo^.bmiHeader.biHeight);
           ImageSize := BmpWidth * BmpHeight;
           //Load Color Table
           ZeroMemory(@BmpInfo^.bmiColors[0], NbrCols * SizeOf(TRGBQuad));
           Stream.ReadBuffer(BmpInfo^.bmiColors, NbrCols * SizeOf(TRGBQuad));
           //Load Bits
           Stream.Seek(Header.bfOffBits, soFromBeginning);
           Bits := AllocMem(ImageSize);
           if Bits = nil then
              raise Exception.Create('Could not allocate memory for bitmap bits');
           try
              Stream.ReadBuffer(Bits^, LongInt(ImageSize));
           except
                 FreeMem(Bits, ImageSize);
                 Bits := nil;
                 raise;
           end;
        except
              FreeMem(BmpInfo, HeaderSize);
              BmpInfo := nil;
              raise;
        end;
     except
           Stream.Free;
           raise;
     end;
     //If the code gets this far the bitmap has been loaded okay
     Stream.Free;

     //if the height is positive the bitmap is Bottom up so flip it.
     if BmpInfo^.bmiHeader.biHeight > 0 then
     begin
          FlipBits(Bits, BmpWidth, BmpHeight);
          BmpInfo^.bmiHeader.biHeight := -BmpInfo^.bmiHeader.biHeight;
     end;

end;


//This function will match a color in the Image Library Palette. If a color is
//matched then the index is returned. If a color is not matched then it is added
//to the palette, otherwise a nearest match is returned;
function GetPaletteIndex(var ImgPalette: TImgLibPalette; ImgColor: TImgLibColor;
                         var Match: TColorMatch): Byte;
var
   n: Byte;
   PalCol: TImgLibColor;
   MatchColor: Byte;
   UnusedColor: Integer;
   ColDif: Integer;
   MinDif: Integer;
begin
     //Check for exact match
     UnusedColor := -1;
     //Start at 1 to ignore transparent colour
     for n:= 1 to 255 do
     begin
          PalCol := ImgPalette[n];
          if PalCol.Used then
          begin
               if (PalCol.Red = ImgColor.Red) and
                  (PalCol.Green = ImgColor.Green) and
                  (PalCol.Blue = ImgColor.Blue) then
                  begin
                       Match := cmExact;
                       Result := n;
                       exit;
                  end;
          end
          else
              if UnusedColor = -1 then
                 UnusedColor := n;
     end;

     //Add Color
     if UnusedColor <> - 1 then
     begin
          PalCol.Red := ImgColor.Red;
          PalCol.Green := ImgColor.Green;
          PalCol.Blue := ImgColor.Blue;
          PalCol.Used := True;
          ImgPalette[UnusedColor] := PalCol;
          Match := cmAdd;
          Result := UnusedColor;
          exit;
     end;

     //Match Nearest Color
     MinDif := 768;
     MatchColor := 0;
     //Start at 1 to ignore transparent colour
     for n := 1 to 255 do
     begin
          PalCol := ImgPalette[n];
          ColDif := Abs(PalCol.Red - ImgColor.Red) +
                    Abs(PalCol.Green - ImgColor.Green) +
                    Abs(PalCol.Blue - ImgColor.Blue);
          if ColDif < MinDif then
          begin
               MinDif := ColDif;
               MatchColor := n;
          end;
     end;
     Match := cmNearest;
     Result := MatchColor;
end;

//Clear the specified palette to a black palette adding system colors if specified
procedure ClearPalette(var ImgPalette: TImgLibPalette; AddSysCols: Boolean);
var
   n: Integer;
   SysCols: array[0..9] of TPaletteEntry;
   dc: HDC;
   Handle: Hwnd;
begin
     //First Blat everything
     FillChar(ImgPalette, SizeOf(ImgPalette), 0);

     //Get System Colors?
     if not AddSysCols then exit;
     Handle := GetFocus;
     dc := GetDC(Handle);
     ImgPalette[0].Used := True;
     GetSystemPaletteEntries(dc, 0, 10, SysCols);
     for n := 0 to 9 do
     begin
          with ImgPalette[n] do
          begin
               Red := SysCols[n].peRed;
               Blue := SysCols[n].peBlue;
               Green := SysCols[n].peGreen;
               Used := True;
          end;
     end;
     GetSystemPaletteEntries(dc,246, 10, SysCols);
     for n := 0 to 9 do
     begin
          with ImgPalette[n + 246] do
          begin
               Red := SysCols[n].peRed;
               Blue := SysCols[n].peBlue;
               Green := SysCols[n].peGreen;
               Used := True;
          end;
     end;
     ReleaseDC(Handle, dc);
end;

//Create Palette from Bitmap Info Header
function PaletteFromBmpInfo(BmpInfo: PBitmapInfo): HPalette;
var
   PalSize, n: Integer;
   Palette: PLogPalette;
begin
     //Allocate Memory for Palette
     PalSize := SizeOf(TLogPalette) + (256 * SizeOf(TPaletteEntry));
     Palette := AllocMem(PalSize);

     //Fill in structure
     with Palette^ do
     begin
          palVersion := $300;
          palNumEntries := 256;
          for n := 0 to 255 do
          begin
               palPalEntry[n].peRed := BmpInfo^.bmiColors[n].rgbRed;
               palPalEntry[n].peGreen := BmpInfo^.bmiColors[n].rgbGreen;
               palPalEntry[n].peBlue := BmpInfo^.bmiColors[n].rgbBlue;
               palPalEntry[n].peFlags := 0;
          end;
     end;
     Result := CreatePalette(Palette^);
     FreeMem(Palette, PalSize);
end;

//Create a DIB from the specified bits and bitmap info. Assign to TBitmap
procedure CreateDIB256(Bmp: TBitmap; BmpInfo: PBitmapInfo; Bits: PByte);
var
   Focus: hWnd;
   dc: HDC;
   OldPal: HPalette;
begin
     //First Release Handle and Palette from BMP
     DeleteObject(Bmp.ReleaseHandle);
     DeleteObject(Bmp.ReleasePalette);

     Focus := GetFocus;
     dc := GetDC(Focus);
     Bmp.Palette := PaletteFromBmpInfo(BmpInfo);
     OldPal := SelectPalette(dc, Bmp.Palette, False);
     RealizePalette(dc);

     Bmp.Handle := CreateDIBitmap(dc, BmpInfo^.bmiHeader, CBM_INIT,
               Pointer(Bits), BmpInfo^, DIB_RGB_COLORS);
     SelectPalette(dc, OldPal, True);
     ReleaseDC(Focus, DC);
     if Bmp.Handle = 0 then
        Exception.Create('CreateDIBitmap failed');
end;

//Get Nearest Color from Palette
function GetNearestRGB(var Palette: TImgLibPalette; Color: TImgLibColor): Byte;
var
   MinDif, ColDif, n: Integer;
   MatchColor: Byte;
   PalCol: TImgLibColor;
begin
     //Match Nearest Color
     MinDif := 768;
     MatchColor := 0;
     //Start at 1 to ignore transparent colour
     for n := 0 to 255 do
     begin
          PalCol := Palette[n];
          ColDif := Abs(PalCol.Red - Color.Red) +
                    Abs(PalCol.Green - Color.Green) +
                    Abs(PalCol.Blue - Color.Blue);
          if ColDif < MinDif then
          begin
               MinDif := ColDif;
               MatchColor := n;
          end;
     end;
     Result := MatchColor;
end;

//Draw Palette
procedure DrawPalette(Canvas: TCanvas; x, y, w: Integer; var Palette: TImgLibPalette);
var
   xc, yc, xp, yp: Integer;
   LogPal: PLogPalette;
   ColIdx: Integer;
   PalCol: TImgLibColor;
   NewPal, OldPal: HPalette;
begin
     //Create, Select and Realize Logical Palette
     GetMem(LogPal, SizeOf(TLogPalette) + (256 * SizeOf(TPaletteEntry)));
     with LogPal^ do
     begin
          palVersion := $300;
          palNumEntries := 256;
          for ColIdx := 0 to 255 do
          begin
               PalCol := Palette[ColIdx];
               palPalEntry[ColIdx].peRed := PalCol.Red;
               palPalEntry[ColIdx].peGreen := PalCol.Green;
               palPalEntry[ColIdx].peBlue := PalCol.Blue;
               palPalEntry[ColIdx].peFlags := 0;
          end;
     end;
     NewPal := CreatePalette(LogPal^);
     OldPal := SelectPalette(Canvas.Handle, NewPal, False);
     RealizePalette(Canvas.Handle);

     ColIdx := 0;
     for yc := 0 to 15 do
     begin
          for xc := 0 to 15 do
          begin
               xp := x + (w * xc);
               yp := y + (w * yc);
               PalCol := Palette[ColIdx];
               Canvas.Brush.Color := PALETTERGB(PalCol.Red, PalCol.Green, PalCol.Blue);
               Canvas.FillRect(Rect(xp, yp, xp + (w - 2), yp + (w - 2)));
               Inc(ColIdx);
          end;                     
     end;
     SelectPalette(Canvas.Handle, OldPal, True);
     FreeMem(LogPal, SizeOf(TLogPalette) + (256 * SizeOf(TPaletteEntry)));
end;

//Convert and Image Lib Palette to a Bitmap Info Palette
procedure BmpInfoToImgLibPal(var Palette: TImgLibPalette; BmpInfo: PBitmapInfo);
var
   n: Integer;
   Col: TRGBQuad;
begin
     for n := 0 to 255 do
     begin
          Col := BmpInfo^.bmiColors[n];
          Palette[n].Red := Col.rgbRed;
          Palette[n].Green := Col.rgbGreen;
          Palette[n].Blue := Col.rgbBlue;
     end;
end;

//Convert and Bitmap Info Palette to ImageLib Palette
procedure ImgLibPalToBmpInfo(var Palette: TImgLibPalette; BmpInfo: PBitmapInfo);
var
   n: Integer;
   Col: TImgLibColor;
begin
     // start at 1 as index is for transparency
     for n := 0 to 255 do
     begin
          Col := Palette[n];
          with BmpInfo^.bmiColors[n] do
          begin
               rgbRed := Col.Red;
               rgbGreen := Col.Green;
               rgbBlue := Col.Blue;
          end;
     end;
end;

//Flip bits for bottom up images
procedure FlipBits(Bits: PByte; WBytes, Height: Integer);
var
   TempBits, TempPtr: PByte;
   Size: Integer;
   n: Integer;
begin
     //Allocate memory and take a copy of image
     Size := WBytes * Height;
     GetMem(TempBits, Size);
     Move(Bits^, TempBits^, Size);
     //Now copy back in reverse order
     TempPtr := TempBits; //Set TempPtr to Last line of Imagee
     Inc(TempPtr, Size - WBytes);
     for n := 1 to Height do
     begin
          Move(TempPtr^, Bits^, WBytes);
          Dec(TempPtr, WBytes);
          Inc(Bits, WBytes);
     end;
     //Free Memory
     FreeMem(TempBits, Size);
end;

end.
