git.chise.org Git - elisp/gnus.git-/blob - lisp/smiley.el

   1 ;;; smiley.el --- displaying smiley faces
   2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu>
   6 ;; Keywords: fun
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs 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 ;; GNU Emacs 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 ;;
  28 ;; comments go here.
  29 ;;
  30
  31 ;;; Test smileys:  :-] :-o :-) ;-) :-\ :-| :-d :-P 8-| :-(
  32
  33 ;; To use:
  34 ;; (require 'smiley)
  35 ;; (setq gnus-treat-display-smileys t)
  36
  37 ;; The smilies were drawn by Joe Reiss <jreiss@vt.edu>.
  38
  39 (eval-when-compile (require 'cl))
  40
  41 (require 'annotations)
  42 (require 'messagexmas)
  43 (require 'custom)
  44
  45 (defgroup smiley nil
  46   "Turn :-)'s into real images (XEmacs)."
  47   :group 'gnus-visual)
  48
  49 (defcustom smiley-data-directory (message-xmas-find-glyph-directory "smilies")
  50   "*Location of the smiley faces files."
  51   :type 'directory
  52   :group 'smiley)
  53
  54 ;; Notice the subtle differences in the regular expressions in the
  55 ;; two alists below.
  56
  57 (defcustom smiley-deformed-regexp-alist
  58   '(("\\(\\^_?\\^;;;\\)\\W" 1 "WideFaceAse3.xbm")
  59     ("\\(\\^_?\\^;;\\)\\W" 1 "WideFaceAse2.xbm")
  60     ("\\(\\^_?\\^;\\)\\W" 1 "WideFaceAse1.xbm")
  61     ("\\(\\^_?\\^\\)\\W" 1 "WideFaceSmile.xbm")
  62     ("\\(;_;\\)\\W" 1 "WideFaceWeep.xbm")
  63     ("\\(T_T\\)\\W" 1 "WideFaceWeep.xbm")
  64     ("\\(:-*[<\e(I+\e(B]+\\)\\W" 1 "FaceAngry.xpm")
  65     ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
  66     ("\\(:-*D\\)\\W" 1 "FaceGrinning.xpm")
  67     ("\\(:-*[)>}\e(I;\e(B]+\\)\\W" 1 "FaceHappy.xpm")
  68     ("\\(=[)>\e(I;\e(B]+\\)\\W" 1 "FaceHappy.xpm")
  69     ("\\(:-*[/\\\"]\\)[^/]\\W" 1 "FaceIronic.xpm")
  70     ("[^.0-9]\\([8|]-*[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
  71     ("\\([:|]-*#+\\)\\W" 1 "FaceNyah.xpm")
  72     ("\\(:-*[({]+\\)\\W" 1 "FaceSad.xpm")
  73     ("\\(=[({]+\\)\\W" 1 "FaceSad.xpm")
  74     ("\\(:-*[Oo\*]\\)\\W" 1 "FaceStartled.xpm")
  75     ("\\(:-*|\\)\\W" 1 "FaceStraight.xpm")
  76     ("\\(:-*p\\)\\W" 1 "FaceTalking.xpm")
  77     ("\\(:-*d\\)\\W" 1 "FaceTasty.xpm")
  78     ("\\(;-*[>)}\e(I;\e(B]+\\)\\W" 1 "FaceWinking.xpm")
  79     ("\\(:-*[Vv\e(I5\e(B]\\)\\W" 1 "FaceWry.xpm")
  80     ("\\([:|]-*P\\)\\W" 1 "FaceYukky.xpm"))
  81   "*Normal and deformed faces for smilies."
  82   :type '(repeat (list regexp
  83                        (integer :tag "Match")
  84                        (string :tag "Image")))
  85   :group 'smiley)
  86
  87 (defcustom smiley-nosey-regexp-alist
  88   '(("\\(:-+[<\e(I+\e(B]+\\)\\W" 1 "FaceAngry.xpm")
  89     ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
  90     ("\\(:-+D\\)\\W" 1 "FaceGrinning.xpm")
  91     ("\\(:-+[}\e(I;\e(B]+\\)\\W" 1 "FaceHappy.xpm")
  92     ("\\(:-*)+\\)\\W" 1 "FaceHappy.xpm")
  93     ("\\(=[)]+\\)\\W" 1 "FaceHappy.xpm")
  94     ("\\(:-+[/\\\"]+\\)\\W" 1 "FaceIronic.xpm")
  95     ("\\([8|]-+[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
  96     ("\\([:|]-+#+\\)\\W" 1 "FaceNyah.xpm")
  97     ("\\(:-+[({]+\\)\\W" 1 "FaceSad.xpm")
  98     ("\\(=[({]+\\)\\W" 1 "FaceSad.xpm")
  99     ("\\(:-+[Oo\*]\\)\\W" 1 "FaceStartled.xpm")
 100     ("\\(:-+|\\)\\W" 1 "FaceStraight.xpm")
 101     ("\\(:-+p\\)\\W" 1 "FaceTalking.xpm")
 102     ("\\(:-+d\\)\\W" 1 "FaceTasty.xpm")
 103     ("\\(;-+[>)}\e(I;\e(B]+\\)\\W" 1 "FaceWinking.xpm")
 104     ("\\(:-+[Vv\e(I5\e(B]\\)\\W" 1 "FaceWry.xpm")
 105     ("\\(][:8B]-[)>]\\)\\W" 1 "FaceDevilish.xpm")
 106     ("\\([:|]-+P\\)\\W" 1 "FaceYukky.xpm"))
 107   "*Smileys with noses.  These get less false matches."
 108   :type '(repeat (list regexp
 109                        (integer :tag "Match")
 110                        (string :tag "Image")))
 111   :group 'smiley)
 112
 113 (defcustom smiley-regexp-alist smiley-deformed-regexp-alist
 114   "*A list of regexps to map smilies to real images.
 115 Defaults to the contents of `smiley-deformed-regexp-alist'.
 116 An alternative is `smiley-nosey-regexp-alist' that matches less
 117 aggressively.
 118 If this is a symbol, take its value."
 119   :type '(radio (variable-item smiley-deformed-regexp-alist)
 120                 (variable-item smiley-nosey-regexp-alist)
 121                 symbol
 122                 (repeat (list regexp
 123                               (integer :tag "Match")
 124                               (string :tag "Image"))))
 125   :group 'smiley)
 126
 127 (defcustom smiley-flesh-color "yellow"
 128   "*Flesh color."
 129   :type 'string
 130   :group 'smiley)
 131
 132 (defcustom smiley-features-color "black"
 133   "*Features color."
 134   :type 'string
 135   :group 'smiley)
 136
 137 (defcustom smiley-tongue-color "red"
 138   "*Tongue color."
 139   :type 'string
 140   :group 'smiley)
 141
 142 (defcustom smiley-circle-color "black"
 143   "*Circle color."
 144   :type 'string
 145   :group 'smiley)
 146
 147 (defcustom smiley-mouse-face 'highlight
 148   "*Face used for mouse highlighting in the smiley buffer.
 149
 150 Smiley buttons will be displayed in this face when the cursor is
 151 above them."
 152   :type 'face
 153   :group 'smiley)
 154
 155 (defvar smiley-glyph-cache nil)
 156 (defvar smiley-running-xemacs (string-match "XEmacs" emacs-version))
 157
 158 (defvar smiley-map (make-sparse-keymap "smiley-keys")
 159   "Keymap to toggle smiley states.")
 160
 161 (define-key smiley-map [(button2)] 'smiley-toggle-extent)
 162 (define-key smiley-map [(button3)] 'smiley-popup-menu)
 163
 164 (defun smiley-popup-menu (e)
 165   (interactive "e")
 166   (popup-menu
 167    `("Smilies"
 168      ["Toggle This Smiley" (smiley-toggle-extent ,e) t]
 169      ["Toggle All Smilies" (smiley-toggle-extents ,e) t])))
 170
 171 (defun smiley-create-glyph (smiley pixmap)
 172   (and
 173    smiley-running-xemacs
 174    (or
 175     (cdr-safe (assoc pixmap smiley-glyph-cache))
 176     (let* ((xpm-color-symbols
 177             (and (featurep 'xpm)
 178                  (append `(("flesh" ,smiley-flesh-color)
 179                            ("features" ,smiley-features-color)
 180                            ("tongue" ,smiley-tongue-color))
 181                          xpm-color-symbols)))
 182            (glyph (make-glyph
 183                    (list
 184                     (cons (if (featurep 'gtk) 'gtk 'x)
 185                           (expand-file-name pixmap smiley-data-directory))
 186                     (cons 'mswindows
 187                           (expand-file-name pixmap smiley-data-directory))
 188                     (cons 'tty smiley)))))
 189       (setq smiley-glyph-cache (cons (cons pixmap glyph) smiley-glyph-cache))
 190       (set-glyph-face glyph 'default)
 191       glyph))))
 192
 193 ;;;###autoload
 194 (defun smiley-region (beg end)
 195   "Smilify the region between point and mark."
 196   (interactive "r")
 197   (smiley-buffer (current-buffer) beg end))
 198
 199 (defun smiley-toggle-extent (event)
 200   "Toggle smiley at given point."
 201   (interactive "e")
 202   (let* ((ant (event-glyph-extent event))
 203          (pt (event-closest-point event))
 204          ext)
 205     (if (annotationp ant)
 206         (when (extentp (setq ext (extent-property ant 'smiley-extent)))
 207           (set-extent-property ext 'invisible nil)
 208           (hide-annotation ant))
 209       (when pt
 210         (while (setq ext (extent-at pt (event-buffer event) nil ext 'at))
 211           (when (annotationp (setq ant
 212                                    (extent-property ext 'smiley-annotation)))
 213             (reveal-annotation ant)
 214             (set-extent-property ext 'invisible t)))))))
 215
 216 (defun smiley-toggle-extents (e)
 217   (interactive "e")
 218   (map-extents
 219    (lambda (e void)
 220      (let (ant)
 221        (if (annotationp (setq ant (extent-property e 'smiley-annotation)))
 222            (if (eq (extent-property e 'invisible) nil)
 223                (progn
 224                  (reveal-annotation ant)
 225                  (set-extent-property e 'invisible t)
 226                  )
 227              (hide-annotation ant)
 228              (set-extent-property e 'invisible nil)))
 229        nil))
 230    (event-buffer e)))
 231
 232 ;;;###autoload
 233 (defun smiley-buffer (&optional buffer st nd)
 234   (interactive)
 235   (when (featurep '(or x gtk mswindows))
 236     (save-excursion
 237       (when buffer
 238         (set-buffer buffer))
 239       (let ((buffer-read-only nil)
 240             (alist (if (symbolp smiley-regexp-alist)
 241                        (symbol-value smiley-regexp-alist)
 242                      smiley-regexp-alist))
 243             (case-fold-search nil)
 244             entry regexp beg group file)
 245         (map-extents
 246          (lambda (e void)
 247            (when (or (extent-property e 'smiley-extent)
 248                      (extent-property e 'smiley-annotation))
 249              (delete-extent e)))
 250          buffer st nd)
 251         (goto-char (or st (point-min)))
 252         (setq beg (point))
 253         ;; loop through alist
 254         (while (setq entry (pop alist))
 255           (setq regexp (car entry)
 256                 group (cadr entry)
 257                 file (caddr entry))
 258           (goto-char beg)
 259           (while (re-search-forward regexp nd t)
 260             (let* ((start (match-beginning group))
 261                    (end (match-end group))
 262                    (glyph (smiley-create-glyph (buffer-substring start end)
 263                                                file)))
 264               (when glyph
 265                 (mapcar 'delete-annotation (annotations-at end))
 266                 (let ((ext (make-extent start end))
 267                       (ant (make-annotation glyph end 'text)))
 268                   ;; set text extent params
 269                   (set-extent-property ext 'end-open t)
 270                   (set-extent-property ext 'start-open t)
 271                   (set-extent-property ext 'invisible t)
 272                   (set-extent-property ext 'keymap smiley-map)
 273                   (set-extent-property ext 'mouse-face smiley-mouse-face)
 274                   (set-extent-property ext 'intangible t)
 275                   ;; set annotation params
 276                   (set-extent-property ant 'mouse-face smiley-mouse-face)
 277                   (set-extent-property ant 'keymap smiley-map)
 278                   ;; remember each other
 279                   (set-extent-property ant 'smiley-extent ext)
 280                   (set-extent-property ext 'smiley-annotation ant)
 281                   ;; Help
 282                   (set-extent-property
 283                    ext 'help-echo
 284                    "button2 toggles smiley, button3 pops up menu")
 285                   (set-extent-property
 286                    ant 'help-echo
 287                    "button2 toggles smiley, button3 pops up menu")
 288                   (set-extent-property ext 'balloon-help
 289                                        "Mouse button2 - toggle smiley
 290 Mouse button3 - menu")
 291                   (set-extent-property ant 'balloon-help
 292                                        "Mouse button2 - toggle smiley
 293 Mouse button3 - menu"))
 294                 (when (smiley-end-paren-p start end)
 295                   (make-annotation ")" end 'text))
 296                 (goto-char end)))))))))
 297
 298 (defun smiley-end-paren-p (start end)
 299   "Try to guess whether the current smiley is an end-paren smiley."
 300   (save-excursion
 301     (goto-char start)
 302     (when (and (re-search-backward "[()]" nil t)
 303                (eq (char-after) ?\()
 304                (goto-char end)
 305                (or (not (re-search-forward "[()]" nil t))
 306                    (eq (char-after (1- (point))) ?\()))
 307       t)))
 308
 309 (defun smiley-toggle-buffer (&optional arg buffer st nd)
 310   "Toggle displaying smiley faces.
 311 With arg, turn displaying on if and only if arg is positive."
 312   (interactive "P")
 313   (let (on off)
 314     (map-extents
 315      (lambda (e void)
 316        (let (ant)
 317          (if (annotationp (setq ant (extent-property e 'smiley-annotation)))
 318              (if (eq (extent-property e 'invisible) nil)
 319                  (setq off (cons (cons ant e) off))
 320                (setq on (cons (cons ant e) on)))))
 321        nil)
 322      buffer st nd)
 323     (if (and (not (and (numberp arg) (< arg 0)))
 324              (or (and (numberp arg) (> arg 0))
 325                  (null on)))
 326         (if off
 327             (while off
 328               (reveal-annotation (caar off))
 329               (set-extent-property (cdar off) 'invisible t)
 330               (setq off (cdr off)))
 331           (smiley-buffer))
 332       (while on
 333         (hide-annotation (caar on))
 334         (set-extent-property (cdar on) 'invisible nil)
 335         (setq on (cdr on))))))
 336
 337 (defvar gnus-article-buffer)
 338 ;;;###autoload
 339 (defun gnus-smiley-display (&optional arg)
 340   "Display \"smileys\" as small graphical icons.
 341 With arg, turn displaying on if and only if arg is positive."
 342   (interactive "P")
 343   (save-excursion
 344     (set-buffer gnus-article-buffer)
 345     (save-restriction
 346       (widen)
 347       (article-goto-body)
 348       (smiley-toggle-buffer arg (current-buffer) (point) (point-max)))))
 349
 350 (provide 'smiley)
 351
 352 ;; Local Variables:
 353 ;; coding: iso-8859-1
 354 ;; End:
 355
 356 ;;; smiley.el ends here