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