Re: png images in tool-bar / alpha mask

[David Reitter]

On 2 Apr 2008, at 13:39, YAMAMOTO Mitsuharu wrote:
> > I'm working on a patch to see if this is doable.  I'll get back to
> > you once I've tested it.
>
> OK, I'll wait a month.

OK, how about the patches below?

The change to image.c is actually very short.
The patch to tool-bar.el is intended to load PNG files where they are  
available, and to automatically load files named <basename>_dis.<ext>  
and <basename>_sel.<ext> to automatically find the disabled (greyed  
out) and selected (darkened) variant where provided.

I find that the algorithm that is applied now (by OS X at least) to my  
PNG graphics works perfectly, so I'm not even providing the _dis and  
_sel files any longer.  However, this was beneficial when the non-tool- 
kit toolbar was used to avoid the default manipulation of the images,  
so I'm leaving it in for others.




Index: image.c
===================================================================
RCS file: /sources/emacs/emacs/src/image.c,v
retrieving revision 1.65.2.13
diff -c -r1.65.2.13 image.c
*** image.c     28 Mar 2008 14:57:32 -0000      1.65.2.13
--- image.c     3 Apr 2008 15:01:11 -0000
***************
*** 2767,2773 ****
      }
    CGContextDrawImage (context, rectangle, image);
    QDEndCGContext (ximg, &context);
!   CGImageRelease (image);

    /* Maybe fill in the background field while we have ximg handy. */
    if (NILP (image_spec_value (img->spec, QCbackground, NULL)))
--- 2767,2774 ----
      }
    CGContextDrawImage (context, rectangle, image);
    QDEndCGContext (ximg, &context);
!
!   img->data.ptr_val = image; /* retain original data */

    /* Maybe fill in the background field while we have ximg handy. */
    if (NILP (image_spec_value (img->spec, QCbackground, NULL)))
Index: tool-bar.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/tool-bar.el,v
retrieving revision 1.7.2.2
diff -c -r1.7.2.2 tool-bar.el
*** tool-bar.el 7 Jan 2008 02:44:11 -0000       1.7.2.2
--- tool-bar.el 3 Apr 2008 15:04:53 -0000
***************
*** 90,95 ****
--- 90,165 ----
                '(menu-item "tool bar" ignore
                            :filter (lambda (ignore) tool-bar-map)))

+ (defun tool-bar-set-file-extension (image-spec-list extension)
+   "Set new file extensions for all :file properties
+ Replace any extensions of :file properties in elements of
+ IMAGE-SPEC-LIST. An extension may start with a period . or an
+ underscore. EXTENSION and the original file name extension (starting
+ with a period) are added to the file name.
+
+ E.g. foo_dis.xpm becomes foo_sel.xpm if EXTENSION is '_sel'."
+   (mapcar
+    (lambda (spec)
+      (let ((f (plist-get spec :file))
+           )
+         (if (null f)
+           spec
+         ;; need to replace previous extensions, including those
+         ;; starting with _ -
+         (plist-put spec :file (concat (replace-regexp-in-string "[\.\_].*$"
+                                                                 "" f)
+                                       extension
+                                       (file-name-extension f t)))
+         )))
+    image-spec-list))
+
+ (defun tool-bar-get-image-spec (icon)
+   (let* ((fg (face-attribute 'tool-bar :foreground))
+        (bg (face-attribute 'tool-bar :background))
+        (colors (nconc (if (eq fg 'unspecified) nil (list :foreground fg))
+                       (if (eq bg 'unspecified) nil (list :background bg))))
+        (xpm-spec (list :type 'xpm :file (concat icon ".xpm")))
+        (xpm-lo-spec (if (> (display-color-cells) 256)
+                         nil
+                       (list :type 'xpm :file
+                               (concat "low-color/" icon ".xpm"))))
+        (png-spec (list :type 'png
+                          :file (concat icon ".png") :background "grey") )
+        (pbm-spec (append (list :type 'pbm :file
+                                  (concat icon ".pbm")) colors))
+        (xbm-spec (append (list :type 'xbm :file
+                                  (concat icon ".xbm")) colors))
+        (image (find-image
+               (if (display-color-p)
+                   (list png-spec xpm-lo-spec xpm-spec pbm-spec xbm-spec)
+                 (list pbm-spec xbm-spec xpm-lo-spec xpm-spec))))
+        (image-sel (find-image
+                    (if (display-color-p)
+                        (tool-bar-set-file-extension
+                         (list png-spec xpm-lo-spec xpm-spec pbm-spec xbm-spec)
+                         "_sel")
+                      nil)))
+        (image-dis (find-image
+                    (if (display-color-p)
+                        (tool-bar-set-file-extension
+                         (list png-spec xpm-lo-spec xpm-spec pbm-spec xbm-spec)
+                         "_dis")
+                      nil)))
+        (images (when image ;; image may be nil if not found.
+                   (unless (image-mask-p image)
+                    (setq image (append image '(:mask heuristic))))
+                  (if (and image-sel image-dis)
+                      (progn           
+                        (unless (image-mask-p image-sel)
+                          (setq image-sel (append image-sel
+                                                  '(:mask heuristic))))
+                        (unless (image-mask-p image-dis)
+                          (setq image-dis (append image-dis
+                                                  '(:mask heuristic))))
+                        (vector image-sel image image-dis image-dis))
+                    image))))
+     (cons image images)))
+
  ;;;###autoload
  (defun tool-bar-add-item (icon def key &rest props)
    "Add an item to the tool bar.
***************
*** 119,147 ****
  function will first try to use low-color/ICON.xpm if display-color- 
cells
  is less or equal to 256, then ICON.xpm, then ICON.pbm, and finally
  ICON.xbm, using `find-image'."
!   (let* ((fg (face-attribute 'tool-bar :foreground))
!        (bg (face-attribute 'tool-bar :background))
!        (colors (nconc (if (eq fg 'unspecified) nil (list :foreground fg))
!                       (if (eq bg 'unspecified) nil (list :background bg))))
!        (xpm-spec (list :type 'xpm :file (concat icon ".xpm")))
!        (xpm-lo-spec (if (> (display-color-cells) 256)
!                         nil
!                       (list :type 'xpm :file
!                               (concat "low-color/" icon ".xpm"))))
!        (pbm-spec (append (list :type 'pbm :file
!                                  (concat icon ".pbm")) colors))
!        (xbm-spec (append (list :type 'xbm :file
!                                  (concat icon ".xbm")) colors))
!        (image (find-image
!               (if (display-color-p)
!                   (list xpm-lo-spec xpm-spec pbm-spec xbm-spec)
!                 (list pbm-spec xbm-spec xpm-lo-spec xpm-spec)))))
!
      (when (and (display-images-p) image)
-       (unless (image-mask-p image)
-       (setq image (append image '(:mask heuristic))))
        (define-key-after map (vector key)
!       `(menu-item ,(symbol-name key) ,def :image ,image ,@props)))))

  ;;;###autoload
  (defun tool-bar-add-item-from-menu (command icon &optional map  
&rest props)
--- 189,200 ----
  function will first try to use low-color/ICON.xpm if display-color- 
cells
  is less or equal to 256, then ICON.xpm, then ICON.pbm, and finally
  ICON.xbm, using `find-image'."
!   (let* ((is (tool-bar-get-image-spec icon))
!        (image (car is))
!        (images (cdr is)))
      (when (and (display-images-p) image)
        (define-key-after map (vector key)
!       `(menu-item ,(symbol-name key) ,def :image ,images ,@props)))))

  ;;;###autoload
  (defun tool-bar-add-item-from-menu (command icon &optional map  
&rest props)
***************
*** 174,196 ****
      (setq from-map global-map))
    (let* ((menu-bar-map (lookup-key from-map [menu-bar]))
         (keys (where-is-internal command menu-bar-map))
!        (fg (face-attribute 'tool-bar :foreground))
!        (bg (face-attribute 'tool-bar :background))
!        (colors (nconc (if (eq fg 'unspecified) nil (list :foreground fg))
!                       (if (eq bg 'unspecified) nil (list :background bg))))
!        (xpm-spec (list :type 'xpm :file (concat icon ".xpm")))
!        (xpm-lo-spec (if (> (display-color-cells) 256)
!                         nil
!                       (list :type 'xpm :file
!                               (concat "low-color/" icon ".xpm"))))
!        (pbm-spec (append (list :type 'pbm :file
!                                  (concat icon ".pbm")) colors))
!        (xbm-spec (append (list :type 'xbm :file
!                                  (concat icon ".xbm")) colors))
!        (spec (if (display-color-p)
!                  (list xpm-lo-spec xpm-spec pbm-spec xbm-spec)
!                (list pbm-spec xbm-spec xpm-lo-spec xpm-spec)))
!        (image (find-image spec))
         submap key)
      (when (and (display-images-p) image)
        ;; We'll pick up the last valid entry in the list of keys if
--- 227,235 ----
      (setq from-map global-map))
    (let* ((menu-bar-map (lookup-key from-map [menu-bar]))
         (keys (where-is-internal command menu-bar-map))
!        (is (tool-bar-get-image-spec icon))
!        (image (car is))
!        (images (cdr is))
         submap key)
      (when (and (display-images-p) image)
        ;; We'll pick up the last valid entry in the list of keys if
***************
*** 210,221 ****
                        key kk)))))
        (when (and (symbolp submap) (boundp submap))
        (setq submap (eval submap)))
-       (unless (image-mask-p image)
-       (setq image (append image '(:mask heuristic))))
        (let ((defn (assq key (cdr submap))))
        (if (eq (cadr defn) 'menu-item)
            (define-key-after in-map (vector key)
!             (append (cdr defn) (list :image image) props))
          (setq defn (cdr defn))
          (define-key-after in-map (vector key)
            (let ((rest (cdr defn)))
--- 249,258 ----
                        key kk)))))
        (when (and (symbolp submap) (boundp submap))
        (setq submap (eval submap)))
        (let ((defn (assq key (cdr submap))))
        (if (eq (cadr defn) 'menu-item)
            (define-key-after in-map (vector key)
!             (append (cdr defn) (list :image images) props))
          (setq defn (cdr defn))
          (define-key-after in-map (vector key)
            (let ((rest (cdr defn)))