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

   1 ;;; riece-icon.el --- display icons in IRC buffers
   2 ;; Copyright (C) 1998-2003 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1998-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 ;; NOTE: This is an add-on module for Riece.
  28
  29 ;;; Code:
  30
  31 (require 'riece-globals)
  32 (require 'riece-signal)
  33
  34 (defvar riece-channel-list-icons
  35   '((" " . "/* XPM */
  36 static char * blank_xpm[] = {
  37 \"12 12 1 1\",
  38 \"      c None\",
  39 \"            \",
  40 \"            \",
  41 \"            \",
  42 \"            \",
  43 \"            \",
  44 \"            \",
  45 \"            \",
  46 \"            \",
  47 \"            \",
  48 \"            \",
  49 \"            \",
  50 \"            \"};")
  51     ("!" . "/* XPM */
  52 static char * balloon_xpm[] = {
  53 \"12 12 3 1\",
  54 \"       c None\",
  55 \"+      c #FFDD99\",
  56 \"@      c #000000\",
  57 \"            \",
  58 \"    ++++    \",
  59 \"  ++++++++  \",
  60 \" ++@@@@@@++ \",
  61 \" ++++++++++ \",
  62 \" ++@@@@@@++ \",
  63 \" ++++++++++ \",
  64 \" ++@@@@@@++ \",
  65 \"  ++++++++  \",
  66 \"   ++++++   \",
  67 \"   +++      \",
  68 \"   +        \"};")
  69     ("+" . "/* XPM */
  70 static char * check_xpm[] = {
  71 \"12 12 3 1\",
  72 \"      c None\",
  73 \".     c #9696FF\",
  74 \"+     c #5959FF\",
  75 \"            \",
  76 \"            \",
  77 \" ..      .. \",
  78 \".++.    .++.\",
  79 \" .++.  .++. \",
  80 \"  .++..++.  \",
  81 \"   .++++.   \",
  82 \"    .++.    \",
  83 \"     ..     \",
  84 \"            \",
  85 \"            \",
  86 \"            \"};")
  87     ("*" . "/* XPM */
  88 static char * active_xpm[] = {
  89 \"12 12 3 1\",
  90 \"      c None\",
  91 \".     c #96FF96\",
  92 \"+     c #59FF59\",
  93 \"            \",
  94 \"     ..     \",
  95 \"     .+.    \",
  96 \" .....++.   \",
  97 \" .+++++++.  \",
  98 \" .++++++++. \",
  99 \" .+++++++.  \",
 100 \" .....++.   \",
 101 \"     .+.    \",
 102 \"     ..     \",
 103 \"            \",
 104 \"            \"};")))
 105
 106 (defvar riece-user-list-icons
 107   '((" " . "/* XPM */
 108 static char * blank_xpm[] = {
 109 \"12 12 1 1\",
 110 \"      c None\",
 111 \"            \",
 112 \"            \",
 113 \"            \",
 114 \"            \",
 115 \"            \",
 116 \"            \",
 117 \"            \",
 118 \"            \",
 119 \"            \",
 120 \"            \",
 121 \"            \",
 122 \"            \"};")
 123     ("@" . "/* XPM */
 124 static char * spiral_xpm[] = {
 125 \"12 12 3 1\",
 126 \"      c None\",
 127 \".     c #FF5959\",
 128 \"+     c #FF9696\",
 129 \"            \",
 130 \"            \",
 131 \"    +++++   \",
 132 \"   ++...++  \",
 133 \"  ++.+++.++ \",
 134 \"  +.++.++.+ \",
 135 \"  +.+.+.+.+ \",
 136 \"  +.+.+++.+ \",
 137 \"  +.++...++ \",
 138 \"  ++.+++++.+\",
 139 \"   ++.....+ \",
 140 \"    ++++++  \"};")
 141     ("+" . "/* XPM */
 142 static char * cross_xpm[] = {
 143 \"12 12 3 1\",
 144 \"      c None\",
 145 \".     c #7F7F7F\",
 146 \"+     c #B2B2B2\",
 147 \"     ++     \",
 148 \"    +..+    \",
 149 \"    +..+    \",
 150 \"  +++..+++  \",
 151 \" +........+ \",
 152 \" +........+ \",
 153 \"  +++..+++  \",
 154 \"    +..+    \",
 155 \"    +..+    \",
 156 \"    +..+    \",
 157 \"    +..+    \",
 158 \"     ++     \"};")))
 159
 160 (defvar riece-pointer-icon
 161   "/* XPM */
 162 static char * a_xpm[] = {
 163 \"14 14 5 1\",
 164 \"      c None\",
 165 \".     c #FF9646\",
 166 \"+     c #FF5909\",
 167 \"@     c #FF7020\",
 168 \"*     c #FFA500\",
 169 \"              \",
 170 \"  @@@@@@@@@@@ \",
 171 \" @*.++++++.**@\",
 172 \" @*.++...++.*@\",
 173 \" @*.++.*.++.*@\",
 174 \" @*.++...+.**@\",
 175 \" @*.+++.+.***@\",
 176 \" @*.++.*.+.**@\",
 177 \" @*.++.*.++.*@\",
 178 \" @*.++.*.++.*@\",
 179 \" @*.++.*.++.*@\",
 180 \" @**..***..**@\",
 181 \"  @@@@@@@@@@@ \",
 182 \"              \"};")
 183
 184 (defvar riece-icon-enabled nil)
 185
 186 (defconst riece-icon-description
 187   "Display icons in IRC buffers.")
 188
 189 (defun riece-icon-available-p ()
 190   (if (featurep 'xemacs)
 191       (featurep 'xpm)
 192     (if (fboundp 'image-type-available-p)
 193         (image-type-available-p 'xpm))))
 194
 195 (eval-and-compile
 196   (if (featurep 'xemacs)
 197       (defun riece-icon-make-image (data string)
 198         (make-glyph (list (vector 'xpm :data data)
 199                           (vector 'string :data string))))
 200     (defun riece-icon-make-image (data string)
 201       (create-image data 'xpm t :ascent 'center))))
 202
 203 (defun riece-icon-make-images (alist)
 204   (let ((pointer (setq alist (copy-alist alist))))
 205     (while pointer
 206       (setcdr (car pointer)
 207               (riece-icon-make-image (cdr (car pointer)) (car (car pointer))))
 208       (setq pointer (cdr pointer)))
 209     alist))
 210
 211 (eval-and-compile
 212   (if (featurep 'xemacs)
 213       (defun riece-icon-add-image-region (image start end)
 214         (map-extents
 215          (lambda (extent ignore)
 216            (if (or (extent-property extent 'riece-icon-user-list-extent)
 217                    (extent-property extent 'riece-icon-user-list-annotation))
 218                (delete-extent extent)))
 219          (current-buffer) start end)
 220         (let ((extent (make-extent start end))
 221               (annotation (make-annotation image end 'text)))
 222           (set-extent-property extent 'end-open t)
 223           (set-extent-property extent 'start-open t)
 224           (set-extent-property extent 'invisible t)
 225           (set-extent-property extent 'intangible t)
 226           (set-extent-property annotation
 227                                'riece-icon-user-list-extent extent)
 228           (set-extent-property extent
 229                                'riece-icon-user-list-annotation annotation)))
 230     (defun riece-icon-add-image-region (image start end)
 231       (let ((inhibit-read-only t)
 232             buffer-read-only)
 233         (add-text-properties start end
 234                              (list 'display
 235                                    image
 236                                    'rear-nonsticky (list 'display)))))))
 237
 238 (defun riece-icon-update-user-list-buffer ()
 239   (if riece-icon-enabled
 240       (let ((images (riece-icon-make-images riece-user-list-icons)))
 241         (save-excursion
 242           (goto-char (point-min))
 243           (while (re-search-forward "^[ @+]" nil t)
 244             (riece-icon-add-image-region
 245              (cdr (assoc (match-string 0) images))
 246              (1- (point)) (point)))))))
 247
 248 (defun riece-icon-update-channel-list-buffer ()
 249   (if riece-icon-enabled
 250       (let ((images (riece-icon-make-images riece-channel-list-icons)))
 251         (save-excursion
 252           (goto-char (point-min))
 253           (while (re-search-forward "^ ?[0-9]+:\\([ !+*]\\)" nil t)
 254             (riece-icon-add-image-region
 255              (cdr (assoc (match-string 1) images))
 256              (match-beginning 1) (match-end 1)))))))
 257
 258 (eval-and-compile
 259   (if (featurep 'xemacs)
 260       (progn
 261         (defvar riece-icon-xemacs-modeline-left-extent
 262           (copy-extent modeline-buffer-id-left-extent))
 263
 264         (defvar riece-icon-xemacs-modeline-right-extent
 265           (copy-extent modeline-buffer-id-right-extent))
 266
 267         (defun riece-icon-modeline-buffer-identification (line)
 268           "Decorate 1st element of `mode-line-buffer-identification' LINE.
 269 Modify whole identification by side effect."
 270           (let ((id (car line)) chopped)
 271             (if (and (stringp id) (string-match "^Riece:" id))
 272                 (progn
 273                   (setq chopped (substring id 0 (match-end 0))
 274                         id (substring id (match-end 0)))
 275                   (nconc
 276                    (list
 277                     (let ((glyph
 278                            (make-glyph
 279                             (nconc
 280                              (if (featurep 'xpm)
 281                                  (list (vector 'xpm :data
 282                                                riece-pointer-icon)))
 283                              (list (vector 'string :data chopped))))))
 284                       (set-glyph-face glyph 'modeline-buffer-id)
 285                       (cons riece-icon-xemacs-modeline-left-extent glyph))
 286                     (cons riece-icon-xemacs-modeline-right-extent id))
 287                    (cdr line)))
 288               line))))
 289     (condition-case nil
 290         (progn
 291           (require 'image)
 292           (defun riece-icon-modeline-buffer-identification (line)
 293             "Decorate 1st element of `mode-line-buffer-identification' LINE.
 294 Modify whole identification by side effect."
 295             (let ((id (copy-sequence (car line)))
 296                   (image
 297                    (if (image-type-available-p 'xpm)
 298                        (create-image riece-pointer-icon 'xpm t
 299                                      :ascent 'center))))
 300               (when (and image
 301                          (stringp id) (string-match "^Riece:" id))
 302                 (add-text-properties 0 (length id)
 303                                      (list 'display image
 304                                            'rear-nonsticky (list 'display))
 305                                      id)
 306                 (setcar line id))
 307               line)))
 308       (error
 309        (defalias 'riece-icon-modeline-buffer-identification 'identity)))))
 310
 311 (defun riece-icon-user-list-mode-hook ()
 312   (if (riece-icon-available-p)
 313       (add-hook 'riece-update-buffer-functions
 314                 'riece-icon-update-user-list-buffer t t)))
 315
 316 (defun riece-icon-channel-list-mode-hook ()
 317   (if (riece-icon-available-p)
 318       (add-hook 'riece-update-buffer-functions
 319                 'riece-icon-update-channel-list-buffer t t)))
 320
 321 (defun riece-icon-insinuate ()
 322   (add-hook 'riece-user-list-mode-hook
 323             'riece-icon-user-list-mode-hook)
 324   (add-hook 'riece-channel-list-mode-hook
 325             'riece-icon-channel-list-mode-hook))
 326
 327 (defun riece-icon-uninstall ()
 328   (remove-hook 'riece-user-list-mode-hook
 329                'riece-icon-user-list-mode-hook)
 330   (remove-hook 'riece-channel-list-mode-hook
 331                'riece-icon-channel-list-mode-hook)
 332   (save-excursion
 333     (set-buffer riece-user-list-buffer)
 334     (remove-hook 'riece-update-buffer-functions
 335                  'riece-icon-update-user-list-buffer)
 336     (set-buffer riece-channel-list-buffer)
 337     (remove-hook 'riece-update-buffer-functions
 338                  'riece-icon-update-user-list-buffer)))
 339
 340 (defvar riece-icon-original-mode-line-buffer-identification nil)
 341
 342 (defun riece-icon-update-mode-line-buffer-identification ()
 343   (let ((buffers riece-buffer-list))
 344     (save-excursion
 345       (while buffers
 346         (set-buffer (car buffers))
 347         (if (local-variable-p 'riece-mode-line-buffer-identification
 348                               (car buffers))
 349             (setq mode-line-buffer-identification
 350                   (riece-mode-line-buffer-identification
 351                    riece-mode-line-buffer-identification)))
 352         (setq buffers (cdr buffers))))))
 353
 354 (defun riece-icon-enable ()
 355   (setq riece-icon-original-mode-line-buffer-identification
 356         (symbol-function 'riece-mode-line-buffer-identification))
 357   (defalias 'riece-mode-line-buffer-identification
 358     'riece-icon-modeline-buffer-identification)
 359   (riece-icon-update-mode-line-buffer-identification)
 360   (setq riece-icon-enabled t)
 361   (if riece-current-channel
 362       (riece-emit-signal 'user-list-changed riece-current-channel))
 363   (riece-emit-signal 'channel-list-changed))
 364
 365 (defun riece-icon-disable ()
 366   (fset 'riece-mode-line-buffer-identification
 367         riece-icon-original-mode-line-buffer-identification)
 368   (riece-icon-update-mode-line-buffer-identification)
 369   (setq riece-icon-enabled nil)
 370   (if riece-current-channel
 371       (riece-emit-signal 'user-list-changed riece-current-channel))
 372   (riece-emit-signal 'channel-list-changed))
 373
 374 (provide 'riece-icon)
 375
 376 ;;; riece-icon.el ends here