//******************************************************************************
// Simple LibGfl Delphi-Demo for GflSDK Version 1.50, by
//  Ingo Neumann,  email: ingo@upstart.de
//  Irwin Scollar, email: al001@mail1.rrz.uni-koeln.de
//------------------------------------------------------------------------------
// History:
// DD/MM/YYYY
// 20/02/2003 : by Pierre-e Gougelet
//             + Support all depth
// 12/03/2001: by Irwin Scollar
//             * better 1, 4 bit support
// 09/03/2001: by Ingo Neumann
//             + Support for LibGfl version 1.50
//             - ABGR_to_BGRA removed
//               LigGfl 1.50 now supports Windows BGRA colormodel
// 06/03/2002: by Irwin Scollar
//             + Support for 1,4,8 bit colormodes
// 10/07/2001: by Ingo Neumann
//             + initial creation
//******************************************************************************
unit ImageView_Form;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, ExtCtrls;

type
  TImageViewForm = class(TForm)
    MainMenu: TMainMenu;
    File1: TMenuItem;
    Formats1: TMenuItem;
    Image: TImage;
    Open1: TMenuItem;
    N1: TMenuItem;
    Exit1: TMenuItem;
    OpenDialog: TOpenDialog;
    Help1: TMenuItem;
    About1: TMenuItem;
    procedure Formats1Click(Sender: TObject);
    procedure ExitClick(Sender: TObject);
    procedure Open1Click(Sender: TObject);
    procedure About1Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    NewPalette: hPalette;
  public
  end;

var
  ImageViewForm: TImageViewForm;

//******************************************************************************
implementation
uses LibGfl, FormatInfo_Form;
{$R *.DFM}

type
  TCol24 = record
    r, g, b: Byte;
  end;

  PLine24 = ^TLine24;
  TLine24 = array[Word] of TCol24;

  TCol32 = record
    r, g, b, a: Byte;
  end;

  PLine32 = ^TLine32;
  TLine32 = array[Word] of TCol32;

  PLine1 = ^TLine1;
  TLine1 = array[Word] of Byte;

//------------------------------------------------------------------------------
function IntToPixelFormat(Bpp: Integer): TPixelFormat;
begin
  case Bpp of
     1: Result := pf1bit;
     4: Result := pf4bit;
     8: Result := pf8bit;
    15: Result := pf15bit;
    16: Result := pf16bit;
    24: Result := pf24bit;
    32: Result := pf32bit;
  else
    Result := pfCustom;
  end;
end;

//------------------------------------------------------------------------------
procedure TImageViewForm.Formats1Click(Sender: TObject);
begin
  FormatInfoForm.Show;
end;

//------------------------------------------------------------------------------
procedure TImageViewForm.ExitClick(Sender: TObject);
begin
  Application.Terminate;
end;

//------------------------------------------------------------------------------
procedure TImageViewForm.Open1Click(Sender: TObject);
var
  finfo: TGFL_FILE_INFORMATION;
  lp: TGFL_LOAD_PARAMS;
  gfl_bmp: PGFL_BITMAP;
  e: GFL_ERROR;
  filename: string;
  bmp: TBitmap;
  x, y, k: Integer;
  LineSrc: Pointer;
  LineDest: Pointer;
  LineIn: PLine1;
  LineOut: PByteArray;
  Mask1: Byte;
  Mask: Byte;
  pal: PLogPalette;
  i, bpp: Integer;
  Arect: TRect;
begin
  gflEnableLZW(GFL_TRUE);

  OpenDialog.Filter := GflFilterString;
  if not OpenDialog.Execute then
    exit;

  // Load GFL Bitmap
  filename := OpenDialog.Filename;
  gflGetDefaultLoadParams(lp);
  lp.ColorModel := GFL_BGR;
  lp.LinePadding := 4;
  //lp.ColorModel := GFL_BGRA;
  //lp.Flags := GFL_LOAD_FORCE_COLOR_MODEL;
  e := gflLoadBitmap(PChar(filename), gfl_bmp, lp, finfo);

  if (e <> gfl_no_error) then begin
    MessageDlg('File not readable: ' + string(gflGetErrorString(e)), mtError, [mbOK], 0);
    exit;
  end;

  pal := nil;
  //bpp := finfo.BitsPerPlane * finfo.NumberOfPlanes;
  if (gfl_bmp.Btype = GFL_BINARY) then begin
    bpp := 1;
  end else begin
    bpp := gfl_bmp.BytesPerPixel * 8;
  end; 

  if not (bpp in [1, 4, 8, 24, 32]) then begin
    MessageDlg('Only 1, 4, 8, 24 or 32 BitsPerPixel are supported in this demo !', mtError, [mbOK], 0);
    gflFreeBitmap(gfl_bmp);
    exit;
  end;

  // Create Delphi Bitmap. If paletted, minimize memory by setting size after pixel format
  bmp := TBitmap.Create;
  bmp.PixelFormat := IntToPixelFormat(bpp);
  bmp.Width := gfl_bmp.Width;
  bmp.Height := gfl_bmp.Height;
  NewPalette := 0;
  //-------------------------------------
  //Fixed. I. Scollar al001@mail1.rrz.uni-koeln.de 6.3.2002


  case bmp.PixelFormat of

    //-------------------
    pf1bit:
      begin
        try
          //pf1bit has a bug. It's palette has only zero entries
          GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 256);
          pal.palVersion := $300;
          pal.palNumEntries := 2;
          for i := 0 to 1 do with pal.palPalEntry[i] do begin
            peRed := i * 255;  peGreen := i * 255;  peBlue := i * 255;
            peFlags := PC_NOCOLLAPSE;
          end;
          if (NewPalette <> 0) then
            DeleteObject(NewPalette);
          NewPalette := CreatePalette(pal^);
        finally
          FreeMem(pal);
        end;
        DeleteObject(bmp.ReleasePalette);
        bmp.Palette := NewPalette;

        //set canvas to white, since positive image usually wanted
        ARect := Bounds(0, 0, bmp.Width, bmp.Height);
        bmp.canvas.Brush.Color := clWhite;
        bmp.Canvas.FillRect(ARect);

        Mask1 := 128; //leftmost bit set

        for y := 0 to gfl_bmp.Height - 1 do begin
          move(  Pointer(Integer(gfl_bmp.data) + (y * gfl_bmp.BytesPerLine))^,
            bmp.Scanline[y]^, gfl_bmp.BytesPerLine);
        end;
        Image.Picture.Bitmap := bmp;
      end;

    //-------------------
    pf4Bit:
      begin
        try
          GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 256);
          pal.palVersion := $300;
          pal.palNumEntries := 16;
          for i := 0 to 15 do with pal.palPalEntry[i] do begin
              peRed   := gfl_bmp.ColorMap^.Red[i];
              peGreen := gfl_bmp.ColorMap^.Green[i];
              peBlue  := gfl_bmp.ColorMap^.Blue[i];
              peFlags := PC_NOCOLLAPSE;
          end;
          if (NewPalette <> 0) then
            DeleteObject(NewPalette);
          NewPalette := CreatePalette(pal^);
        finally
          FreeMem(pal);
        end;
        DeleteObject(bmp.ReleasePalette);
        bmp.Palette := NewPalette;

        for y := 0 to gfl_bmp.Height - 1 do begin
          move(  Pointer(Integer(gfl_bmp.data) + (y * gfl_bmp.BytesPerLine))^,
            bmp.Scanline[y]^, gfl_bmp.BytesPerLine);
        end;
{
        for y := 0 to gfl_bmp.Height - 1 do begin
          LineIn := Pointer(Integer(gfl_bmp.data) + (y * gfl_bmp.BytesPerLine));
          LineOut := bmp.Scanline[y];
          k := -1;
          for x := 0 to gfl_bmp.Width - 1 do begin
            if not Odd(x) then begin
              inc(k);
              LineOut[k] := (LineIn[x] shl 4);
            end else begin
              LineOut[k] := Linein[x] or LineOut[k];
            end;
          end;
        end;
}
        Image.Picture.Bitmap := bmp;
      end;

    //-------------------
    pf8Bit:
      begin
        if gfl_bmp.ColorMap <> nil then begin
          try
            GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 256);
            pal.palVersion := $300;
            pal.palNumEntries := 256;
            for i := 0 to 255 do with pal.palPalEntry[i] do begin
                peRed   := gfl_bmp.ColorMap^.Red[i];
                peGreen := gfl_bmp.ColorMap^.Green[i];
                peBlue  := gfl_bmp.ColorMap^.Blue[i];
                peFlags := PC_NOCOLLAPSE;
            end;
            if (NewPalette <> 0) then
              DeleteObject(NewPalette);

            NewPalette := CreatePalette(pal^);
          finally
            FreeMem(pal);
          end;
        end else begin
          {PCX bug in GflLib, pcx has no color palette, so make gray palette}
          try
            GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 256);
            pal.palVersion := $300;
            pal.palNumEntries := 256;
            for i := 0 to 255 do begin
              pal.palPalEntry[i].peRed := i;
              pal.palPalEntry[i].peGreen := i;
              pal.palPalEntry[i].peBlue := i;
              pal.palPalEntry[i].peFlags := PC_NOCOLLAPSE;
            end;
            if (NewPalette <> 0) then
              DeleteObject(NewPalette);
            NewPalette := CreatePalette(pal^);
          finally
            FreeMem(pal);
          end;
        end;

        DeleteObject(bmp.ReleasePalette);
        bmp.Palette := NewPalette;
        // Copy Pixel Data
        for y := 0 to gfl_bmp.Height - 1 do
                   // Pointer to Scanline of TGFL_Bitmap
            move(  Pointer(Integer(gfl_bmp.data) + (y * gfl_bmp.BytesPerLine))^,
                   // Pointer to Scanline of TBitmap
                   bmp.Scanline[y]^, gfl_bmp.BytesPerLine);

        Image.Picture.Bitmap := bmp;
      end;

    //-------------------
    // 24 + 32 Bit images
    pf24Bit, pf32Bit:
      begin
        for y := 0 to gfl_bmp.Height - 1 do begin
          // get Pointer to Scanlines
          lineSrc  := Pointer(Integer(gfl_bmp.data) + (y * gfl_bmp.BytesPerLine));
          lineDest := bmp.Scanline[y];
          // copy Pixel Data
          move(lineSrc^, lineDest^, gfl_bmp.BytesPerLine);
        end;
        Image.Picture.Bitmap := bmp;
      end;
  end; {case pixelformat}


  // Free Resources
  bmp.Free;
  gflFreeBitmap(gfl_bmp);
end;

//------------------------------------------------------------------------------
procedure TImageViewForm.About1Click(Sender: TObject);
begin
  MessageDlg('Simple LibGfl Delphi-Demo for GflSDK Version 1.50, by' + #13 + #10 + #13 + #10 +
    'Ingo Neumann, email: ingo@upstart.de'                     + #13 + #10 +
    'Irwin Scollar, email: al001@mail1.rrz.uni-koeln.de',
    mtInformation, [mbOK], 0);
end;

procedure TImageViewForm.FormDestroy(Sender: TObject);
begin
  if (NewPalette <> 0) then
    DeleteObject(NewPalette);
end;

end.

