;;; w3-style.el,v --- Emacs-W3 binding style sheet mechanism
;; Author: wmperry
;; Created: 1995/08/27 01:10:25
;; Version: 1.37
;; Keywords: faces, hypermedia

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)
;;;
;;; This file is not part of GNU Emacs, but the same permissions apply.
;;;
;;; GNU Emacs 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, or (at your option)
;;; any later version.
;;;
;;; GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A style sheet mechanism for emacs-w3
;;;
;;; This will eventually be able to under DSSSL[-lite] as well as the
;;; experimental W3C mechanism
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun w3-blend-colors (start end percentage)
  (interactive "sStart Color:
sEnd Color:
nPercentage: ")
  (setq percentage (max 0 (min percentage 100)))
  (let* ((vals    (w3-color-rgb-components start))
	 (red-1   (nth 0 vals))
	 (green-1 (nth 1 vals))
	 (blue-1  (nth 2 vals))
	 (new     (w3-color-rgb-components end))
	 (red-2   (abs (/ (* percentage (- red-1   (nth 0 new))) 100)))
	 (green-2 (abs (/ (* percentage (- green-1 (nth 1 new))) 100)))
	 (blue-2  (abs (/ (* percentage (- blue-1  (nth 2 new))) 100))))
    (format "#%04x%04x%04x"
	    (abs (- red-1 red-2))
	    (abs (- green-1 green-2))
	    (abs (- blue-1 blue-2)))))

(defun w3-percentage-from-date (date-1 date-2 length)
  "Return the percentage of LENGTH that has elapsed between DATE-1 and DATE-2
DATE-1 and DATE-2 are lists as returned by `current-time'
LENGTH is in days"
  (let ((secsbetween (+ (lsh (abs (- (nth 0 date-1) (nth 0 date-2))) 16)
			(abs (- (nth 1 date-1) (nth 1 date-2)))))
	(lengthinsecs (* length 24 60 60)))
    (round (* (/ (float secsbetween) (max lengthinsecs 1)) 100))))

(defun w3-parse-dssl-lite (fname &optional string)
  (let ((dest-buf (current-buffer))
	(url-mime-accept-string
	 "Accept: application/stylesheet ; notation=dsssl-lite")
	(sheet nil))
    (save-excursion
      (set-buffer (get-buffer-create
		   (url-generate-new-buffer-name " *style*")))
      (erase-buffer)
      (if fname (url-insert-file-contents fname))
      (goto-char (point-max))
      (if string (insert string))
      (goto-char (point-min))
      (delete-matching-lines "^[ \t]*#") ; Nuke comments
      (delete-matching-lines "^[ \t\r]*$") ; Nuke blank lines
      (goto-char (point-min))
      (insert "(")
      (goto-char (point-max))
      (insert ")")
      (goto-char (point-min))
      (setq sheet (condition-case ()
		      (read (current-buffer))
		    (error nil)))
      ;; Now need to convert the DSSSL-lite flow objects
      ;; into our internal representation
      ;; WORK WORK WORK!
      )))

(if (not (fboundp 'string-to-number))
    (fset 'string-to-number 'string-to-int))

(defun w3-spatial-to-canonical (spec)
  "Convert SPEC (in inches, millimeters, points, or picas) into pixels"
  (let ((num nil)
	(type nil)
	(dim1 (+ 25 (/ (float 4) 10)))
	(dim2 (float 72))
	(retval nil))
    (if (string-match "[^0-9.]+$" spec)
	(setq type (substring spec (match-beginning 0))
	      spec (substring spec 0 (match-beginning 0)))
      (setq type "px"
	    spec spec))
    (setq num (string-to-number spec))
    (cond
     ((member type '("pixel" "px" "pix"))
      (setq retval num
	    num nil))
     ((member type '("point" "pt"))
      (setq num num))
     ((member type '("inch" "in"))
      (setq num (/ num dim2)))
     ((string= type "mm")
      (setq num (* num (/ dim1 dim2))))
     ((string= type "cm")
      (setq num (* num (/ dim1 dim2))))
     )
    (if (not retval)
	(setq retval (* 10 num)))
    retval))

(defun w3-lookup-rgb-components (color)
  "Lookup COLOR (a color name) in rgb.txt and return a list of RGB values.
The list (R G B) is returned, or an error is signaled if the lookup fails."
  (let ((lib-list (if (boundp 'x-library-search-path)
		      x-library-search-path
		    ;; This default is from XEmacs 19.13 - hope it covers
		    ;; everyone.
		    (list "/usr/X11R6/lib/X11/"
			  "/usr/X11R5/lib/X11/"
			  "/usr/lib/X11R6/X11/"
			  "/usr/lib/X11R5/X11/"
			  "/usr/local/X11R6/lib/X11/"
			  "/usr/local/X11R5/lib/X11/"
			  "/usr/local/lib/X11R6/X11/"
			  "/usr/local/lib/X11R5/X11/"
			  "/usr/X11/lib/X11/"
			  "/usr/lib/X11/"
			  "/usr/local/lib/X11/"
			  "/usr/X386/lib/X11/"
			  "/usr/x386/lib/X11/"
			  "/usr/XFree86/lib/X11/"
			  "/usr/unsupported/lib/X11/"
			  "/usr/athena/lib/X11/"
			  "/usr/local/x11r5/lib/X11/"
			  "/usr/lpp/Xamples/lib/X11/"
			  "/usr/openwin/lib/X11/"
			  "/usr/openwin/share/lib/X11/")))
	file r g b)
    (while lib-list
      (setq file (expand-file-name "rgb.txt" (car lib-list)))
      (if (file-readable-p file)
	  (setq lib-list nil)
	(setq lib-list (cdr lib-list)
	      file nil)))
    (if (null file)
	(error "w3-lookup-rgb-components: Can't find rgb.txt file.")
      (save-excursion
	(set-buffer (find-file-noselect file))
	(save-excursion
	  (save-restriction
	    (widen)
	    (goto-char (point-min))
	    (if (re-search-forward (format "\t%s$" (regexp-quote color)) nil t)
		(progn
		  (beginning-of-line)
		  (setq r (* (read (current-buffer)) 256)
			g (* (read (current-buffer)) 256)
			b (* (read (current-buffer)) 256)))
	      (message "No such color: %s" color)
	      (w3-warn 'html (format "No such color: %s" color))
	      (setq r 0
		    g 0
		    b 0))
	    (list r g b) ))))))

(defun w3-hex-string-to-number (string)
  "Convert STRING to an integer by parsing it as a hexadecimal number."
  (let ((conv-list '((?0 . 0) (?a . 10) (?A . 10)
		     (?1 . 1) (?b . 11) (?B . 11)
		     (?2 . 2) (?c . 12) (?C . 12)
		     (?3 . 3) (?d . 13) (?D . 13)
		     (?4 . 4) (?e . 14) (?E . 14)
		     (?5 . 5) (?f . 15) (?F . 15)
		     (?6 . 6) 
		     (?7 . 7)
		     (?8 . 8)
		     (?9 . 9)))
	(n 0)
	(i 0)
	(lim (length string)))
    (while (< i lim)
      (setq n (+ (* n 16) (or (cdr (assq (aref string i) conv-list)) 0))
	    i (1+ i)))
    n ))

(defun w3-parse-rgb-components (color)
  "Parse RGB color specification and return a list of integers (R G B).
#FEFEFE and rgb:fe/fe/fe style specifications are parsed."
  (let ((case-fold-search t)
	r g b str)
  (cond ((string-match "^#[0-9a-f]+$" color)
	 (cond
	  ((= (length color) 4)
	   (setq r (w3-hex-string-to-number (substring color 1 2))
		 g (w3-hex-string-to-number (substring color 2 3))
		 b (w3-hex-string-to-number (substring color 3 4))
		 r (* r 4096)
		 g (* g 4096)
		 b (* b 4096)))
	  ((= (length color) 7)
	   (setq r (w3-hex-string-to-number (substring color 1 3))
		 g (w3-hex-string-to-number (substring color 3 5))
		 b (w3-hex-string-to-number (substring color 5 7))
		 r (* r 256)
		 g (* g 256)
		 b (* b 256)))
	  ((= (length color) 10)
	   (setq r (w3-hex-string-to-number (substring color 1 4))
		 g (w3-hex-string-to-number (substring color 4 7))
		 b (w3-hex-string-to-number (substring color 7 10))
		 r (* r 16)
		 g (* g 16)
		 b (* b 16)))
	  ((= (length color) 13)
	   (setq r (w3-hex-string-to-number (substring color 1 5))
		 g (w3-hex-string-to-number (substring color 5 9))
		 b (w3-hex-string-to-number (substring color 9 13))))
	  (t (error "Invalid RGB color specification: %s" color))))
	((string-match "rgb:\\([0-9a-f]+\\)/\\([0-9a-f]+\\)/\\([0-9a-f]+\\)"
		       color)
	 (if (or (> (- (match-end 1) (match-beginning 1)) 4)
		 (> (- (match-end 2) (match-beginning 2)) 4)
		 (> (- (match-end 3) (match-beginning 3)) 4))
	     (error "Invalid RGB color specification: %s" color)
	   (setq str (match-string 1 color)
		 r (* (w3-hex-string-to-number str)
		      (expt 16 (- 4 (length str))))
		 str (match-string 2 color)
		 g (* (w3-hex-string-to-number str)
		      (expt 16 (- 4 (length str))))
		 str (match-string 3 color)
		 b (* (w3-hex-string-to-number str)
		      (expt 16 (- 4 (length str)))))))
	(t
	 (w3-warn 'html (format "Invalid RGB color specification: %s"
				color))
	 (setq r 0
	       g 0
	       b 0)))
  (list r g b) ))

(defun w3-color-rgb-components (color)
  "Return the RGB components of COLOR as a list of integers (R G B).
16-bit values are always returned.
#FEFEFE and rgb:fe/fe/fe style color specifications are parsed directly
into their components.
RGB values for color names are looked up in the rgb.txt file.
The variable x-library-search-path is use to locate the rgb.txt file."
  (let ((case-fold-search t))
    (cond
     ((or (string-match "^#" color)
	  (string-match "^rgb:" color))
      (w3-parse-rgb-components color))
     ((string-match "\\([0-9.]+\\)[ \t]\\([0-9.]+\\)[ \t]\\([0-9.]+\\)"
		    color)
      (let ((r (string-to-number (url-match color 1)))
	    (g (string-to-number (url-match color 2)))
	    (b (string-to-number (url-match color 3))))
	(if (floatp r)
	    (setq r (round (* 255 r))
		  g (round (* 255 g))
		  b (round (* 255 b))))
	(w3-parse-rgb-components (format "#%02x%02x%02x" r g b))))
     (t
      (w3-lookup-rgb-components color)))))

(defun w3-normalize-color (color)
  "Return an RGB tuple, given any form of input.  If an error occurs, black
is returned."
  (apply 'format "#%04x%04x%04x" (w3-color-rgb-components color)))


(defun w3-parse-arena-style-sheet (fname &optional string)
  (let ((dest-buf (current-buffer))
	(url-mime-accept-string
	 (concat
	  "Accept: application/stylesheet ; notation=experimental\r\n"
	  "Accept: application/stylesheet ; notation=w3c-style"))
	(save-pos nil)
	(applies-to nil)		; List of tags to apply style to
	(attrs nil)			; List of name/value pairs
	(tag nil)
	(att nil)
	(val nil)
	(sheet nil))
    (save-excursion
      (set-buffer (get-buffer-create
		   (url-generate-new-buffer-name " *style*")))
      (erase-buffer)
      (if fname (url-insert-file-contents fname))
      (goto-char (point-max))
      (if string (insert string))
      (goto-char (point-min))
      (delete-matching-lines "^[ \t]*#")   ; Nuke comments
      (delete-matching-lines "^[ \t\r]*$") ; Nuke blank lines
      (w3-replace-regexp "--.*$" "")	   ; Nuke new style comments
      (w3-replace-regexp "^[ \t\r]+" "")   ; Nuke whitespace at beg. of line
      (w3-replace-regexp "[ \t\r]+$" "")   ; Nuke whitespace at end of line
      (w3-replace-regexp "![ \t]*\\([^ \t\r\n]+\\).*" "; priority=\"\\1\"")
      (goto-char (point-min))
      (while (not (eobp))
	(beginning-of-line)
	(setq save-pos (point))
	(skip-chars-forward "^:")
	(downcase-region save-pos (point))
	;; Could use read(), but it would slurp in the ':' as well
	(setq applies-to (url-split (buffer-substring save-pos (point))
				    "[ \t\r\n,&]"))
	(skip-chars-forward " \t:")
	(setq save-pos (point))
	(end-of-line)
	(skip-chars-backward "\r")
	(setq attrs (mm-parse-args save-pos (point) t))
	(skip-chars-forward "\r\n")
	(while applies-to
	  (setq tag (intern (downcase (car (car applies-to))))
		applies-to (cdr applies-to))
	  (let ((loop attrs))
	    (while loop
	      (setq att (car (car loop))
		    val (cdr (car loop))
		    loop (cdr loop))
	      (cond
	       ((string= "align" att)
		(setq val (intern val)))
	       ((or (string= "indent" att)
		    (string-match "^margin" att))
		(setq val (string-to-int val)))
	       (t nil))
	      (let* ((node-1 (assoc tag sheet))
		     (node-2 (and node-1 (assoc att node-1)))
		     (node-3 (assoc (symbol-name tag) sheet))
		     (node-4 (and node-3 (assoc att node-3))))
		(cond
		 ((not node-3)
		  (setq sheet (cons (cons (symbol-name tag)
					  (list (cons att val))) sheet)))
		 ((not node-4)
		  (setcdr node-3 (cons (cons att val) (cdr node-3))))
		 (t
		  (setcdr node-4 val)))
		(cond
		 ((not node-1)
		  (setq sheet (cons (cons tag (list (cons att val))) sheet)))
		 ((not node-2)
		  (setcdr node-1 (cons (cons att val) (cdr node-1))))
		 (t
		  (setcdr node-2 val))))))))
      (set-buffer-modified-p nil)
      (kill-buffer (current-buffer)))
    sheet))

(if (and (not (fboundp 'find-face))
	 (fboundp 'face-list))
    (defun find-face (face)
      (car-safe (memq face (face-list)))))

(defun w3-create-x-font (family style size em)
  (format
   "-*-%s-%s-%s-*-*-*-%s-%s-*-*-*-iso8859-1"
   family
   (if (string-match "bold" style) "bold" "medium")
   (if (string-match "italic" style) "i" "r")
   (if (eq em 'pixels) size "*")
   (if (eq em 'points) size "*")))

(defun w3-generate-stylesheet-faces (sheet)
  (url-lazy-message "Applying style hints...")
  (let ((todo (delq nil (mapcar
			 (function (lambda (x) (if (symbolp (car x)) x)))
			 sheet)))
	(cur nil)
	(node nil)
	(fore nil)
	(back nil)
	(font nil)
	(family nil)
	(scale nil)
	(var nil)
	(locale (if (fboundp 'valid-specifier-locale-p) (current-buffer)))
	(face-name nil))
    (while todo
      (setq cur (car todo)
	    todo (cdr todo)
	    var (cdr-safe (assoc (car cur) w3-all-faces))
	    node cur)
      (if node
	  (progn
	    (setq fore (downcase (or (cdr-safe (assoc "color.text" node))
				     (cdr-safe (assoc "text-color" node))
				     (cdr-safe (assoc "font.color" node))
				     (cdr-safe (assoc "font-color" node))
				     "none"))
		  back (downcase (or (cdr-safe (assoc "color.background" node))
				     (cdr-safe (assoc "text-background" node))
				     (cdr-safe (assoc "font-background" node))
				     (cdr-safe (assoc "font.background" node))
				     "none"))
		  scale (or (cdr-safe (assoc "font.size" node))
			    (cdr-safe (assoc "font-size" node)))
		  scale (cond
			 ((null scale) "none")
			 ((listp scale) (condition-case ()
					    (int-to-string
					     (eval (read
						    (format "(%c 3 %s)"
							    (car scale)
							    (cdr scale)))))
					  (error 3)))
			 ((stringp scale) (downcase scale)))
		  family (downcase (or (cdr-safe (assoc "font.family" node))
				       (cdr-safe (assoc "font-family" node))
				       "none"))
		  font (downcase (or (cdr-safe (assoc "font.style" node))
				     (cdr-safe (assoc "font-style" node))
				     "none"))
		  font (mapconcat (function (lambda (x)
					      (cond
					       ((= x ? ) "")
					       ((= x ?,) "-")
					       ((= x ?&) "-")
					       (t (char-to-string x)))))
				  font "")
		  font (mapconcat 'identity
				  (sort (mapcar 'car (url-split font "-"))
					'string-lessp)
				  "-")
		  face-name (intern (if (fboundp 'make-face-larger)
					(concat fore "/" back "/" font
						"/" scale)
				      (concat fore "/" back "/" font))))
	    (cond
	     ((and (string= fore "none")
		   (string= back "none")
		   (string= scale "none")
		   (string= font "none"))
	      nil)			; Do nothing - no style directives
	     ((find-face face-name)
	      (setcdr node (cons (cons "face" face-name) (cdr node)))
	      (let ((x (assoc (symbol-name (car node)) w3-current-stylesheet)))
		(if x
		    (setcdr x (cons (cons "face" face-name) (cdr x)))))
	      (and var (set var face-name))) ; face already created
	     (t
	      (setcdr node (cons (cons "face" face-name) (cdr node)))
	      (let ((x (assoc (symbol-name (car node)) w3-current-stylesheet)))
		(if x
		    (setcdr x (cons (cons "face" face-name) (cdr x)))))
	      (make-face face-name)
	      (and var (set var face-name))
	      (if (not (string= fore "none"))
		  (w3-munge-color-fore face-name (w3-normalize-color fore)))
	      (if (not (string= back "none"))
		  (w3-munge-color-back face-name (w3-normalize-color back)))
	      (if (and (not (string= scale "none"))
		       (fboundp 'make-face-larger))
		  (let ((size (1- (string-to-int scale))))
		    (mapcar (cond
			     ((= size 0) 'identity)
			     ((< size 0) 'make-face-smaller)
			     ((> size 0) 'make-face-larger))
			    (make-list (abs size) face-name))))
	      (if (string= font "none")
		  nil
		(progn
		  (if (string-match "bold" font)
		      (condition-case ()
			  (make-face-bold face-name)
			(error nil)))
		  (if (string-match "italic" font)
		      (condition-case ()
			  (make-face-italic face-name)
			(error nil)))
		  (if (string-match "underline" font)
		      (apply 'set-face-underline-p face-name t))))))))))
  (url-lazy-message "Applying style hints... done"))

(defun w3-handle-style (&optional args)
  (let ((fname (or (cdr-safe (assoc "href" args))
		   (cdr-safe (assoc "src" args))
		   (cdr-safe (assoc "uri" args))))
	(type (downcase (or (cdr-safe (assoc "notation" args))
			    "experimental")))
	(url-working-buffer " *style*")
	(base (cdr-safe (assoc "base" args)))
	(stylesheet nil)
	(string (cdr-safe (assoc "data" args))))
    (if fname (setq fname (url-expand-file-name fname
						(cdr-safe
						 (assoc base w3-base-alist)))))
    (save-excursion
      (set-buffer (get-buffer-create url-working-buffer))
      (erase-buffer)
      (setq url-be-asynchronous nil)
      (cond
       ((member type '("experimental" "arena" "w3c-style"))
	(setq stylesheet (w3-parse-arena-style-sheet fname string)))
       ((string= type "dsssl-lite")
	(setq stylesheet (w3-parse-dsssl-lite fname string)))
       (t
	(w3-warn 'html "Unknown stylesheet notation: %s" type))))
    (setq w3-current-stylesheet stylesheet)
    (if (and w3-current-stylesheet (fboundp 'make-face))
	(w3-generate-stylesheet-faces w3-current-stylesheet))))

(provide 'w3-style)
