hit-a-hint を #xyzzy でつくろうとして挫折した記録。

gistfile1.cl

;; hit-a-hint を xyzzy でつくろうとして挫折した記録。
;;
;; きっかけ:
;;   http://twitter.com/takets/status/26264120538
;;
;; 方式:
;;   1. 画面に表示している分だけ buffer-substring して新しいバッファを作成
;;   2. overlay っぽくバッファを書き換え
;;   3. キー入力を呼んでバッファを切り替え
;; とやろうとしたけど、2 の段階で キーワードの色が付かなくなることに気づいてやめた。
;; "(defun hoge" を "[1]fun hoge" にすると defun の色が消える。

(defun hit-a-hint ()
  (interactive)
  (let ((h (make-hash-table)))
    (setf (gethash :max h) 0)
    (dolist (w (list-window))
      (create-hit-a-hint-buffer w h))
    h))

(defun create-hit-a-hint-buffer (window hints)
  (switch-to-clone-buffer window)
  (save-excursion
    (goto-char (point-min))
    (let ((n (gethash :max hints)))
      (while (scan-buffer "^(defun " :tail nil :regexp t)
        (let* ((overlay (format nil "[~D]" (incf n)))
               (overlay-len (length overlay))
               (start (point)))
          (replace-match (format nil "~A~A" overlay (substring "(defun " overlay-len)))
          (set-text-attribute start (+ start overlay-len) nil :foreground 7 :background 12)
          (setf (gethash n hints) (cons window (current-line-number)))))
      (setf (gethash :max hints) n))))

(defun switch-to-clone-buffer (window)
  (multiple-value-bind (contents start-line)
      (buffer-substring-in-window window)
    (set-buffer (window-buffer window))
    (let ((mode (buffer-local-value (window-buffer window) 'buffer-mode))
          (wline (get-window-line window))
          (lineno (current-line-number))
          (linecol (current-column)))
      (let ((buffer (create-new-buffer "*Hit a Hint*")))
        (set-buffer buffer)
        (setup-temp-buffer buffer)
        (erase-buffer buffer)
        (when (> start-line 1)
          (insert (make-sequence 'string (- start-line 1) :initial-element #\LFD)))
        (insert contents)
        (funcall mode)
        (goto-line lineno)
        (goto-column linecol)
        (recenter wline)
        buffer))))

(defun buffer-substring-in-window (window)
  (let* ((start-line (get-window-start-line window))
         (end-line (+ start-line (window-height window))))
    (save-excursion
      (set-buffer (window-buffer window))
      (values
       (buffer-substring (progn (goto-line start-line) (point))
                         (progn (goto-line end-line) (point)))
       start-line))))

(defun list-window ()
  (let ((r nil)
        (w (selected-window)))
    (loop
      (push w r)
      (setf w (next-window w))
      (when (equal w (selected-window))
        (return)))
    r))