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