;;; Copyright (c) 2005, Michael Goffioul (michael dot goffioul at swing dot be)
;;;
;;;   This program 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.
;;;
;;;   See file '../../Copyright' for full details.
;;;
;;; FOREIGN FUNCTION INTERFACE TO MICROSOFT WINDOWS API
;;;

(defpackage "WIN32"
  (:use "COMMON-LISP" "FFI")
  (:export))

(in-package "WIN32")

(clines
  "#include <windows.h>"
  "#include <commctrl.h>"
  )

;; Windows types

(def-foreign-type HANDLE :pointer-void)
(def-foreign-type LPCSTR :cstring)
(def-foreign-type WNDPROC :pointer-void)
(def-foreign-type DWORD :unsigned-int)
(def-foreign-type WORD :unsigned-short)

;; Windows constants

(defmacro define-win-constant (name value &optional (c-type :int))
  `(defconstant ,name ,value))

(define-win-constant *TRUE* 1)
(define-win-constant *FALSE* 0)

(define-win-constant *WM_CLOSE*         #x0010)
(define-win-constant *WM_COMMAND*       #x0111)
(define-win-constant *WM_CONTEXTMENU*   #x007b)
(define-win-constant *WM_COPY*          #x0301)
(define-win-constant *WM_CREATE*        #x0001)
(define-win-constant *WM_CUT*           #x0300)
(define-win-constant *WM_DESTROY*       #x0002)
(define-win-constant *WM_GETFONT*       #x0031)
(define-win-constant *WM_GETMINMAXINFO* #x0024)
(define-win-constant *WM_INITMENU*      #x0116)
(define-win-constant *WM_INITMENUPOPUP* #x0117)
(define-win-constant *WM_NCPAINT*       #x0085)
(define-win-constant *WM_NOTIFY*        #x004e)
(define-win-constant *WM_PAINT*         #x000f)
(define-win-constant *WM_PASTE*         #x0302)
(define-win-constant *WM_QUIT*          #x0012)
(define-win-constant *WM_SETFOCUS*      #x0007)
(define-win-constant *WM_SETFONT*       #x0030)
(define-win-constant *WM_SIZE*          #x0005)
(define-win-constant *WM_UNDO*          #x0304)
(define-win-constant *WM_USER*          #x0400)

(define-win-constant *WS_BORDER*                #x00800000)
(define-win-constant *WS_CHILD*                 #x40000000)
(define-win-constant *WS_CLIPCHILDREN*          #x02000000)
(define-win-constant *WS_CLIPSIBLINGS*          #x04000000)
(define-win-constant *WS_DLGFRAME*              #x00400000)
(define-win-constant *WS_DISABLED*              #x08000000)
(define-win-constant *WS_HSCROLL*               #x00100000)
(define-win-constant *WS_OVERLAPPEDWINDOW*      #x00CF0000)
(define-win-constant *WS_VISIBLE*               #x10000000)
(define-win-constant *WS_VSCROLL*               #x00200000)

(define-win-constant *WS_EX_CLIENTEDGE* #x00000200)

(define-win-constant *RICHEDIT_CLASS*   "RichEdit20A")
(define-win-constant *WC_LISTVIEW*      "SysListView32")
(define-win-constant *WC_TABCONTROL*    "SysTabControl32")

(define-win-constant *HWND_BOTTOM*      (make-pointer  1 'HANDLE))
(define-win-constant *HWND_NOTOPMOST*   (make-pointer -2 'HANDLE))
(define-win-constant *HWND_TOP*         (make-pointer  0 'HANDLE))
(define-win-constant *HWND_TOPMOST*     (make-pointer -1 'HANDLE))

(define-win-constant *SWP_DRAWFRAME*            #x0020)
(define-win-constant *SWP_HIDEWINDOW*           #x0080)
(define-win-constant *SWP_NOMOVE*               #x0002)
(define-win-constant *SWP_NOOWNERZORDER*        #x0200)
(define-win-constant *SWP_NOREDRAW*             #x0008)
(define-win-constant *SWP_NOREPOSITION*         #x0200)
(define-win-constant *SWP_NOSIZE*               #x0001)
(define-win-constant *SWP_NOZORDER*             #x0004)
(define-win-constant *SWP_SHOWWINDOW*           #x0040)

(define-win-constant *BS_DEFPUSHBUTTON* #x00000000)
(define-win-constant *BS_PUSHBUTTON*    #x00000001)

(define-win-constant *BN_CLICKED*       0)

(define-win-constant *ES_AUTOHSCROLL*   #x0080)
(define-win-constant *ES_AUTOVSCROLL*   #x0040)
(define-win-constant *ES_LEFT*          #x0000)
(define-win-constant *ES_MULTILINE*     #x0004)

(define-win-constant *EM_CANUNDO*       #x00c6)
(define-win-constant *EM_SETEVENTMASK*  (+ *WM_USER* 69))
(define-win-constant *EM_SETSEL*        #x00b1)
(define-win-constant *EM_UNDO*          #x00c7)
(define-win-constant *EN_CHANGE*        #x0300)
(define-win-constant *ENM_CHANGE*       #x00000001)

(define-win-constant *TCIF_IMAGE*       #x0002)
(define-win-constant *TCIF_PARAM*       #x0008)
(define-win-constant *TCIF_RTLREADING*  #x0004)
(define-win-constant *TCIF_STATE*       #x0010)
(define-win-constant *TCIF_TEXT*        #x0001)

(define-win-constant *TCHT_NOWHERE*     #x0001)
(define-win-constant *TCHT_ONITEM*      #x0006)
(define-win-constant *TCHT_ONITEMICON*  #x0002)
(define-win-constant *TCHT_ONITEMLABEL* #x0004)

(define-win-constant *TCM_FIRST*        #x1300)
(define-win-constant *TCN_FIRST*        #xfffffdda)
(define-win-constant *TCM_ADJUSTRECT*   (+ *TCM_FIRST* 40))
(define-win-constant *TCM_DELETEITEM*   (+ *TCM_FIRST* 8))
(define-win-constant *TCM_GETCURSEL*    (+ *TCM_FIRST* 11))
(define-win-constant *TCM_HITTEST*      (+ *TCM_FIRST* 13))
(define-win-constant *TCM_INSERTITEM*   (+ *TCM_FIRST* 7))
(define-win-constant *TCM_SETCURSEL*    (+ *TCM_FIRST* 12))
(define-win-constant *TCM_SETITEM*      (+ *TCM_FIRST* 6))
(define-win-constant *TCN_SELCHANGE*    (- *TCN_FIRST* 1))

(define-win-constant *NM_FIRST*         #x100000000)
(define-win-constant *NM_CLICK*         (- *NM_FIRST* 1))
(define-win-constant *NM_RCLICK*        (- *NM_FIRST* 5))

(define-win-constant *SW_HIDE*          0)
(define-win-constant *SW_SHOW*          5)
(define-win-constant *SW_SHOWNORMAL*    1)

(define-win-constant *RDW_ERASE*                #x0004)
(define-win-constant *RDW_FRAME*                #x0400)
(define-win-constant *RDW_INTERNALPAINT*        #x0002)
(define-win-constant *RDW_INVALIDATE*           #x0001)
(define-win-constant *RDW_NOERASE*              #x0020)
(define-win-constant *RDW_NOFRAME*              #x0800)
(define-win-constant *RDW_NOINTERNALPAINT*      #x0010)
(define-win-constant *RDW_VALIDATE*             #x0008)
(define-win-constant *RDW_ERASENOW*             #x0200)
(define-win-constant *RDW_UPDATENOW*            #x0100)
(define-win-constant *RDW_ALLCHILDREN*          #x0080)
(define-win-constant *RDW_NOCHILDREN*           #x0040)

(define-win-constant *CW_USEDEFAULT*    (- #x80000000))

(define-win-constant *IDC_ARROW*        32512)
(define-win-constant *IDI_APPLICATION*  32512)

(define-win-constant *COLOR_BACKGROUND*         1)
(define-win-constant *DEFAULT_GUI_FONT*         17)
(define-win-constant *OEM_FIXED_FONT*           10)
(define-win-constant *SYSTEM_FONT*              13)
(define-win-constant *SYSTEM_FIXED_FONT*        16)

(define-win-constant *MB_HELP*                  #x00004000)
(define-win-constant *MB_OK*                    #x00000000)
(define-win-constant *MB_OKCANCEL*              #x00000001)
(define-win-constant *MB_YESNO*                 #x00000004)
(define-win-constant *MB_YESNOCANCEL*           #x00000003)
(define-win-constant *MB_ICONEXCLAMATION*       #x00000030)
(define-win-constant *MB_ICONWARNING*           #x00000020)
(define-win-constant *MB_ICONERROR*             #x00000010)
(define-win-constant *MB_ICONINFORMATION*       #x00000040)
(define-win-constant *MB_ICONQUESTION*          #x00000020)

(define-win-constant *IDCANCEL* 2)
(define-win-constant *IDNO*     7)
(define-win-constant *IDOK*     1)
(define-win-constant *IDYES*    6)

(define-win-constant *MF_BYCOMMAND*     #x00000000)
(define-win-constant *MF_BYPOSITION*    #x00000400)
(define-win-constant *MF_CHECKED*       #x00000008)
(define-win-constant *MF_DISABLED*      #x00000002)
(define-win-constant *MF_ENABLED*       #x00000000)
(define-win-constant *MF_GRAYED*        #x00000001)
(define-win-constant *MF_MENUBREAK*     #x00000040)
(define-win-constant *MF_POPUP*         #x00000010)
(define-win-constant *MF_SEPARATOR*     #x00000800)
(define-win-constant *MF_STRING*        #x00000000)
(define-win-constant *MF_UNCHECKED*     #x00000000)

(define-win-constant *TPM_CENTERALIGN*  #x0004)
(define-win-constant *TPM_LEFTALIGN*    #x0000)
(define-win-constant *TPM_RIGHTALIGN*   #x0008)
(define-win-constant *TPM_BOTTOMALIGN*  #x0020)
(define-win-constant *TPM_TOPALIGN*     #x0000)
(define-win-constant *TPM_VCENTERALIGN* #x0010)
(define-win-constant *TPM_NONOTIFY*     #x0080)
(define-win-constant *TPM_RETURNCMD*    #x0100)
(define-win-constant *TPM_LEFTBUTTON*   #x0000)
(define-win-constant *TPM_RIGHTBUTTON*  #x0002)

(define-win-constant *OFN_FILEMUSTEXIST*        #x00001000)
(define-win-constant *OFN_OVERWRITEPROMPT*      #x00000002)
(define-win-constant *OFN_PATHMUSTEXIST*        #x00000800)
(define-win-constant *OFN_READONLY*             #x00000001)

(define-win-constant *FVIRTKEY*         *TRUE*)
(define-win-constant *FNOINVERT*        #x02)
(define-win-constant *FSHIFT*           #x04)
(define-win-constant *FCONTROL*         #x08)
(define-win-constant *FALT*             #x10)

(define-win-constant *VK_F1*    #x70)
(define-win-constant *VK_LEFT*  #x25)
(define-win-constant *VK_RIGHT* #x27)

(define-win-constant *GWL_EXSTYLE*      -20)
(define-win-constant *GWL_HINSTANCE*    -6)
(define-win-constant *GWL_HWNDPARENT*   -8)
(define-win-constant *GWL_ID*           -12)
(define-win-constant *GWL_STYLE*        -16)
(define-win-constant *GWL_WNDPROC*      -4)

(define-win-constant *FINDMSGSTRING* "commdlg_FindReplace")
(define-win-constant *HELPMSGSTRING* "commdlg_help")

(define-win-constant *FR_DIALOGTERM*    #x00000040)
(define-win-constant *FR_DOWN*          #x00000001)
(define-win-constant *FR_FINDNEXT*      #x00000008)
(define-win-constant *FR_HIDEUPDOWN*    #x00004000)
(define-win-constant *FR_HIDEMATCHCASE* #x00008000)
(define-win-constant *FR_HIDEWHOLEWORD* #x00010000)
(define-win-constant *FR_MATCHCASE*     #x00000004)
(define-win-constant *FR_NOMATCHCASE*   #x00000800)
(define-win-constant *FR_NOUPDOWN*      #x00000400)
(define-win-constant *FR_NOWHOLEWORD*   #x00001000)
(define-win-constant *FR_REPLACE*       #x00000010)
(define-win-constant *FR_REPLACEALL*    #x00000020)
(define-win-constant *FR_SHOWHELP*      #x00000080)
(define-win-constant *FR_WHOLEWORD*     #x00000002)

(defconstant *NULL* (make-null-pointer :void))

;; Windows structures

(def-struct WNDCLASS
            (style :unsigned-int)
            (lpfnWndProc WNDPROC)
            (cbClsExtra :int)
            (cbWndExtra :int)
            (hInstance HANDLE)
            (hIcon HANDLE)
            (hCursor HANDLE)
            (hbrBackground HANDLE)
            (lpszMenuName :cstring)
            (lpszClassName :cstring))
(defun make-wndclass (name &key (style 0) (lpfnWndProc nil) (cbClsExtra 0) (cbWndExtra 0) (hInstance *NULL*)
                                (hIcon (default-icon)) (hCursor (default-cursor)) (hbrBackground (default-background))
                                (lpszMenuName ""))
  (with-foreign-object (cls 'WNDCLASS)
    (setf (get-slot-value cls 'WNDCLASS 'style) style
          (get-slot-value cls 'WNDCLASS 'lpfnWndProc) (callback 'wndproc-proxy)
          (get-slot-value cls 'WNDCLASS 'cbClsExtra) cbClsExtra
          (get-slot-value cls 'WNDCLASS 'cbWndExtra) cbWndExtra
          (get-slot-value cls 'WNDCLASS 'hInstance) hInstance
          (get-slot-value cls 'WNDCLASS 'hIcon) hIcon
          (get-slot-value cls 'WNDCLASS 'hCursor) hCursor
          (get-slot-value cls 'WNDCLASS 'hbrBackground) hbrBackground
          (get-slot-value cls 'WNDCLASS 'lpszMenuName) lpszMenuName
          (get-slot-value cls 'WNDCLASS 'lpszClassName) (string name))
    (register-wndproc (string name) lpfnWndProc)
    (registerclass cls)))
(def-struct POINT
            (x :int)
            (y :int))
(def-struct MSG
            (hwnd HANDLE)
            (message :unsigned-int)
            (wParam :unsigned-int)
            (lParam :int)
            (time :unsigned-int)
            (pt POINT))
(def-struct CREATESTRUCT
            (lpCreateParams :pointer-void)
            (hInstance HANDLE)
            (hMenu HANDLE)
            (hwndParent HANDLE)
            (cx :int)
            (cy :int)
            (x :int)
            (y :int)
            (style :long)
            (lpszName :cstring)
            (lpszClass :cstring)
            (dwExStyle :unsigned-int))
(def-struct MINMAXINFO
            (ptReserved POINT)
            (ptMaxSize POINT)
            (ptMaxPosition POINT)
            (ptMinTrackSize POINT)
            (ptMaxTrackSize POINT))
(def-struct TEXTMETRIC (tmHeight :long) (tmAscent :long) (tmDescent :long) (tmInternalLeading :long) (tmExternalLeading :long)
                       (tmAveCharWidth :long) (tmMaxCharWidth :long) (tmWeight :long) (tmOverhang :long) (tmDigitizedAspectX :long)
                       (tmDigitizedAspectY :long) (tmFirstChar :char) (tmLastChar :char) (tmDefaultChar :char) (tmBreakChar :char)
                       (tmItalic :byte) (tmUnderlined :byte) (tmStruckOut :byte) (tmPitchAndFamily :byte) (tmCharSet :byte))
(def-struct SIZE (cx :long) (cy :long))
(def-struct RECT (left :long) (top :long) (right :long) (bottom :long))
(def-struct TITLEBARINFO (cbSize :unsigned-int) (rcTitlebar RECT) (rgstate (:array :unsigned-int 6)))
(def-struct OPENFILENAME (lStructSize :unsigned-int) (hwndOwner HANDLE) (hInstance HANDLE) (lpstrFilter LPCSTR) (lpstrCustomFilter LPCSTR)
                         (nMaxFilter :unsigned-int) (nFilterIndex :unsigned-int) (lpstrFile LPCSTR) (nMaxFile :unsigned-int) (lpstrFileTitle LPCSTR)
                         (nMaxFileTitle :unsigned-int) (lpstrInitialDir LPCSTR) (lpstrTitle LPCSTR) (Flags :unsigned-int) (nFileOffset :unsigned-short)
                         (nFileExtension :unsigned-short) (lpstrDefExt LPCSTR) (lCustData :int) (lpfnHook HANDLE) (lpTemplateName LPCSTR)
                         #|(pvReserved :pointer-void) (dwReserved :unsigned-int) (FlagsEx :unsigned-int)|#)
(def-struct ACCEL (fVirt :byte) (key :unsigned-short) (cmd :unsigned-short))
(def-struct TCITEM (mask :unsigned-int) (dwState :unsigned-int) (dwStateMask :unsigned-int)
                   (pszText :cstring) (cchTextMax :int) (iImage :int) (lParam :long))
(def-struct NMHDR (hwndFrom HANDLE) (idFrom :unsigned-int) (code :unsigned-int))
(def-struct TCHITTESTINFO (pt POINT) (flag :unsigned-int))
(def-struct TPMPARAMS (cbSize :unsigned-int) (rcExclude RECT))
(def-struct FINDREPLACE (lStructSize :unsigned-int) (hwndOwner HANDLE) (hInstance HANDLE) (Flags DWORD)
                        (lpstrFindWhat LPCSTR) (lpstrReplaceWith LPCSTR) (wFindWhatLen WORD) (wReplaceWithLen WORD)
                        (lpCustData :int) (lpfnHook HANDLE) (lpTemplateName LPCSTR))

;; Windows functions

(defvar *wndproc-db* nil)
(defun register-wndproc (class-or-obj wndproc)
  (let ((entry (assoc class-or-obj *wndproc-db* :test #'equal)))
    (if entry
      (rplacd entry wndproc)
      (push (cons class-or-obj wndproc) *wndproc-db*)))
  (unless (stringp class-or-obj)
    (let ((old-proc (make-pointer (getwindowlong class-or-obj *GWL_WNDPROC*) 'HANDLE)))
      (setwindowlong class-or-obj *GWL_WNDPROC* (make-lparam (callback 'wndproc-proxy)))
      old-proc)))
(defun get-wndproc (obj)
  (let ((entry (or (assoc obj *wndproc-db* :test #'equal)
                   (assoc (getclassname obj) *wndproc-db* :test #'equal))))
    (and entry
         (cdr entry))))
(defcallback (wndproc-proxy :stdcall) :int ((hnd :pointer-void) (umsg :unsigned-int) (wparam :unsigned-int) (lparam :int))
  (let* ((wndproc (get-wndproc hnd)))
    (unless wndproc
      (error "Cannot find a registered Windows prodecure for object ~S" hnd))
    (funcall wndproc hnd umsg wparam lparam)))

(defun make-ID (id) (make-pointer id :pointer-void))
(setf (symbol-function 'make-handle) #'make-ID)
(defun make-wparam (hnd) (pointer-address hnd))
(defun make-lparam (hnd) (pointer-address hnd))
(defmacro with-cast-int-pointer ((var type &optional ptr) &body body)
  (unless ptr (setq ptr var))
  `(let ((,var (make-pointer ,ptr ',type))) ,@body))

(defmacro def-win32-function (name args &key (returning :void) module)
  `(def-function ,name ,args :returning ,returning :module ,module :call :stdcall))
(eval-when (:compile-toplevel)
  (define-compiler-macro def-win32-function (name args &key (returning :void) module)
    `(def-function ,name ,args :returning ,returning)))
(load-foreign-library "kernel32")
(load-foreign-library "comdlg32")
(load-foreign-library "gdi32")
(load-foreign-library "comctl32")

(def-win32-function ("RtlZeroMemory" zeromemory) ((Destination :pointer-void) (Length :unsigned-int)) :returning :void :module "kernel32")
(def-win32-function ("LoadLibraryA" loadlibrary) ((lpLibFileName LPCSTR)) :returning HANDLE :module "kernel32")
(def-win32-function ("FreeLibrary" freelibrary) ((hLibModule HANDLE)) :returning :int :module "kernel32")
(def-win32-function ("GetModuleHandleA" getmodulehandle) ((lpModuleName LPCSTR)) :returning HANDLE :module "kernel32")
(def-win32-function ("GetStockObject" getstockobject) ((fnObject :int)) :returning HANDLE :module "gdi32")
(def-win32-function ("GetTextMetricsA" gettextmetrics) ((hdc HANDLE) (lptm (* TEXTMETRIC))) :returning :int :module "gdi32")
(def-win32-function ("GetDC" getdc) ((hWnd HANDLE)) :returning HANDLE :module "user32")
(def-win32-function ("ReleaseDC" releasedc) ((hWnd HANDLE) (hdc HANDLE)) :returning :int :module "user32")
(def-win32-function ("SelectObject" selectobject) ((hdc HANDLE) (hgdiobj HANDLE)) :returning HANDLE :module "gdi32")
(def-win32-function ("GetTextExtentPoint32A" gettextextentpoint32) ((hdc HANDLE) (lpString :cstring) (cbString :int) (lpSize (* SIZE))) :returning :int :module "gdi32")
(def-win32-function ("LoadCursorA" loadcursor-string) ((hnd HANDLE) (lpCursorName LPCSTR)) :returning HANDLE :module "user32")
(def-win32-function ("LoadCursorA" loadcursor-int) ((hnd HANDLE) (lpCursorName :unsigned-int)) :returning HANDLE :module "user32")
(defun loadcursor (hnd cur-name)
  (etypecase cur-name
    (fixnum (loadcursor-int hnd cur-name))
    (string (loadcursor-string hnd cur-name))))
(defun default-cursor () (loadcursor *NULL* *IDC_ARROW*))
(def-win32-function ("LoadIconA" loadicon-int) ((hnd HANDLE) (lpIconName :unsigned-int)) :returning HANDLE :module "user32")
(def-win32-function ("LoadIconA" loadicon-string) ((hnd HANDLE) (lpIconName LPCSTR)) :returning HANDLE :module "user32")
(defun loadicon (hnd cur-name)
  (etypecase cur-name
    (fixnum (loadicon-int hnd cur-name))
    (string (loadicon-string hnd cur-name))))
(defun default-icon () (loadicon *NULL* *IDI_APPLICATION*))
(defun default-background () (getstockobject *COLOR_BACKGROUND*))
(def-win32-function ("GetLastError" getlasterror) () :returning :unsigned-int :module "kernel32")
(def-win32-function ("GetClassNameA" getclassname-i) ((hnd HANDLE) (lpClassName (* :char)) (maxCount :int)) :returning :int :module "user32")
(defun getclassname (hnd &aux (max-length 64))
  (with-foreign-object (s `(:array :char ,max-length))
    (let ((n (getclassname-i hnd s max-length)))
      (when (= n 0)
        (error "Unable to get class name for ~A" hnd))
      (convert-from-foreign-string s :length n))))
(def-win32-function ("RegisterClassA" registerclass) ((lpWndClass (* WNDCLASS))) :returning :int :module "user32")
(def-win32-function ("UnregisterClassA" unregisterclass) ((lpClassName :cstring) (hInstance HANDLE)) :returning :int :module "user32")
(def-win32-function ("GetWindowLongA" getwindowlong) ((hWnd HANDLE) (nIndex :int)) :returning :long :module "user32")
(def-win32-function ("SetWindowLongA" setwindowlong) ((hWnd HANDLE) (nIndex :int) (dwNewLong :long)) :returning :long :module "user32")
(def-win32-function ("CreateWindowExA" createwindowex) ((dwExStyle :unsigned-int) (lpClassName :cstring) (lpWindowName :cstring) (dwStyle :unsigned-int)
                                                 (x :int) (y :int) (nWidth :int) (nHeight :int) (hWndParent HANDLE) (hMenu HANDLE) (hInstance HANDLE)
                                                 (lpParam :pointer-void))
                                                :returning HANDLE :module "user32")
(defun createwindow (&rest args)
  (apply #'createwindowex 0 args))
(def-win32-function ("DestroyWindow" destroywindow) ((hWnd HANDLE)) :returning :int :module "user32")
(def-win32-function ("ShowWindow" showwindow) ((hWnd HANDLE) (nCmdShow :int)) :returning :int :module "user32")
(def-win32-function ("UpdateWindow" updatewindow) ((hWnd HANDLE)) :returning :void :module "user32")
(def-win32-function ("RedrawWindow" redrawwindow) ((hWnd HANDLE) (lprcUpdate (* RECT)) (hrgnUpdate HANDLE) (flags :unsigned-int)) :returning :int :module "user32")
(def-win32-function ("MoveWindow" movewindow) ((hWnd HANDLE) (x :int) (y :int) (nWidth :int) (nHeight :int) (bRepaint :int)) :returning :int :module "user32")
(def-win32-function ("SetWindowPos" setwindowpos) ((hWnd HANDLE) (hWndInsertAfter HANDLE) (x :int)
                                             (y :int) (cx :int) (cy :int) (uFlags :unsigned-int)) :returning :int :module "user32")
(def-win32-function ("BringWindowToTop" bringwindowtotop) ((hWnd HANDLE)) :returning :int :module "user32")
(def-win32-function ("GetWindowTextA" getwindowtext-i) ((hWnd HANDLE) (lpString LPCSTR) (nMaxCount :int)) :returning :int :module "user32")
(defun getwindowtext (hnd)
  (let ((len (1+ (getwindowtextlength hnd))))
    (with-cstring (s (make-string len))
      (getwindowtext-i hnd s len)
      (subseq s 0 (1- len)))))
(def-win32-function ("GetWindowTextLengthA" getwindowtextlength) ((hWnd HANDLE)) :returning :int :module "user32")
(def-win32-function ("SetWindowTextA" setwindowtext) ((hWnd HANDLE) (lpString LPCSTR)) :returning :int :module "user32")
(def-win32-function ("GetParent" getparent) ((hWnd HANDLE)) :returning HANDLE :module "user32")
(def-win32-function ("GetClientRect" getclientrect) ((hWnd HANDLE) (lpRect (* RECT))) :returning :int :module "user32")
(def-win32-function ("GetWindowRect" getwindowrect) ((hWnd HANDLE) (lpRect (* RECT))) :returning :int :module "user32")
(def-win32-function ("InvalidateRect" invalidaterect) ((hWnd HANDLE) (lpRect (* RECT)) (bErase :int)) :returning :int :module "user32")
(def-win32-function ("SetRect" setrect) ((lpRect (* RECT)) (xLeft :int) (yTop :int) (xRight :int) (yBottom :int)) :returning :int :module "user32")
;(def-win32-function ("GetTitleBarInfo" gettitlebarinfo) ((hWnd HANDLE) (pti (* TITLEBARINFO))) :returning :int)
(def-win32-function ("SetFocus" setfocus) ((hWnd HANDLE)) :returning HANDLE :module "user32")
(def-win32-function ("PostQuitMessage" postquitmessage) ((nExitCode :int)) :returning :void :module "user32")
(def-win32-function ("SendMessageA" sendmessage) ((hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int :module "user32")
(def-win32-function ("PostMessageA" postmessage) ((hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int :module "user32")
(def-win32-function ("RegisterWindowMessageA" registerwindowmessage) ((lpString LPCSTR)) :returning :unsigned-int :module "user32")
(def-win32-function ("IsDialogMessageA" isdialogmessage) ((hDlg HANDLE) (lpMsg (* MSG))) :returning :int :module "user32")
(def-win32-function ("DefWindowProcA" defwindowproc) ((hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int :module "user32")
(def-win32-function ("CallWindowProcA" callwindowproc) ((wndProc HANDLE) (hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int :module "user32")
(defun loword (x) (logand x #xffff))
(defun hiword (x) (logand (floor x 65536) #xffff))
(defun get-x-lparam (x) (loword x))
(defun get-y-lparam (x) (hiword x))
(def-win32-function ("ScreenToClient" screentoclient) ((hWnd HANDLE) (pt (* POINT))) :returning :int :module "user32")
(def-win32-function ("MessageBoxA" messagebox) ((hWnd HANDLE) (lpText LPCSTR) (lpCaption LPCSTR) (uType :unsigned-int)) :returning :int :module "user32")
(def-win32-function ("GetOpenFileNameA" getopenfilename) ((lpofn (* OPENFILENAME))) :returning :int :module "comdlg32")
(def-win32-function ("GetSaveFileNameA" getsavefilename) ((lpofn (* OPENFILENAME))) :returning :int :module "comdlg32")
(def-win32-function ("FindTextA" findtext) ((lpfr (* FINDREPLACE))) :returning HANDLE :module "comdlg32")
(def-win32-function ("ReplaceTextA" replacetext) ((lpfr (* FINDREPLACE))) :returning HANDLE :module "comdlg32")
(def-win32-function ("GetMessageA" getmessage) ((lpMsg (* MSG)) (hWnd HANDLE) (wMsgFitlerMin :unsigned-int) (wMsgFilterMax :unsigned-int)) :returning :int :module "user32")
(def-win32-function ("TranslateMessage" translatemessage) ((lpMsg (* MSG))) :returning :int :module "user32")
(def-win32-function ("DispatchMessageA" dispatchmessage) ((lpMsg (* MSG))) :returning :int :module "user32")
(def-win32-function ("CreateMenu" createmenu) nil :returning HANDLE :module "user32")
(def-win32-function ("CreatePopupMenu" createpopupmenu) nil :returning HANDLE :module "user32")
(def-win32-function ("DestroyMenu" destroymenu) ((hMenu HANDLE)) :returning :int :module "user32")
(def-win32-function ("AppendMenuA" appendmenu) ((hMenu HANDLE) (uFlags :unsigned-int) (uIDNewItem :unsigned-int) (lpNewItem LPCSTR)) :returning :int :module "user32")
(def-win32-function ("GetSubMenu" getsubmenu) ((hMenu HANDLE) (nPos :int)) :returning HANDLE :module "user32")
(def-win32-function ("DeleteMenu" deletemenu) ((hMenu HANDLE) (uPosition :unsigned-int) (uFlags :unsigned-int)) :returning :int :module "user32")
(def-win32-function ("RemoveMenu" removemenu) ((hMenu HANDLE) (uPosition :unsigned-int) (uFlags :unsigned-int)) :returning :int :module "user32")
(def-win32-function ("GetMenuItemCount" getmenuitemcount) ((hMenu HANDLE)) :returning :int :module "user32")
(def-win32-function ("CheckMenuItem" checkmenuitem) ((hMenu HANDLE) (uIDCheckItem :unsigned-int) (uCheck :unsigned-int)) :returning :int :module "user32")
(def-win32-function ("EnableMenuItem" enablemenuitem) ((hMenu HANDLE) (uIDCheckItem :unsigned-int) (uCheck :unsigned-int)) :returning :int :module "user32")
(def-win32-function ("TrackPopupMenu" trackpopupmenu) ((hMenu HANDLE) (uFlags :unsigned-int) (x :int) (y :int)
                                                 (nReserved :int) (hWnd HANDLE) (prcRect HANDLE)) :returning :int :module "user32")
(def-win32-function ("TrackPopupMenuEx" trackpopupmenuex) ((hMenu HANDLE) (fuFlags :unsigned-int) (x :int) (y :int)
                                                     (hWnd HANDLE) (lptpl (* TPMPARAMS))) :returning :int :module "user32")
(def-win32-function ("CreateAcceleratorTableA" createacceleratortable) ((lpaccl (* ACCEL)) (cEntries :int)) :returning HANDLE :module "user32")
(def-win32-function ("TranslateAcceleratorA" translateaccelerator) ((hWnd HANDLE) (hAccTable HANDLE) (lpMsg (* MSG))) :returning :int :module "user32")
(def-win32-function ("DestroyAcceleratorTable" destroyacceleratortable) ((hAccTable HANDLE)) :returning :int :module "user32")
(def-win32-function ("InitCommonControls" initcommoncontrols) () :returning :void :module "comctl32")

(defun event-loop (&key (accelTable *NULL*) (accelMain *NULL*) (dlgSym nil))
  (with-foreign-object (msg 'MSG)
    (loop for bRet = (getmessage msg *NULL* 0 0)
          when (= bRet 0) return bRet
          if (= bRet -1)
                do (error "GetMessage failed!!!")
          else
            do (or (and (not (null-pointer-p accelTable))
                        (not (null-pointer-p accelMain))
                        (/= (translateaccelerator accelMain accelTable msg) 0))
                   (and dlgSym
                        (not (null-pointer-p (symbol-value dlgSym)))
                        (/= (isdialogmessage (symbol-value dlgSym) msg) 0))
                   (progn
                     (translatemessage msg)
                     (dispatchmessage msg))))))

(defun y-or-no-p (&optional control &rest args)
  (let ((s (coerce (apply #'format nil control args) 'simple-string)))
    (= (messagebox *NULL* s "ECL Dialog" (logior *MB_YESNO* *MB_ICONQUESTION*))
       *IDYES*)))

(defun get-open-filename (&key (owner *NULL*) initial-dir filter (dlgfn #'getopenfilename) 
                               (flags 0) &aux (max-fn-size 1024))
  (flet ((null-concat (x &optional y &aux (xx (if y x (car x))) (yy (if y y (cdr x))))
           (concatenate 'string xx (string #\Null) yy)))
    (when filter
      (setq filter (format nil "~A~C~C" (reduce #'null-concat (mapcar #'null-concat filter)) #\Null #\Null)))
    (with-foreign-object (ofn 'OPENFILENAME)
      (with-cstrings ((fn (make-string  max-fn-size :initial-element #\Null))
                      (filter filter))
        (zeromemory ofn (size-of-foreign-type 'OPENFILENAME))
        (setf (get-slot-value ofn 'OPENFILENAME 'lStructSize) (size-of-foreign-type 'OPENFILENAME))
        (setf (get-slot-value ofn 'OPENFILENAME 'hwndOwner) owner)
        (setf (get-slot-value ofn 'OPENFILENAME 'lpstrFile) fn)
        (setf (get-slot-value ofn 'OPENFILENAME 'nMaxFile) max-fn-size)
        (setf (get-slot-value ofn 'OPENFILENAME 'Flags) flags)
        (when filter
          (setf (get-slot-value ofn 'OPENFILENAME 'lpstrFilter) filter))
        (unless (= (funcall dlgfn ofn) 0)
          (pathname (string-trim (string #\Null) fn)))))))

(defun find-text (&key (owner *NULL*) &aux (max-txt-size 1024))
  (with-foreign-object (fr 'FINDREPLACE)
    (with-cstring (txt (make-string max-txt-size :initial-element #\Null))
      (zeromemory fr (size-of-foreign-type 'FINDREPLACE))
      (setf (get-slot-value fr 'FINDREPLACE 'lStructSize) (size-of-foreign-type 'FINDREPLACE))
      (setf (get-slot-value fr 'FINDREPLACE 'hwndOwner) owner)
      (setf (get-slot-value fr 'FINDREPLACE 'wFindWhatLen) max-txt-size)
      ;(setf (get-slot-value fr 'FINDREPLACE 'Flags) 1)
      (let ((result (findtext fr)))
        (print result)
        txt))))

#|
(defun set-wndproc (obj fun)
  (let ((cb (si:make-dynamic-callback fun (read-from-string (format nil "~A-WNDPROC" (gensym))) :int '(:pointer-void :unsigned-int :unsigned-int :int)))
        (old-wndproc (make-pointer (getwindowlong obj *GWL_WNDPROC*) 'HANDLE)))
    (setwindowlong obj *GWL_WNDPROC* (make-lparam cb))
    old-wndproc))
|#

(provide "WIN32")

;;; Test code

(defconstant *HELLO_ID* 100)
(defconstant *OK_ID* 101)

(defparameter hBtn nil)
(defparameter hOk nil)

(defun button-min-size (hnd)
  (let ((fnt (make-pointer (sendmessage hnd *WM_GETFONT* 0 0) :pointer-void))
        (hdc (getdc hnd))
        (txt (getwindowtext hnd)))
    (unless (null-pointer-p fnt)
      (selectobject hdc fnt))
    (with-foreign-objects ((sz 'SIZE)
                           (tm 'TEXTMETRIC))
      (gettextextentpoint32 hdc txt (length txt) sz)
      (gettextmetrics hdc tm)
      (releasedc hnd hdc)
      (list (+ (get-slot-value sz 'SIZE 'cx) 20)
            (+ (get-slot-value tm 'TEXTMETRIC 'tmHeight) 10)))))

(defun get-titlebar-rect (hnd)
  (with-foreign-object (ti 'TITLEBARINFO)
    (setf (get-slot-value ti 'TITLEBARINFO 'cbSize) (size-of-foreign-type 'TITLEBARINFO))
    (gettitlebarinfo hnd ti)
    (let ((rc (get-slot-value ti 'TITLEBARINFO 'rcTitlebar)))
      (list (get-slot-value rc 'RECT 'left)
            (get-slot-value rc 'RECT 'top)
            (get-slot-value rc 'RECT 'right)
            (get-slot-value rc 'RECT 'bottom)))))

(defun test-wndproc (hwnd umsg wparam lparam)
  (cond ((= umsg *WM_DESTROY*)
         (setq hBtn nil hOk nil)
         (postquitmessage 0)
         0)
        ((= umsg *WM_CREATE*)
         (setq hBtn (createwindowex 0  "BUTTON" "Hello World!" (logior *WS_VISIBLE* *WS_CHILD* *BS_PUSHBUTTON*)
                                  0 0 50 20 hwnd (make-ID *HELLO_ID*) *NULL* *NULL*))
         (setq hOk (createwindowex 0  "BUTTON" "Close" (logior *WS_VISIBLE* *WS_CHILD* *BS_PUSHBUTTON*)
                                 0 0 50 20 hwnd (make-ID *OK_ID*) *NULL* *NULL*))
         (sendmessage hBtn *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0)
         (sendmessage hOk *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0)
         0)
        ((= umsg *WM_SIZE*)
         (let* ((new-w (loword lparam))
                (new-h (hiword lparam))
                (wb (- new-w 20))
                (hb (/ (- new-h 30) 2)))
           (movewindow hBtn 10 10 wb hb *TRUE*)
           (movewindow hOk 10 (+ 20 hb) wb hb *TRUE*))
         0)
        ((= umsg *WM_GETMINMAXINFO*)
         (let* ((btn1-sz (and hBtn (button-min-size hBtn)))
                (btn2-sz (and hOk (button-min-size hOk)))
                #|(rc (get-titlebar-rect hWnd))|#
                (titleH #|(1+ (- (fourth rc) (second rc)))|# 30))
           (when (and btn1-sz btn2-sz (> titleH 0))
             (with-foreign-object (minSz 'POINT)
               (setf (get-slot-value minSz 'POINT 'x) (+ (max (first btn1-sz) (first btn2-sz)) 20))
               (setf (get-slot-value minSz 'POINT 'y) (+ (second btn1-sz) (second btn2-sz) 30 titleH))
               (with-cast-int-pointer (lparam MINMAXINFO)
                 (setf (get-slot-value lparam 'MINMAXINFO 'ptMinTrackSize) minSz)))))
         0)
        ((= umsg *WM_COMMAND*)
         (let ((n (hiword wparam))
               (id (loword wparam)))
           (cond ((= n *BN_CLICKED*)
                  (cond ((= id *HELLO_ID*)
                         (format t "~&Hellow World!~%")
                         (get-open-filename :owner hwnd))
                        ((= id *OK_ID*)
                         (destroywindow hwnd))))
                 (t
                  (format t "~&Un-handled notification: ~D~%" n))))
         0)
        (t
         (defwindowproc hwnd umsg wparam lparam))))

(defun do-test ()
  (make-wndclass "MyClass"
    :lpfnWndProc #'test-wndproc)
  (let* ((hwnd (createwindowex
                0
                "MyClass"
                "ECL/Win32 test"
                *WS_OVERLAPPEDWINDOW*
                *CW_USEDEFAULT*
                *CW_USEDEFAULT*
                130
                120
                *NULL*
                *NULL*
                *NULL*
                *NULL*)))
    (when (si::null-pointer-p hwnd)
      (error "Unable to create window"))
    (showwindow hwnd *SW_SHOWNORMAL*)
    (updatewindow hwnd)
    (event-loop)
    (unregisterclass "MyClass" *NULL*)))

