;;; 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.
;;;
;;; SAMPLE TEXT EDITOR APPLICATION USING THE WIN32 API
;;;

(require "WIN32" "win32")

(in-package "WIN32")

(defvar *txtedit-class-registered* nil)
(defvar *txtedit-width* 800)
(defvar *txtedit-height* 600)

(defvar *txtedit-edit* nil)
(defvar *txtedit-tab* *NULL*)
(defvar *txtedit-tab-proc* *NULL*)
(defvar *txtedit-current* nil)
(defvar *txtedit-edit-class* 0)
(defvar *txtedit-process* nil)
(defvar *txtedit-handle* *NULL*)
(defvar *txtedit-files* nil)
(defvar *txtedit-dlg-handle* *NULL*)
(defvar *txtedit-findreplace-msg* (registerwindowmessage *FINDMSGSTRING*))
(defstruct txtedit (handle *NULL*) title dirty)

(defvar *txtedit-default-title* "ECL Text Editor")

(defparameter +IDM_OPEN+ 100)
(defparameter +IDM_QUIT+ 101)
(defparameter +IDM_SAVE+ 102)
(defparameter +IDM_SAVEAS+ 103)
(defparameter +IDM_NEW+ 104)
(defparameter +IDM_CUT+ 105)
(defparameter +IDM_COPY+ 106)
(defparameter +IDM_PASTE+ 107)
(defparameter +IDM_UNDO+ 108)
(defparameter +IDM_SELECTALL+ 109)
(defparameter +IDM_ABOUT+ 110)
(defparameter +IDM_NEXTWINDOW+ 111)
(defparameter +IDM_PREVWINDOW+ 112)
(defparameter +IDM_CLOSE+ 113)
(defparameter +IDM_MATCH_PAREN+ 114)
(defparameter +IDM_FIND+ 115)
(defparameter +IDM_WINDOW_FIRST+ 500)
(defparameter +IDM_WINDOW_LAST+ 600)

(defparameter +EDITCTL_ID+  1000)
(defparameter +TABCTL_ID+ 1001)

(defparameter *txtedit-about-text*
"Text Editor for ECL.

This application serves as a demonstrator
for the WIN32 FFI interface of ECL.

Copyright (c) 2005, Michael Goffioul.")

(defun create-menus ()
  ;(return *NULL*)
  (let ((bar (createmenu))
        (file_pop (createpopupmenu))
        (edit_pop (createpopupmenu))
        (win_pop (createpopupmenu))
        (help_pop (createpopupmenu)))
    ;; File menu
    (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam file_pop) "&File")
    (appendmenu file_pop *MF_STRING* +IDM_NEW+ "&New    Ctrl+N")
    (appendmenu file_pop *MF_STRING* +IDM_OPEN+ "&Open...       Ctrl+O")
    (appendmenu file_pop *MF_STRING* +IDM_CLOSE+ "&Close        Ctrl+W")
    (appendmenu file_pop *MF_SEPARATOR* 0 "")
    (appendmenu file_pop *MF_STRING* +IDM_SAVE+ "&Save  Ctrl+S")
    (appendmenu file_pop *MF_STRING* +IDM_SAVEAS+ "Save &As...")
    (appendmenu file_pop *MF_SEPARATOR* 0 "")
    (appendmenu file_pop *MF_STRING* +IDM_QUIT+ "&Exit  Ctrl+Q")
    ;; Edit menu
    (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam edit_pop) "&Edit")
    (appendmenu edit_pop *MF_STRING* +IDM_UNDO+ "&Undo  Ctrl+Z")
    (appendmenu edit_pop *MF_SEPARATOR* 0 "")
    (appendmenu edit_pop *MF_STRING* +IDM_CUT+ "&Cut    Ctrl+X")
    (appendmenu edit_pop *MF_STRING* +IDM_COPY+ "Cop&y  Ctrl+C")
    (appendmenu edit_pop *MF_STRING* +IDM_PASTE+ "&Paste        Ctrl+V")
    (appendmenu edit_pop *MF_SEPARATOR* 0 "")
    (appendmenu edit_pop *MF_STRING* +IDM_MATCH_PAREN+ "&Match parenthesis      Ctrl+D")
    (appendmenu edit_pop *MF_SEPARATOR* 0 "")
    (appendmenu edit_pop *MF_STRING* +IDM_SELECTALL+ "&Select All       Ctrl+A")
    ;; Windows menu
    (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam win_pop) "&Window")
    (appendmenu win_pop *MF_STRING* +IDM_NEXTWINDOW+ "&Next     Ctrl+Right")
    (appendmenu win_pop *MF_STRING* +IDM_PREVWINDOW+ "&Previous Ctrl+Left")
    ;; Help menu
    (appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam help_pop) "&Help")
    (appendmenu help_pop *MF_STRING* +IDM_ABOUT+ "&About...")
    bar))

(defun create-accels ()
  (macrolet ((add-accel (key ID accTable pos)
               `(with-foreign-object (a 'ACCEL)
                  (setf (get-slot-value a 'ACCEL 'fVirt) (logior *FCONTROL* *FVIRTKEY*))
                  (setf (get-slot-value a 'ACCEL 'key) ,(if (characterp key) `(char-code ,key) key))
                  (setf (get-slot-value a 'ACCEL 'cmd) ,ID)
                  (setf (deref-array ,accTable '(* ACCEL) ,pos) a))))
    (let* ((accTableSize (if (= *txtedit-edit-class* 2) 10 9))
           (accTable (allocate-foreign-object 'ACCEL accTableSize)))
      (add-accel #\Q +IDM_QUIT+ accTable 0)
      (add-accel #\N +IDM_NEW+ accTable 1)
      (add-accel #\O +IDM_OPEN+ accTable 2)
      (add-accel #\S +IDM_SAVE+ accTable 3)
      (add-accel #\A +IDM_SELECTALL+ accTable 4)
      (add-accel *VK_LEFT* +IDM_PREVWINDOW+ accTable 5)
      (add-accel *VK_RIGHT* +IDM_NEXTWINDOW+ accTable 6)
      (add-accel #\W +IDM_CLOSE+ accTable 7)
      (add-accel #\F +IDM_FIND+ accTable 8)
      (when (= *txtedit-edit-class* 2)
        (add-accel #\D +IDM_MATCH_PAREN+ accTable 9))
      (prog1
        (createacceleratortable accTable accTableSize)
        (free-foreign-object accTable)))))

(defun update-caption (hwnd)
  (let ((str (tab-name (current-editor) #'identity nil)))
    (setwindowtext hwnd (format nil "~@[~A - ~]~A~C" str *txtedit-default-title* #\Null))))

(defun current-editor ()
  (nth *txtedit-current* *txtedit-edit*))

(defun tab-name (editor &optional (fun #'file-namestring) (final-char #\Null))
  (format nil "~:[New~;~:*~A~]~@[*~*~]~@[~C~]"
              (and (txtedit-title editor) (funcall fun (txtedit-title editor)))
              (txtedit-dirty editor) final-char))

(defun update-tab (idx)
  (let ((editor (nth idx *txtedit-edit*)))
    (with-foreign-object (tab 'TCITEM)
      (setf (get-slot-value tab 'TCITEM 'mask) *TCIF_TEXT*)
      (setf (get-slot-value tab 'TCITEM 'pszText) (tab-name editor))
      (sendmessage *txtedit-tab* *TCM_SETITEM* idx (make-lparam tab))
      )))

(defun set-current-editor (idx hwnd &optional force-p)
  (when (<= 0 idx (1- (length *txtedit-edit*)))
    (let ((old-ed (and *txtedit-current*
                       (current-editor)))
          (new-ed (nth idx *txtedit-edit*)))
      (unless (and (null force-p)
                   (eq old-ed new-ed))
        (setq *txtedit-current* idx)
        (setwindowpos (txtedit-handle new-ed) *HWND_TOP* 0 0 0 0 (logior *SWP_NOSIZE* *SWP_NOMOVE*))
        (setfocus (txtedit-handle new-ed))
        (when (/= (sendmessage *txtedit-tab* *TCM_GETCURSEL* 0 0) idx)
          (sendmessage *txtedit-tab* *TCM_SETCURSEL* idx 0))
        (update-caption hwnd)))))

(defun close-editor (idx hwnd)
  (let ((editor (nth idx *txtedit-edit*)))
    (if (or (null (txtedit-dirty editor))
            (and (set-current-editor idx hwnd) nil)
            (let ((m-result (messagebox hwnd (format nil "Do you want to save changes?~@[~2%~A~%~]~C"
                                                     (txtedit-title editor) #\Null)
                                        "Confirmation" (logior *MB_YESNOCANCEL* *MB_ICONQUESTION*))))
              (cond ((= m-result *IDNO*) t)
                    ((= m-result *IDCANCEL*) nil)
                    ((= m-result *IDYES*) (warn "Not implemented") nil))))
      (progn
        (destroywindow (txtedit-handle editor))
        (sendmessage *txtedit-tab* *TCM_DELETEITEM* idx 0)
        (setq *txtedit-edit* (remove editor *txtedit-edit*))
        (when *txtedit-edit*
          (set-current-editor (min (1- (length *txtedit-edit*))
                                   (max *txtedit-current*
                                        0))
                              hwnd t))
        t)
      nil)))

(ffi:def-struct SCNotification (NotifyHeader NMHDR) (position :int) (ch :int))

(defun init-scintilla-component (hnd)
  ;; Set LISP lexer
  (sendmessage hnd 4001 21 0)
  ;(sendmessage hnd 2090 7 0)
  ;; Define default style attributes
  (with-foreign-string (fn "Courier New")
    (sendmessage hnd 2056 32 (make-lparam fn)))
  (sendmessage hnd 2050 0 0)
  ;; Define comment style
  (sendmessage hnd 2051 1 #xDD0000)
  (sendmessage hnd 2054 1 0)
  (sendmessage hnd 2051 12 #xDD0000)
  (sendmessage hnd 2054 12 0)
  ;; Define string style
  (sendmessage hnd 2051 6 #x0000C8)
  ;; Define number style
  (sendmessage hnd 2051 2 #x0000C8)
  ;; Define operator style
  (sendmessage hnd 2051 10 #xC800C8)
  ;; Define symbol style
  (sendmessage hnd 2051 5 #xC8C800)
  ;; Define brace style
  (sendmessage hnd 2052 34 #xFFCCCC)
  (sendmessage hnd 2051 35 #xFFFFFF)
  (sendmessage hnd 2052 35 #x0000CC)
  ;; Define keyword style
  (sendmessage hnd 2051 3 #x00C8C8)
  (sendmessage hnd 2053 3 0)
  (sendmessage hnd 2051 4 #x00C800)
  (sendmessage hnd 2051 11 #x00C800)
  (unless (boundp '*txtedit-lisp-kw*)
    (load "lisp-kw.lisp"))
  (with-foreign-strings ((kwList *txtedit-lisp-kw*)
                         (kwList2 *txtedit-lisp-kw2*))
    (sendmessage hnd 4005 0 (make-lparam kwList))
    (sendmessage hnd 4005 1 (make-lparam kwList2)))
  ;; Define margins
  (sendmessage hnd 2242 1 0)
  (with-foreign-string (s "_9999")
    (sendmessage hnd 2242 0 (sendmessage hnd 2276 33 (make-lparam s))))
  ;; Define selection style
  (sendmessage hnd 2067 1 #xFFFFFF)
  )

(defun scintilla-indent-position (pos line hnd)
  (+ (sendmessage hnd 2127 line 0)
     (- pos
        (sendmessage hnd 2128 line 0))))

(defun scintilla-read-form (pos hnd)
  (read-from-string
    (with-output-to-string (s)
      (loop for k from pos
            with style = (sendmessage hnd 2010 pos 0)
            for ch = (code-char (sendmessage hnd 2007 k 0))
            for st = (sendmessage hnd 2010 k 0)
            if (and (= st style)
                    (graphic-char-p ch)
                    (not (eq ch #\Space)))
            do (write-char ch s)
            else
              return nil))
    nil nil))

(defun scintilla-declare-form-p (form)
  (member form *txtedit-decl-forms*))

(defun scintilla-compute-indentation (curPos curLine hnd)
  (loop for k from curPos downto 0
        for ch = (code-char (sendmessage hnd 2007 k 0))
        for st = (sendmessage hnd 2010 k 0)
        with depth = 0
        with lineIndent = 0
        with lastCharPos = nil
        with prevCharPos = nil
        when (= st 10)
        do (cond ((and (= depth 0) (eq ch #\())
                  (if lastCharPos
                    (let ((lastChar (code-char (sendmessage hnd 2007 lastCharPos 0)))
                          lastForm)
                      (cond ((member lastChar (list #\( #\;))
                             (return (scintilla-indent-position lastCharPos curLine hnd)))
                            ((and (setq lastForm (scintilla-read-form lastCharPos hnd))
                                  (scintilla-declare-form-p lastForm))
                             (return (+ (scintilla-indent-position k curLine hnd) 2)))
                            ((and prevCharPos (not (eq prevCharPos lastCharPos)))
                             (return (scintilla-indent-position prevCharPos curLine hnd)))
                            (t
                             (return (+ (scintilla-indent-position lastCharPos curLine hnd) 1)))))
                    (progn
                      (return (+ (scintilla-indent-position k curLine hnd) 1)))))
                 ((eq ch #\() (decf depth))
                 ((eq ch #\)) (incf depth)))
        if (and (graphic-char-p ch) (not (eq ch #\Space)))
          do (setq lastCharPos k)
        else
          do (setq prevCharPos lastCharPos)
        when (eq ch #\Newline)
          do (decf curLine) and
          do (case lineIndent
               (0 (incf lineIndent))
               (1 (when (= depth 0) (return (sendmessage hnd 2127 (1+ curLine) 0)))))
        finally (return -1)))

(defun scintilla-char-added (hnd ch)
  (cond ((eq ch #\Newline)
         (let* ((curPos (sendmessage hnd 2008 0 0))
                (curLine (sendmessage hnd 2166 curPos 0))
                (indent (scintilla-compute-indentation (1- curPos) curLine hnd)))
           (when (>= indent 0)
             (sendmessage hnd 2126 curLine indent)
             (sendmessage hnd 2025 (sendmessage hnd 2128 curLine 0) 0)
             )))
        ;((eq ch #\()
        ; (let ((curPos (1- (sendmessage hnd 2008 0 0))))
        ;   (when (scintilla-valid-brace-p curPos hnd)
        ;     (with-foreign-string (s ")")
        ;       (sendmessage hnd 2003 (1+ curPos) (make-lparam s))))))
        (t
          )))

(defun scintilla-get-matching-braces (hnd &aux curPos)
  (when (>= (setq curPos (1- (sendmessage hnd 2008 0 0))) 0)
    (let ((ch (code-char (sendmessage hnd 2007 curPos 0))))
      (when (and (or (eq ch #\() (eq ch #\)))
                 (= (sendmessage hnd 2010 curPos 0) 10))
        (let ((matchPos (sendmessage hnd 2353 curPos 0)))
          (return-from scintilla-get-matching-braces (values curPos matchPos))))))
  (values nil nil))

(defun scintilla-check-for-brace (hnd)
  (multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd)
    (if curPos
      (if (>= matchPos 0)
        (sendmessage hnd 2351 curPos matchPos)
        (sendmessage hnd 2352 curPos 0))
      (sendmessage hnd 2351 #xFFFFFFFF -1))))

(defun create-editor (parent &optional (set-current t))
  (with-foreign-object (r 'RECT)
    (getclientrect parent r)
    (sendmessage *txtedit-tab* *TCM_ADJUSTRECT* *FALSE* (make-lparam r))
    (let ((new-editor (make-txtedit :handle (createwindowex *WS_EX_CLIENTEDGE* (txtedit-class-name) ""
                                                            (logior *WS_CHILD* *WS_HSCROLL* *WS_VSCROLL* *WS_VISIBLE* *WS_CLIPSIBLINGS*
                                                                    *ES_AUTOHSCROLL* *ES_AUTOVSCROLL* *ES_MULTILINE* *ES_LEFT*)
                                                            (get-slot-value r 'RECT 'left)
                                                            (get-slot-value r 'RECT 'top)
                                                            (- (get-slot-value r 'RECT 'right) (get-slot-value r 'RECT 'left))
                                                            (- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top))
                                                            *txtedit-tab* (make-ID +EDITCTL_ID+) *NULL* *NULL*))))
      (sendmessage (txtedit-handle new-editor) *WM_SETFONT* (make-wparam (getstockobject *SYSTEM_FIXED_FONT*)) 0)
      (case *txtedit-edit-class*
        (1 (sendmessage (txtedit-handle new-editor) *EM_SETEVENTMASK* 0 *ENM_CHANGE*))
        (2 (init-scintilla-component (txtedit-handle new-editor))))
      (with-foreign-object (tab 'TCITEM)
        (setf (get-slot-value tab 'TCITEM 'mask) *TCIF_TEXT*)
        (setf (get-slot-value tab 'TCITEM 'pszText) (tab-name new-editor))
        (sendmessage *txtedit-tab* *TCM_INSERTITEM* (length *txtedit-edit*) (make-lparam tab)))
      (setq *txtedit-edit* (append *txtedit-edit* (list new-editor)))
      (when set-current
        (set-current-editor (1- (length *txtedit-edit*)) parent))
      new-editor)))

(defun unix2dos (str)
  (let ((new-str (make-array (length str) :element-type 'character :adjustable t :fill-pointer 0))
        (return-p nil)
        c)
    (with-output-to-string (out new-str)
      (do ((it (si::make-seq-iterator str) (si::seq-iterator-next str it)))
          ((null it))
        (case (setq c (si::seq-iterator-ref str it))
          (#\Return (setq return-p t))
          (#\Newline (unless return-p (write-char #\Return out)) (setq return-p nil))
          (t (setq return-p nil)))
        (write-char c out)))
    new-str))

(defun read-file (pn hwnd)
  (setq pn (probe-file pn))
  (if pn
    (with-open-file (f pn)
      (let* ((len (file-length f))
             (buf (make-string len)))
        (read-sequence buf f)
        (setwindowtext (txtedit-handle (current-editor)) (unix2dos buf))
        (setf (txtedit-dirty (current-editor)) nil)
        (setf (txtedit-title (current-editor)) (substitute #\\ #\/ (namestring pn)))
        (update-caption hwnd)
        (update-tab *txtedit-current*)))
    (messagebox hwnd "File does not exist." "Error" (logior *MB_OK* *MB_ICONERROR*))))

(defun save-file (pn hwnd)
  (unless pn
    (setq pn (txtedit-title (current-editor))))
  (with-open-file (f pn :direction :output :if-does-not-exist :create :if-exists :supersede)
    (let ((txt (getwindowtext (txtedit-handle (current-editor)))))
      (write-sequence txt f)
      (setf (txtedit-title (current-editor)) (substitute #\\ #\/(namestring pn)))
      (setf (txtedit-dirty (current-editor)) nil)
      (update-caption hwnd)
      (update-tab *txtedit-current*))))

(defun close-or-exit (idx hwnd)
  (if (= (length *txtedit-edit*) 1)
    (postmessage hwnd *WM_CLOSE* 0 0)
    (close-editor idx hwnd)))

(defun tab-proc (hwnd umsg wparam lparam)
  (cond ((or (= umsg *WM_COMMAND*)
             (= umsg *WM_NOTIFY*))
         (txtedit-proc (getparent hwnd) umsg wparam lparam))
        (t
          (callwindowproc *txtedit-tab-proc* hwnd umsg wparam lparam))))

(defvar *txtedit-level* 0)
(defun txtedit-proc (hwnd umsg wparam lparam &aux (*txtedit-level* (1+ *txtedit-level*)))
  ;(format t "txtedit-proc: ~D~%" *txtedit-level*)
  (cond ((= umsg *WM_DESTROY*)
         (postquitmessage 0)
         0)
        ((= umsg *WM_CLOSE*)
         (if (do ((flag t))
                 ((not (and *txtedit-edit* flag)) flag)
               (setq flag (close-editor 0 hwnd)))
           (destroywindow hwnd)
           0))
        ((= umsg *WM_CREATE*)
         (when (null-pointer-p (getmodulehandle "comctl32"))
           (initcommoncontrols))
         (setq *txtedit-tab* (createwindowex 0 *WC_TABCONTROL* ""
                                             (logior *WS_CHILD* *WS_VISIBLE* *WS_CLIPCHILDREN*) 0 0 0 0
                                             hwnd (make-ID +TABCTL_ID+) *NULL* *NULL*))
         (setq *txtedit-tab-proc* (register-wndproc *txtedit-tab* #'tab-proc))
         (sendmessage *txtedit-tab* *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0)
         (create-editor hwnd)
         (with-cast-int-pointer (lparam CREATESTRUCT)
           (let ((params (get-slot-value lparam 'CREATESTRUCT 'lpCreateParams)))
             (unless (null-pointer-p params)
               (read-file (convert-from-foreign-string params) hwnd))))
         0)
        ((= umsg *WM_SIZE*)
         (unless (null-pointer-p *txtedit-tab*)
           (movewindow *txtedit-tab* 0 0 (loword lparam) (hiword lparam) *TRUE*)
           (with-foreign-object (r 'RECT)
             (setrect r 0 0 (loword lparam) (hiword lparam))
             (sendmessage *txtedit-tab* *TCM_ADJUSTRECT* *FALSE* (make-lparam r))
             (dotimes (k (length *txtedit-edit*))
               (movewindow (txtedit-handle (nth k *txtedit-edit*))
                           (get-slot-value r 'RECT 'left) (get-slot-value r 'RECT 'top)
                           (- (get-slot-value r 'RECT 'right) (get-slot-value r 'RECT 'left))
                           (- (get-slot-value r 'RECT 'bottom) (get-slot-value r 'RECT 'top))
                           (if (= k *txtedit-current*) *TRUE* *FALSE*)))))
         0)
        ((= umsg *WM_SETFOCUS*)
         (unless (null-pointer-p (txtedit-handle (current-editor)))
           (setfocus (txtedit-handle (current-editor))))
         0)
        ((= umsg *WM_NOTIFY*)
         (with-cast-int-pointer (lparam NMHDR)
           (let ((ctrl-ID (get-slot-value lparam 'NMHDR 'idFrom))
                 (code (get-slot-value lparam 'NMHDR 'code))
                 (hnd (get-slot-value lparam 'NMHDR 'hwndFrom)))
             (cond ((= ctrl-ID +TABCTL_ID+)
                    (cond ((= code *TCN_SELCHANGE*)
                           (set-current-editor (sendmessage hnd *TCM_GETCURSEL* 0 0) hwnd))
                          (t
                            )))
                   ((and (= *txtedit-edit-class* 2)
                         (= code 2001))
                    (with-cast-pointer (lparam SCNotification)
                      (scintilla-char-added hnd (code-char (get-slot-value lparam 'SCNotification 'ch)))))
                   ((and (= *txtedit-edit-class* 2)
                         (= code 2007))
                    (scintilla-check-for-brace hnd))
                   (t
                     ))))
         0)
        ((= umsg *WM_CONTEXTMENU*)
         (let ((hnd (make-handle wparam))
               (x (get-x-lparam lparam))
               (y (get-y-lparam lparam)))
           (cond ((equal hnd *txtedit-tab*)
                  (with-foreign-objects ((ht 'TCHITTESTINFO)
                                         (pt 'POINT))
                    (setf (get-slot-value pt 'POINT 'x) x)
                    (setf (get-slot-value pt 'POINT 'y) y)
                    (screentoclient *txtedit-tab* pt)
                    (setf (get-slot-value ht 'TCHITTESTINFO 'pt) pt)
                    (let ((tab (sendmessage *txtedit-tab* *TCM_HITTEST* 0 (make-lparam ht))))
                      (when (>= tab 0)
                        (let ((hMenu (createpopupmenu))
                              menu-ID)
                          (appendmenu hMenu *MF_STRING* +IDM_CLOSE+ "&Close")
                          (when (/= (setq menu-ID (trackpopupmenuex hMenu (logior *TPM_NONOTIFY* *TPM_RETURNCMD*) x y hwnd *NULL*)) 0)
                            (close-or-exit tab hwnd))
                          (destroymenu hMenu))))))))
         0)
        ((= umsg *WM_INITMENUPOPUP*)
         (case (loword lparam)
           (2 (let* ((wMenu (make-handle wparam))
                     (nPos (loword lparam))
                     (nItems (getmenuitemcount wMenu)))
                (dotimes (j (- nItems 2))
                  (deletemenu wMenu 2 *MF_BYPOSITION*))
                (when *txtedit-edit*
                  (appendmenu wMenu *MF_SEPARATOR* 0 "")
                  (loop for e in *txtedit-edit*
                        for k from 0
                        do (progn
                             (appendmenu wMenu *MF_STRING* (+ +IDM_WINDOW_FIRST+ k) (tab-name e))
                             (when (= k *txtedit-current*)
                               (checkmenuitem wMenu (+ k 3) (logior *MF_BYPOSITION* *MF_CHECKED*))))))
                (enablemenuitem wMenu +IDM_PREVWINDOW+ (if (= *txtedit-current* 0) *MF_GRAYED* *MF_ENABLED*))
                (enablemenuitem wMenu +IDM_NEXTWINDOW+ (if (< *txtedit-current* (1- (length *txtedit-edit*))) *MF_ENABLED* *MF_GRAYED*))
                ))
           )
         0)
        ((= umsg *WM_COMMAND*)
         (let ((ctrl-ID (loword wparam))
               (nmsg (hiword wparam))
               (hnd (make-pointer lparam 'HANDLE)))
           (cond ((= ctrl-ID +EDITCTL_ID+)                
                  (cond ((= nmsg *EN_CHANGE*)
                         (unless (txtedit-dirty (current-editor))
                           (setf (txtedit-dirty (current-editor)) t)
                           (update-caption hwnd)
                           (update-tab *txtedit-current*)))
                        (t
                         )))
                 ((= ctrl-ID +IDM_QUIT+)
                  (sendmessage hwnd *WM_CLOSE* 0 0))
                 ((= ctrl-ID +IDM_OPEN+)
                  (let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp")
                                                                     ("All Files (*)" . "*")))))
                    (when pn
                      (create-editor hwnd)
                      (read-file pn hwnd))))
                 ((and (= ctrl-ID +IDM_SAVE+)
                       (txtedit-title (current-editor)))
                  (save-file nil hwnd))
                 ((or (= ctrl-ID +IDM_SAVEAS+)
                      (and (= ctrl-ID +IDM_SAVE+)
                           (null (txtedit-title (current-editor)))))
                  (let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp")
                                                                     ("All Files (*)" . "*"))
                                               :dlgfn #'getsavefilename :flags *OFN_OVERWRITEPROMPT*)))
                    (when pn
                      (save-file pn hwnd))))
                 ((= ctrl-ID +IDM_NEW+)
                  (create-editor hwnd))
                 ((= ctrl-ID +IDM_CUT+)
                  (sendmessage (txtedit-handle (current-editor)) *WM_CUT* 0 0))
                 ((= ctrl-ID +IDM_COPY+)
                  (sendmessage (txtedit-handle (current-editor)) *WM_COPY* 0 0))
                 ((= ctrl-ID +IDM_PASTE+)
                  (sendmessage (txtedit-handle (current-editor)) *WM_PASTE* 0 0))
                 ((= ctrl-ID +IDM_UNDO+)
                  (unless (= (sendmessage (txtedit-handle (current-editor)) *EM_CANUNDO* 0 0) 0)
                    (sendmessage (txtedit-handle (current-editor)) *EM_UNDO* 0 0)))
                 ((= ctrl-ID +IDM_SELECTALL+)
                  (sendmessage (txtedit-handle (current-editor)) *EM_SETSEL* 0 -1))
                 ((= ctrl-ID +IDM_ABOUT+)
                  (messagebox hwnd *txtedit-about-text* "About" (logior *MB_OK* *MB_ICONINFORMATION*)))
                 ((= ctrl-ID +IDM_NEXTWINDOW+)
                  (unless (>= (1+ *txtedit-current*) (length *txtedit-edit*))
                    (set-current-editor (1+ *txtedit-current*) hwnd)))
                 ((= ctrl-ID +IDM_PREVWINDOW+)
                  (unless (= *txtedit-current* 0)
                    (set-current-editor (1- *txtedit-current*) hwnd)))
                 ((= ctrl-ID +IDM_CLOSE+)
                  (close-or-exit *txtedit-current* hwnd))
                 ((= ctrl-ID +IDM_MATCH_PAREN+)
                  (let ((hnd (txtedit-handle (current-editor))))
                    (multiple-value-bind (curPos matchPos) (scintilla-get-matching-braces hnd)
                      (when (and curPos (>= matchPos 0))
                        (sendmessage hnd 2025 (1+ matchPos) 0)))))
                 ((= ctrl-ID +IDM_FIND+)
                  (let* ((fr (allocate-foreign-object 'FINDREPLACE))
                         (str (make-string 1024 :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) hwnd)
                    (setf (get-slot-value fr 'FINDREPLACE 'lpstrFindWhat) str)
                    (setf (get-slot-value fr 'FINDREPLACE 'wFindWhatLen) 1024)
                    (setf (get-slot-value fr 'FINDREPLACE 'Flags) *FR_DOWN*)
                    (setq *txtedit-dlg-handle* (findtext fr))))
                 ((<= +IDM_WINDOW_FIRST+ ctrl-ID +IDM_WINDOW_LAST+)
                  (set-current-editor (- ctrl-ID +IDM_WINDOW_FIRST+) hwnd)
                  0)
                 (t
                   )))
         0)
        ((= uMsg (1+ *WM_USER*))
         (print "Open file request received")
         (let ((fname (pop *txtedit-files*)))
           (when fname
             (create-editor hwnd)
             (read-file fname hwnd)))
         0)
        ((= uMsg *txtedit-findreplace-msg*)
         (with-cast-int-pointer (lparam FINDREPLACE)
           (let ((flags (get-slot-value lparam 'FINDREPLACE 'Flags))
                 (hnd (txtedit-handle (current-editor))))
             (cond ((/= 0 (logand flags *FR_DIALOGTERM*))
                    (free-foreign-object lparam)
                    (setq *txtedit-dlg-handle* *NULL*))
                   ((/= 0 (logand flags *FR_FINDNEXT*))
                    (let ((str (get-slot-value lparam 'FINDREPLACE 'lpstrFindWhat)) 
                          pos
                          (down (/= (logand flags *FR_DOWN*) 0)))
                      (cond ((= *txtedit-edit-class* 2)
                             (let ((selStart (sendmessage hnd 2143 0 0))
                                   (selEnd (sendmessage hnd 2145 0 0)))
                               (sendmessage hnd 2025 (if down selEnd selStart) 0)
                               (sendmessage hnd 2366 0 0)
                               (with-foreign-string (s str)
                                 (if (/= (setq pos (sendmessage hnd (if down 2367 2368) 0 (make-lparam s))) -1)
                                   (sendmessage hnd 2169 0 0)
                                   (progn
                                     (messagebox *txtedit-dlg-handle* "Finished searching the document"
                                                 "Find" (logior *MB_OK* *MB_ICONINFORMATION*))
                                     (sendmessage hnd 2160 selStart selEnd))))))
                            )))
                   )))
         0)
        (t
         (defwindowproc hwnd umsg wparam lparam))
  ))

(defun txtedit-class-name ()
  (case *txtedit-edit-class*
    (0 "EDIT")
    (1 *RICHEDIT_CLASS*)
    (2 "Scintilla")))

(defun register-txtedit-class ()
  (unless *txtedit-class-registered*
    (case *txtedit-edit-class*
      (-1 (or (and (not (null-pointer-p (loadlibrary "SciLexer.dll")))
                   (setq *txtedit-edit-class* 2))
              (and (not (null-pointer-p (loadlibrary "riched20.dll")))
                   (setq *txtedit-edit-class* 1))
              (setq *txtedit-edit-class* 0)))
      (1 (and (null-pointer-p (loadlibrary "riched20.dll"))
              (error "Cannot load WIN32 library: riched20.dll")))
      (2 (and (null-pointer-p (loadlibrary "SciLexer.dll"))
              (error "Cannot load WIN32 library: SciLexer.dll"))))
    (make-wndclass "SimpleTextEditor"
                   :lpfnWndProc #'txtedit-proc)
    (setq *txtedit-class-registered* t)))

(defun unregister-txtedit-class ()
  (when *txtedit-class-registered*
    (unregisterclass "SimpleTextEditor" *NULL*)
    (case *txtedit-edit-class*
      (1 (freelibrary (getmodulehandle "riched20.dll")))
      (2 (freelibrary (getmodulehandle "SciLexer.dll"))))
    (setq *txtedit-class-registered* nil)))

(defun txtedit (&optional fname &key (class -1) &aux (*txtedit-edit-class* class))
  (register-txtedit-class)
  (let* ((fname-str (if fname
                      (convert-to-foreign-string (coerce fname 'simple-string))
                      *NULL*))
         (w (createwindow "SimpleTextEditor"
                         *txtedit-default-title*
                         (logior *WS_OVERLAPPEDWINDOW*)
                         *CW_USEDEFAULT* *CW_USEDEFAULT*
                         *txtedit-width* *txtedit-height*
                         *NULL* (create-menus) *NULL* fname-str))
         (accTable (create-accels)))
    (setq *txtedit-handle* w)
    (showwindow w *SW_SHOWNORMAL*)
    (updatewindow w)
    (event-loop :accelTable accTable :accelMain w :dlgSym '*txtedit-dlg-handle*)
    (setq *txtedit-edit* nil)
    (setq *txtedit-process* nil)
    (setq *txtedit-handle* *NULL*)
    (destroyacceleratortable accTable)
    (unless (null-pointer-p fname-str)
      (free-foreign-object fname-str))
    (unregister-txtedit-class)
    nil))

(defun edit (&optional fname &key (class -1) (detach-p (member :threads *features*)))
  (if (or detach-p *txtedit-process*)
    (if (member :threads *features*)
      (if *txtedit-process*
        (progn
          (push fname *txtedit-files*)
          (postmessage *txtedit-handle* (1+ *WM_USER*) 0 0))
        #+:threads (setq *txtedit-process* (mp:process-run-function "Text Editor" (lambda () (txtedit fname :class class)))))
      (error "No multi-threading environment detected."))
    (txtedit fname :class class)))
