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 (defun smiley-create-glyph-ems (smiley pixmap)
 197   (condition-case e
 198       (create-image (expand-file-name pixmap smiley-data-directory))
 199     (error nil)))
 200
 201
 202 ;;;###autoload
 203 (defun smiley-region (beg end)
 204   "Smilify the region between point and mark."
 205   (interactive "r")
 206   (smiley-buffer (current-buffer) beg end))
 207
 208 (defun smiley-toggle-extent (event)
 209   "Toggle smiley at given point."
 210   (interactive "e")
 211   (let* ((ant (event-glyph-extent event))
 212          (pt (event-closest-point event))
 213          ext)
 214     (if (annotationp ant)
 215         (when (extentp (setq ext (extent-property ant 'smiley-extent)))
 216           (set-extent-property ext 'invisible nil)
 217           (hide-annotation ant))
 218       (when pt
 219         (while (setq ext (extent-at pt (event-buffer event) nil ext 'at))
 220           (when (annotationp (setq ant
 221                                    (extent-property ext 'smiley-annotation)))
 222             (reveal-annotation ant)
 223             (set-extent-property ext 'invisible t)))))))
 224
 225 ;; FIXME::
 226 (defun smiley-toggle-extent-ems (event)
 227   "Toggle smiley at given point.
 228 Note -- this function hasn't been implemented yet."
 229   (interactive "e")
 230   (error "This function hasn't been implemented yet.")
 231 )
 232
 233 (defun smiley-toggle-extents (e)
 234   (interactive "e")
 235   (map-extents
 236    (lambda (e void)
 237      (let (ant)
 238        (if (annotationp (setq ant (extent-property e 'smiley-annotation)))
 239            (if (eq (extent-property e 'invisible) nil)
 240                (progn
 241                  (reveal-annotation ant)
 242                  (set-extent-property e 'invisible t)
 243                  )
 244              (hide-annotation ant)
 245              (set-extent-property e 'invisible nil)))
 246        nil))
 247    (event-buffer e)))
 248
 249 ;; FIXME::
 250 (defun smiley-toggle-extents-ems (e)
 251   (interactive "e")
 252   (error "This function hasn't been implemented yet.")
 253 )
 254
 255 ;;;###autoload
 256 (defun smiley-buffer (&optional buffer st nd)
 257   (interactive)
 258   (when (featurep '(or x gtk mswindows))
 259     (save-excursion
 260       (when buffer
 261         (set-buffer buffer))
 262       (let ((buffer-read-only nil)
 263             (alist (if (symbolp smiley-regexp-alist)
 264                        (symbol-value smiley-regexp-alist)
 265                      smiley-regexp-alist))
 266             (case-fold-search nil)
 267             entry regexp beg group file)
 268         (map-extents
 269          (lambda (e void)
 270            (when (or (extent-property e 'smiley-extent)
 271                      (extent-property e 'smiley-annotation))
 272              (delete-extent e)))
 273          buffer st nd)
 274         (goto-char (or st (point-min)))
 275         (setq beg (point))
 276         ;; loop through alist
 277         (while (setq entry (pop alist))
 278           (setq regexp (car entry)
 279                 group (cadr entry)
 280                 file (caddr entry))
 281           (goto-char beg)
 282           (while (re-search-forward regexp nd t)
 283             (let* ((start (match-beginning group))
 284                    (end (match-end group))
 285                    (glyph (smiley-create-glyph (buffer-substring start end)
 286                                                file)))
 287               (when glyph
 288                 (mapcar 'delete-annotation (annotations-at end))
 289                 (let ((ext (make-extent start end))
 290                       (ant (make-annotation glyph end 'text)))
 291                   ;; set text extent params
 292                   (set-extent-property ext 'end-open t)
 293                   (set-extent-property ext 'start-open t)
 294                   (set-extent-property ext 'invisible t)
 295                   (set-extent-property ext 'keymap smiley-map)
 296                   (set-extent-property ext 'mouse-face smiley-mouse-face)
 297                   (set-extent-property ext 'intangible t)
 298                   ;; set annotation params