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