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

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