--- a/lisp/utils/live-icon.el	Mon Aug 13 09:29:37 2007 +0200
+++ b/lisp/utils/live-icon.el	Mon Aug 13 09:30:11 2007 +0200
@@ -6,7 +6,11 @@
 ;; Authors: Rich Williams <rdw@hplb.hpl.hp.com>
 ;;          Jamie Zawinski <jwz@netscape.com>
 
-;; Version 1.2
+;; Minor cleanups and conversion from obsolete functions by
+;; Karl M. Hegbloom <karlheg@inetarena.com>
+
+;; Version 1.3
+
 
 ;; This file is part of XEmacs.
 
@@ -29,33 +33,6 @@
 
 ;; Generates little pixmaps representing the contents of your frames.
 
-;; #### This thing is somewhat of a mess and could stand some clean-up.
-
-(defun live-icon-colour-name-from-face (face &optional bg-p)
-  "Do backward compatible things to faces and colours"
-  (if (and (boundp 'emacs-major-version)
-	   (or (> emacs-major-version 19)
-	       (and (= emacs-major-version 19)
-		    (>= emacs-minor-version 12))))
-      (let* ((face (if (consp face) (car face) face))
-	     (colour (if bg-p
-			 (face-background face)
-		       (face-foreground face))))
-	(if (consp colour)
-	    (setq colour (cdr (car colour))))
-	(if (color-instance-p colour)
-	    (setq colour (color-instance-name colour)))
-	(if (specifierp colour)
-	    (setq colour (color-name colour)))
-	(if colour
-	    (let ((hack (format "%s" colour)))
-	      (if (string-match "(?\\([^)]*\\))?" hack)
-		  (substring hack (match-beginning 1) (match-end 1))
-		hack))))
-    (let ((p (if bg-p (face-background face) (face-foreground face))))
-      (and (pixelp p)
-	   (pixel-name p)))))
-
 (defun live-icon-alloc-colour (cmv colour)
   "Allocate a colour and a char from the magic vector"
   (let ((bob (assoc colour (aref cmv 0)))
@@ -70,20 +47,20 @@
 (defun live-icon-from-frame (&optional frame)
   "Calculates the live-icon XPM of FRAME."
   (if (not frame)
-      (setq frame (selected-screen)))
+      (setq frame (selected-frame)))
   (save-excursion
-    (select-screen frame)
-    (let* ((w (screen-width))
-	   (h (screen-height))
+    (select-frame frame)
+    (let* ((w (frame-width))
+	   (h (frame-height))
 	   (pix (make-vector h nil))
 	   (ny 0)
 	   (cmv (vector nil 0 ?A))
 	   (d (live-icon-alloc-colour
-	       cmv (pixel-name (face-background 'default))))
+	       cmv (color-name (face-background 'default))))
 	   (m (live-icon-alloc-colour
-	       cmv (pixel-name (face-background 'modeline))))
+	       cmv (color-name (face-background 'modeline))))
 	   (x (live-icon-alloc-colour
-	       cmv (pixel-name (face-foreground 'default))))
+	       cmv (color-name (face-foreground 'default))))
 	   y)
       (let ((loop 0))
 	(while (< loop h)
@@ -108,8 +85,11 @@
 					  (< (current-column) w))
 				(if (> (char-after (point)) 32)
 				    (let* ((ex (extent-at (point) (current-buffer) 'face))
-					   (f (if ex (extent-face ex)))
-					   (z (if f (live-icon-colour-name-from-face f)))
+					   (f (if ex (let ((f (extent-face ex)))
+						       (if (not (consp f))
+							   f
+							 (car f)))))
+					   (z (if f (color-name (face-foreground f))))
 					   (c (if z (live-icon-alloc-colour cmv z) x)))
 				      (aset (aref pix y) (current-column) c)))
 				(forward-char 1))
@@ -117,18 +97,14 @@
 			      (forward-line 1))))))
 	      (sort (if (fboundp 'window-list)
 			(window-list)
-		      (let* ((w (screen-root-window))
+		      (let* ((w (frame-root-window))
 			     (ws nil))
 			(while (not (memq (setq w (next-window w)) ws))
 			  (setq ws (cons w ws)))
 			ws))
-		    (if (fboundp 'window-pixel-edges)
 			#'(lambda (won woo)
 			    (< (nth 1 (window-pixel-edges won))
-			       (nth 1 (window-pixel-edges woo))))
-		      #'(lambda (won woo)
-			  (< (nth 1 (window-edges won))
-			     (nth 1 (window-edges woo)))))))
+			       (nth 1 (window-pixel-edges woo))))))
       (concat "/* XPM */\nstatic char icon[] = {\n" 
 	      (format "\"%d %d %d 1\",\n" w (* h 2) (aref cmv 1))
 	      (mapconcat #'(lambda (colour-entry)
@@ -140,189 +116,212 @@
 	      ",\n"
 	      (mapconcat #'(lambda (scan-line)
 			   (concat "\"" scan-line "\"," "\n"
-;;				   "\"" scan-line "\""
 				   "\"" (make-string w d) "\","
 				   ))
 			 pix
 			 ",\n")
 	      "};\n"))))
 
-
-(defun live-icon-start-ppm-stuff (&optional frame)
-  "Start a live icon conversion going"
-  (interactive)
-  (if (not frame)
-      (setq frame (selected-screen)))
-  (let ((buf (get-buffer-create " *live-icon*")))
-    (message "live-icon...(backgrounding)")
-    (save-excursion
-      (set-buffer buf)
-      (erase-buffer))
-    (set-process-sentinel
-     (start-process-shell-command "live-icon"
-				  buf
-				  "xwd"
-				  "-id" (format "%s" (x-window-id frame)) "|"
-				  "xwdtopnm" "|" 
-				  "pnmscale" "-xysize" "64" "64" "|"
-				  "ppmquant" "256" "|"
-				  "ppmtoxpm")
-     #'(lambda (p s)
-	 (message "live-icon...(munching)")
-	 (save-excursion
-	   (set-buffer " *live-icon*")
-	   (goto-char (point-min))
-	   (search-forward "/* XPM */")
-	   (x-set-screen-icon-pixmap frame
-				    (make-pixmap
-				     (buffer-substring
-				      (match-beginning 0) (point-max)))))
-	 (message "live-icon...... done"))))
-  nil)
-
-
 (defun live-icon-one-frame (&optional frame)
   "Gives FRAME (defaulting to (selected-frame)) a live icon."
   (interactive)
-;  (message "Updating live icon...")
   (if (not frame)
-      (setq frame (selected-screen)))
-  (x-set-screen-icon-pixmap frame (make-pixmap (live-icon-from-frame frame)))
-;  (message "Updating live icon... done")
-  )
+      (setq frame (selected-frame)))
+  (set-glyph-image frame-icon-glyph (live-icon-from-frame frame) frame))
 
-(defun live-icon-all-frames ()
-  "Gives all your frames live-icons."
-  (interactive)
-  (message "Updating live icons...")
-  (mapcar #'(lambda (fr)
-	      (x-set-screen-icon-pixmap
-	       fr (make-pixmap (live-icon-from-frame fr))))
-	  (screen-list))
-  (message "Updating live icons... done"))
+;;(defun live-icon-all-frames ()
+;;  "Gives all your frames live-icons."
+;;  (interactive)
+;;  (mapcar #'(lambda (fr)
+;;	      (set-glyph-image frame-icon-glyph
+;;			       (live-icon-from-frame fr)
+;;			       fr))
+;;	  (frame-list)))
 
 (add-hook 'unmap-screen-hook 'live-icon-one-frame)
 ;;(start-itimer "live-icon" 'live-icon-all-frames 120 120)
 
+(provide 'live-icon)
+;;; live-icon.el ends here
+
 
 
-(defun live-icon-goto-position (x y)
-  (let (window edges)
-    (catch 'done
-      (walk-windows
-       #'(lambda (w)
-	   (setq edges (window-edges w))
-	   (if (and (>= x (nth 0 edges))
-		    (<= x (nth 2 edges))
-		    (>= y (nth 1 edges))
-		    (<= y (nth 3 edges)))
-	       (throw 'done (setq window w))))
-       nil t))
-    (if (not window)
-	nil
-      (select-window window)
-      (move-to-window-line (- y (nth 1 edges)))
-      (move-to-column (- x (nth 0 edges)))
-      )))
+;;;; Spare parts and leftovers department:
+
+;; #### This thing is somewhat of a mess and could stand some clean-up.
+
+;;(defun live-icon-colour-name-from-face (face &optional bg-p)
+;;  "Do backward compatible things to faces and colours"
+;;  (if (and (boundp 'emacs-major-version)
+;;	   (or (> emacs-major-version 19)
+;;	       (and (= emacs-major-version 19)
+;;		    (>= emacs-minor-version 12))))
+;;      (let* ((face (if (consp face) (car face) face))
+;;	     (colour (if bg-p
+;;			 (face-background face)
+;;		       (face-foreground face))))
+;;	(if (consp colour)
+;;	    (setq colour (cdr (car colour))))
+;;	(if (color-instance-p colour)
+;;	    (setq colour (color-instance-name colour)))
+;;	(if (specifierp colour)
+;;	    (setq colour (color-name colour)))
+;;	(if colour
+;;	    (let ((hack (format "%s" colour)))
+;;	      (if (string-match "(?\\([^)]*\\))?" hack)
+;;		  (substring hack (match-beginning 1) (match-end 1))
+;;		hack))))
+;;    (let ((p (if bg-p (face-background face) (face-foreground face))))
+;;      (and (pixelp p)
+;;	   ;; ** The following functions are not known to be defined:  pixelp
+;;	   (pixel-name p)))))
+;;;;  ** pixel-name is an obsolete function; use color-name instead.
+
+;;(defun live-icon-start-ppm-stuff (&optional frame)
+;;  "Start a live icon conversion going"
+;;  (interactive)
+;;  (if (not frame)
+;;      (setq frame (selected-frame)))
+;;  (let ((buf (get-buffer-create " *live-icon*")))
+;;    (message "live-icon...(backgrounding)")
+;;    (save-excursion
+;;      (set-buffer buf)
+;;      (erase-buffer))
+;;    (set-process-sentinel
+;;     (start-process-shell-command "live-icon"
+;;				  buf
+;;				  "xwd"
+;;				  "-id" (format "%s" (x-window-id frame)) "|"
+;;				  "xwdtopnm" "|" 
+;;				  "pnmscale" "-xysize" "64" "64" "|"
+;;				  "ppmquant" "256" "|"
+;;				  "ppmtoxpm")
+;;     #'(lambda (p s)
+;;	 (message "live-icon...(munching)")
+;;	 (save-excursion
+;;	   (set-buffer " *live-icon*")
+;;	   (goto-char (point-min))
+;;	   (search-forward "/* XPM */")
+;;	   (set-glyph-image frame-icon-glyph
+;;			    (buffer-substring (match-beginning 0) (point-max))
+;;			    frame))
+;;	 (message "live-icon...... done"))))
+;;  nil)
+
+;;(defun live-icon-goto-position (x y)
+;;  (let (window edges)
+;;    (catch 'done
+;;      (walk-windows
+;;       #'(lambda (w)
+;;	   (setq edges (window-edges w))
+;;	   (if (and (>= x (nth 0 edges))
+;;		    (<= x (nth 2 edges))
+;;		    (>= y (nth 1 edges))
+;;		    (<= y (nth 3 edges)))
+;;	       (throw 'done (setq window w))))
+;;       nil t))
+;;    (if (not window)
+;;	nil
+;;      (select-window window)
+;;      (move-to-window-line (- y (nth 1 edges)))
+;;      (move-to-column (- x (nth 0 edges)))
+;;      )))
 
-(defun live-icon-make-image (width height)
-  (let* ((text-aspect 1.5)
-	 (xscale (/ (/ (* (screen-width)  1.0) width) text-aspect))
-	 (yscale (/ (* (screen-height) 1.0) height))
-	 (x 0)
-	 (y 0)
-	 (cmv (vector nil 0 ?A))
-	 (default-fg (live-icon-alloc-colour
-		      cmv (pixel-name (face-foreground 'default))))
-	 (default-bg (live-icon-alloc-colour
-		      cmv (pixel-name (face-background 'default))))
-	 (modeline-bg (live-icon-alloc-colour
-		       cmv (pixel-name (face-background 'modeline))))
-	 (lines (make-vector height nil)))
-    ;;
-    ;; Put in the text.
-    ;;
-    (save-excursion
-      (save-window-excursion
-	(while (< y height)
-	  (aset lines y (make-string width default-bg))
-	  (setq x 0)
-	  (while (< x width)
-	    (let ((sx (floor (* x xscale)))
-		  (sy (floor (* y yscale))))
-	      (live-icon-goto-position sx sy)
-	      (let* ((extent (extent-at (point) (current-buffer) 'face))
-		     (face (if extent (extent-face extent)))
-		     (name (if face (live-icon-colour-name-from-face
-				     face (<= (char-after (point)) 32))))
-		     (color (if name
-				(live-icon-alloc-colour cmv name)
-			      (if (<= (or (char-after (point)) 0) 32)
-				  default-bg default-fg))))
-		(aset (aref lines y) x color)))
-	    (setq x (1+ x)))
-	  (setq y (1+ y)))))
-    ;;
-    ;; Now put in the modelines.
-    ;;
-    (let (sx sy)
-      (walk-windows
-       #'(lambda (w)
-	   (let ((edges (window-edges w)))
-	     (setq x (nth 0 edges)
-		   y (nth 3 edges)
-		   sx (floor (/ x xscale))
-		   sy (floor (/ y yscale)))
-	     (while (and (< x (1- (nth 2 edges)))
-			 (< sx (length (aref lines 0))))
-	       (aset (aref lines sy) sx modeline-bg)
-	       (if (> sy 0)
-		   (aset (aref lines (1- sy)) sx modeline-bg))
-	       (setq x (1+ x)
-		     sx (floor (/ x xscale))))
-	     (if (>= sx (length (aref lines 0)))
-		 (setq sx (1- sx)))
-	     (while (>= y (nth 1 edges))
-	       (aset (aref lines sy) sx modeline-bg)
-	       (setq y (1- y)
-		     sy (floor (/ y yscale))))))
-       nil nil))
-    ;;
-    ;; Now put in the top and left edges
-    ;;
-    (setq x 0)
-    (while (< x width)
-      (aset (aref lines 0) x modeline-bg)
-      (setq x (1+ x)))
-    (setq y 0)
-    (while (< y height)
-      (aset (aref lines y) 0 modeline-bg)
-      (setq y (1+ y)))
-    ;;
-    ;; Now make the XPM
-    ;;
-    (concat "/* XPM */\nstatic char icon[] = {\n" 
-	    (format "\"%d %d %d 1\",\n"
-		    width
-;;		    (* height 2)
-		    height
-		    (aref cmv 1))
-	    (mapconcat #'(lambda (colour-entry)
-			   (format "\"%c c %s\""
-				   (cdr colour-entry) 
-				   (car colour-entry)))
-		       (aref cmv 0)
-		       ",\n")
-	    ",\n"
-	    (mapconcat #'(lambda (scan-line)
-			   (concat "\"" scan-line "\"," "\n"
-;;				   "\"" scan-line "\""
-;;				   "\"" (make-string width default-bg)
-;;				   "\","
-				   ))
-		       lines
-		       ",\n")
-	    "};\n")))
-
-(provide 'live-icon)
-;;; live-icon.el ends here
+;;(defun live-icon-make-image (width height)
+;;  (let* ((text-aspect 1.5)
+;;	 (xscale (/ (/ (* (frame-width)  1.0) width) text-aspect))
+;;	 (yscale (/ (* (frame-height) 1.0) height))
+;;	 (x 0)
+;;	 (y 0)
+;;	 (cmv (vector nil 0 ?A))
+;;	 (default-fg (live-icon-alloc-colour
+;;		      cmv (color-name (face-foreground 'default))))
+;;	 (default-bg (live-icon-alloc-colour
+;;		      cmv (color-name (face-background 'default))))
+;;	 (modeline-bg (live-icon-alloc-colour
+;;		       cmv (color-name (face-background 'modeline))))
+;;	 (lines (make-vector height nil)))
+;;    ;;
+;;    ;; Put in the text.
+;;    ;;
+;;    (save-excursion
+;;      (save-window-excursion
+;;	(while (< y height)
+;;	  (aset lines y (make-string width default-bg))
+;;	  (setq x 0)
+;;	  (while (< x width)
+;;	    (let ((sx (floor (* x xscale)))
+;;		  (sy (floor (* y yscale))))
+;;	      (live-icon-goto-position sx sy)
+;;	      (let* ((extent (extent-at (point) (current-buffer) 'face))
+;;		     (face (if extent (extent-face extent)))
+;;		     (name (if face (live-icon-colour-name-from-face
+;;				     face (<= (char-after (point)) 32))))
+;;		     (color (if name
+;;				(live-icon-alloc-colour cmv name)
+;;			      (if (<= (or (char-after (point)) 0) 32)
+;;				  default-bg default-fg))))
+;;		(aset (aref lines y) x color)))
+;;	    (setq x (1+ x)))
+;;	  (setq y (1+ y)))))
+;;    ;;
+;;    ;; Now put in the modelines.
+;;    ;;
+;;    (let (sx sy)
+;;      (walk-windows
+;;       #'(lambda (w)
+;;	   (let ((edges (window-edges w)))
+;;	     (setq x (nth 0 edges)
+;;		   y (nth 3 edges)
+;;		   sx (floor (/ x xscale))
+;;		   sy (floor (/ y yscale)))
+;;	     (while (and (< x (1- (nth 2 edges)))
+;;			 (< sx (length (aref lines 0))))
+;;	       (aset (aref lines sy) sx modeline-bg)
+;;	       (if (> sy 0)
+;;		   (aset (aref lines (1- sy)) sx modeline-bg))
+;;	       (setq x (1+ x)
+;;		     sx (floor (/ x xscale))))
+;;	     (if (>= sx (length (aref lines 0)))
+;;		 (setq sx (1- sx)))
+;;	     (while (>= y (nth 1 edges))
+;;	       (aset (aref lines sy) sx modeline-bg)
+;;	       (setq y (1- y)
+;;		     sy (floor (/ y yscale))))))
+;;       nil nil))
+;;    ;;
+;;    ;; Now put in the top and left edges
+;;    ;;
+;;    (setq x 0)
+;;    (while (< x width)
+;;      (aset (aref lines 0) x modeline-bg)
+;;      (setq x (1+ x)))
+;;    (setq y 0)
+;;    (while (< y height)
+;;      (aset (aref lines y) 0 modeline-bg)
+;;      (setq y (1+ y)))
+;;    ;;
+;;    ;; Now make the XPM
+;;    ;;
+;;    (concat "/* XPM */\nstatic char icon[] = {\n" 
+;;	    (format "\"%d %d %d 1\",\n"
+;;		    width
+;;;;		    (* height 2)
+;;		    height
+;;		    (aref cmv 1))
+;;	    (mapconcat #'(lambda (colour-entry)
+;;			   (format "\"%c c %s\""
+;;				   (cdr colour-entry) 
+;;				   (car colour-entry)))
+;;		       (aref cmv 0)
+;;		       ",\n")
+;;	    ",\n"
+;;	    (mapconcat #'(lambda (scan-line)
+;;			   (concat "\"" scan-line "\"," "\n"
+;;;;				   "\"" scan-line "\""
+;;;;				   "\"" (make-string width default-bg)
+;;;;				   "\","
+;;				   ))
+;;		       lines
+;;		       ",\n")
+;;	    "};\n")))