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 (if (featurep 'gtk) 'gtk 'x)
 184                           (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 gtk 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