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