wl/wl-demo.el

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