2ch-modeでIDに色付け

xyzzy

Jane Styleでは何回も発言したIDに色が付くようなので、
2ch-modeで同様の機能を実装してみることにした。


ある程度まで書いたところで、すでに似たような機能が
公開されていることに気づいたけど、
せっかく作ったのでこっちも公開。
まあ一応こっちは何種類か色をつけられるということで。


というわけで機能について。

  • 発言回数に応じてIDの色を変える（*id-color-alist*参照）
  • 携帯から（IDの末尾が"O"）の場合はIDに下線を引く

ことができます。
あと、*2ch-extract-regexp*はxyzzy Part12 290-291、300のものを
微妙に改造してますが、向こうのコードもそのまま使えるはず。

;;; 以下を.2ch/config.lに追加

;;; 二回以上発言している ID の色を変える
(defvar *2ch-extract-regexp*
  ;; 英数字しかマッチしないので ??? はこの段階で除外される。
  (compile-regexp "\\(ID:\\||\\)\\([+/0-9a-zA-Z]+\\)●?\\( BE:.+([0-9]+)\\)?\\(]\\||\\|$\\)"))
(defmacro match-id-str ()
  `(match-string 2))
(defmacro match-id-beg ()
  `(match-beginning 2))
(defmacro match-id-end ()
  `(match-end 2))

;; 発言回数や色を変える（追加する）場合はここを変更
(defvar *id-color-alist*
  `((5 . 1)                        ; 5回以上発言した場合は色1
    (2 . 4)                        ; 2回以上発言した場合は色4
    (1 . ,*thread-fgcolor-date*))) ; それ以外はデフォルトの色

(defvar-local thread-id-table nil)

(defun mobile-p (id)
  (string-match "O$" id))

(defun map-thread-id (func)
  (save-excursion
    (goto-char (point-min))
    (let (from to id)
      (while (multiple-value-setq (from to)
               (find-text-attribute 'date :start (point)))
        (goto-char from)
        (scan-buffer *2ch-extract-regexp* :regexp t :limit to)
        (when (setf id (match-id-str))
          (goto-char (match-id-beg))
          (funcall func id))
        (goto-char to)))))

(defun collect-thread-id ()
  (setf thread-id-table (make-hash-table :test #'equal :size 997))
  (map-thread-id
   #'(lambda (id)
       (setf (gethash id thread-id-table)
             (1+ (or (gethash id thread-id-table) 0))))))

(defun change-id-color ()
  (map-thread-id
   #'(lambda (id)
       (let* ((cnt (gethash id thread-id-table))
              (pair (find-if #'(lambda (val) (>= cnt val))
                             *id-color-alist* :key #'first)))
         (set-text-attribute (point) (+ (point) (length id)) 'date
                             :foreground (rest pair)
                             :underline (mobile-p id))))))

(defun change-id-color-buffer ()
  (collect-thread-id)
  (change-id-color))

(add-hook '*thread-show-pre-hook* 'change-id-color-buffer)