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 'x (expand-file-name pixmap smiley-data-directory))
 185                     (cons 'mswindows
 186                           (expand-file-name pixmap smiley-data-directory))
 187                     (cons 'tty smiley)))))
 188       (setq smiley-glyph-cache (cons (cons pixmap glyph) smiley-glyph-cache))
 189       (set-glyph-face glyph 'default)
 190       glyph))))
 191
 192 ;;;###autoload
 193 (defun smiley-region (beg end)
 194   "Smilify the region between point and mark."
 195   (interactive "r")
 196   (smiley-buffer (current-buffer) beg end))
 197
 198 (defun smiley-toggle-extent (event)
 199   "Toggle smiley at given point."
 200   (interactive "e")
 201   (let* ((ant (event-glyph-extent event))
 202          (pt (event-closest-point event))
 203          ext)
 204     (if (annotationp ant)
 205         (when (extentp (setq ext (extent-property ant 'smiley-extent)))
 206           (set-extent-property ext 'invisible nil)
 207           (hide-annotation ant))
 208       (when pt
 209         (while (setq ext (extent-at pt (event-buffer event) nil ext 'at))
 210           (when (annotationp (setq ant
 211                                    (extent-property ext 'smiley-annotation)))
 212             (reveal-annotation ant)
 213             (set-extent-property ext 'invisible t)))))))
 214
 215 (defun smiley-toggle-extents (e)
 216   (interactive "e")
 217   (map-extents
 218    (lambda (e void)
 219      (let (ant)
 220        (if (annotationp (setq ant (extent-property e 'smiley-annotation)))
 221            (if (eq (extent-property e 'invisible) nil)
 222                (progn
 223                  (reveal-annotation ant)
 224                  (set-extent-property e 'invisible t)
 225                  )
 226              (hide-annotation ant)
 227              (set-extent-property e 'invisible nil)))
 228        nil))
 229    (event-buffer e)))
 230
 231 ;;;###autoload
 232 (defun smiley-buffer (&optional buffer st nd)
 233   (interactive)
 234   (when (featurep '(or x mswindows))
 235     (save-excursion
 236       (when buffer
 237         (set-buffer buffer))
 238       (let ((buffer-read-only nil)
 239             (alist (if (symbolp smiley-regexp-alist)
 240                        (symbol-value smiley-regexp-alist)
 241                      smiley-regexp-alist))
 242             (case-fold-search nil)
 243             entry regexp beg group file)
 244         (map-extents
 245          (lambda (e void)
 246            (when (or (extent-property e 'smiley-extent)
 247                      (extent-property e 'smiley-annotation))
 248              (delete-extent e)))
 249          buffer st nd)
 250         (goto-char (or st (point-min)))
 251         (setq beg (point))
 252         ;; loop through alist
 253         (while (setq entry (pop alist))
 254           (setq regexp (car entry)
 255                 group (cadr entry)
 256                 file (caddr entry))
 257           (goto-char beg)
 258           (while (re-search-forward regexp nd t)
 259             (let* ((start (match-beginning group))
 260                    (end (match-end group))
 261                    (glyph (smiley-create-glyph (buffer-substring start end)
 262                                                file)))
 263               (when glyph
 264                 (mapcar 'delete-annotation (annotations-at end))
 265                 (let ((ext (make-extent start end))
 266                       (ant (make-annotation glyph end 'text)))
 267                   ;; set text extent params
 268                   (set-extent-property ext 'end-open t)
 269                   (set-extent-property ext 'start-open t)
 270                   (set-extent-property ext 'invisible t)
 271                   (set-extent-property ext 'keymap smiley-map)
 272                   (set-extent-property ext 'mouse-face smiley-mouse-face)
 273                   (set-extent-property ext 'intangible t)
 274                   ;; set annotation params
 275                   (set-extent-property ant 'mouse-face smiley-mouse-face)
 276                   (set-extent-property ant 'keymap smiley-map)
 277                   ;; remember each other
 278                   (set-extent-property ant 'smiley-extent ext)
 279                   (set-extent-property ext 'smiley-annotation ant)
 280                   ;; Help
 281                   (set-extent-property
 282                    ext 'help-echo
 283                    "button2 toggles smiley, button3 pops up menu")
 284                   (set-extent-property
 285                    ant 'help-echo
 286                    "button2 toggles smiley, button3 pops up menu")
 287                   (set-extent-property ext 'balloon-help
 288                                        "Mouse button2 - toggle smiley
 289 Mouse button3 - menu")
 290                   (set-extent-property ant 'balloon-help
 291                                        "Mouse button2 - toggle smiley
 292 Mouse button3 - menu"))
 293                 (when (smiley-end-paren-p start end)
 294                   (make-annotation ")" end 'text))
 295                 (goto-char end)))))))))
 296
 297 (defun smiley-end-paren-p (start end)
 298   "Try to guess whether the current smiley is an end-paren smiley."
 299   (save-excursion
 300     (goto-char start)
 301     (when (and (re-search-backward "[()]" nil t)
 302                (eq (char-after) ?\()
 303                (goto-char end)
 304                (or (not (re-search-forward "[()]" nil t))
 305                    (eq (char-after (1- (point))) ?\()))
 306       t)))
 307
 308 (defun smiley-toggle-buffer (&optional arg buffer st nd)
 309   "Toggle displaying smiley faces.
 310 With arg, turn displaying on if and only if arg is positive."
 311   (interactive "P")
 312   (let (on off)
 313     (map-extents
 314      (lambda (e void)
 315        (let (ant)
 316          (if (annotationp (setq ant (extent-property e 'smiley-annotation)))
 317              (if (eq (extent-property e 'invisible) nil)
 318                  (setq off (cons (cons ant e) off))
 319                (setq on (cons (cons ant e) on)))))
 320        nil)
 321      buffer st nd)
 322     (if (and (not (and (numberp arg) (< arg 0)))
 323              (or (and (numberp arg) (> arg 0))
 324                  (null on)))
 325         (if off
 326             (while off
 327               (reveal-annotation (caar off))
 328               (set-extent-property (cdar off) 'invisible t)
 329               (setq off (cdr off)))
 330           (smiley-buffer))
 331       (while on
 332         (hide-annotation (caar on))
 333         (set-extent-property (cdar on) 'invisible nil)
 334         (setq on (cdr on))))))
 335
 336 (defvar gnus-article-buffer)
 337 ;;;###autoload
 338 (defun gnus-smiley-display (&optional arg)
 339   "Display \"smileys\" as small graphical icons.
 340 With arg, turn displaying on if and only if arg is positive."
 341   (interactive "P")
 342   (save-excursion
 343     (set-buffer gnus-article-buffer)
 344     (save-restriction
 345       (widen)
 346       (article-goto-body)
 347       (smiley-toggle-buffer arg (current-buffer) (point) (point-max)))))
 348
 349 (provide 'smiley)
 350
 351 ;; Local Variables:
 352 ;; coding: iso-8859-1
 353 ;; End:
 354
 355 ;;; smiley.el ends here