{
  ------------------------------------------------------------------------------
  Translation of Example.c program for Free Pascal by

  Guus Scholten
  E-Mail : jacco@wishmail.net

  Free Pascal version used : 1.0.6 under Windows ME


  ------------------------------------------------------------------------------
  History:
  DD/MM/YYYY
  07/12/2003: by Guus Scholten (jacco@wishmail.net)
              changed code to use gflLoadBitmapIntoDDB

  26/06/2003: by Guus Scholten (jacco@wishmail.net)
              added scrollbars to main window

  30/04/2003: by Guus Scholten (jacco@wishmail.net)
              + initial creation
}

program WindowsApp;
{$APPTYPE GUI}
{$MODE DELPHI}
uses
  Windows,
  Strings,
  LibGFL,
  ScrollBars;

const

  AppName          = 'GFL_SDK_example';

  { Introduced this comnstant for easier implementation in Free Pascal }
  max_formats      = 1000;

  { Constants from Resource.h }
  IDR_MENU1        =   101;
  IDD_DIALOG1      =   102;
  IDC_LIST2        =  1001;
  ID_OPEN          = 40001;
  ID_EXIT          = 40002;
  ID_ABOUT_FORMATS = 40003;

  { Constants not (yet) in the Free Pascal Windows RTL }
  LVM_FIRST                    = $1000;
  LVM_SETEXTENDEDLISTVIEWSTYLE = LVM_FIRST + 54;
  LVS_EX_FULLROWSELECT         = $00000020;
  OFN_ENABLESIZING             = $00800000;


type
  BUFFER  = array [1..16384] of char;
  PBUFFER = ^BUFFER;

var
  filename   : array [0..MAX_PATH] of char;
  string1    : array [0..MAX_PATH] of char;
  hInst      : Handle;
  hBmp       : HBITMAP = 0;
  list       : array [1..max_formats] of PGFL_FORMAT_INFORMATION;
  ofname     : OPENFILENAME;
  PictScroll : ScrollInfoEx;
  cxClient,
  cyClient   : integer;
  bmpWidth   : integer = 0;
  bmpHeight  : integer = 0;


{ Function not (yet) in the Free Pascal Windows RTL }
function ListView_SetExtendedListViewStyle ( hwndLV : HWND; dwExStyle : DWORD ) : LRESULT;
  begin
    ListView_SetExtendedListViewStyle := SendMessage(hwndLV, LVM_SETEXTENDEDLISTVIEWSTYLE, 0, LPARAM(dwExStyle));
  end;

function SortItem (const format1, format2 : GFL_FORMAT_INFORMATION) : INT;
  begin
    if (format1.NumberOfExtension <> 0) and (format2.NumberOfExtension = 0)
    then Exit(-1);

    if (format1.NumberOfExtension = 0) and (format2.NumberOfExtension <> 0)
    then Exit( 1);

    if (format1.NumberOfExtension = 0) and (format2.NumberOfExtension = 0)
    then Exit(StrIComp(@format1.Description[0],@format2.Description[0]));

    Exit(StrIComp(@format1.Extension[0][0],@format2.Extension[0][0]));
  end;

function SortItem2 (const format1, format2 : GFL_FORMAT_INFORMATION) : INT;
  begin
    SortItem2 := StrIComp(@format1.Description[0],@format2.Description[0]);
  end;

procedure FormatsListCreate ( hWindow : HWND );
  var
    pcol       : LV_COLUMN;
    lvi        : LV_ITEM;
    i,j,k,l    : integer;
    extensions : array [0..127] of char;
    num_fmts   : integer;
    temp       : PGFL_FORMAT_INFORMATION;
  begin
    pcol.mask       := LVCF_TEXT;
    pcol.fmt        := LVCFMT_LEFT;
    pcol.pszText    := 'Name'#0;

    pcol.cchTextMax := strlen(pcol.pszText);
    pcol.iSubItem   := 0;
    ListView_InsertColumn( hWindow, 0, pcol );

    pcol.pszText    := 'Readable'#0;
    pcol.cchTextMax := strlen(pcol.pszText);
    ListView_InsertColumn( hWindow, 1, pcol );

    pcol.pszText    := 'Writable'#0;
    pcol.cchTextMax := strlen(pcol.pszText);
    ListView_InsertColumn( hWindow, 2, pcol );

    pcol.pszText    := 'Extension'#0;
    pcol.cchTextMax := strlen(pcol.pszText);
    ListView_InsertColumn( hWindow, 3, pcol );

    num_fmts := gflGetNumberOfFormat;

    if num_fmts > max_formats
    then num_fmts := max_formats;       // To Do : Else an Error message should be displayed
                                        // Recompile with a larger constant value for max_formats.

    for i := 1 to num_fmts do
    begin
      list[i] := nil;
      New(temp);
      if temp <> nil
      then begin
             gflGetFormatInformationByIndex( i - 1, temp );
             j := i;
             while ((j - 1) >= 1) and
                   (SortItem2(list[j-1]^,temp^) > 0) do
             begin
               list[j] := list[j - 1];
               j := j - 1;
             end;
             list[j] := temp;
           end;
    end;

    for i := 0 to num_fmts - 1 do
    with list[i+1]^ do
    begin
      k := 0;

      for j:=0 to NumberOfExtension - 1 do
      begin
        l := 0;
        while Extension[j][l] <> #0 do
        begin
          extensions[k] := Extension[j][l];
          k := k + 1;
          l := l + 1;
        end;
        extensions[k] := ',';
        k := k + 1;
      end;

      if k > 0
      then k := k - 1;

      extensions[k] := #0;

      lvi.mask     := LVIF_TEXT;
      lvi.iItem    := i;
      lvi.iSubItem := 0;
      lvi.pszText  := @Description[0];
      ListView_InsertItem( hWindow, lvi );

      if (Status and GFL_READ) = GFL_READ
      then ListView_SetItemText( hWindow, i, 1, 'Yes' )
      else ListView_SetItemText( hWindow, i, 1, 'No' );

      if (Status and GFL_WRITE) = GFL_WRITE
      then ListView_SetItemText( hWindow, i, 2, 'Yes' )
      else ListView_SetItemText( hWindow, i, 2, 'No' );

      ListView_SetItemText( hWindow, i, 3, @extensions[0] );
    end;

    ListView_SetColumnWidth( hWindow, 0, LVSCW_AUTOSIZE );
    ListView_SetColumnWidth( hWindow, 1, LVSCW_AUTOSIZE_USEHEADER );
    ListView_SetColumnWidth( hWindow, 2, LVSCW_AUTOSIZE_USEHEADER );
    ListView_SetColumnWidth( hWindow, 3, LVSCW_AUTOSIZE );

    ListView_SetExtendedListViewStyle ( hWindow, LVS_EX_FULLROWSELECT );

    for i:=1 to num_fmts do Dispose(list[i]);
  end;

function HelpDlgProc (hWindow: HWnd; AMessage, WParam,
                      LParam: Longint): BOOL; stdcall; export;
  begin
    case AMessage of
      WM_INITDIALOG : FormatsListCreate ( GetDlgItem(hWindow, IDC_LIST2) );
      WM_COMMAND    : begin
                        if (LoWord(wParam) = IDOK) or (LoWord(wParam) = IDCANCEL)
                        then begin
                               EndDialog(hWindow, 1);
                               Exit(TRUE);
                             end;
                      end;
    end;

    Exit(FALSE);
  end;

procedure OpenFormatsDialog ( hWindow : HWND );
  begin
    DialogBox( hInst, MAKEINTRESOURCE(IDD_DIALOG1), hWindow, @HelpDlgProc );
  end;

procedure AddFilterString ( var filter     : BUFFER;
                            var index      : integer;
                                 AddString : PChar;
                                 AddZero   : Boolean );
  begin
    repeat
      filter[index] := AddString^;
      index         := index + 1;
      AddString     := AddString + 1;
    until filter[index - 1] = #0;

    if not AddZero
    then index := index - 1;
  end;

function OpenFileDialog( hWindow : HWND;filename : PChar) : INT;
  var
    filter1, string1       : PBUFFER;
    ptr1                   : integer;
    i, j, k, ret, num_fmts : integer;
    temp                   : PGFL_FORMAT_INFORMATION;
  begin
    new(filter1);

    num_fmts := gflGetNumberOfFormat;

    if num_fmts > max_formats
    then num_fmts := max_formats;       // To Do : Else an Error message should be displayed
                                        // Recompile with a larger constant value for max_formats.
    for i := 1 to num_fmts do
    begin
      list[i] := nil;
      New(temp);
      if temp <> nil
      then begin
             gflGetFormatInformationByIndex( i - 1, temp );
             j := i;
             while ((j - 1) >= 1) and
                   (SortItem(list[j-1]^,temp^) > 0) do
             begin
               list[j] := list[j - 1];
               j := j - 1;
             end;
             list[j] := temp;
           end;
    end;

    ptr1 := 1;

    AddFilterString( filter1^, ptr1, 'All files', true);
    AddFilterString( filter1^, ptr1, '*.*', true);

    for i := 1 to num_fmts do
    begin
      if (list[i]^.Status and GFL_READ) <> 0
      then begin
             if list[i]^.NumberOfExtension <> 0
             then begin
                    AddFilterString(filter1^, ptr1, @list[i]^.Extension[0][0], False);
                    AddFilterString(filter1^, ptr1, ' - ', False);
                  end;
             AddFilterString(filter1^, ptr1, @list[i]^.Description[0], True);

             if list[i]^.NumberOfExtension <> 0
             then begin
                    for  k := 0 to list[i]^.NumberOfExtension - 1 do
                    begin
                      AddFilterString(filter1^, ptr1, '*.', False);
                      AddFilterString(filter1^, ptr1, @list[i]^.Extension[k][0], False);
                      AddFilterString(filter1^, ptr1, ';', False);
                    end;
                    AddFilterString(filter1^, ptr1, '', True);
                  end
             else AddFilterString(filter1^, ptr1, '*.*', True);
           end;
    end;

    AddFilterString(filter1^, ptr1, '', True);

    New(string1);

    ofname.lStructSize     := sizeof(OPENFILENAME);
    ofname.hwndOwner       := hWindow;
    ofname.lpstrFilter     := @filter1[1];
    ofname.nFilterIndex    := 0;
    ofname.lpstrFile       := @string1[1];
    ofname.nMaxFile        := 10000;
    ofname.lpstrInitialDir := NULL;
    ofname.lpstrTitle      := 'Open picture...';
    ofname.hInstance       := hInst;
    ofname.Flags           := OFN_FILEMUSTEXIST or OFN_PATHMUSTEXIST or OFN_ALLOWMULTISELECT or OFN_EXPLORER or OFN_HIDEREADONLY or OFN_ENABLESIZING;

	ret := LongInt(GetOpenFileName( @ofname ));

    if ret <> 0
    then StrCopy( filename, @string1[1] );

    Dispose( filter1 );
    Dispose( String1 );

    for i := 1 to num_fmts do Dispose(list[i]);

    Exit(ret);
  end;

procedure LoadTheBitmap ( hWindow  : HWND;
                          filename : PChar;
                          var hBmp : HBITMAP );
  var
    load_params : GFL_LOAD_PARAMS;
    info        : GFL_FILE_INFORMATION;
  begin

    if hBmp <> 0
    then DeleteObject(hBmp);

    hBmp := 0;

    gflGetDefaultLoadParams( @load_params );

    load_params.Flags       := load_params.Flags or GFL_LOAD_SKIP_ALPHA;
    load_params.Origin      := GFL_BOTTOM_LEFT;
    load_params.ColorModel  := GFL_BGR;
    load_params.LinePadding := 4;

    if gflLoadBitmapIntoDDB( filename, hBmp, @load_params, @info ) <> 0
    then MessageBox( hWindow, 'Error loading file...', 'Error', MB_OK )
    else InvalidateRect( hWindow, NULL, TRUE );

    if hBmp <> 0
    then begin
           bmpWidth := info.Width;
           bmpHeight:= info.Height;
         end
    else begin
           bmpWidth := 0;
           bmpHeight:= 0;
         end;

    gflFreeFileInformation( @info );

    SizeScrollBars(hWindow, bmpWidth, bmpHeight, PictScroll )

  end;

procedure DrawBitmap ( hDC1 : HDC; hBmp : HBITMAP; xStart, yStart : integer);
  var
    hdcMem        : hDC;
    bm            : BITMAP;
    ptSize, ptOrg : POINT;
  begin
    hdcMem := CreateCompatibleDC( hDC1 );
    SelectObject( hdcMem, hBmp );
    SetMapMode( hdcMem, GetMapMode(hDC1) );

    GetObject( hBmp, sizeof(BITMAP), @bm );

    ptSize.x := bm.bmWidth;
    ptSize.y := bm.bmHeight;
    DPtoLP( hDC1, ptSize, 1);

    ptOrg.x := 0;
    ptOrg.y := 0;
    DPtoLP( hDC1, ptOrg, 1);

    BitBlt( hDC1, xStart, yStart, ptSize.x, ptSize.y, hdcMem, ptOrg.x, ptOrg.y, SRCCOPY);

    DeleteDC( hdcMem );
  end;

function WindowProc(hWindow: HWnd; AMessage, WParam,
          LParam: Longint): Longint; stdcall; export;
  var
    ps       : PAINTSTRUCT;
    hDC1     : HDC;
    hDrop1   : HDROP;
    iHScroll,
    iVScroll : integer;
  begin

    case AMessage of
      WM_CREATE    : begin
                       InitScrollInfoEx(PictScroll);
                     end;
      WM_COMMAND   : begin
                       case LOWORD(wparam) of
                         ID_EXIT : SendMessage( hWindow, WM_DESTROY, 0, 0 );
                         ID_OPEN : begin
                                     if OpenFileDialog( hWindow, @filename[0] ) <> 0
                                     then LoadTheBitmap( hWindow, @filename[0], hBmp );
                                   end;
                         ID_ABOUT_FORMATS : OpenFormatsDialog( hWindow );
                       end;
                     end;
      WM_SIZE    : begin
                     cxClient := Lo (LParam);
                     cyClient := Hi (LParam);

                     SizeScrollBars(hWindow, bmpWidth, bmpHeight, PictScroll );

                     Exit(0);
                   end;
      WM_PAINT   : begin
                     BeginPaint( hWindow, @ps );
                     hDC1 := GetDC( hWindow );

                     if hBmp <> 0
                     then begin
                            GetScrollPos (iHscroll, iVScroll, PictScroll);

                            if (cxClient > bmpWidth)
                            then iHScroll := (bmpWidth - cxClient) div 2;

                            if (cyClient > bmpHeight)
                            then iVScroll := (bmpHeight - cyClient) div 2;

                            DrawBitmap( hDC1, hBmp, - iHscroll, - iVscroll );
                          end;

                     ReleaseDC( hWindow, hDC1 );
                     EndPaint( hWindow, @ps );
                   end;
    WM_VSCROLL   : begin
                     VertScroll(hWindow, WParam, PictScroll);
                     Exit(0);
                   end;
    WM_HSCROLL   : begin
                     HorzScroll(hWindow, WParam, PictScroll);
                     Exit(0);
                   end;
    WM_DROPFILES : begin
                     hDrop1 := HANDLE(wparam);
                     DragQueryFile( hDrop1, 0, @string1[0], sizeof(string1) );
                     LoadTheBitmap( hWindow, @string1[0], hBmp );
                     DragFinish( hDrop1 );
                     Exit(0);
                   end;
    WM_DESTROY   : begin
                     if hBmp <> 0
                     then DeleteObject( hBmp );
                     PostQuitMessage(0);
                     Exit(0);
                   end;
  end;

  WindowProc := DefWindowProc(hWindow, AMessage, WParam, LParam);
end;

{ Register the Window Class }
function WinRegister: Boolean;
var WindowClass: WndClass;
begin
  WindowClass.Style         := cs_hRedraw or cs_vRedraw;
  WindowClass.lpfnWndProc   := WndProc(@WindowProc);
  WindowClass.cbClsExtra    := 0;
  WindowClass.cbWndExtra    := 0;
  WindowClass.hInstance     := system.MainInstance;
  WindowClass.hIcon         := LoadIcon(0, idi_Application);
  WindowClass.hCursor       := LoadCursor(0, idc_Arrow);
  WindowClass.hbrBackground := HBRUSH (COLOR_3DFACE + 1);
  WindowClass.lpszMenuName  := MAKEINTRESOURCE(IDR_MENU1);
  WindowClass.lpszClassName := AppName;

  Result := RegisterClass(@WindowClass) <> 0;
end;

{ Create the Window Class }
function WinCreate: HWnd;
var hWindow: HWnd;
begin
  hWindow := CreateWindowEx(0, AppName, 'GFL SDK example',
         WS_OVERLAPPEDWINDOW or WS_CLIPCHILDREN  or WS_HSCROLL OR WS_VSCROLL,
         cw_UseDefault, cw_UseDefault, cw_UseDefault, cw_UseDefault,
         0, 0, system.MainInstance, nil);

  DragAcceptFiles( hWindow, TRUE );

  if hWindow <> 0 then begin
     ShowWindow(hWindow, CmdShow);
     UpdateWindow(hWindow);
  end;

  Result := hWindow;
end;

var
  AMessage : Msg;
  hWindow  : HWnd;

begin
  hInst := System.MainInstance;

  if not WinRegister
  then begin
         MessageBox(0, 'Register failed', nil, mb_Ok);
         Exit;
       end;

  hWindow := WinCreate;
  if longint(hWindow) = 0
  then begin
         MessageBox(0, 'WinCreate failed', nil, mb_Ok);
         Exit;
       end;

  InitCommonControls;

  while GetMessage(@AMessage, 0, 0, 0) do begin
    TranslateMessage(@AMessage);
    DispatchMessage(@AMessage);
  end;

  Halt(AMessage.wParam);
end.
