gnus-picons update

gnus-picons update

[Wesley.Hardaker]

Heh...  

Ok, I've out-done myself in stupid useless coding projects with this
one.  There is no reason what-so-ever for actually using the following
features...  You have been warned...

The following patch is against rgnus-0.27 and does 2 things:

1) speed improvements:
  - first, I put a sit-for at the top of the display routines so that
    you can begin reading the article in question before the icons
    show up...  This really should be an option...  Oh well...
  - Lars, in order to simplify and shorten the code length, searched
    both the domains and users database for both types of icons
    (username and "unknown").  I removed this, as you will never find
    username directories under the domains section and likewise for
    the users section...  IE, half the number of searches (I realize
    this is only a slight speed gain).

2) Stupid useless improvements:
  - The icons are now displayed as a real email address rather than
    just as icons.  It relpaces the parts of the address that can be
    represented by icons with icons, and replaces the user name with a
    face for the user, if present.  You can, of course, click on the
    appropriate graphic symbol and have it change into text and
    vise-versa.  As I said...  Stupid...  But cute...

3) gnus-group-display-picons:  Hey...  Can't have it all in a day.  I
   still have to munge this one...  It can actually be done fairly
   easily, providing you don't mind the newsgroup tokens being
   backwards (ie, gnus.emacs.gnu instead of gnu.emacs.gnus)...  sigh...

Hey!  I hate that!  What a stupid idea!  Please make it go away! :
  (setq gnus-picons-display-as-address nil)

Lars, I greatly @#$#ed up the nice pretty code you had in there...
Sorry about that...  It needs to be visually cleaned up a bit,
reworking the indentation sceme...  Sorry...

Wes

Index: ChangeLog
===================================================================
RCS file: /home/whardake/src/cvsroot/rgnus/ChangeLog,v
retrieving revision 1.1.1.5
retrieving revision 1.6
diff -c -r1.1.1.5 -r1.6
*** 1.1.1.5	1996/09/06 12:35:19
--- 1.6	1996/09/06 12:45:19
***************
*** 1,3 ****
--- 1,14 ----
+ Fri Sep  6 14:38:54 1996  Wes Hardaker <Wesley.Hardaker@sphys.unil.ch>
+ 
+ 	* gnus-picons.el (gnus-picons-display-as-address): New variable.
+ 	(gnus-picons-map): New keymap for picons.
+ 	(gnus-picons-toggle-extent): New function.
+ 	(gnus-article-display-picons): use them.
+ 	(gnus-picons-insert-face-if-exists): ditto.
+ 	(gnus-picons-try-to-find-face): ditto.
+ 	(gnus-group-display-picons): let display catch up.
+ 	(gnus-article-display-picons): ditto.
+ 
  Thu Sep  5 19:50:19 1996  Lars Magne Ingebrigtsen  <larsi@ifi.uio.no>
  
  	* gnus-xmas.el (gnus-xmas-modeline-glyph): Set string properly.
Index: gnus-picon.el
===================================================================
RCS file: /home/whardake/src/cvsroot/rgnus/gnus-picon.el,v
retrieving revision 1.1.1.1
retrieving revision 1.3
diff -c -r1.1.1.1 -r1.3
*** 1.1.1.1	1996/08/20 07:06:45
--- 1.3	1996/09/06 12:32:53
***************
*** 110,115 ****
--- 110,118 ----
    "Command to convert the x-face header into a xbm file."
  )
  
+ (defvar gnus-picons-display-as-address t
+   "*If t display textual email addresses along with pictures.")
+ 
  (defvar gnus-picons-file-suffixes
    (when (featurep 'x)
      (let ((types (list "xbm")))
***************
*** 124,129 ****
--- 127,137 ----
    "*Whether to move point to first empty line when displaying picons.
  This has only an effect if `gnus-picons-display-where' hs value article.")
  
+ (defvar gnus-picons-map (make-sparse-keymap "gnus-picons-keys")
+  "keymap to hide/show picon glpyhs")
+ 
+ (define-key gnus-picons-map [(button2)] 'gnus-picons-toggle-extent)
+ 
  ;;; Internal variables.
         
  (defvar gnus-group-annotations nil)
***************
*** 207,212 ****
--- 215,222 ----
  (defun gnus-article-display-picons ()
    "Display faces for an author and his/her domain in gnus-picons-display-where."
    (interactive)
+   ;; let drawing catch up
+   (sit-for 0)
    (let (from at-idx databases)
      (when (and (featurep 'xpm) 
  	       (or (not (fboundp 'device-type)) (equal (device-type) 'x))
***************
*** 240,264 ****
  	  (gnus-picons-remove gnus-article-annotations)
  	  (setq gnus-article-annotations nil)
  
! 	  (setq databases (append gnus-picons-user-directories
! 				  gnus-picons-domain-directories))
  	  (while databases
  	    (setq gnus-article-annotations
  		  (nconc (gnus-picons-insert-face-if-exists
  			  (car databases)
  			  addrs
! 			  "unknown")
! 			 (gnus-picons-insert-face-if-exists
! 			  (car databases)
! 			  addrs
! 			  (downcase username) t)
  			 gnus-article-annotations))
  	    (setq databases (cdr databases)))
  	  (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))))
  
  (defun gnus-group-display-picons ()
    "Display icons for the group in the gnus-picons-display-where buffer." 
    (interactive)
    (when (and (featurep 'xpm) 
  	     (or (not (fboundp 'device-type)) (equal (device-type) 'x)))
      (save-excursion
--- 250,300 ----
  	  (gnus-picons-remove gnus-article-annotations)
  	  (setq gnus-article-annotations nil)
  
! 	  ;; look for domain paths.
! 	  (setq databases gnus-picons-domain-directories)
  	  (while databases
  	    (setq gnus-article-annotations
  		  (nconc (gnus-picons-insert-face-if-exists
  			  (car databases)
  			  addrs
! 			  "unknown" t)
  			 gnus-article-annotations))
  	    (setq databases (cdr databases)))
+ 
+ 	  ;; add an '@' if displaying as address
+ 	  (when gnus-picons-display-as-address
+ 	    (setq gnus-article-annotations
+ 		  (nconc gnus-article-annotations
+ 			 (list 
+ 			  (make-annotation "@" (point) 'text nil nil nil t)))))
+ 
+ 	  ;; then do user directories,
+ 	  (let (found)
+ 	    (setq databases gnus-picons-user-directories)
+ 	    (setq username (downcase username))
+ 	    (while databases
+ 	      (setq found
+ 		    (nconc  (gnus-picons-insert-face-if-exists
+ 			     (car databases)
+ 			     addrs
+ 			     username)
+ 			    found))
+ 	      (setq databases (cdr databases)))
+ 	    ;; add their name if no face exists
+ 	    (when (and gnus-picons-display-as-address (not found))
+ 	      (setq found
+ 		    (list 
+ 		     (make-annotation username (point) 'text nil nil nil t))))
+ 	    (setq gnus-article-annotations 
+ 		  (nconc found gnus-article-annotations)))
+ 
  	  (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))))
  
  (defun gnus-group-display-picons ()
    "Display icons for the group in the gnus-picons-display-where buffer." 
    (interactive)
+   ;; let display catch up so far
+   (sit-for 0)
    (when (and (featurep 'xpm) 
  	     (or (not (fboundp 'device-type)) (equal (device-type) 'x)))
      (save-excursion
***************
*** 312,345 ****
    ;;  1. MISC/Name
    ;; The special treatment of MISC doesn't conform with the conventions for
    ;; picon databases, but otherwise we would always see the MISC/unknown face.
!   (let ((bar (and (not nobar-p)
  		  (annotations-in-region 
  		   (point) (min (point-max) (1+ (point)))
  		   (current-buffer))))
  	(path (concat (file-name-as-directory gnus-picons-database)
  		      database "/"))
! 	picons found bar-ann)
      (if (string-match "/MISC" database)
  	(setq addrs '("")))
      (while (and addrs
  		(file-accessible-directory-p path))
!       (setq path (concat path (pop addrs) "/"))
!       (when (setq found
! 		  (gnus-picons-try-suffixes
! 		   (concat path filename "/face.")))
! 	(when bar
! 	  (setq bar-ann (gnus-picons-try-to-find-face 
! 			 (concat gnus-xmas-glyph-directory "bar.xbm")))
! 	  (when bar-ann
! 	    (setq picons (nconc picons bar-ann))
! 	    (setq bar nil)))
! 	(setq picons (nconc (gnus-picons-try-to-find-face found)
! 			    picons))))
!     (nreverse picons)))
  
  (defvar gnus-picons-glyph-alist nil)
        
! (defun gnus-picons-try-to-find-face (path &optional xface-p)
    "If PATH exists, display it as a bitmap.  Returns t if succedded."
    (let ((glyph (and (not xface-p)
  		    (cdr (assoc path gnus-picons-glyph-alist)))))
--- 348,398 ----
    ;;  1. MISC/Name
    ;; The special treatment of MISC doesn't conform with the conventions for
    ;; picon databases, but otherwise we would always see the MISC/unknown face.
!   (let ((bar (and (not gnus-picons-display-as-address)
! 		  (not nobar-p)
  		  (annotations-in-region 
  		   (point) (min (point-max) (1+ (point)))
  		   (current-buffer))))
  	(path (concat (file-name-as-directory gnus-picons-database)
  		      database "/"))
! 	(domainp (and gnus-picons-display-as-address nobar-p))
! 	picons found bar-ann cur first)
      (if (string-match "/MISC" database)
  	(setq addrs '("")))
      (while (and addrs
  		(file-accessible-directory-p path))
!       (setq cur (pop addrs)
! 	    path (concat path cur "/"))
!       (if (setq found 
! 		(gnus-picons-try-suffixes (concat path filename "/face.")))
! 	  (progn 
! 	    (when bar
! 	      (setq bar-ann (gnus-picons-try-to-find-face 
! 			     (concat gnus-xmas-glyph-directory "bar.xbm")))
! 	      (when bar-ann
! 		(setq picons (nconc picons bar-ann))
! 		(setq bar nil)))
! 	    (setq picons (nconc (when (and domainp first)
! 				  (list (make-annotation "." (point) 'text 
! 							 nil nil nil t) picons))
! 				(gnus-picons-try-to-find-face 
! 				 found nil (if domainp cur filename))
! 				picons)))
! 	(when domainp
! 	  (setq picons 
! 		(nconc (list (make-annotation (if first (concat cur ".") cur)
! 					      (point) 'text nil nil nil t)) 
! 		       picons))))
!       (setq first t))
!     (when (and addrs domainp)
!       (let ((it (mapconcat 'downcase addrs ".")))
! 	(make-annotation 
! 	 (if first (concat it ".") it) (point) 'text nil nil nil t)))
!     picons))
  
  (defvar gnus-picons-glyph-alist nil)
        
! (defun gnus-picons-try-to-find-face (path &optional xface-p part)
    "If PATH exists, display it as a bitmap.  Returns t if succedded."
    (let ((glyph (and (not xface-p)
  		    (cdr (assoc path gnus-picons-glyph-alist)))))
***************
*** 349,362 ****
  	(unless xface-p
  	  (push (cons path glyph) gnus-picons-glyph-alist))
  	(set-glyph-face glyph 'default))
!       (nconc
!        (list (make-annotation glyph (point) 'text))
!        (when (eq major-mode 'gnus-article-mode)
! 	 (list (make-annotation " " (point) 'text)))))))
  
  (defun gnus-picons-reverse-domain-path (str)
    "a/b/c/d -> d/c/b/a"
    (mapconcat 'downcase (nreverse (message-tokenize-header str "/")) "/"))
  
  (gnus-add-shutdown 'gnus-picons-close 'gnus)
  
--- 402,435 ----
  	(unless xface-p
  	  (push (cons path glyph) gnus-picons-glyph-alist))
  	(set-glyph-face glyph 'default))
!       (let ((new (make-annotation glyph (point) 'text nil nil nil t)))
! 	(nconc
! 	 (list new)
! 	 (when (and (eq major-mode 'gnus-article-mode)
! 		    (not gnus-picons-display-as-address)
! 		    (not part))
! 	   (list (make-annotation " " (point) 'text nil nil nil t)))
! 	 (when (and part gnus-picons-display-as-address)
! 	   (let ((txt (make-annotation part (point) 'text nil nil nil t)))
! 	     (hide-annotation txt)
! 	     (set-extent-property txt 'its-partner new)
! 	     (set-extent-property txt 'keymap gnus-picons-map)
! 	     (set-extent-property txt 'mouse-face gnus-article-mouse-face)
! 	     (set-extent-property new 'its-partner txt)
! 	     (set-extent-property new 'keymap gnus-picons-map))))))))
  
  (defun gnus-picons-reverse-domain-path (str)
    "a/b/c/d -> d/c/b/a"
    (mapconcat 'downcase (nreverse (message-tokenize-header str "/")) "/"))
+ 
+ (defun gnus-picons-toggle-extent (event)
+   "Toggle picon glyph at given point"
+   (interactive "e")
+   (let* ((ant1 (event-glyph-extent event))
+ 	 (ant2 (extent-property ant1 'its-partner)))
+     (when (and (annotationp ant1) (annotationp ant2))
+       (reveal-annotation ant2)
+       (hide-annotation ant1))))
  
  (gnus-add-shutdown 'gnus-picons-close 'gnus)
  

Re: gnus-picons update

[Hans de Graaff]

Wesley.Hardaker@sphys.unil.ch writes:

Cool... but some comments ;-)

> 1) speed improvements:
>   - first, I put a sit-for at the top of the display routines so that
>     you can begin reading the article in question before the icons
>     show up...  This really should be an option...  Oh well...

What is irritating about this is that the initial line is just
text. As soon as the icons get inserted this changes the line height,
and shifts all other text down. Annoying. How about inserting a small
blank xpm of the proper height immediately, to reserve the line height.

> 2) Stupid useless improvements:
>   - The icons are now displayed as a real email address rather than
>     just as icons.  It relpaces the parts of the address that can be
>     represented by icons with icons, and replaces the user name with a
>     face for the user, if present.  You can, of course, click on the
>     appropriate graphic symbol and have it change into text and
>     vise-versa.  As I said...  Stupid...  But cute...

Also redundant. I'd rather see this changed in the From: line. Then
the X-Face, which is currently shown there just after the From: could
be included in the email-address as well, and we would have the picons
all in one place.

Hans
-- 
Hans de Graaff                        http://is.twi.tudelft.nl/~graaff/

Re: gnus-picons update

[Wesley.Hardaker]

Hans de Graaff <J.J.deGraaff@twi.tudelft.nl> writes:

> What is irritating about this is that the initial line is just
> text. As soon as the icons get inserted this changes the line height,
> and shifts all other text down. Annoying. How about inserting a small
> blank xpm of the proper height immediately, to reserve the line
> height.

I've thought about this...  However, this would slow it down more and
additionally require reading yet one more image file...  

What should be done (and will be I promise) is to create a variable so
that it will optionally update the buffer first rather than force it
to, as is being done now...  That way you can pick if it does said
improvement.  

> Also redundant. I'd rather see this changed in the From: line. Then
> the X-Face, which is currently shown there just after the From: could
> be included in the email-address as well, and we would have the picons
> all in one place.

Yep, its on my todo list in fact...  I want to essentially zap the
address out of the From: line and replace it with icons...  This
should be an option though.  Maybe set gnus-picons-display-where to
'from-line or something instead of 'article.  That way its
user-pickable...

Wes

Re: gnus-picons update

[William Perry]

Wesley Hardaker writes:
>Hans de Graaff <J.J.deGraaff@twi.tudelft.nl> writes:
>
>> What is irritating about this is that the initial line is just
>> text. As soon as the icons get inserted this changes the line height,
>> and shifts all other text down. Annoying. How about inserting a small
>> blank xpm of the proper height immediately, to reserve the line
>> height.
>
>I've thought about this...  However, this would slow it down more and
>additionally require reading yet one more image file...

  You would only need to do this once at startup.  And you can build a
pixmap pretty easily in memory.  I've got the code to do it for Emacs-W3.
Try something like:

(defun create-blank-pixmap (width height)
  (let ((retval
	 (concat "/* XPM */\n"
		 "static char *pixmap[] = {\n"
		 ;;"/* width height num_colors chars_per_pixel */\n"
		 (format "\"    %d   %d   2     1\",\n" width height)
		 ;;"/* colors */\n"
		 "\". c #000000 s background\",\n"
		 "\"# c #FFFFFF s foreground\",\n"
		 ;;"/* pixels /*\n"
		 ))
	(line (concat "\"" (make-string width ?.) "\"")))
    (while (/= 1 height)
      (setq retval (concat retval line ",\n")
	    height (1- height)))
    (concat retval line "\n};")))

Then: 
 (make-glyph (vector 'xpm :data (create-blank-pixmap 40 40))))

 Wheee.

-Bill P.

Re: gnus-picons update

[Wesley.Hardaker]

William Perry <wmperry@aventail.com> writes:

>   You would only need to do this once at startup.  And you can build a
> pixmap pretty easily in memory.  I've got the code to do it for Emacs-W3.
> Try something like:

Thanks for the code.  I suppose it should go in as another optional
feature...

Wes