;;; skk-inline.el --- Inline candidate display support for SKK -*- coding: iso-2022-jp -*-

;; Copyright (C) 2005 Masatake YAMATO <jet@gyve.org>
;; Copyright (C) 2007 IRIE Tetsuya <irie@t.email.ne.jp>

;; Maintainer: SKK Development Team <skk@ring.gr.jp>
;; Keywords: japanese, mule, input method

;; This file is part of Daredevil SKK.

;; Daredevil SKK is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.

;; Daredevil SKK is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with Daredevil SKK, see the file COPYING.  If not, write to
;; the Free Software Foundation Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Code:

(eval-when-compile
  (require 'cl)
  (require 'skk-vars)
  (require 'skk-macs))

;; Functions.
(defun skk-add-background-color (string color)
  "STRING のなかで背景色指定がない文字にだけ COLOR の背景色をつける。"
  (when (eval-when-compile skk-running-gnu-emacs)
    (when (and string color)
      (let ((start 0)
	    (end 1)
	    orig-face)
	(while (< start (length string))
	  (setq orig-face (get-text-property start 'face string))
	  (while (and (< end (length string))
		      (eq orig-face (get-text-property end 'face string)))
	    (setq end (1+ end)))
	  (cond
	   ((not orig-face)
	    (put-text-property start end 'face
			       `(:background ,color)
			       string))
	   ((and (facep orig-face) (not (face-background orig-face)))
	    (cond
	     ((eval-when-compile (= emacs-major-version 21))
	      ;; Emacs 21 で :inherit がうまく継承されない？
	      ;; workaround
	      (let (attrs)
		(dolist (pair face-attribute-name-alist)
		  (let* ((attr (car pair))
			 (val (face-attribute orig-face attr (selected-frame))))
		    (unless (eq val 'unspecified)
		      (setq attrs (cons attr (cons val attrs))))))
		(put-text-property start end 'face
				   (append attrs `(:background ,color))
				   string)))
	     (t
	      (put-text-property start end 'face
				 `(:inherit ,orig-face :background ,color)
				 string))))
	   ((and (listp orig-face)
		 (not (plist-get (get-text-property start 'face string)
				 :background))
		 (not (and (plist-get (get-text-property start 'face start)
				      :inherit)
			   (face-background
			    (plist-get (get-text-property start 'face start)
				       :inherit)))))
	    (put-text-property start end 'face
			       (cons
				`(:background ,color)
				orig-face)
			       string)))
	  (setq start (max (1+ start) end)
		end (1+ start)))))
    string))

;;;###autoload
(defun skk-inline-hide-1 ()
  (dolist (ol skk-inline-overlays)
    (delete-overlay ol))
  (setq skk-inline-overlays nil))

;;;###autoload
(defun skk-inline-show (str face &optional vertical-str text-max-height)
  (skk-inline-hide)
  (if (and (eq 'vertical skk-show-inline)
	   ;; window が候補群を表示できる高さがあるかチェック
	   (stringp vertical-str)
	   (integerp text-max-height)
	   (< (1+ text-max-height) (skk-window-body-height)))
      (skk-inline-show-vertically vertical-str face)
    (skk-inline-show-horizontally str face)))

(defun skk-inline-show-horizontally (string face)
  (unless (skk-in-minibuffer-p)
    (let ((ol (make-overlay (point) (point)))
	  (base-ol (make-overlay (point) (1+ (point)))))
      (overlay-put base-ol 'face 'default)
      (push base-ol skk-inline-overlays)
      (push ol skk-inline-overlays)
      (when face
	(setq string (propertize string 'face face)))
      (when skk-inline-show-background-color
	(setq string (skk-add-background-color
		      string skk-inline-show-background-color)))
      (overlay-put ol 'after-string string))))

(defun skk-inline-show-vertically (string face)
  (unless (skk-in-minibuffer-p)
    (let* ((margin 2)
	   ;; XXX beg-col が -1 になって `make-string' でエラーになる
	   ;; 場合あり ?
	   (beg-col (max 0 (- (skk-screen-column) margin)))
	   (candidates (split-string string "\n"))
	   (max-width (apply 'max (mapcar 'string-width candidates)))
	   (i 0)
	   bottom col ol invisible)
      (dolist (str candidates)
	(setq str (concat (when (/= 0 i) (make-string margin ? ))
			  str
			  (make-string (+ (- max-width (string-width str))
					  margin)
				       ? )))
	(when face
	  (setq str (propertize str 'face face)))
	(when skk-inline-show-background-color
	  (setq str (skk-add-background-color
		     str skk-inline-show-background-color)))
	(save-excursion
	  (scroll-left (max 0
			    (- (+ beg-col margin max-width margin 1)
			       (window-width) (window-hscroll))))

	  (unless (zerop (window-hscroll))
	    (setq beg-col
		  (save-excursion (goto-char skk-henkan-start-point)
				  (- (current-column) margin))))
	  (case i
	   (0
	    (setq col (skk-screen-column)))
	   (t
	    (setq bottom (> i (vertical-motion i)))
	    (cond
	     (bottom
	      ;; バッファ最終行では普通に overlay を追加していく方法だ
	      ;; と overlay の表示される順番が狂うことがあってうまくな
	      ;; い。したがって前回の overlay の after-string に追加す
	      ;; る。
	      (setq ol (cond ((< (overlay-end
				  (car skk-inline-overlays))
				 (point))
			      (make-overlay (point) (point)))
			     (t (pop skk-inline-overlays))))
	      (setq str (concat (overlay-get ol 'after-string)
				"\n" (make-string beg-col ? ) str)))
	     (t
	      (setq col (skk-move-to-screen-column beg-col))
	      (cond ((> beg-col col)
		     ;; 桁合わせの空白を追加
		     (setq str (concat (make-string (- beg-col col) ? )
				       str)))
		    ;; overlay の左端がマルチ幅文字と重なったときの微調整
		    ((< beg-col col)
		     (backward-char)
		     (setq col (skk-screen-column))
		     (setq str (concat (make-string (- beg-col col) ? )
				       str))))))))
	  ;; この時点で overlay の開始位置に point がある
	  (unless bottom
	    (let ((ol-beg (point))
		  (ol-end-col (+ col (string-width str)))
		  base-ol)
	      (setq col (skk-move-to-screen-column ol-end-col))
	      ;; overlay の右端がマルチ幅文字と重なったときの微調整
	      (when (< ol-end-col col)
		(setq str (concat str
				  (make-string (- col ol-end-col) ? ))))
	      (setq ol (make-overlay ol-beg (point)))
	      ;; 元テキストの face を継承しないように1つ後ろに overlay
	      ;; を作って、その face を 'default に指定しておく
	      (setq base-ol (make-overlay (point) (1+ (point))))
	      (overlay-put base-ol 'face 'default)
	      (push base-ol skk-inline-overlays)
	      ;; 候補が可視かどうかチェック
	      (unless (pos-visible-in-window-p (point))
		(setq invisible t)))))
	(overlay-put ol 'invisible t)
	(overlay-put ol 'after-string str)
	(push ol skk-inline-overlays)
	(incf i))
      (when (or invisible
		(and bottom
		     (> (1+ (* 7 skk-henkan-show-candidates-rows))
			(- (skk-window-body-height)
			   (count-screen-lines (window-start) (point))))))
	(recenter (- (1+ (* 7 skk-henkan-show-candidates-rows))))))))

(provide 'skk-inline)

;;; skk-inline.el ends here
