;;;-*- mode:Emacs-Lisp -*-
;;; ansi-codes.el --- translate some of the ANSI escape sequences into faces

;; Copyright (C) 2003 A. Fornasiero
          
;; 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 2 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., 59 Temple Place, Suite 330, Boston,
;; MA 02111-1307 USA

;; Author:   A. Fornasiero <fornasiero@mail.dm.unipi.it>
;; Created:  23 Nov 2003
;; Modified: 18 Dec 2003
;; Version:  1.03
;; X-URL:    http://www.dm.unipi.it/~fornasiero/
;; Keywords: comm processes terminals services
;;
;; Inspired by ansi-color.el (Copyright (C) 2002 Free Software Foundation)
;; by Alex Schroeder <alex@gnu.org>

;;; Commentary:

;; This file provides a function that takes a string
;; containing Select Graphic Rendition (SGR) control sequences (formerly
;; known as ANSI escape sequences) and tries to translate these into
;; faces.

;; SGR control sequences are defined in section 8.3.117 of the ECMA-48
;; standard (identical to ISO/IEC 6429), which is freely available as a
;; PDF file <URL:http://www.ecma.ch/ecma1/STAND/ECMA-048.HTM>.  The
;; "Graphic Rendition Combination Mode (GRCM)" implemented is
;; "cumulative mode" as defined in section 7.2.8.  Cumulative mode means
;; that whenever possible, SGR control sequences are combined (ie. blue
;; and bold).

;; The algorithm is implemented as a "machine" M whose state is contained
;; in `ansi-codes-state'.
;; Each SGR control sequence will change this state.
;; For instance, the sequence \e[3m will set the property `italic' to t.
;; The current state of M determines the text properties of the characters
;; printed at this time.


;;; History:

;;; Differences with ansi-color.el:

;; Added the possibility to choose different background and foreground colours
;; (e.g. 33 specifies gold for foreground, 43 specifies yellow for background).
;; In this way, I will always be able to read the text, 
;; (unless the sender explicitly uses the sequence 8).
;;
;; Added "Default" colour (the empty string ""). 
;; It cancels the corresponding colour specification, 
;; but leaves other face specifications unchanged.
;;
;; If the foreground colour is specified many times, only the last colour
;; specifications is retained, and similarly for background.
;; If my screen is black against white, while the sender thinks that it 
;; is white against black, and it uses 37 (foreground White) instead of
;; 39 (foreground Default), I will not be able to see anything on my screen 
;; with the ansi-color.el default choice of colours (i.e. it would print white 
;; against white).
;; On the other hand, if I choose "Black" as the colour corresponding to 37,
;; I will have large chunks of text with the foreground property "Black",
;; which slows down considerably the scrolling.
;; (The latter thing actually happened to me).
;; However, by specifying that 37 is the default foreground colour and 40 
;; is the default background one, I speed up the scrolling of text written 
;; in white against black (quite common in muds).
;;
;; Added support for strike-through, invisible, framed.
;;
;; The codes 1 and 2 can be translated either as bold and faint, 
;; or as high and low intensity.
;;
;; Corrected bug: if a region starts with a sequence like "\e[33n" 
;; and has no SGR control sequences, ansi-color.el will put all the 
;; region in `ansi-color-context-region' instead of printing it.

;;; Bugs:

;; It does not support XEmacs.
;;
;; It does not support older version of Emacs.
;;
;; `ansi-codes-apply-region' ignores the value of `ansi-codes-conceal'.
;; Instead, it will always uses the `invisible' property.
;;
;; Colourisation in eshell presents some problems
;; a workaround is to add `ansi-codes-reset-ignore-args' to `eshell-kill-hook'.

;;; To Do:

;; Choose better colours.
;; Implement the possibility to ignore the conceal control sequence 
;; (e.g. code 8), like for other sequences.
;;
;; Implement font choice (codes 11--20).

;;; Questions:

;; The ECMA-48 standard defines "concealed characters": what are they exactly?
;;
;; The codes 30--37 are for the display colour, the 38 for the 
;; foreground colour: in what do they differ?
;; Same question for "background" and "character background" colour.
;;
;; What does "encircled" mean? (code 52)
;;
;; Does "framed" (code 51) means that every single character is framed,
;; or there is a unique box containing all the string of characters?
;; In the second case, where does a string end?
;; For instance, can I change from normal to bold inside a box?



;;; SGR escape sequences (taken from the ECMA-48 standard, section 8.3.117)

;; 0 Default: cancel effects of all preceding occurrence of SGR
;; 1 Bold or high intensity
;; 2 Faint, decreased intensity
;; 3 Italicised
;; 4 Singly underlined
;; 5 Slowly blinking
;; 6 Rapidly blinking
;; 7 Negative image
;; 8 Concealed characters
;; 9 Crossed-out
;; 10 Primary (default) font
;; 11--19 Alternative fonts
;; 20 Fraktur (Gothic)
;; 21 Doubly underlined
;; 22 Normal colour or normal intensity (neither bold nor faint)
;; 23 Not italicised, not fraktur
;; 24 Not underlined
;; 25 Not blinking
;; 26 (Reserved for proportional spacing)
;; 27 Positive image
;; 28 Revealed characters
;; 29 Not crossed out
;; 30 Black display
;; 31 Red     ,,
;; 32 Green   ,,
;; 33 Yellow  ,,
;; 34 Blue    ,,
;; 35 Magenta ,,
;; 36 Cyan    ,,
;; 37 White   ,,
;; 38 (Not used)
;; 39 Default display colour
;; 40--49 Same as 30--39 for background colour
;; 50 (Reserved for cancelling the effects of 26)
;; 51 Framed
;; 52 Encircled
;; 53 Over-lined
;; 54 Not framed, not encircled
;; 55 Not over-lined
;; 56--59 (Not used)
;; 60 Ideogram underline or right side line
;; 61   ,,  double  ,,   or  ,,    ,,  double line
;; 62   ,,    over-line  or left   ,,  line
;; 63   ,,  double ,,    or  ,,    ,,  double line
;; 64   ,,  stress marking
;; 65 Cancels the effects of 60--64



;;; Code:

;; Customization

(defgroup ansi-codes nil
  "Translating SGR control sequences to faces.
This translation effectively colourises strings and regions based upon
SGR control sequences embedded in the text.  SGR (Select Graphic
Rendition) control sequences are defined in section 8.3.117 of the
ECMA-48 standard \(identical to ISO/IEC 6429), which is freely available
as a PDF file
<http://www.ecma.ch/ecma1/STAND/ECMA-048.HTM>."
  :version "21.2"
  :prefix "ansi-codes-"
  :group 'processes)

(defcustom ansi-codes-action t
  "Determines what action to perform on ANSI sequences.
nil ignore them.
t interprets them.
`filter' filter them out.
You can set this variable by calling one of:
\\[ansi-codes-on]
\\[ansi-codes-off]
\\[ansi-codes-filter].
The value of this variable will determine the behaviour of
`ansi-codes-apply-region', `ansi-codes-apply-string' and 
`ansi-codes-process-comint-output'."
  :type '(radio (const :tag "Do nothing" nil)
		(const :tag "Filter" 'filter)
		(const :tag "Translate" t))
  :group 'ansi-codes)

(defun ansi-codes-on ()
  "Set `ansi-codes-action' to t.
SGR sequences will be translated to text properties."
  (interactive)
  (setq ansi-codes-action t))

(defun ansi-codes-off ()
  "Set `ansi-codes-action' to nil.
SGR sequences will not be translated."
  (interactive)
  (setq ansi-codes-action nil))

(defun ansi-codes-filter ()
  "Set `ansi-codes-action' to symbol `filter'.
SGR sequences will be filtered out."
  (interactive)
  (setq ansi-codes-action 'filter))

(defcustom ansi-codes-intensity t
  "How to translate the ANSI sequences \"[1m\" and \"[2m\".
If nil, interpret as high and low intensity respectively.
Otherwise, use `ansi-codes-bold' and `ansi-codes-faint'."
  :type '(radio (const :tag "High/low intensity" t)
		(const :tag "Bold/faint" nil))
  :group 'ansi-codes)

(defcustom ansi-codes-conceal ?*
  "How to show concealed characters.
Substitute the value for the concealed text, 
or make invisible if the value is nil"
  :type '(radio (const :tag "Don't show" nil)
		character)
  :group 'ansi-codes)

(defcustom ansi-codes-high-color "DimGray"
  "Default high intensity colour.
It is used when a high intensity colour in `ansi-codes-colors'
is the empty string."
  :type 'color
  :group 'ansi-codes)

(defcustom ansi-codes-low-color "DarkGrey"
  "Default low intensity colour.
It is used when the low intensity colour in `ansi-codes-colors'
is the empty string."
  :type 'color
  :group 'ansi-codes)

(defcustom ansi-codes-special-color "Orange"
  "Special colour used for double underline, circle frame, etc."
  :type 'color
  :group 'ansi-codes)

(defcustom ansi-codes-colors
  [("DarkSlateGray" "DimGray"    ""          "DarkGrey") 
   ("Red"           "HotPink"    "Firebrick" "DarkRed")
   ("Green"         "LawnGreen"  "DarkGreen" "PaleGreen")
   ("Gold"          "Yellow1"    "Yellow2"   "Goldenrod") 
   ("Blue"          "SkyBlue"    "Navy"      "DarkBlue")
   ("Magenta"       "Violet"     "Plum"      "DarkMagenta")
   ("Cyan3"         "Aquamarine" "Cyan1"     "DarkCyan")
   (""              ""           ""          "")
   (nil             nil          nil         nil)]
;   (""              ""           ""          "")]
  "Vector of colours associated to SGR codes from 0 to 9.
The first component is the foreground colour \(codes from 30 to 39\),
the second is the high intensity version,
the third the background colour \(codes from 40 to 49\),
the fourth the low intensity version.

Digit  SGR Colour Foreground    High Intens  Background  Low Intens
  0    Black      DarkSlateGray DimGray      Default     DarkGrey
  1    Red        Red           HotPink      Firebrick   DarkRed   
  2    Green      Green         LawnGreen    DarkGreen   PaleGreen
  3    Yellow     Gold          Yellow1      Yellow2     Goldenrod
  4    Blue       Blue          SkyBlue      Navy        DarkBlue
  5    Magenta    Magenta       Violet       Plum        DarkMagenta
  6    Cyan       Cyan3         Aquamarine   Cyan1       DarkCyan
  7    White      Default       Default      Default     Default
  8    Not used   nil           nil          nil         nil
  9    Default    Default       Default      Default     Default

An empty string produces the default colour (i.e. no colour specification),
except for the intensity value, where it produces either
`ansi-codes-high-color' or `ansi-codes-low-color'
if `ansi-codes-intensity' is t.
nil does not change the colour specification.

The default value is optimised for default colour of black foreground
on white background.
If you use the opposite default, substitute the white background with White.
Moreover, you should change also `ansi-codes-high-color' to White and `ansi-codes-low-color' to LightGrey."
  :type 
  (let (velt lelt (result nil) (i 0))
    (setq result '(vector))
    (setq lelt '(choice (const :tag "Do nothing" nil) color))
    (setq velt `(list ,lelt ,lelt ,lelt ,lelt))
    (while (< i 9)
      (setq result (append result (list velt)))
      (setq i (1+ i)))
    result)
  :group 'ansi-codes
  )

(defcustom ansi-codes-italic '(:slant italic)
  "Plist of attributes corresponding to the italic SGR sequence \"[3m\".
Set to nil if you want to ignore this sequence."
  :type 'plist
  :group 'ansi-codes)

(defcustom ansi-codes-bold '(:weight bold)
  "Plist of attributes corresponding to the underline SGR sequence \"[1m\".
Set to nil if you want to ignore this sequence."
  :type 'plist
  :group 'ansi-codes)
(defcustom ansi-codes-faint '(:weight light)
  "Plist of attributes corresponding to the double underline SGR sequence \"[2m\".
Set to nil if you want to ignore this sequence."
  :type 'plist
  :group 'ansi-codes)

(defcustom ansi-codes-underline '(:underline t)
  "Plist of attributes corresponding to the underline SGR sequence \"[4m\".
Set to nil if you want to ignore this sequence."
  :type 'plist
  :group 'ansi-codes)
(defcustom ansi-codes-double-underline (list :underline ansi-codes-special-color)
  "Plist of attributes corresponding to the double underline SGR sequence \"[21m\".
Set to nil if you want to ignore this sequence."
  :type 'plist
  :group 'ansi-codes)

(defcustom ansi-codes-overline '(:overline t)
  "Plist of attributes corresponding to the over-line SGR sequence \"[53m\".
Set to nil if you want to ignore this sequence."
  :type 'plist
  :group 'ansi-codes)

(defcustom ansi-codes-slow-blink '(:weight bold)
  "Plist of attributes corresponding to the slow-blinking SGR sequence \"[5m\".
Set to nil if you want to ignore this sequence."
  :type 'plist
  :group 'ansi-codes)
(defcustom ansi-codes-fast-blink '(:weight ultra-bold)
  "Plist of attributes corresponding to the fast-blinking SGR sequence \"[6m\".
Set to nil if you want to ignore this sequence."
  :type 'plist
  :group 'ansi-codes)

(defcustom ansi-codes-inverse-video '(:inverse-video t)
  "Plist of attributes corresponding to the inverse SGR sequence \"[7m\".
Set to nil if you want to ignore this sequence."
  :type 'plist
  :group 'ansi-codes)

(defcustom ansi-codes-strike-through '(:strike-through t)
  "Plist of attributes corresponding to the strike-through SGR sequence \"[9m\".
Set to nil if you want to ignore this sequence."
  :type 'plist
  :group 'ansi-codes)

(defcustom ansi-codes-frame '(:box t)
  "Plist of attributes corresponding to frame SGR sequence \"[51m\".
Set to nil if you want to ignore this sequence."
  :type 'plist
  :group 'ansi-codes)
(defcustom ansi-codes-circle-frame (list :box (list :color ansi-codes-special-color))
  "Plist of attributes corresponding to encircle SGR sequence \"[52m\".
Set to nil if you want to ignore this sequence."
  
  :type 'plist
  ;:set-after '(ansi-codes-special-color)
  :group 'ansi-codes)

(defvar ansi-codes-truncated-regexp "\e\\[\\([[:digit:];]*\\)"
  "Regular expression for truncated SGR control sequences.
If you modify this, modify also `ansi-codes-regexp'.")

(defvar ansi-codes-regexp 
  (concat ansi-codes-truncated-regexp "\\([a-zA-Z]\\)")
  "Regular expression matching SGR control sequences.
A SGR control sequence is of the form \"^[[CODESm\", 
where CODES is \"CODE1;CODE2;...CODEN;\", with CODE1,...,CODEN numbers.
^[ is the escape character, which in emacs can be specified either as \\e or as \\033.")

(defvar ansi-codes-state nil
  "Association list containing the current state of the machine.")
;; example: ((foreground . 1)(background . 2)(bold . t)(italic . t))
(make-variable-buffer-local 'ansi-codes-state)


;; Interface with comint mode

(defun ansi-codes-support-comint ()
  "Activate SGR translation for comint output.
Add `ansi-codes-process-comint-output' to the hook `comint-output-filter-functions'."
  (interactive)
  (add-hook 'comint-output-filter-functions 'ansi-codes-process-comint-output))

(defun ansi-codes-process-comint-output (string)
  "Maybe translate SGR control sequences of comint output into text-properties.

Depending on variable `ansi-codes-action' the comint output is either not processed, SGR control sequences are filtered or SGR control sequences are translated into text-properties.
It uses `ansi-codes-apply-region'.

The comint output is assumed to lie between the marker
`comint-last-output-start' and the process-mark.
The input STRING is ignored.

This is a good function to put in `comint-output-filter-functions'.
Do not use in other situations, unless you know what you are doing."
  (let ((start-marker (or comint-last-output-start
			  (point-min-marker)))
	(end-marker (process-mark (get-buffer-process (current-buffer)))))
    (ansi-codes-apply-region start-marker end-marker)))

;; Support for obsolete ansi-color functions

(defalias 'ansi-color-for-comint-mode-on     'ansi-codes-on)
(defalias 'ansi-color-for-comint-mode-off    'ansi-codes-off)
(defalias 'ansi-color-for-comint-mode-filter 'ansi-codes-filter)
(defalias 'ansi-color-process-output         'ansi-codes-process-comint-output)
(defalias 'ansi-color-apply                  'ansi-codes-apply-string)

(make-obsolete 'ansi-color-for-comint-mode-on     'ansi-codes-on)
(make-obsolete 'ansi-color-for-comint-mode-off    'ansi-codes-off)
(make-obsolete 'ansi-color-for-comint-mode-filter 'ansi-codes-filter)
(make-obsolete 'ansi-color-process-output         'ansi-codes-process-comint-output)
(make-obsolete 'ansi-color-apply                  'ansi-codes-apply-string)

(make-obsolete-variable 'ansi-color-faces-vector
      "Use the customizable variables in the group ansi-codes instead.")
(make-obsolete-variable 'ansi-color-names-vector 'ansi-codes-colors)
(make-obsolete-variable 'ansi-color-for-comint-mode 'ansi-codes-action)
(make-obsolete-variable 'ansi-color-context 'ansi-codes-residue)

;; Working with strings

(defvar ansi-codes-residue nil
  "Incomplete ANSI sequence from last string translation.")
(make-variable-buffer-local 'ansi-codes-residue)

(defun ansi-codes-apply-string (string)
  "Maybe translate SGR control sequences of STRING into text-properties.
Translate, filter out or ignore the ANSI sequences, according to the value of `ansi-codes-action', and return the string with the corresponding text properties.
Every call to this function will set and use the buffer-local variable
`ansi-codes-residue' to save partial escape sequences and
`ansi-codes-state' to save current face.
This information will be used for the next call to `ansi-codes-apply-string'.
Set `ansi-codes-residue' to nil and use `ansi-codes-reset-state' if you don't want this, or use the function `ansi-codes-reset'.

This function can be added to `comint-preoutput-filter-functions' and to `eshell-preoutput-filter-functions'.

You cannot insert the strings returned into buffers using font-lock.
See `ansi-codes-unfontify-region' for a way around this."
  (if ansi-codes-action
      (let ((str string) (start 0) (result "") 
	    (partial-result "") partial-length match-end end  face
	    escape-sequence character)
	;; manage residue from last call
	(if ansi-codes-residue
	    (setq str (concat ansi-codes-residue str)
		  ansi-codes-residue nil))
	;; split the string between ANSI sequences,
	;; and colourise each substring
	(while (setq end (string-match ansi-codes-regexp str start))
	  (setq match-end (match-end 0)
		escape-sequence (match-string 1 str)
		character (string-to-char (match-string 2 str))
		partial-result (substring str start end))
	  ;; colourises the partial string according to `ansi-codes-state'
	  (unless (eq ansi-codes-action 'filter)
	    ;; manage conceal property: it is not in the face
	    (setq partial-length (length partial-result))
	    (when (assq 'conceal ansi-codes-state)
	      ;(debug-message "Invisible!")
	      (if ansi-codes-conceal
		  (setq partial-result 
			(make-string partial-length ansi-codes-conceal))
		(put-text-property 0 partial-length
				   'invisible t partial-result)
		))
	    (when (setq face (ansi-codes-face))
	      (put-text-property 0 partial-length 'ansi-color t partial-result)
	      (put-text-property 0 partial-length 'face face partial-result))
	    ;; change the state according to the ANSI escape sequence
	    (ansi-codes-change-state escape-sequence character))
	  (setq result (concat result partial-result))
	  (setq start match-end))
	
	(if (setq end (string-match ansi-codes-truncated-regexp str start))
	    (setq ansi-codes-residue (substring str end)) ;then
	  (setq ansi-codes-residue nil 	;else
		))
	(let ((result-start (length result)))
	  (setq result (concat result (substring str start end)))
	  (unless (eq ansi-codes-action 'filter)
	    (when (setq face (ansi-codes-face))
	      (setq partial-length (length result))
	      (put-text-property result-start partial-length 'ansi-color t result)
	      (put-text-property result-start partial-length 'face face result)
	      )))
	result)
    string 
    ))

;; Working with regions

(defvar ansi-codes-residue-region nil
  "Beginning of last incomplete ANSI escape sequence from last translation
on a region, or nil if no such sequence has been found.")
(make-variable-buffer-local 'ansi-codes-residue-region)

(defun ansi-codes-apply-region (begin end)
  "Maybe translate SGR control sequences in region into text-properties.

Depending on variable `ansi-codes-action' the region is either not processed,
SGR control sequences are filtered or SGR control sequences are translated 
into text-properties.

Every call to this function will set and use the buffer-local variable
`ansi-codes-residue-region' to save partial escape sequences and
`ansi-codes-state' to save current face.
This information will be used for the next call to `ansi-codes-apply-region'.
Set `ansi-codes-residue-region' to nil and use `ansi-codes-reset-state' if 
you don't want this."
  (interactive "r")
  (if ansi-codes-action
      (let (face escape-sequence character
	    (start-marker (or ansi-codes-residue-region 
			      (copy-marker begin)))
	    (end-marker (copy-marker end))
	    (match-begin (make-marker)) 
	    (match-end (make-marker))
	    extent conceal)
	(save-excursion
	  (goto-char start-marker)
	  (while (re-search-forward ansi-codes-regexp end-marker t)
	    (setq escape-sequence (match-string 1)
		  character (string-to-char (match-string 2)))
	    ;(debug-message "Code:" escape-sequence (string character))
	    (set-marker match-begin (match-beginning 0))
	    (set-marker match-end (match-end 0))
	    (replace-match "")
	    (unless (eq ansi-codes-action 'filter)
	      ;;ansi-codes-face performs a search
	      (setq face (ansi-codes-face)
		    conceal (assq 'conceal ansi-codes-state))
	      (when (or face conceal)
		(setq extent (ansi-codes-make-extent start-marker match-begin))
		(if face
		    (overlay-put extent 'face face))
		(if conceal
		    (ansi-codes-make-invisible extent)))
	      ;(debug-message "Region: " start-marker match-begin)
	      ;(debug-message "Face:" face)
	      (ansi-codes-change-state escape-sequence character)
	      )
	    (set-marker start-marker match-end)
	    ;(debug-message "New start:" start-marker)
	    )
	  ;; Dispose of the last substring and possible incomplete SGR sequence
	  (if (re-search-forward ansi-codes-truncated-regexp end-marker t)
	      (setq end-marker (copy-marker (match-beginning 0))
	      	    ansi-codes-residue-region end-marker)
	    (setq ansi-codes-residue-region nil)
	    )

	  (when (or (setq face (ansi-codes-face))
		    (setq conceal (assq 'conceal ansi-codes-state)))
	    (setq extent (ansi-codes-make-extent start-marker end-marker))
	    (if face
		(overlay-put extent 'face face))
	    (if conceal
		(ansi-codes-make-invisible extent)))
	  ;; dispose of unused markers
	  (set-marker match-begin nil)
	  (set-marker match-end nil)
	  (set-marker start-marker nil)
	  (unless ansi-codes-residue-region
	    (set-marker end-marker nil))
;;; if `ansi-codes-residue-region' is not nil, it is `eq' to `end-marker'
;;; therefore, (set-marker end-marker nil) would set the residue-region to
;;; the nil marker.
	  ))))

(defun ansi-codes-make-extent (from to &optional object)
 "Make an extent for the range [FROM, TO) in OBJECT.
Return the new extent.

OBJECT defaults to the current buffer.
The extent is deleted automatically if it ever becomes empty.
Moreover, it cannot be extended."

 (let ((overlay (make-overlay from to object t nil)))
   (overlay-put overlay 'evaporate t)
   overlay))

(defun ansi-codes-make-invisible (extent)
  "Make extent invisible."
  (overlay-put extent 'invisible t)
  )

(defun ansi-codes-change-state (escape char)
  "Changes `ansi-codes-state' according to the ANSI sequence ESCAPE CHAR.
ESCAPE is a string containing numbers separated by `;'.
CHAR is a character.

Sequence   Action               Property changed
  [0m      Reset, clears all    Reset `ansi-codes-state' to nil
           colours and styles   
  [1m      High intensity       intensity t
  [2m      Faint                intensity low
  [3m      Italics on           italic
  [4m      Single underline     underline t
  [5m      Slowly blinking      blink slow
  [6m      Rapidly blinking     blink t
  [7m      Negative image on    inverse-video
  [8m      Concealed character  conceal t
  [9m      Strike-through on    strike-through
  [10-20m  Font selection
  [21m     Double underline     underline double
  [22m     Normal intensity     intensity nil
  [23m     Italics off          italic nil
  [24m     No underline         underline nil
  [25m     Not blinking         blink nil
  [26m     Not used             
  [27m     Negative image off   inverse-video nil
  [28m     Revealed character   conceal nil
  [29m     Strike-through off   strike-through nil
  [30-39m  Foreground colour     foreground
  [40-49m  Background colour     background
  [50m     Not used
  [51m     Framed               frame t
  [52m     Encircled            frame circle
  [53m     Over-lined           overline t
  [54m     No frame             framed nil
  [55m     Not over-lined       overline nil
  [57-59m  Not used
  [60-65   Ideogram lines"
  (let ((ansi-codes-r "[0-9][0-9]?") 
	(codes nil)
	code color
	(i 0))
    ;; create a list of control sequences
    (while (string-match ansi-codes-r escape-sequence i)
      (setq i (match-end 0))
      
      (setq codes (append codes (list (string-to-int 
				       (match-string 0 escape-sequence) 10)))))
      ;(setq codes (cons ;append should be used instead
      ;		   (string-to-int (match-string 0 escape-sequence) 10) codes)))
    (when (eq char ?m) ;m is the char corresponding to faces
      ;;change the state according to the control sequence in codes
      (while codes  
	(setq code (car codes) codes (cdr codes))
	(cond
	 ((eq code 0)
	  (ansi-codes-reset-state))
	 
	 ((eq code 1)
	  (ansi-codes-set-state 'intensity t))
	 ((eq code 2)
	  (ansi-codes-set-state 'intensity 'low))
	 ((eq code 22)
	  (ansi-codes-set-state 'intensity nil))

	 ((eq code 3)
	  (ansi-codes-set-state 'italic t))
	 ((eq code 23)
	  (ansi-codes-set-state 'italic nil))

	 ((eq code 4)
	  (ansi-codes-set-state 'underline t))
	 ((eq code 21)
	  (ansi-codes-set-state 'underline 'double))
	 ((eq code 24)
	  (ansi-codes-set-state 'underline nil))

	 ((eq code 5)
	  (ansi-codes-set-state 'blink 'slow))
	 ((eq code 6)
	  (ansi-codes-set-state 'blink 'fast))
	 ((eq code 25)
	  (ansi-codes-set-state 'blink nil))
	 
	 ((eq code 7)
	  (ansi-codes-set-state 'inverse-video t))
	 ((eq code 27)
	  (ansi-codes-set-state 'inverse-video nil))

	 ((eq code 8)
	  (ansi-codes-set-state 'conceal t))
	  ;(debug-message "Conceal!"))
	 ((eq code 28)
	  (ansi-codes-set-state 'conceal nil))
	  ;(debug-message "Reveal!"))

	 ((eq code 9)
	  (ansi-codes-set-state 'strike-through t))
	 ((eq code 29)
	  (ansi-codes-set-state 'strike-through nil))

	 ((eq code 51)
	  (ansi-codes-set-state 'frame t))
	 ((eq code 52)
	  (ansi-codes-set-state 'frame 'circle))
	 ((eq code 54)
	  (ansi-codes-set-state 'frame nil))

	 ((eq code 53)
	  (ansi-codes-set-state 'overline t))
	 ((eq code 55)
	  (ansi-codes-set-state 'overline nil))
	 
	 ((eq code 10)			;default font
	  (ansi-codes-set-state 'font nil))
	 ((and (< 10 code) (> 20 code))	;font choice
	  (ansi-codes-set-state 'font (- code 10)))

	 ((eq code 39)			;default fg colour
	  (ansi-codes-set-state 'foreground nil))
	 ((and (<= 30 code) (> 39 code)) ;foreground colour
	  (setq color (- code 30))
	  (if (ansi-codes-get-color color) ;fg-color[color] is non-nil
	      (ansi-codes-set-state 'foreground color)))
	 ((eq code 49)			;default bg colour
	  (ansi-codes-set-state 'background nil))
	 ((and (<= 40 code) (> 49 code)) ;background colour
	  (setq color (- code 40))
	  (if (ansi-codes-get-color color 'background) ;bg-color[color] is non-nil
	      (ansi-codes-set-state 'background color)))
	 )))))

(defun ansi-codes-set-state (property value)
  "Set PROPERTY to VALUE in `ansi-codes-set-state'.
If PROPERTY is already in it, delete the old value.
If PROPERTY is nil, do nothing.
If VALUE is nil, remove the property."
  (when property
    (setq ansi-codes-state (assq-delete-all property ansi-codes-state))
    (if value
	(setq ansi-codes-state (cons (cons property value) ansi-codes-state)))
    ))

(defun ansi-codes-face ()
  "Return the plist with the text properties determined by ansi-codes-state.
It can be used as the value of the `face' property of a string."
  (let ((plist nil)
	face intensity 
	(intens (cdr (assq 'intensity ansi-codes-state))))
    (setq intensity (and ansi-codes-intensity intens))
    (if (setq face (assq 'foreground ansi-codes-state))
	(setq plist (append (ansi-codes-get-fg-color (cdr face) intensity) plist))
      (setq plist (append (ansi-codes-get-fg-color nil intensity) plist) ))
    (setq face (assq 'background ansi-codes-state))
    (setq plist (append plist (ansi-codes-get-bg-color (cdr face))))

    (if (and intens (not ansi-codes-intensity))
	(if (eq intens 'low)
	    (setq plist (append ansi-codes-faint plist))
	  (setq plist (append ansi-codes-bold plist))))
    (if (assq 'italic ansi-codes-state)
	(setq plist (append ansi-codes-italic plist)))
    (if (setq face (assq 'underline ansi-codes-state))
	(if (eq (cdr face) 'double)
	    (setq plist (append ansi-codes-double-underline plist))
	  (setq plist (append ansi-codes-underline plist))))
    (if (setq face (assq 'blink ansi-codes-state))
	(if (eq (cdr face) 'slow)
	    (setq plist (append ansi-codes-slow-blink plist))
	  (setq plist (append ansi-codes-fast-blink plist))))
    (if (assq 'inverse-video ansi-codes-state)
	(setq plist (append ansi-codes-inverse-video plist)))
    (if (assq 'strike-through ansi-codes-state)
	(setq plist (append ansi-codes-strike-through plist)))
    (if (setq face (assq 'frame ansi-codes-state))
	(if (eq (cdr face) 'circle)
	    (setq plist (append ansi-codes-circle-frame plist))
	  (setq plist (append ansi-codes-frame plist))))
    (if (assq 'overline ansi-codes-state)
	(setq plist (append ansi-codes-overline plist)))
    ;(princ plist)
    ;(princ "; ")
    ;(princ intens)
    ;(princ "\n")
    plist))

(defun ansi-codes-get-color (color &optional which)
  "Return the colour name corresponding to the code COLOR.
COLOR should be a number between 0 and 9.
If WHICH is nil, or is not specified, return the foreground colour,
if WHICH is `background' return the background colour,
if WHICH is `low' return the low intensity version,
otherwise return the high intensity version."
  (condition-case nil
      (cond
       ((not which)
	(car (aref ansi-codes-colors color)))
       ((eq which 'background)
	(car (cddr (aref ansi-codes-colors color))))
	;(print (car (cddr (aref ansi-codes-colors color)))))
       ((eq which 'low)
	(nth 3 (aref ansi-codes-colors color)))
       (t
	(cadr (aref ansi-codes-colors color))))
    ('args-out-of-range nil)))

(defun ansi-codes-get-fg-color (color &optional intensity)
  "Return the plist containing the text property corresponding to the foreground colour COLOR, with optional modifier INTENSITY for intensity.
INTENSITY should be either nil for normal intensity, `low' for low intensity, or t (or any other value different from `background') for high intensity.
No value for HIGH is equivalent to nil.
COLOR should be a number from 0 to 9, or nil.
A possible return value is, for instance, \(:foreground \"red\"\).
If COLOR is nil, return nil."
  (if color
      (let ((color-name (ansi-codes-get-color color intensity))) ;then
	(if (and color-name (not (string= color-name "")))
	    (list :foreground color-name)
	  (if intensity 
	      (if (eq intensity 'low)
		  (list :foreground ansi-codes-low-color)
		(list :foreground ansi-codes-high-color))
	    nil)))			
    (if intensity			;else
	(if (eq intensity 'low)
	    (list :foreground ansi-codes-low-color)
	  (list :foreground ansi-codes-high-color))
      nil)))	

(defun ansi-codes-get-bg-color (color)
  "Return the plist containing the text property corresponding to the background colour COLOR.
COLOR should be a number from 0 to 9, or nil.
A possible return value is, for instance, \(:background \"red\"\).
If COLOR is nil, return nil."
  (if color
      (let ((color-name (ansi-codes-get-color color 'background)))
	;(print color-name)
	(if (and color-name (not (string= color-name "")))
	    (list :background color-name)
	  nil))
    nil))

(defun ansi-codes-reset-state ()
  "Reset the state to the default value."
  (setq ansi-codes-state nil))

(defun ansi-codes-reset ()
  "Reset the state to the default value and the residue to nil."
  (interactive)
  (ansi-codes-reset-state)
  (setq ansi-codes-residue nil)
  (setq ansi-codes-residue-region nil))

(defun ansi-codes-reset-ignore-args (&rest args)
  "Reset the state to the default value and the residue to nil.
Arguments are ignored. To be used, for instance, in `eshell-kill-hook'."
  (ansi-codes-reset))

;; Support for font-lock. Stolen from ansi-color.el

;(autoload 'save-buffer-state "font-lock")
;; it does not work (probably because of the `eval-when-compile'

(eval-when-compile
  ;; We use this to preserve or protect things when modifying text
  ;; properties.  Stolen from lazy-lock and font-lock.  Ugly!!!
  ;; Probably most of this is not needed?
  (defmacro save-buffer-state (varlist &rest body)
    "Bind variables according to VARLIST and eval BODY restoring buffer state."
    (` (let* ((,@ (append varlist
		   '((modified (buffer-modified-p)) (buffer-undo-list t)
		     (inhibit-read-only t) (inhibit-point-motion-hooks t)
		     before-change-functions after-change-functions
		     deactivate-mark buffer-file-name buffer-file-truename))))
	 (,@ body)
	 (when (and (not modified) (buffer-modified-p))
	   (set-buffer-modified-p nil)))))
  (put 'save-buffer-state 'lisp-indent-function 1))

(defun ansi-codes-unfontify-region (beg end &rest xemacs-stuff)
  "Replacement function for `font-lock-default-unfontify-region'.

As text-properties are implemented using extents in XEmacs, this
function is probably not needed.  In Emacs, however, things are a bit
different: When font-lock is active in a buffer, you cannot simply add
face text-properties to the buffer.  Font-lock will remove the face
text-property using `font-lock-unfontify-region-function'.  If you want
to insert the strings returned by `ansi-codes-apply-string' into such buffers,
you must set `font-lock-unfontify-region-function' to
`ansi-codes-unfontify-region'.  This function will not remove all face
text-properties unconditionally.  It will keep the face text-properties
if the property `ansi-color' is set.

The region from BEG to END is unfontified.  XEMACS-STUFF is ignored.

A possible way to install this would be:

\(add-hook 'font-lock-mode-hook
	  \(function (lambda ()
		      \(setq font-lock-unfontify-region-function
			    'ansi-codes-unfontify-region))))

To do it interactively, use `ansi-codes-support-font-lock'."
  ;; save-buffer-state is a macro in font-lock.el!
  (save-buffer-state nil
    (when (boundp 'font-lock-syntactic-keywords)
      (remove-text-properties beg end '(syntax-table nil)))
    ;; instead of just using (remove-text-properties beg end '(face
    ;; nil)), we find regions with a non-nil face text-property, skip
    ;; positions with the ansi-color property set, and remove the
    ;; remaining face text-properties.
    (while (setq beg (text-property-not-all beg end 'face nil))
      (setq beg (or (text-property-not-all beg end 'ansi-color t) end))
      (when (get-text-property beg 'face)
	(let ((end-face (or (text-property-any beg end 'face nil)
			    end)))
	  (remove-text-properties beg end-face '(face nil))
	  (setq beg end-face))))))

(defun ansi-codes-support-font-lock ()
  "Support for font-lock.
Changes the value of `font-lock-unfontify-region-function' to `ansi-codes-unfontify-region'."
  (interactive)
  (setq font-lock-unfontify-region-function
	(function ansi-codes-unfontify-region)))

;; Test functions

(defun ansi-codes-test-string ()
  "Test for `ansi-codes-apply-string'.

Use it for instance in the `*scratch*' buffer.
Run the function `ansi-codes-support-font-lock' before doing the test.
Print 4 strings and their colourised versions, using both `insert' and `prin1'.
Moreover, print a matrix of colours in `*ansi-color-test*'."
  (let (result1 result2 result3 result4
	(string1 "Aa\e[1mBb\e[2mCc\e[3")
	(string2 "2mDd\e[22mEe\e[3mFf\e[23mGg\e[4mHh\e[21mIi\e[24mJj\e[39mKk")
	(string3 "\e[5mLl\e[6mMm\e[25mNn\e[7mOo\e[27mPp\e[8mQq\e[28mRr")
	(string4 "\e[9mSs\e[29mTt\e[51mUu\e[52mVv\e[54mWw\e[53mXx\e[55mYy"))
    (ansi-codes-reset-state)
    (setq ansi-codes-residue nil)
    (setq result1 (ansi-codes-apply-string string1))
    (setq result2 (ansi-codes-apply-string string2))
    (setq result3 (ansi-codes-apply-string string3))
    (setq result4 (ansi-codes-apply-string string4))
    (insert "Inputs:\n")
    (insert string1 " " string2 " " string3 " " string4 "\n")
    (insert "Outputs:\n")
    (insert result1 " " result2 " " result3 " " result4 "\n")
    (prin1 (concat result1 " " result2 " " result3 " " result4)))
  (insert "\n")
  (princ "Final state: ")
  (princ ansi-codes-state)
  (insert "\n")
  (let ((i 0) (I 0) (j ?a) (J ?A) fg bg result (string "")
	(log-buffer (get-buffer-create "*ansi-color-test*")))
    (setq string "   ")
    (while (< I 10)
      (setq string (concat string "  4" (number-to-string I) "  "))
      (setq I (1+ I))
      )
    (debug-pmessage "Colours: Normal, High-intensity, Low-intensity\n")
    (debug-pmessage string "\n")
    (setq I 0)
    (setq string "\e[0m")
    (while (< i 10)
      (setq fg (number-to-string (+ 30 i)))
      (setq string (concat string "\e[" fg "m"))
      (setq j ?a J ?A)
      (while (< I 10)
	(setq bg (number-to-string (+ 40 I)))
	(setq string (concat string "\e[22;" bg "m" (string J j)))
	(cicle-alphabet j J)
	(setq string (concat string "\e[1m" (string J j)))
	(cicle-alphabet j J)
	(setq string (concat string "\e[2m" (string J j)))
	(cicle-alphabet j J)
	(setq I (1+ I)))
      (setq result (ansi-codes-apply-string string))
      ;(insert string "\n")
      (debug-pmessage fg " " result "\n")
      (setq string "\e[0m")
      (setq i (1+ i))
      (setq I 0)
      )
    (debug-message "Final state:" ansi-codes-state))
  "Test done")

(defun ansi-codes-test-region ()
  "Test for `ansi-codes-apply-region'.

Use it in the *scratch* buffer.
Print 2 strings and colourise them as two separate regions.
Moreover, print the original strings in the buffer `*ansi-color-test*',
together with a list of the text properties of the colourised regions."
  (let ((string1 "Aa\e[3mBb\e[31mCc\e[1mDd\e[4")
	(string2 "3mEe\e[4mFf\e[9;22mGg\e[0mHh\e[8mIi\e[28mJj")
	(my-start (point-marker))
	(log-buffer (get-buffer-create "*ansi-color-test*"))
	my-end
	i char face prop pchar)
    ;(with-current-buffer log-buffer
    ;  (emacs-lisp-mode))
    ;(save-excursion
      (goto-char my-start)
      (insert string1)
      (setq my-end (point-marker))
      (ansi-codes-reset-state)
      (setq ansi-codes-residue-region nil)
      (ansi-codes-apply-region my-start my-end)
      (goto-char my-start)
      (insert "<")
      (set-marker my-start (1+ my-start))
      (goto-char my-end)
      ;(insert "}\n")
      (setq i (copy-marker my-start))
      (set-marker my-start my-end)
      (goto-char my-start)
      (insert string2)
      (set-marker my-end (point-marker))
      (insert ">\n")
      (ansi-codes-apply-region my-start my-end)
      (debug-message "Input:") 
      (debug-message string1 string2)
      (debug-message "Char" "Fontified?" "Face")
      (while (< i my-end)
	(setq face (get-char-property i 'face))
	(setq prop (get-char-property i 'evaporate))
	(setq char (char-after i))
	(set-marker i (1+(1+ i)))
	(setq pchar (string char))
	(put-text-property 0 1 'face face pchar)
	(debug-pmessage " " pchar "; ")
	(debug-message prop "; " face))
      (set-marker i nil)
      (set-marker my-start nil)
      (set-marker my-end nil)
      (debug-message "Final state:" ansi-codes-state)
      "Test done."
	;)
  ))

(defmacro cicle-alphabet (i j)
  "Cycles the value of I and J between ?a and ?z for I, ?A and ?Z for J."
  `(progn
     (if (< ,i ?a)
      (setq ,i ?a))
  (if (< ,j ?A)
      (setq ,j ?A))
  (setq ,i (1+ ,i))
  (setq ,j (1+ ,j))
  (if (> ,i ?z)
      (setq ,i ?a))
  (if (> ,j ?Z)
      (setq ,j ?A))))

(defun debug-message (&rest objects)
  "Print OBJECTS into the buffer log-buffer.
Uses `princ'. Separate each object with a space, ends with a newline."
  (let (elt)
    (save-excursion
      (while objects
	(setq elt (car objects)
	      objects (cdr objects))
	(princ elt log-buffer)
	(princ " " log-buffer))
	(princ "\n" log-buffer))))

(defmacro debug-pmessage (&rest args)
  "Insert the arguments, either strings or characters, into log-buffer, together with their text properties."
  `(save-excursion
     (set-buffer log-buffer)
     (insert ,@args)))

(provide 'ansi-codes)

;;; ansi-codes.el ends here