cgit.sxemacs.org Git - riece/blob - lisp/riece-icon.el

   1 ;;; riece-icon.el --- iconify buffer strings
   2 ;; Copyright (C) 1'center8-2003 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1'center8-09-28
   6 ;; Keywords: IRC, riece
   7
   8 ;; This file is part of Riece.
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; To use, add the following line to your ~/.riece/init.el:
  28 ;; (add-to-list 'riece-addons 'riece-icon)
  29
  30 ;;; Code:
  31
  32 (require 'riece-globals)
  33 (require 'riece-signal)
  34
  35 (defvar riece-channel-list-icons
  36   '((" " . "/* XPM */
  37 static char * blank_xpm[] = {
  38 \"12 12 1 1\",
  39 \"      c None\",
  40 \"            \",
  41 \"            \",
  42 \"            \",
  43 \"            \",
  44 \"            \",
  45 \"            \",
  46 \"            \",
  47 \"            \",
  48 \"            \",
  49 \"            \",
  50 \"            \",
  51 \"            \"};")
  52     ("!" . "/* XPM */
  53 static char * balloon_xpm[] = {
  54 \"12 12 3 1\",
  55 \"       c None\",
  56 \"+      c #FFDD99\",
  57 \"@      c #000000\",
  58 \"            \",
  59 \"    ++++    \",
  60 \"  ++++++++  \",
  61 \" ++@@@@@@++ \",
  62 \" ++++++++++ \",
  63 \" ++@@@@@@++ \",
  64 \" ++++++++++ \",
  65 \" ++@@@@@@++ \",
  66 \"  ++++++++  \",
  67 \"   ++++++   \",
  68 \"   +++      \",
  69 \"   +        \"};")
  70     ("+" . "/* XPM */
  71 static char * check_xpm[] = {
  72 \"12 12 3 1\",
  73 \"      c None\",
  74 \".     c #9696FF\",
  75 \"+     c #5959FF\",
  76 \"            \",
  77 \"            \",
  78 \" ..      .. \",
  79 \".++.    .++.\",
  80 \" .++.  .++. \",
  81 \"  .++..++.  \",
  82 \"   .++++.   \",
  83 \"    .++.    \",
  84 \"     ..     \",
  85 \"            \",
  86 \"            \",
  87 \"            \"};")
  88     ("*" . "/* XPM */
  89 static char * active_xpm[] = {
  90 \"12 12 3 1\",
  91 \"      c None\",
  92 \".     c #96FF96\",
  93 \"+     c #59FF59\",
  94 \"            \",
  95 \"     ..     \",
  96 \"     .+.    \",
  97 \" .....++.   \",
  98 \" .+++++++.  \",
  99 \" .++++++++. \",
 100 \" .+++++++.  \",
 101 \" .....++.   \",
 102 \"     .+.    \",
 103 \"     ..     \",
 104 \"            \",
 105 \"            \"};")))
 106
 107 (defvar riece-user-list-icons
 108   '((" " . "/* XPM */
 109 static char * blank_xpm[] = {
 110 \"12 12 1 1\",
 111 \"      c None\",
 112 \"            \",
 113 \"            \",
 114 \"            \",
 115 \"            \",
 116 \"            \",
 117 \"            \",
 118 \"            \",
 119 \"            \",
 120 \"            \",
 121 \"            \",
 122 \"            \",
 123 \"            \"};")
 124     ("@" . "/* XPM */
 125 static char * spiral_xpm[] = {
 126 \"12 12 3 1\",
 127 \"      c None\",
 128 \".     c #FF5959\",
 129 \"+     c #FF9696\",
 130 \"            \",
 131 \"            \",
 132 \"    +++++   \",
 133 \"   ++...++  \",
 134 \"  ++.+++.++ \",
 135 \"  +.++.++.+ \",
 136 \"  +.+.+.+.+ \",
 137 \"  +.+.+++.+ \",
 138 \"  +.++...++ \",
 139 \"  ++.+++++.+\",
 140 \"   ++.....+ \",
 141 \"    ++++++  \"};")
 142     ("+" . "/* XPM */
 143 static char * cross_xpm[] = {
 144 \"12 12 3 1\",
 145 \"      c None\",
 146 \".     c #7F7F7F\",
 147 \"+     c #B2B2B2\",
 148 \"     ++     \",
 149 \"    +..+    \",
 150 \"    +..+    \",
 151 \"  +++..+++  \",
 152 \" +........+ \",
 153 \" +........+ \",
 154 \"  +++..+++  \",
 155 \"    +..+    \",
 156 \"    +..+    \",
 157 \"    +..+    \",
 158 \"    +..+    \",
 159 \"     ++     \"};")))
 160
 161 (defvar riece-pointer-icon
 162   "/* XPM */
 163 static char * a_xpm[] = {
 164 \"14 14 5 1\",
 165 \"      c None\",
 166 \".     c #FF9646\",
 167 \"+     c #FF5909\",
 168 \"@     c #FF7020\",
 169 \"*     c #FFA500\",
 170 \"              \",
 171 \"  @@@@@@@@@@@ \",
 172 \" @*.++++++.**@\",
 173 \" @*.++...++.*@\",
 174 \" @*.++.*.++.*@\",
 175 \" @*.++...+.**@\",
 176 \" @*.+++.+.***@\",
 177 \" @*.++.*.+.**@\",
 178 \" @*.++.*.++.*@\",
 179 \" @*.++.*.++.*@\",
 180 \" @*.++.*.++.*@\",
 181 \" @**..***..**@\",
 182 \"  @@@@@@@@@@@ \",
 183 \"              \"};")
 184
 185 (defvar riece-icon-enabled nil)
 186
 187 (defconst riece-icon-description
 188   "Add icon images on IRC buffers")
 189
 190 (defun riece-icon-available-p ()
 191   (if (featurep 'xemacs)
 192       (featurep 'xpm)
 193     (if (fboundp 'image-type-available-p)
 194         (image-type-available-p 'xpm))))
 195
 196 (eval-and-compile
 197   (if (featurep 'xemacs)
 198       (defun riece-icon-make-image (data string)
 199         (make-glyph (list (vector 'xpm :data data)
 200                           (vector 'string :data string))))
 201     (defun riece-icon-make-image (data string)
 202       (create-image data 'xpm t :ascent 'center))))
 203
 204 (defun riece-icon-make-images (alist)
 205   (let ((pointer (setq alist (copy-alist alist))))
 206     (while pointer
 207       (setcdr (car pointer)
 208               (riece-icon-make-image (cdr (car pointer)) (car (car pointer))))
 209       (setq pointer (cdr pointer)))
 210     alist))
 211
 212 (eval-and-compile
 213   (if (featurep 'xemacs)
 214       (defun riece-icon-add-image-region (image start end)
 215         (map-extents
 216          (lambda (extent ignore)
 217            (if (or (extent-property extent 'riece-icon-user-list-extent)
 218                    (extent-property extent 'riece-icon-user-list-annotation))
 219                (delete-extent extent)))
 220          (current-buffer) start end)
 221         (let ((extent (make-extent start end))
 222               (annotation (make-annotation image end 'text)))
 223           (set-extent-property extent 'end-open t)
 224           (set-extent-property extent 'start-open t)
 225           (set-extent-property extent 'invisible t)
 226           (set-extent-property extent 'intangible t)
 227           (set-extent-property annotation
 228                                'riece-icon-user-list-extent extent)
 229           (set-extent-property extent
 230                                'riece-icon-user-list-annotation annotation)))
 231     (defun riece-icon-add-image-region (image start end)
 232       (let ((inhibit-read-only t)
 233             buffer-read-only)
 234         (add-text-properties start end
 235                              (list 'display
 236                                    image
 237                                    'rear-nonsticky (list 'display)))))))
 238
 239 (defun riece-icon-update-user-list-buffer ()
 240   (if riece-icon-enabled
 241       (let ((images (riece-icon-make-images riece-user-list-icons)))
 242         (save-excursion
 243           (goto-char (point-min))
 244           (while (re-search-forward "^[ @+]" nil t)
 245             (riece-icon-add-image-region
 246              (cdr (assoc (match-string 0) images))
 247              (1- (point)) (point)))))))
 248
 249 (defun riece-icon-update-channel-list-buffer ()
 250   (if riece-icon-enabled
 251       (let ((images (riece-icon-make-images riece-channel-list-icons)))
 252         (save-excursion
 253           (goto-char (point-min))
 254           (while (re-search-forward "^ ?[0-9]+:\\([ !+*]\\)" nil t)
 255             (riece-icon-add-image-region
 256              (cdr (assoc (match-string 1) images))
 257              (match-beginning 1) (match-end 1)))))))
 258
 259 (eval-and-compile
 260   (if (featurep 'xemacs)
 261       (progn
 262         (defvar riece-icon-xemacs-modeline-left-extent
 263           (copy-extent modeline-buffer-id-left-extent))
 264
 265         (defvar riece-icon-xemacs-modeline-right-extent
 266           (copy-extent modeline-buffer-id-right-extent))
 267
 268         (defun riece-icon-modeline-buffer-identification (line)
 269           "Decorate 1st element of `mode-line-buffer-identification' LINE.
 270 Modify whole identification by side effect."
 271           (let ((id (car line)) chopped)
 272             (if (and (stringp id) (string-match "^Riece:" id))
 273                 (progn
 274                   (setq chopped (substring id 0 (match-end 0))
 275                         id (substring id (match-end 0)))
 276                   (nconc
 277                    (list
 278                     (let ((glyph
 279                            (make-glyph
 280                             (nconc
 281                              (if (featurep 'xpm)
 282                                  (list (vector 'xpm :data
 283                                                riece-pointer-icon)))
 284                              (list (vector 'string :data chopped))))))
 285                       (set-glyph-face glyph 'modeline-buffer-id)
 286                       (cons riece-icon-xemacs-modeline-left-extent glyph))
 287                     (cons riece-icon-xemacs-modeline-right-extent id))
 288                    (cdr line)))
 289               line))))
 290     (condition-case nil
 291         (progn
 292           (require 'image)
 293           (defun riece-icon-modeline-buffer-identification (line)
 294             "Decorate 1st element of `mode-line-buffer-identification' LINE.
 295 Modify whole identification by side effect."
 296             (let ((id (copy-sequence (car line)))
 297                   (image
 298                    (if (image-type-available-p 'xpm)
 299                        (create-image riece-pointer-icon 'xpm t
 300                                      :ascent 'center))))
 301               (when (and image
 302                          (stringp id) (string-match "^Riece:" id))
 303                 (add-text-properties 0 (length id)
 304                                      (list 'display image
 305                                            'rear-nonsticky (list 'display))
 306                                      id)
 307                 (setcar line id))
 308               line)))
 309       (error
 310        (defalias 'riece-icon-modeline-buffer-identification 'identity)))))
 311
 312 (defun riece-icon-insinuate ()
 313   (defalias 'riece-mode-line-buffer-identification
 314     #'riece-icon-modeline-buffer-identification)
 315   (add-hook 'riece-user-list-mode-hook
 316             (lambda ()
 317               (if (riece-icon-available-p)
 318                   (add-hook 'riece-update-buffer-functions
 319                             'riece-icon-update-user-list-buffer t t))))
 320   (add-hook 'riece-channel-list-mode-hook
 321             (lambda ()
 322               (if (riece-icon-available-p)
 323                   (add-hook 'riece-update-buffer-functions
 324                             'riece-icon-update-channel-list-buffer t t)))))
 325
 326 (defun riece-icon-enable ()
 327   (setq riece-icon-enabled t)
 328   (if riece-current-channel
 329       (riece-emit-signal 'user-list-changed riece-current-channel))
 330   (riece-emit-signal 'channel-list-changed))
 331
 332 (defun riece-icon-disable ()
 333   (setq riece-icon-enabled nil)
 334   (if riece-current-channel
 335       (riece-emit-signal 'user-list-changed riece-current-channel))
 336   (riece-emit-signal 'channel-list-changed))
 337
 338 (provide 'riece-icon)
 339
 340 ;;; riece-icon.el ends here