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