*** x-face.el-orig	Sat Nov 13 05:29:07 1999
--- x-face.el	Sat Nov 13 05:33:06 1999
***************
*** 1224,1231 ****
  	       "^\\(X-Face-Type\\|X-Face\\):[\n\t ]+"))
  	(re2 (concat "geometry[\t \"'`]*=[\t \"'`]*"
  		     "\\([1-9]+\\)[\t \"'`]*x[\t \"'`]*\\([1-9]+\\)"))
  	beg end prop filename cache attributes modtime size image
! 	rgb geometry num field fields faces x-faces)
      (save-restriction
        (x-face-narrow-to-header)
        (while (re-search-forward re1 nil t)
--- 1224,1233 ----
  	       "^\\(X-Face-Type\\|X-Face\\):[\n\t ]+"))
  	(re2 (concat "geometry[\t \"'`]*=[\t \"'`]*"
  		     "\\([1-9]+\\)[\t \"'`]*x[\t \"'`]*\\([1-9]+\\)"))
+ 	(re3 (concat "animate[\t \"'`]*=[\t \"'`]*"
+                      "\\([\.0-9]+\\)[\t \"'`]*"))
  	beg end prop filename cache attributes modtime size image
! 	rgb geometry num field fields faces x-faces animate)
      (save-restriction
        (x-face-narrow-to-header)
        (while (re-search-forward re1 nil t)
***************
*** 1260,1265 ****
--- 1262,1271 ----
  		(goto-char beg)
  		(setq rgb (or (looking-at "[\t \"'`]*RGB")
  			      (re-search-forward ";[\t \"'`]*RGB" end t)))
+                 (goto-char beg)
+                 (setq animate (and (re-search-forward re3 end t)
+                                    (string-to-number (match-string 1))))
+                 (setq animate (and (numberp animate) (max animate 0.05)))
  		(goto-char beg)
  		(setq geometry (and (re-search-forward re2 end t)
  				    (list (string-to-int (match-string 1))
***************
*** 1280,1291 ****
  				    (point-max)))
  				  (decf num)))))
  		    (progn
! 		      (setq field (format "X-Face-Type: %s%s\n"
! 					  (if rgb
! 					      (if geometry
! 						  "RGB; "
! 						"RGB")
! 					    "")
  					  (if geometry
  					      (apply 'format
  						     "geometry=%dx%d" geometry)
--- 1286,1303 ----
  				    (point-max)))
  				  (decf num)))))
  		    (progn
!                       (setq field (format "X-Face-Type: %s%s%s\n"
!                                           (if rgb
!                                               (if (or geometry animate)
!                                                   "RGB; "
!                                                 "RGB")
!                                             "")
!                                           (if animate
!                                               (if geometry
!                                                   (format "animate=%g; " animate)
!                                                 (format "animate=%g" animate)
! 						(setq geometry '(1 1)))
!                                             "")
  					  (if geometry
  					      (apply 'format
  						     "geometry=%dx%d" geometry)
***************
*** 1297,1303 ****
  				(point-max)))
  		      (goto-char beg)
  		      (setq faces nil)
! 		      (while (and (> num 0)
  				  (re-search-forward "X-Face:[\n\t ]+" end t))
  			(decf num)
  			(setq faces
--- 1309,1315 ----
  				(point-max)))
  		      (goto-char beg)
  		      (setq faces nil)
! 		      (while (and (or (> num 0) animate)
  				  (re-search-forward "X-Face:[\n\t ]+" end t))
  			(decf num)
  			(setq faces
***************
*** 1334,1349 ****
  				  (mapcar
  				   'x-face-x-face-encoded-string-to-icon-string
  				   faces))
! 			    (if (and geometry
! 				     (eq (apply '* (if rgb 3 1) geometry)
! 					 (length faces)))
  				(list
  				 (append (cons (if rgb 'rgb 'mono) geometry)
! 					 faces))
  			      (mapcar
  			       (function
  				(lambda (face)
! 				  (cons '(mono 1 1) (list face))))
  			       faces)))))))
  	    (list
  	     (if (and x-face-xmas-xface-p glyph)
--- 1346,1362 ----
  				  (mapcar
  				   'x-face-x-face-encoded-string-to-icon-string
  				   faces))
! 			    (if (and geometry 
! 				     (or animate
! 					 (eq (apply '* (if rgb 3 1) geometry)
! 					     (length faces))))
  				(list
  				 (append (cons (if rgb 'rgb 'mono) geometry)
! 					 (list animate) faces))
  			      (mapcar
  			       (function
  				(lambda (face)
! 				  (list '(mono 1 1) (list animate face))))
  			       faces)))))))
  	    (list
  	     (if (and x-face-xmas-xface-p glyph)
***************
*** 1356,1362 ****
  			      "X-Face: "
  			      (buffer-substring-no-properties beg end)))))
  		   (set-glyph-face glyph 'x-face-xmas-x-face-face))
! 	       (list 'mono 1 1
  		     (x-face-x-face-region-to-icon-string beg end))))
  	    )))))
      (mapcar
--- 1369,1375 ----
  			      "X-Face: "
  			      (buffer-substring-no-properties beg end)))))
  		   (set-glyph-face glyph 'x-face-xmas-x-face-face))
! 	       (list 'mono 1 1 nil
  		     (x-face-x-face-region-to-icon-string beg end))))
  	    )))))
      (mapcar
***************
*** 1367,1373 ****
    (save-excursion
      (set-buffer buffer)
      (mapcar
!      (function (lambda (elt) (car (cdr (cdr (cdr (cdr elt)))))))
       (x-face-extract-x-face-fields-to-icons 'single))))
  
  (defun x-face-concat-mono-icons (x y icons)
--- 1380,1386 ----
    (save-excursion
      (set-buffer buffer)
      (mapcar
!      (function (lambda (elt) (car (cdr (cdr (cdr (cdr (cdr elt))))))))
       (x-face-extract-x-face-fields-to-icons 'single))))
  
  (defun x-face-concat-mono-icons (x y icons)
***************
*** 1649,1654 ****
--- 1662,1668 ----
  	(setq type (pop icons)
  	      x (pop icons)
  	      y (pop icons))
+ 	(pop icons)
  	(push (if (eq 'rgb type)
  		  (cons spec
  			(funcall x-face-icons-to-color-picture-function
***************
*** 1716,1721 ****
--- 1730,1736 ----
  	(setq type (pop icons)
  	      x (pop icons)
  	      y (pop icons))
+ 	(pop icons)
  	(if (eq 'rgb type)
  	    (setq names (x-face-generate-file-name
  			 real-dir name num spec compr)
*** x-face-xmas.el-orig	Sat Nov 13 05:29:19 1999
--- x-face-xmas.el	Sat Nov 13 05:33:27 1999
***************
*** 334,375 ****
    (x-face-xmas-display-x-face-not-read-only *cmail-mail-buffer arg))
  
  (defun x-face-xmas-extract-x-face-fields-to-glyphs ()
!   (let (field type x y glyph)
      (mapcar
       (lambda (icons)
         (setq field (pop icons))
!        (if (glyphp icons)
  	   icons
  	 (setq type (pop icons)
  	       x (pop icons)
  	       y (pop icons)
  	       glyph nil)
! 	 (if (eq 'rgb type)
! 	     (save-excursion
! 	       (set-buffer (x-face-icons-to-xpm
! 			    "noname" x y
! 			    (x-face-concat-rgb-icons x y icons)))
! 	       (setq glyph (make-glyph
! 			    (vector 'xpm :data (buffer-string))))
! 	       (kill-buffer (current-buffer)))
! 	   (setq glyph
! 		 (make-glyph
! 		  (vector
! 		   'xbm :data
! 		   (list
! 		    (* 48 x) (* 48 y)
! 		    (mapconcat 'char-to-string
! 			       (x-face-ascii-to-binary-icon
! 				(x-face-concat-mono-icons x y icons)
! 				nil nil 'xmas)
! 			       "")))))
! 	   (set-glyph-face glyph 'x-face-xmas-x-face-face))
  	 (and field (push (list field glyph) x-face-xmas-image-field-cache))
  	 glyph))
       (save-excursion
         (x-face-extract-x-face-fields-to-icons nil 'glyph)
         ))))
  
  (defun x-face-xmas-search-extents ()
    (let ((case-fold-search t)
  	points extent extents from x-face)
--- 334,402 ----
    (x-face-xmas-display-x-face-not-read-only *cmail-mail-buffer arg))
  
  (defun x-face-xmas-extract-x-face-fields-to-glyphs ()
!   (let (field animate type x y glyph)
      (mapcar
       (lambda (icons)
         (setq field (pop icons))
!        (if (or (glyphp icons)
! 	       (numberp (car icons))) ; animated glyph
  	   icons
  	 (setq type (pop icons)
  	       x (pop icons)
  	       y (pop icons)
+ 	       animate (pop icons)
  	       glyph nil)
! 	 (setq glyph
! 	       (if animate
! 		   (cons animate
! 			 (mapcar '(lambda (icon)
! 				    (x-face-xmas-extract-x-face-fields-internal
! 				     type x y icon))
! 				 (x-face-xmas-pack-icons 
! 				  icons (apply '* (if (eq 'rgb type) 3 1)
! 					       (list x y)))))
! 		 (x-face-xmas-extract-x-face-fields-internal type x y icons)))
  	 (and field (push (list field glyph) x-face-xmas-image-field-cache))
  	 glyph))
       (save-excursion
         (x-face-extract-x-face-fields-to-icons nil 'glyph)
         ))))
  
+ (defun x-face-xmas-extract-x-face-fields-internal (type x y icon)
+   (let (glyph)
+     (if (eq 'rgb type)
+ 	(save-excursion
+ 	  (set-buffer (x-face-icons-to-xpm
+ 		       "noname" x y
+ 		       (x-face-concat-rgb-icons x y icon)))
+ 	  (setq glyph (make-glyph
+ 		       (vector 'xpm :data (buffer-string))))
+ 	  (kill-buffer (current-buffer)))
+       (setq glyph
+ 	    (make-glyph
+ 	     (vector
+ 	      'xbm :data
+ 	      (list
+ 	       (* 48 x) (* 48 y)	       (mapconcat 'char-to-string
+ 			  (x-face-ascii-to-binary-icon
+ 			   (x-face-concat-mono-icons x y icon)
+ 			   nil nil 'xmas)
+ 			  "")))))
+       (set-glyph-face glyph 'x-face-xmas-x-face-face))
+     glyph))
+ 
+ (defsubst x-face-xmas-pack-icons (icons num)
+   (let (ic)
+     (while icons
+       (setq ic
+ 	    (append ic (list icons)))
+       (setq icons
+ 	    (prog1
+ 		(nthcdr num icons)
+ 	      (if (nthcdr (1- num) icons)
+ 		  (setcdr (nthcdr (1- num) icons) nil)))))
+     ic))
+ 
  (defun x-face-xmas-search-extents ()
    (let ((case-fold-search t)
  	points extent extents from x-face)
***************
*** 469,477 ****
  		 (mapcar
  		  (lambda (glyph)
  		    (setq extent (make-extent (1- pt) pt))
! 		    (if (and x-face-xmas-like-highlight-headers from)
! 			(set-extent-end-glyph extent glyph)
! 		      (set-extent-begin-glyph extent glyph))
  		    (set-extent-property extent 'x-face-image t)
  		    (set-extent-property extent 'duplicable t))
  		  (if (and x-face-xmas-like-highlight-headers (not from))
--- 496,510 ----
  		 (mapcar
  		  (lambda (glyph)
  		    (setq extent (make-extent (1- pt) pt))
! 		    (if (listp glyph) ;; animated glyph
! 			(x-face-xmas-display-x-face-animate 
! 			 (car glyph)
! 			 extent
! 			 (and x-face-xmas-like-highlight-headers from)
! 			 (cdr glyph))
! 		      (if (and x-face-xmas-like-highlight-headers from)
! 			  (set-extent-end-glyph extent glyph)
! 			(set-extent-begin-glyph extent glyph)))
  		    (set-extent-property extent 'x-face-image t)
  		    (set-extent-property extent 'duplicable t))
  		  (if (and x-face-xmas-like-highlight-headers (not from))
***************
*** 487,492 ****
--- 520,536 ----
  	      (lambda (i)
  		(put-text-property (car i) (caddr i) 'invisible nil))
  	      x-face))))))))
+ 
+ (defun x-face-xmas-display-x-face-animate (sec ext locate glyphs)
+   "Display X-Face fields as XEmacs glyph."
+   (if (extent-live-p ext)
+       (if (extent-detached-p ext)
+ 	  (delete-extent ext)
+ 	(if locate
+ 	    (set-extent-end-glyph ext (car glyphs))
+ 	  (set-extent-begin-glyph ext (car glyphs)))
+ 	(run-with-timer sec nil 'x-face-xmas-display-x-face-animate sec ext
+ 			locate (append (cdr glyphs) (list (car glyphs)))))))
  
  ;;;###autoload
  (defun x-face-xmas-force-display-x-face ()