;; popwindow.l
;;
;; このファイルをsite-lisp以下に置いて、バイトコンパイル。
;;
;; ~/.xyzzyに
;; (require "popwindow")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require "foreign") (require "wip/winapi"))

(provide "popwindow")

(in-package "win-user")

(export '(*pop-window-font-size*
		  *pop-window-default-alpha*
		  *pop-window-limit*
		  *pop-window-height*
		  *pop-window-width*
		  ))

(defconstant *pop-window-class* "popwindow-class")
(defvar *hwnd-pop-window* nil)
(defvar *pop-window-dc-handle* nil)

;; ポップアップウィンドウのフォントサイズ
(defvar *pop-window-font-size* 14)
;; 透過ウィンドウのアルファ値 0-255で値が大きくなるほど透過しない
(defvar *pop-window-default-alpha* 200)
;; ポップアップウィンドウが非表示になるまでの秒数
(defvar *pop-window-limit* 30)
;; ポップアップウィンドウのサイズ。表示後に変更可
(defvar *pop-window-height* 600)
(defvar *pop-window-width* 400)

(unless (find "api" *modules* :test 'string=)
  ; dll関数の登録
  (define-dll-entry LONG GetWindowLong (HWND int) "user32" "GetWindowLongA")
  (define-dll-entry LONG SetWindowLong (HWND int LONG) "user32" "SetWindowLongA")
  (define-dll-entry LONG SetLayeredWindowAttributes (HWND DWORD BYTE DWORD) "user32")
  (*define GWL_EXSTYLE  -20)
  (*define SW_SHOWNA 8)
  (*define WS_EX_TOOLWINDOW #x00000080)
  (*define WM_SIZE #x0005)
  )

(define-dll-entry int DrawTextW (HDC LPCSTR int (RECT *) UINT) "user32")
(define-dll-entry BOOL DestroyWindow (HWND) "user32")
(define-dll-entry LONG TabbedTextOutW (HDC int int LPCSTR int int (int *) int ) "user32")
(define-dll-entry BOOL GetTextExtentPoint32 (HDC LPCSTR int (POINT *)) "gdi32" "GetTextExtentPoint32W")
(define-dll-entry BOOL TextOutW (HDC int int LPCSTR int) "gdi32")
(define-dll-entry DWORD SetTextColor (HDC DWORD) "gdi32")
;;(*define-c-type DWORD COLORREF)
(*define-c-macro RGB (r g b) (logior (logior (ash r 0) (ash g 8)) (ash b 16)))

(defun set-layered-window (hwnd alpha)
  (let ((ex-style (GetWindowLong hwnd GWL_EXSTYLE)))
    (SetWindowLong hwnd GWL_EXSTYLE (logior ex-style #x80000))
    (SetLayeredWindowAttributes hwnd 0 alpha 2)))

(defun set-hide-window ()
  (let ((ex-style (GetWindowLong *hwnd-pop-window* GWL_EXSTYLE)))
    (SetWindowLong *hwnd-pop-window* GWL_EXSTYLE (logior ex-style #x80000))
	(SetLayeredWindowAttributes *hwnd-pop-window* 0 0 2)))
  ;;(DestroyWindow *hwnd-pop-window*))

;; 描画に使用するフォントを設定
(defun pop-window-set-font (hdc mwsfFontName &optional mwsfFontSize mwsfFontWeight mwsfFontItalic mwsfFontUnderline mwsfCharSet)
  (let ((lf (make-LOGFONT))
		rt)
	(si:clear-chunk lf)
	(if mwsfFontSize
		(setf (LOGFONT-lfHeight lf) mwsfFontSize)
	  (setf (LOGFONT-lfHeight lf) *pop-window-font-size*))
	(if mwsfCharSet
		(setf (LOGFONT-lfCharSet lf) mwsfCharSet)
	  (setf (LOGFONT-lfCharSet lf) SHIFTJIS_CHARSET))
	(when mwsfFontWeight
	  (setf (LOGFONT-lfWeight lf) mwsfFontWeight))
	(when mwsfFontItalic
	  (setf (LOGFONT-lfItalic lf) 1))
	(when mwsfFontUnderline
	  (setf (LOGFONT-lfUnderline lf) 1))
	(si:pack-string lf (c-struct-offset-of LOGFONT winapi::lfFaceName) mwsfFontName)
	(setq rt (SelectObject hdc (CreateFontIndirect lf)))
	rt))

;; テキストの描画
(let (mtext)
  (defun textout-ex (hwnd hdc &optional otext)
	(if otext
		(setq mtext otext)
	  (setq otext mtext))
	(let* ((r (make-RECT))
		   (sz (make-SIZE))
		   (text (si:make-string-chunk (ed:map-internal-to-ucs-2 otext)))
		   (l (length otext))
		   (ofont)
		   (tfont)
		   bcr)
	  (setq ofont (pop-window-set-font hdc "ＭＳ ゴシック"))
	  (GetClientRect hwnd r)
	  (let (yPos)
		(setq yPos 0)
		(dolist (item (ed:split-string otext "\n" t "\n"))
		  (setq text (si:make-string-chunk item))
		  (setq l (length item))
		  ;; テキストの先頭行を別のフォントで描画する
		  (if (eql 0 yPos)
			  (progn
				(setq tfont (pop-window-set-font hdc "Arial" 18 700 1))
				;; 先頭行の文字色を変更
				(setq bcr (SetTextColor hdc (RGB 0 0 255)))))
		  (GetTextExtentPoint32 hdc text l sz)
		  (ExtTextOut hdc 0 yPos 0 0 text (- (si:chunk-size text) 1) 0)
		  ;; テキストの先頭行の描画に使用したフォントを削除
		  ;; して、別のフォントを設定する
		  (if (eql 0 yPos)
			  (progn
				(SetTextColor hdc bcr)
				(DeleteObject (SelectObject hdc tfont))
				(setq ofont (pop-window-set-font hdc "ＭＳ ゴシック"))
				)
			)
		  (if (eql 0 yPos)
			  (setf yPos (+ yPos (+ 4 *pop-window-font-size*))) 
			(setf yPos (+ yPos *pop-window-font-size*)))
		  ))
	  (UpdateWindow hwnd)
	  (DeleteObject (SelectObject hdc ofont))
	  ;; 透過ウィンドウにしない場合はコメントアウト
	  (set-layered-window *hwnd-pop-window* *pop-window-default-alpha*)
	  (ShowWindow hwnd SW_SHOWNA)
	  )))

;; テキストの描画（DrawTextを使用。今は使用してない。）
(let (mtext)
  (defun draw-text-ex (hwnd hdc &optional otext)
    (if otext
		(setq mtext otext)
	  (setq otext mtext))
    (let* ((r (make-RECT))
		   (sz (make-SIZE))
		   (text (si:make-string-chunk (ed::map-internal-to-ucs-2 otext)))
		   (l (length otext))
		   ofont)
	  (let ((lf (make-LOGFONT)))
		(si:clear-chunk lf)
		(setf (LOGFONT-lfHeight lf) *pop-window-font-size*)
		(setf (LOGFONT-lfCharSet lf) SHIFTJIS_CHARSET)
		;;(setf (LOGFONT-lfCharSet lf) CHINESEBIG5_CHARSET)
		(si:pack-string lf (c-struct-offset-of LOGFONT winapi::lfFaceName) "ＭＳ ゴシック")
		(setq ofont (SelectObject hdc (CreateFontIndirect lf))))
	  (GetClientRect hwnd r)
      (GetTextExtentPoint32 hdc text l sz)
      (setf (RECT-right r) (- (RECT-right r) 5))
      (setf (RECT-left r) (+ (RECT-left r) 10))
      (setf (RECT-top r) (+ (RECT-top r) 10))
      (setf (RECT-bottom r) (- (RECT-bottom r) 5))
	  (DrawTextW hdc text l r 16)
	  (UpdateWindow hwnd)
	  (DeleteObject (SelectObject hdc ofont))
      ;; 透過ウィンドウにしない場合はコメントアウト
      (set-layered-window *hwnd-pop-window* *pop-window-default-alpha*)
      (ShowWindow hwnd SW_SHOWNA))))

;; おまじない
(unless (fboundp 'pop-window-wndproc-stub)
  (defun-c-callable LRESULT pop-window-wndproc-stub ((HWND hwnd) (UINT msg) (WPARAM wparam) (LPARAM lparam))
		    (pop-window-wndproc hwnd msg wparam lparam)))

;; おまじない
(defun pop-window-wndproc (hwnd msg wparam lparam)
  (cond
   ((= msg WM_NCDESTROY)
	(setq *hwnd-pop-window* nil)
	(ed:stop-timer 'set-hide-window)
	(return-from pop-window-wndproc 0))
   ((= msg WM_PAINT)
	(let* ((ps (make-PAINTSTRUCT))
		   (hdc (BeginPaint hwnd ps)))
	  ;;(draw-text-ex hwnd hdc)
	  (textout-ex hwnd hdc)
	  (EndPaint hwnd ps)
	  (UpdateWindow hwnd))
	(return-from pop-window-wndproc 0)))
  (DefWindowProc hwnd msg wparam lparam))

;; おまじない
(defun register-pop-window-window ()
  (let ((wc (make-WNDCLASS)))
    (setf (WNDCLASS-style wc) (logior CS_HREDRAW CS_VREDRAW))
    (setf (WNDCLASS-lpfnWndProc wc) #'pop-window-wndproc-stub)
    (setf (WNDCLASS-cbClsExtra wc) 0)
    (setf (WNDCLASS-cbWndExtra wc) 0)
    (setf (WNDCLASS-hInstance wc) (GetModuleHandle 0))
    (setf (WNDCLASS-hIcon wc) (LoadIcon 0 (MAKEINTRESOURCE IDI_APPLICATION)))
    (setf (WNDCLASS-hCursor wc) (LoadCursor 0 (MAKEINTRESOURCE IDC_ARROW)))
    (setf (WNDCLASS-hbrBackground wc) (+ 1 5))
    (setf (WNDCLASS-lpszMenuName wc) 0)
    (setf (WNDCLASS-lpszClassName wc)
	  (si:make-string-chunk *pop-window-class*))
    (RegisterClass wc)))

;; おまじない
(defun create-pop-window-window ()
  (let ((hwnd (CreateWindowEx WS_EX_TOOLWINDOW (si:make-string-chunk *pop-window-class*)
			      (si:make-string-chunk "popwindow")
							  WS_OVERLAPPEDWINDOW
							  CW_USEDEFAULT CW_USEDEFAULT
							  *pop-window-height* *pop-window-width*
							  (ed::get-window-handle) 0 (GetModuleHandle 0) 0)))
	(UpdateWindow hwnd)
    hwnd))

;; おまじない
(defun pop-window-init ()
  (if *hwnd-pop-window*
	  (progn
		(InvalidateRect *hwnd-pop-window* 0 1)
		;;(UpdateWindow *hwnd-pop-window*)
		;;(setq *pop-window-dc-handle* (BeginPaint *hwnd-pop-window* ps))
		(setq *pop-window-dc-handle* (GetDC *hwnd-pop-window*))
		;;(DestroyWindow *hwnd-pop-window*)
		)
	(progn
	  (register-pop-window-window)
	  (setq *hwnd-pop-window* (create-pop-window-window))
	  ;;(setf ps (make-PAINTSTRUCT))
	  ;;(setq *pop-window-dc-handle* (BeginPaint *hwnd-pop-window* ps))
	  (setq *pop-window-dc-handle* (GetDC *hwnd-pop-window*))
	  )))

(defun user::pop-window-pop (text)
  "pop-up pop-window"
  (pop-window-init)
  (textout-ex *hwnd-pop-window* *pop-window-dc-handle* text)
  (InvalidateRect *hwnd-pop-window* 0 1)
  (UpdateWindow *hwnd-pop-window*)
  ;; 非表示にしない場合は下の2行をコメントアウトする
  (ed:stop-timer 'set-hide-window)
  (ed:start-timer *pop-window-limit* 'set-hide-window t)
  )

;;pop-windowのサンプルとしてのrefe
;; (define-key *ruby-mode-map* '(#\C-c #\r) 'win-user::refe)
;; とか、好きなキーにバインド。
(defun user::refe (word)
  (ed:interactive "sSearch reference: ")
  (let (refe-result-string)
    (ed:save-window-excursion
      (let ((outbuffer nil)
	    (outstr nil))
		(setq outbuffer (ed:create-new-buffer "refe output"))
		;; cygwinが入っていない場合はバッチファイルを指定？バッチファイルを使う場合の指定方法は知らん(笑)
		(ed:execute-shell-command (ed:concat "bash -t -c 'refe " word "'") :output outbuffer)
		(ed:set-buffer outbuffer)
		(setq refe-result-string (ed:buffer-substring (ed:point-min) (ed:point-max)))
		(ed:delete-buffer outbuffer)))
	(user::pop-window-pop refe-result-string)))

;;EOF