;;; lui-irc-colors.el --- Add IRC color support to LUI

;; Copyright (C) 2005  Jorgen Schaefer

;; Author: Jorgen Schaefer <forcer@forcix.cx>

;; This file is part of Lui.

;; This program 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 3
;; of the License, or (at your option) any later version.

;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
;; 02110-1301  USA

;;; Commentary:

;; This tells LUI how to display IRC colors:
;; ^B - Bold
;; ^_ - Underline
;; ^V - Inverse
;; ^] - Italic
;; ^O - Return to normal
;; ^C1,2 - Colors

;; The colors are documented at http://www.mirc.co.uk/help/color.txt

;;; Code:

(require 'lui)

(defgroup lui-irc-colors nil
  "LUI IRC colors faces."
  :group 'circe)

(defface lui-irc-colors-inverse-face
  '((t (:inverse-video t)))
  "Face used for inverse video."
  :group 'lui-irc-colors)

(defun lui-irc-defface (face property on-dark on-light rest doc)
  (custom-declare-face
   face
   `((((type graphic) (class color) (background dark))
      (,property ,on-dark))
     (((type graphic) (class color) (background light))
      (,property ,on-light))
     (t (,property ,rest)))
   doc
   :group 'lui-irc-colors))

(defun lui-irc-defface-pair (number on-dark on-light rest name)
  (lui-irc-defface
   (intern (format "lui-irc-colors-fg-%d-face" number))
   :foreground
   on-dark on-light rest
   (concat "Face used for foreground IRC color "
	   (number-to-string number) " (" name ")."))
  (lui-irc-defface
   (intern (format "lui-irc-colors-bg-%d-face" number))
   :background
   on-light on-dark rest
   (concat "Face used for background IRC color "
	   (number-to-string number) " (" name ").")))

(defun lui-irc-defface-bulk (colors)
  (dotimes (n (length colors))
    (apply 'lui-irc-defface-pair n (nth n colors))))

(lui-irc-defface-bulk
 '(("#ffffff" "#585858" "white"    "white")
   ("#a5a5a5" "#000000" "black"    "black")
   ("#9b9bff" "#0000ff" "blue4"    "blue")
   ("#40eb51" "#006600" "green4"   "green")
   ("#ff9696" "#b60000" "red"      "red")
   ("#d19999" "#8f3d3d" "red4"     "brown")
   ("#d68fff" "#9c009c" "magenta4" "purple")
   ("#ffb812" "#7a4f00" "yellow4"  "orange")
   ("#ffff00" "#5c5c00" "yellow"   "yellow")
   ("#80ff95" "#286338" "green"    "light green")
   ("#00b8b8" "#006078" "cyan4"    "teal")
   ("#00ffff" "#006363" "cyan"     "light cyan")
   ("#a8aeff" "#3f568c" "blue"     "light blue")
   ("#ff8bff" "#853885" "magenta"  "pink")
   ("#cfcfcf" "#171717" "dimgray"  "grey")
   ("#e6e6e6" "#303030" "gray"     "light grey")))

(defvar lui-irc-colors-regex
  "\\(\x02\\|\x1F\\|\x16\\|\x1D\\|\x0F\\|\x03\\)"
  "A regular expression matching IRC control codes.")

;;;###autoload
(defun enable-lui-irc-colors ()
  "Enable IRC color interpretation for Lui."
  (interactive)
  (add-hook 'lui-pre-output-hook 'lui-irc-colors))

(defun disable-lui-irc-colors ()
  "Disable IRC color interpretation for Lui."
  (interactive)
  (remove-hook 'lui-pre-output-hook 'lui-irc-colors))

(defun lui-irc-colors ()
  "Add color faces for IRC colors.
This is an appropriate function for `lui-pre-output-hook'."
  (goto-char (point-min))
  (let ((start (point))
        (boldp nil)
        (inversep nil)
        (italicp nil)
        (underlinep nil)
        (fg nil)
        (bg nil))
    (while (re-search-forward lui-irc-colors-regex nil t)
      (lui-irc-propertize start (point)
                          boldp inversep italicp underlinep
                          fg bg)
      (let ((code (match-string 1)))
        (replace-match "")
        (setq start (point))
        (cond
         ((string= code "")
          (setq boldp (not boldp)))
         ((string= code "")
          (setq inversep (not inversep)))
         ((string= code "")
          (setq italicp (not italicp)))
         ((string= code "")
          (setq underlinep (not underlinep)))
         ((string= code "")
          (setq boldp nil
                inversep nil
                italicp nil
                underlinep nil
                fg nil
                bg nil))
         ((string= code "")
          (if (looking-at "\\([0-9][0-9]?\\)\\(,\\([0-9][0-9]?\\)\\)?")
              (progn
                (setq fg (string-to-number (match-string 1))
                      bg (if (match-string 2)
                             (string-to-number (match-string 3))
                           bg))
                (setq fg (if (and fg (not (= fg 99))) (mod fg 16) nil)
                      bg (if (and bg (not (= bg 99))) (mod bg 16) nil))
                (replace-match ""))
            (setq fg nil
                  bg nil)))
         (t
          (error "lui-irc-colors: Can't happen!")))))
    (lui-irc-propertize (point) (point-max)
                        boldp inversep italicp underlinep fg bg)))

(defun lui-irc-propertize (start end boldp inversep italicp underlinep fg bg)
  "Propertize the region between START and END."
  (let ((faces (append (and boldp '(bold))
                       (and inversep '(lui-irc-colors-inverse-face))
                       (and italicp '(italic))
                       (and underlinep '(underline))
                       (and fg (list (lui-irc-colors-face 'fg fg)))
                       (and bg (list (lui-irc-colors-face 'bg bg))))))
    (when faces
      (add-face-text-property start end faces))))

(defun lui-irc-colors-face (type n)
  "Return a face appropriate for face number N.
TYPE is either 'fg or 'bg."
  (if (and (<= 0 n)
           (<= n 15))
      (intern (format "lui-irc-colors-%s-%s-face" type n))
    'default-face))

(provide 'lui-irc-colors)
;;; lui-irc-colors.el ends here