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