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 (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 (defun riece-icon-available-p ()
 183   (if (featurep 'xemacs)
 184       (featurep 'xpm)
 185     (image-type-available-p 'xpm)))
 186
 187 (eval-and-compile
 188   (if (featurep 'xemacs)
 189       (defun riece-icon-make-image (data string)
 190         (make-glyph (list (vector 'xpm :data data)
 191                           (vector 'string :data string))))
 192     (defun riece-icon-make-image (data string)
 193       (create-image data 'xpm t :ascent 'center))))
 194
 195 (defun riece-icon-make-images (alist)
 196   (let ((pointer (setq alist (copy-alist alist))))
 197     (while pointer
 198       (setcdr (car pointer)
 199               (riece-icon-make-image (cdr (car pointer)) (car (car pointer))))
 200       (setq pointer (cdr pointer)))
 201     alist))
 202
 203 (eval-and-compile
 204   (if (featurep 'xemacs)
 205       (defun riece-icon-add-image-region (image start end)
 206         (map-extents
 207          (lambda (extent ignore)
 208            (if (or (extent-property extent 'riece-icon-user-list-extent)
 209                    (extent-property extent 'riece-icon-user-list-annotation))
 210                (delete-extent extent)))
 211          (current-buffer) start end)
 212         (let ((extent (make-extent start end))
 213               (annotation (make-annotation image end 'text)))
 214           (set-extent-property extent 'end-open t)
 215           (set-extent-property extent 'start-open t)
 216           (set-extent-property extent 'invisible t)
 217           (set-extent-property extent 'intangible t)
 218           (set-extent-property annotation
 219                                'riece-icon-user-list-extent extent)
 220           (set-extent-property extent
 221                                'riece-icon-user-list-annotation annotation)))
 222     (defun riece-icon-add-image-region (image start end)
 223       (let ((inhibit-read-only t)
 224             buffer-read-only)
 225         (add-text-properties start end
 226                              (list 'display
 227                                    image
 228                                    'rear-nonsticky (list 'display)))))))
 229
 230 (defun riece-icon-update-user-list-buffer ()
 231   (let ((images (riece-icon-make-images riece-user-list-icons)))
 232     (save-excursion
 233       (goto-char (point-min))
 234       (while (re-search-forward "^[ @+]" nil t)
 235         (riece-icon-add-image-region
 236          (cdr (assoc (match-string 0) images))
 237          (1- (point)) (point))))))
 238
 239 (defun riece-icon-update-channel-list-buffer ()
 240   (let ((images (riece-icon-make-images riece-channel-list-icons)))
 241     (save-excursion
 242       (goto-char (point-min))
 243       (while (re-search-forward "^ ?[0-9]+:\\([ !+*]\\)" nil t)
 244         (riece-icon-add-image-region
 245          (cdr (assoc (match-string 1) images))
 246          (match-beginning 1) (match-end 1))))))
 247
 248 (eval-and-compile
 249   (if (featurep 'xemacs)
 250       (progn
 251         (defvar riece-icon-xemacs-modeline-left-extent
 252           (copy-extent modeline-buffer-id-left-extent))
 253
 254         (defvar riece-icon-xemacs-modeline-right-extent
 255           (copy-extent modeline-buffer-id-right-extent))
 256
 257         (defun riece-icon-modeline-buffer-identification (line)
 258           "Decorate 1st element of `mode-line-buffer-identification' LINE.
 259 Modify whole identification by side effect."
 260           (let ((id (car line)) chopped)
 261             (if (and (stringp id) (string-match "^Riece:" id))
 262                 (progn
 263                   (setq chopped (substring id 0 (match-end 0))
 264                         id (substring id (match-end 0)))
 265                   (nconc
 266                    (list
 267                     (let ((glyph
 268                            (make-glyph
 269                             (nconc
 270                              (if (featurep 'xpm)
 271                                  (list (vector 'xpm :data
 272                                                riece-pointer-icon)))
 273                              (list (vector 'string :data chopped))))))
 274                       (set-glyph-face glyph 'modeline-buffer-id)
 275                       (cons riece-icon-xemacs-modeline-left-extent glyph))
 276                     (cons riece-icon-xemacs-modeline-right-extent id))
 277                    (cdr line)))
 278               line))))
 279     (condition-case nil
 280         (progn
 281           (require 'image)
 282           (defun riece-icon-modeline-buffer-identification (line)
 283             "Decorate 1st element of `mode-line-buffer-identification' LINE.
 284 Modify whole identification by side effect."
 285             (let ((id (copy-sequence (car line)))
 286                   (image
 287                    (if (image-type-available-p 'xpm)
 288                        (create-image riece-pointer-icon 'xpm t
 289                                      :ascent 'center))))
 290               (when (and image
 291                          (stringp id) (string-match "^Riece:" id))
 292                 (add-text-properties 0 (length id)
 293                                      (list 'display image
 294                                            'rear-nonsticky (list 'display))
 295                                      id)
 296                 (setcar line id))
 297               line)))
 298       (error
 299        (defalias 'riece-icon-modeline-buffer-identification 'identity)))))
 300
 301 (defun riece-icon-insinuate ()
 302   (defalias 'riece-mode-line-buffer-identification
 303     'riece-icon-modeline-buffer-identification)
 304   (add-hook 'riece-user-list-mode-hook
 305             (lambda ()
 306               (if (riece-icon-available-p)
 307                   (add-hook 'riece-update-buffer-functions
 308                             'riece-icon-update-user-list-buffer t t))))
 309   (add-hook 'riece-channel-list-mode-hook
 310             (lambda ()
 311               (if (riece-icon-available-p)
 312                   (add-hook 'riece-update-buffer-functions
 313                             'riece-icon-update-channel-list-buffer t t)))))
 314
 315 (provide 'riece-icon)
 316
 317 ;;; riece-icon.el ends here