;;; faced-buf2htm.el --- convert buffer text with face properties into HTML
;; Copyright (c) 2009 Justin Lee

;; Author: Justin Lee <cf9404@yahoo.com.tw>
;; Created: 24 May 2009
;; Version: 1.0
;; Keywords:

;; This 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

;;; Commentary:

(defvar g-r-dat)
(defvar g-g-dat)
(defvar g-b-dat)

(defun get-cdat (cv0 cv1)
  (cons cv0 (- cv1 cv0)))

(defun cv2htmcv (cv cdat)
  (/ (* 255 (- cv (car cdat)))
     (cdr cdat)))

(defun cvs2htmcvs (cvs)
  (format "#%02x%02x%02x"
          (cv2htmcv (nth 0 cvs) g-r-dat)
          (cv2htmcv (nth 1 cvs) g-g-dat)
          (cv2htmcv (nth 2 cvs) g-b-dat)))

(defun faced-buf2htm-init ()
  (let (a-v1 a-v2)
    (setq a-v1 (color-values "black"))
    (setq a-v2 (color-values "white"))
    (setq g-r-dat (get-cdat (nth 0 a-v1) (nth 0 a-v2)))
    (setq g-g-dat (get-cdat (nth 1 a-v1) (nth 1 a-v2)))
    (setq g-b-dat (get-cdat (nth 2 a-v1) (nth 2 a-v2)))

    ;;  Make a face with all attribute values being `unspecified'. It is merely used to be
    ;;  overridden by the inherited face(s) (the last parameter of function `face-attribute')
    ;;  for simulating a merge process.
    ;;
    ;;  Emacs help info: You can specify more than one face for a given piece of text; Emacs
    ;;  merges the attributes of all the faces to determine how to display the text. If a
    ;;  list of faces is used, attributes from faces earlier in the list override those from
    ;;  later faces.
    (make-face 'nil-face)))

;;  <span style='color:red;'><s><u><b><i>txt</i></b></u></s></span>
(defun format-faced-txt (txt face)
  (let (a-v1 a-v2 a-v3)
    (setq a-v1 txt)
    (setq a-v1 (replace-regexp-in-string "&" "&amp;" a-v1))
    (setq a-v1 (replace-regexp-in-string "<" "&lt;" a-v1))
    (setq a-v1 (replace-regexp-in-string ">" "&gt;" a-v1))
    (setq a-v1 (list a-v1))
    (setq a-v2 a-v1)

    (setq a-v3 (face-attribute 'nil-face :slant nil face))
    (unless (eq a-v3 'unspecified)
      (setq a-v1 (cons "<i>" a-v1))
      (rplacd a-v2 (list "</i>"))
      (setq a-v2 (cdr a-v2)))
    (setq a-v3 (face-attribute 'nil-face :weight nil face))
    (unless (eq a-v3 'unspecified)
      (setq a-v1 (cons "<b>" a-v1))
      (rplacd a-v2 (list "</b>"))
      (setq a-v2 (cdr a-v2)))
    (setq a-v3 (face-attribute 'nil-face :underline nil face))
    (unless (eq a-v3 'unspecified)
      (setq a-v1 (cons "<u>" a-v1))
      (rplacd a-v2 (list "</u>"))
      (setq a-v2 (cdr a-v2)))
    (setq a-v3 (face-attribute 'nil-face :strike-through nil face))
    (unless (eq a-v3 'unspecified)
      (setq a-v1 (cons "<s>" a-v1))
      (rplacd a-v2 (list "</s>"))
      (setq a-v2 (cdr a-v2)))
    (setq a-v3 (face-attribute 'nil-face :foreground nil face))
    (unless (eq a-v3 'unspecified)
      (setq a-v1 (append (list "<span style='color: " (cvs2htmcvs (color-values a-v3)) ";'>") a-v1))
      (rplacd a-v2 (list "</span>"))
      (setq a-v2 (cdr a-v2)))
    a-v1))

(defun faced-buf2htm-process (buf1 buf2)
  (let (a-v1 a-v2 a-v3 a-v4 a-v5)

    (with-current-buffer buf1
      (setq a-v1 (point-min)))

    (setq a-v3 t)
    (while a-v3
      (setq a-v2 (next-single-property-change a-v1 'face buf1))
      (unless a-v2
        (setq a-v2 (with-current-buffer buf1 (point-max)))
        (setq a-v3 nil))

      (with-current-buffer buf1
        (setq a-v4 (buffer-substring a-v1 a-v2)))
      (setq a-v5 (get-text-property 0 'face a-v4))
      (with-current-buffer buf2
        (apply 'insert (format-faced-txt a-v4 a-v5)))

      (setq a-v1 a-v2))

    ))

;;  Make sure the text properties are updated by scrolling through the whole buffer.
(defun update-txt-prop ()
  (goto-char (point-min))
  (set-window-start (selected-window) (point-min))
  (scroll-up (1- (count-lines (point-min) (point-max)))))

(defun faced-buf2htm ()
  (interactive)
  (let (a-v1)
    (save-excursion

      (setq a-v1 (get-buffer-create (generate-new-buffer-name "*HtmlFromFacedBuf*")))

      (message nil) (message "Updating text properties of the buffer ...")
      (update-txt-prop)

      (with-current-buffer a-v1
        (insert "<pre>"))

      (message nil) (message "Converting buffer text ...")
      (faced-buf2htm-init)
      (faced-buf2htm-process (current-buffer) a-v1)

      (with-current-buffer a-v1
        (insert "</pre>")
        (html-mode))

      (switch-to-buffer a-v1)

      )))

(provide 'faced-buf2htm)

;;;  Code snippets for experiments.

;; (text-properties-at (point))
;; (goto-char (next-property-change (point)))
;; (goto-char (next-single-property-change (point) 'face))
;; (color-values (face-attribute 'font-lock-type-face :foreground))

;;  (defun update-txt-prop ()
;;    (goto-char (point-min))
;;    (scroll-up (1- (count-lines (point-min) (point-max)))))
;;
;;  (defun update-txt-prop ()
;;    (set-window-start (selected-window) (point-min))
;;    (beginning-of-buffer)
;;    (scroll-up (1- (count-lines (point-min) (point-max)))))
;;
;;  (defun update-txt-prop ()
;;    (beginning-of-buffer)
;;    (set-window-start (selected-window) (point-min))
;;    (scroll-up (1- (count-lines (point-min) (point-max)))))