wl/wl-demo.el

   1 ;;; wl-demo.el --- Opening demo on Wanderlust
   2
   3 ;; Copyright (C) 1998,1999,2000,2001,2002,2003,2004
   4 ;;      Yuuichi Teranishi <teranisi@gohome.org>
   5 ;; Copyright (C) 2000,2001,2004
   6 ;;      Katsumi Yamaoka <yamaoka@jpl.org>
   7
   8 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   9 ;;      Katsumi Yamaoka <yamaoka@jpl.org>
  10 ;; Keywords: mail, net news
  11
  12 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
  13
  14 ;; This program is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; This program is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  27 ;; Boston, MA 02111-1307, USA.
  28
  29 ;;; Commentary:
  30
  31 ;;; Code:
  32
  33 (defconst wl-demo-copyright-notice
  34   "Copyright (C) 1998-2010 Yuuichi Teranishi <teranisi@gohome.org>"
  35   "A declaration of the copyright on Wanderlust.")
  36
  37 (eval-when-compile
  38   (require 'cl))
  39 (require 'path-util)
  40 (require 'wl-vars)
  41 (require 'wl-version)
  42 (require 'wl-highlight)
  43
  44 (defun wl-demo-icon-name ()
  45   "A function to determine logo file name."
  46   (catch 'found
  47     (dolist (pair wl-demo-icon-name-alist)
  48       (when (eval (car pair))
  49         (throw 'found (eval (cdr pair)))))))
  50
  51 (defvar wl-logo-ascii "\
  52         o$                  oo$$$$$$ooo
  53      oo$$$      o$$      o$$$\"\"\"\"\"\"$$$$$o
  54   $$$$$$\"     o$$$\"    o$\"\"          \"$$$
  55     $$\"      o$\"\"    o$\"              $$$
  56    $\"      oo$\"     $\"                $$$
  57  o$     oo\"\"$$     $                  $$
  58 o$$  oo$\"  \"$$$o  $                 o$$
  59 $$$$\"\"       \"$$oo$    o          o$\"
  60                \"$$o   \"$$$o oooo$\"\"
  61                  $$       \"\"\"\"
  62                Wanderlust
  63                   \"$
  64 Yet Another Message Interface On Emacsen"
  65   "Ascii picture used to splash the startup screen.")
  66
  67 (eval-and-compile
  68   (when wl-on-emacs21
  69     ;; `display-images-p' has not been available in Emacs versions
  70     ;; prior to Emacs 21.0.105.
  71     (defalias-maybe 'display-images-p 'display-graphic-p)))
  72
  73 ;; Avoid byte compile warnings.
  74 (eval-when-compile
  75   (autoload 'bitmap-insert-xbm-file "bitmap" nil t)
  76   (autoload 'create-image "image")
  77   (autoload 'device-on-window-system-p "device")
  78   (autoload 'image-type-available-p "image")
  79   (autoload 'insert-image "image")
  80   (autoload 'make-glyph "glyphs")
  81   (autoload 'set-glyph-face "glyphs")
  82   (autoload 'set-specifier "specifier")
  83   (defalias-maybe 'face-background-name 'ignore)
  84   (defalias-maybe 'frame-char-height 'ignore)
  85   (defalias-maybe 'frame-char-width 'ignore)
  86   (defalias-maybe 'glyph-height 'ignore)
  87   (defalias-maybe 'glyph-width 'ignore)
  88   (defalias-maybe 'image-size 'ignore)
  89   (defalias-maybe 'make-extent 'ignore)
  90   (defalias-maybe 'propertize 'ignore)
  91   (defalias-maybe 'set-extent-end-glyph 'ignore)
  92   (defalias-maybe 'window-pixel-height 'ignore)
  93   (defalias-maybe 'window-pixel-width 'ignore))
  94
  95 (defvar wl-demo-bitmap-mule-available-p 'unknown
  96   "Internal variable to say whether the BITMAP-MULE package is available.")
  97
  98 (defun wl-demo-image-type-alist ()
  99   "Return an alist of available logo image types on the current frame."
 100   (if (or (and (featurep 'xemacs)
 101                (device-on-window-system-p))
 102           window-system)
 103       (let ((xpm
 104              (when (or (and (featurep 'xemacs)
 105                             (featurep 'xpm))
 106                        (and wl-on-emacs21
 107                             (display-images-p)
 108                             (image-type-available-p 'xpm)))
 109                '("xpm" . xpm)))
 110             (xbm
 111              (when (or (featurep 'xemacs)
 112                        (and wl-on-emacs21
 113                             (display-images-p)
 114                             (image-type-available-p 'xbm))
 115                        (eq t wl-demo-bitmap-mule-available-p)
 116                        (and (eq 'unknown wl-demo-bitmap-mule-available-p)
 117                             (module-installed-p 'bitmap)
 118                             (setq wl-demo-bitmap-mule-available-p t)))
 119                '("xbm" . xbm)))
 120             (bitmap
 121              (when (and (not (featurep 'xemacs))
 122                         (or (eq t wl-demo-bitmap-mule-available-p)
 123                             (and (eq 'unknown wl-demo-bitmap-mule-available-p)
 124                                  (module-installed-p 'bitmap)
 125                                  (setq wl-demo-bitmap-mule-available-p t))))
 126                '("bitmap" . bitmap))))
 127         (if (and wl-on-emacs21
 128                  (image-type-available-p 'xbm))
 129             ;; Prefer xbm rather than bitmap on Emacs 21.
 130             (delq nil (list xpm xbm bitmap '("ascii")))
 131           (delq nil (list xpm bitmap xbm '("ascii")))))
 132     '(("ascii"))))
 133
 134 (defun wl-demo-image-filter (file type)
 135   "Get filtered image data.
 136 FILE is the image file name.
 137 TYPE is the filter function."
 138   (let ((filter (catch 'found
 139                   (dolist (pair wl-demo-image-filter-alist)
 140                     (when (eq (car pair) type)
 141                       (throw 'found (cdr pair)))))))
 142     (with-temp-buffer
 143       (set-buffer-multibyte nil)
 144       (insert-file-contents file)
 145       (goto-char (point-min))
 146       (when filter
 147         (funcall filter))
 148       (buffer-string))))
 149
 150 (defun wl-demo-insert-image (image-type)
 151   "Insert a logo image at the point and position it to be centered.
 152 IMAGE-TYPE specifies what a type of image should be displayed.
 153 Return a number of lines that an image occupies in the buffer."
 154   (let ((file (cond ((eq 'xpm image-type)
 155                      (concat (wl-demo-icon-name) ".xpm"))
 156                     ((eq 'bitmap image-type)
 157                      (concat (wl-demo-icon-name) ".img"))
 158                     ((eq 'xbm image-type)
 159                      (concat (wl-demo-icon-name) ".xbm"))))
 160         image width height)
 161     (when (featurep 'xemacs)
 162       (when (boundp 'default-gutter-visible-p)
 163         (set-specifier (symbol-value 'default-gutter-visible-p)
 164                        nil (current-buffer)))
 165       (when (featurep 'scrollbar)
 166         (set-specifier (symbol-value 'scrollbar-height) 0 (current-buffer))
 167         (set-specifier (symbol-value 'scrollbar-width) 0 (current-buffer))))
 168     (if (and file
 169              (if (and wl-icon-directory
 170                       (file-directory-p wl-icon-directory))
 171                  (setq file (expand-file-name file wl-icon-directory))
 172                (message "You have to specify the value of `wl-icon-directory'")
 173                nil)
 174              (if (file-exists-p file)
 175                  (if (file-readable-p file)
 176                      t
 177                    (message "Permission denied: %s" file)
 178                    nil)
 179                (message "File not found: %s" file)
 180                nil))
 181         (progn
 182           (cond ((featurep 'xemacs)
 183                  (setq width (window-pixel-width)
 184                        height (window-pixel-height)
 185                        image (make-glyph
 186                               (if (eq image-type 'xbm)
 187                                   (vector image-type ':file file)
 188                                 (vector image-type ':data
 189                                         (wl-demo-image-filter
 190                                          file image-type)))))
 191                  (when (eq 'xbm image-type)
 192                    (set-glyph-face image 'wl-highlight-logo-face))
 193                  (insert-char (string-to-char " ")
 194                               (max 0 (/ (+ (* (- width (glyph-width image))
 195                                               (window-width)) width)
 196                                         (* 2 width))))
 197                  (set-extent-end-glyph (make-extent (point) (point)) image)
 198                  (insert "\n")
 199                  (/ (+ (* 2 (glyph-height image) (window-height)) height)
 200                     (* 2 height)))
 201                 ((and wl-on-emacs21
 202                       (or (eq 'xpm image-type)
 203                           (and (eq 'xbm image-type)
 204                                (image-type-available-p 'xbm))))
 205                  ;; Use the new redisplay engine on Emacs 21.
 206                  (setq image (create-image (wl-demo-image-filter file
 207                                                                  image-type)
 208                                            image-type t)
 209                        width (image-size image)
 210                        height (cdr width)
 211                        width (car width))
 212                  (when (eq 'xbm image-type)
 213                    (let ((bg (face-background 'wl-highlight-demo-face))
 214                          (fg (face-foreground 'wl-highlight-logo-face)))
 215                      (when (stringp bg)
 216                        (plist-put (cdr image) ':background bg))
 217                      (when (stringp fg)
 218                        (plist-put (cdr image) ':foreground fg))))
 219                  (insert (propertize " " 'display
 220                                      (list 'space ':align-to
 221                                            (max 0 (round (- (window-width)
 222                                                             width)
 223                                                          2)))))
 224                  (insert-image image)
 225                  (insert "\n")
 226                  (round height))
 227                 ((eq 'bitmap image-type)
 228                  ;; Use ready-composed bitmap image.
 229                  (require 'bitmap)
 230                  (let ((coding-system-for-read 'iso-2022-7bit)
 231                        (input-coding-system '*iso-2022-jp*))
 232                    (insert-file-contents file))
 233                  (goto-char (point-max))
 234                  (unless (bolp)
 235                    (insert "\n"))
 236
 237                  ;; Emacs 21.x may fail on computing the end of the
 238                  ;; column if there're bitmap characters.
 239 ;;;              (setq width 0)
 240 ;;;              (while (progn
 241 ;;;                       (end-of-line 0)
 242 ;;;                       (not (bobp)))
 243 ;;;                (setq width (max width (current-column))))
 244                  (setq width 1024)
 245                  (while (progn
 246                           (end-of-line 0)
 247                           (not (bobp)))
 248                    (setq width (min width (current-column))))
 249
 250                  ;; Emacs 21.1 would fail to decode composite chars
 251                  ;; if it has been built without fixing coding.c.
 252                  (when (and wl-on-emacs21
 253                             (>= width 80))
 254                    (erase-buffer)
 255                    (let ((coding-system-for-read 'raw-text))
 256                      (insert-file-contents file))
 257                    (goto-char (point-max))
 258                    (unless (bolp)
 259                      (insert "\n"))
 260                    (setq width 0)
 261                    (while (progn
 262                             (end-of-line 0)
 263                             (not (bobp)))
 264                      ;; Decode bitmap data line by line.
 265                      (decode-coding-region (line-beginning-position)
 266                                            (point)
 267                                            'iso-2022-7bit)
 268                      (setq width (max width (current-column)))))
 269                  (indent-rigidly (point-min) (point-max)
 270                                  (max 0 (/ (1+ (- (window-width) width)) 2)))
 271                  (put-text-property (point-min) (point-max) 'fixed-width t)
 272                  (count-lines (point-min) (goto-char (point-max))))
 273                 ((eq 'xbm image-type)
 274                  (message "Composing a bitmap image...")
 275                  (require 'bitmap)
 276                  (bitmap-insert-xbm-file file)
 277                  (backward-char)
 278                  (indent-rigidly (point-min) (point-max)
 279                                  (max 0 (/ (1+ (- (window-width)
 280                                                   (current-column)))
 281                                            2)))
 282                  (put-text-property (point-min) (point-max) 'fixed-width t)
 283                  (message "Composing a bitmap image...done")
 284                  (count-lines (point-min) (goto-char (point-max))))))
 285       (insert wl-logo-ascii)
 286       (unless (bolp)
 287         (insert "\n"))
 288       (setq width 0)
 289       (while (progn
 290                (end-of-line 0)
 291                (not (bobp)))
 292         (setq width (max width (current-column))))
 293       (indent-rigidly (point-min) (point-max)
 294                       (max 0 (/ (1+ (- (window-width) width)) 2)))
 295       (put-text-property (point-min) (point-max) 'fixed-width t)
 296       (count-lines (point-min) (goto-char (point-max))))))
 297
 298 (defun wl-demo-setup-properties ()
 299   "Set up properties of the demo buffer."
 300   (cond
 301    (wl-on-emacs21
 302     ;; I think there should be a better way to set face background
 303     ;; for the buffer only. But I don't know how to do it on Emacs21.
 304     (goto-char (point-max))
 305     (dotimes (i (- (window-height)
 306                    (count-lines (point-min) (point))))
 307       (insert ?\n))
 308     (let* ((fg (face-foreground 'wl-highlight-demo-face))
 309            (bg (face-background 'wl-highlight-demo-face))
 310            (oblique (nconc '(variable-pitch :slant oblique)
 311                            (when (stringp bg)
 312                              (list ':background bg))
 313                            (when (stringp fg)
 314                              (list ':foreground fg))))
 315            (start (text-property-any (point-min) (point-max) 'fixed-width t))
 316            end)
 317       (if start
 318           (progn
 319             (put-text-property (point-min) start 'face oblique)
 320             (setq end (or (text-property-not-all start (point-max)
 321                                                  'fixed-width t)
 322                           (point-max)))
 323             (put-text-property start end 'face
 324                                (nconc '(wl-highlight-logo-face)
 325                                       (when (stringp bg)
 326                                         (list ':background bg))))
 327             (put-text-property end (point-max) 'face oblique))
 328         (put-text-property (point-min) (point-max) 'face oblique))))
 329    ((and (featurep 'xemacs)
 330          (face-background-name 'wl-highlight-demo-face))
 331     (set-face-background 'default
 332                          (face-background-name 'wl-highlight-demo-face)
 333                          (current-buffer)))
 334    (t
 335     (goto-char (point-max))
 336     (dotimes (i (- (window-height)
 337                    (count-lines (point-min) (point))))
 338       (insert ?\n))
 339     (let ((start (text-property-any (point-min) (point-max) 'fixed-width t))
 340           end)
 341       (if start
 342           (progn
 343             (put-text-property (point-min) start 'face 'wl-highlight-demo-face)
 344             (setq end (or (text-property-not-all start (point-max)
 345                                                  'fixed-width t)
 346                           (point-max)))
 347             (put-text-property start end 'face 'wl-highlight-logo-face)
 348             (put-text-property end (point-max) 'face 'wl-highlight-demo-face))
 349         (put-text-property (point-min) (point-max)
 350                            'face 'wl-highlight-demo-face))))))
 351
 352 (defun wl-demo-insert-text (height)
 353   "Insert a version and the copyright message after a logo image.  HEIGHT
 354 should be a number of lines that an image occupies in the buffer."
 355   (let* ((height (- (window-height) height 1))
 356          (text (format (cond ((<= height 2)
 357                               "version %s - \"%s\"\n%s\n")
 358                              ((eq height 3)
 359                               "version %s - \"%s\"\n\n%s\n")
 360                              (t
 361                               "\nversion %s - \"%s\"\n\n%s\n"))
 362                        (product-version-string (product-find 'wl-version))
 363                        (product-code-name (product-find 'wl-version))
 364                        wl-demo-copyright-notice))
 365          start)
 366     (goto-char (point-min))
 367     (insert-char ?\n (max 0 (/ (- height 4) 2)))
 368     (setq start (goto-char (point-max)))
 369     (insert text)
 370     (let ((fill-column (window-width)))
 371       (center-region start (point)))))
 372
 373 (defun wl-demo (&optional image-type)
 374   "Demo on the startup screen.  IMAGE-TYPE should be a symbol which
 375 overrides the variable `wl-demo-display-logo'.  It will prompt user
 376 for the type of image when it is called interactively with a prefix
 377 argument."
 378   (interactive "P")
 379   (let ((selection (wl-demo-image-type-alist))
 380         type)
 381     (if (and image-type (interactive-p))
 382         (setq type (completing-read "Image type: " selection nil t)
 383               image-type (when (assoc type selection)
 384                            (cdr (assoc type selection))))
 385       (if (setq type (assoc (format "%s" (or image-type wl-demo-display-logo))
 386                             selection))
 387           (setq image-type (cdr type))
 388         (setq image-type (when wl-demo-display-logo
 389                            (cdr (car selection)))))))
 390   (let ((buffer (let ((default-enable-multibyte-characters t)
 391                       (default-mc-flag t)
 392                       (default-line-spacing 0))
 393                   (get-buffer-create "*WL Demo*"))))
 394     (switch-to-buffer buffer)
 395     (setq buffer-read-only nil)
 396     (buffer-disable-undo)
 397     (erase-buffer)
 398     (setq truncate-lines t
 399           tab-width 8)
 400     (set (make-local-variable 'tab-stop-list)
 401          '(8 16 24 32 40 48 56 64 72 80 88 96 104 112 120))
 402     (wl-demo-insert-text (wl-demo-insert-image image-type))
 403     (wl-demo-setup-properties)
 404     (set-buffer-modified-p nil)
 405     (goto-char (point-min))
 406     (sit-for (if (featurep 'lisp-float-type)
 407                  (/ (float 5) (float 10))
 408                1))
 409     buffer))
 410
 411 ;; Prune functions provided temporarily to avoid compile warnings.
 412 (eval-when-compile
 413   (dolist (fn '(face-background-name
 414                 frame-char-height frame-char-width glyph-height glyph-width
 415                 image-size make-extent propertize set-extent-end-glyph
 416                 window-pixel-height window-pixel-width))
 417     (when (and (get fn 'defalias-maybe)
 418                (eq (symbol-function fn) 'ignore))
 419       (put fn 'defalias-maybe nil)
 420       (fmakunbound fn))))
 421
 422 (require 'product)
 423 (product-provide (provide 'wl-demo) (require 'wl-version))
 424
 425 ;;; wl-demo.el ends here