cgit.sxemacs.org Git - gnus/blob - lisp/smiley.el

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