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 ;; Using BITMAP-MULE to compose a logo image will take a long time.
  30 ;; It will be used if you are using Mule, Emacs 20 or Emacs 21 without
  31 ;; a new redisplay engine.  If it makes you irritated, you can inhibit
  32 ;; the use of BITMAP-MULE on the startup screen by the following line
  33 ;; in your .wl file:
  34 ;;
  35 ;; (setq wl-demo-display-logo nil)
  36
  37 ;;; Code:
  38
  39 (defconst wl-demo-copyright-notice
  40   "Copyright (C) 1998-2001 Yuuichi Teranishi <teranisi@gohome.org>"
  41   "A declaration of the copyright on Wanderlust.")
  42
  43 (eval-when-compile
  44   (require 'cl))
  45 (require 'wl-vars)
  46 (require 'wl-version)
  47 (require 'wl-highlight)
  48
  49 (defconst wl-demo-icon-name
  50   (concat "wl-" (wl-version-status)
  51           (if (string-match "^... Dec \\([ 1][0-9]\\|2[0-4]\\)"
  52                             (current-time-string))
  53               "-xmas-logo"
  54             "-logo"))
  55   "Basename of the logo file.")
  56
  57 (defvar wl-logo-ascii "\
  58         o$                  oo$$$$$$ooo
  59      oo$$$      o$$      o$$$\"\"\"\"\"\"$$$$$o
  60   $$$$$$\"     o$$$\"    o$\"\"          \"$$$
  61     $$\"      o$\"\"    o$\"              $$$
  62    $\"      oo$\"     $\"                $$$
  63  o$     oo\"\"$$     $                  $$
  64 o$$  oo$\"  \"$$$o  $                 o$$
  65 $$$$\"\"       \"$$oo$    o          o$\"
  66                \"$$o   \"$$$o oooo$\"\"
  67                  $$       \"\"\"\"
  68                Wanderlust
  69                   \"$
  70 Yet Another Message Interface On Emacsen"
  71   "Ascii picture used to splash the startup screen.")
  72
  73 (eval-and-compile
  74   (when wl-on-emacs21
  75     ;; `display-images-p' has not been available in Emacs versions
  76     ;; prior to Emacs 21.0.105.
  77     (defalias-maybe 'display-images-p 'display-graphic-p)))
  78
  79 ;; Avoid byte compile warnings.
  80 (eval-when-compile
  81   (defalias-maybe 'bitmap-insert-xbm-file 'ignore)
  82   (defalias-maybe 'create-image 'ignore)
  83   (defalias-maybe 'device-on-window-system-p '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 'image-type-available-p 'ignore)
  90   (defalias-maybe 'insert-image 'ignore)
  91   (defalias-maybe 'make-extent 'ignore)
  92   (defalias-maybe 'make-glyph 'ignore)
  93   (defalias-maybe 'propertize 'ignore)
  94   (defalias-maybe 'set-extent-end-glyph 'ignore)
  95   (defalias-maybe 'set-glyph-face 'ignore)
  96   (defalias-maybe 'set-specifier 'ignore)
  97   (defalias-maybe 'window-pixel-height 'ignore)
  98   (defalias-maybe 'window-pixel-width 'ignore))
  99
 100 (defun wl-demo-insert-image (image-type)
 101   "Insert a logo image at the point and position it to be centered.
 102 IMAGE-TYPE specifies what a type of image should be displayed.
 103 Return a number of lines that an image occupies in the buffer."
 104   (let ((file (cond ((eq image-type 'xpm)
 105                      (concat wl-demo-icon-name ".xpm"))
 106                     ((memq image-type '(xbm bitmap))
 107                      (concat wl-demo-icon-name ".xbm"))))
 108         image width height)
 109     (when (featurep 'xemacs)
 110       (when (boundp 'default-gutter-visible-p)
 111         (set-specifier (symbol-value 'default-gutter-visible-p)
 112                        nil (current-buffer)))
 113       (set-specifier (symbol-value 'scrollbar-height) 0 (current-buffer))
 114       (set-specifier (symbol-value 'scrollbar-width) 0 (current-buffer)))
 115     (if (and file
 116              (if (and wl-icon-dir
 117                       (file-directory-p wl-icon-dir))
 118                  (setq file (expand-file-name file wl-icon-dir))
 119                (message "You should specify the value of `wl-icon-dir'")
 120                nil)
 121              (if (file-exists-p file)
 122                  (if (file-readable-p file)
 123                      t
 124                    (message "Permission denied: %s" file)
 125                    nil)
 126                (message "File not found: %s" file)
 127                nil))
 128         (progn
 129           (cond ((featurep 'xemacs)
 130                  (setq width (window-pixel-width)
 131                        height (window-pixel-height)
 132                        image (make-glyph (vector image-type ':file file)))
 133                  (when (eq 'xbm image-type)
 134                    (set-glyph-face image 'wl-highlight-logo-face))
 135                  (insert-char ?\  (max 0 (/ (+ (* (- width (glyph-width image))
 136                                                   (window-width)) width)
 137                                             (* 2 width))))
 138                  (set-extent-end-glyph (make-extent (point) (point)) image)
 139                  (insert "\n")
 140                  (/ (+ (* 2 (glyph-height image) (window-height)) height)
 141                     (* 2 height)))
 142                 ((eq 'bitmap image-type)
 143                  (message "Composing a bitmap image...")
 144                  (save-restriction
 145                    (narrow-to-region (point) (point))
 146                    (bitmap-insert-xbm-file file)
 147                    (backward-char)
 148                    (indent-rigidly (point-min) (point-max)
 149                                    (max 0 (/ (1+ (- (window-width)
 150                                                     (current-column)))
 151                                              2)))
 152                    (put-text-property (point-min) (point-max)
 153                                       'face 'wl-highlight-logo-face)
 154                    (message "Composing a bitmap image...done")
 155                    (count-lines (point-min) (goto-char (point-max)))))
 156                 ((>= emacs-major-version 21)
 157                  (if (eq 'xpm image-type)
 158                      (setq image (create-image file 'xpm)
 159                            width (image-size image)
 160                            height (cdr width)
 161                            width (car width))
 162                    (with-temp-buffer
 163                      (setq case-fold-search t)
 164                      (insert-file-contents file)
 165                      (goto-char (point-min))
 166                      (re-search-forward "\
 167 ^#define[[:blank:]]+[^[:blank:]]+_width[[:blank:]]+")
 168                      (setq width (read (current-buffer)))
 169                      (goto-char (point-min))
 170                      (re-search-forward "\
 171 ^#define[[:blank:]]+[^[:blank:]]+_height[[:blank:]]+")
 172                      (setq height (read (current-buffer)))
 173                      (search-forward "{")
 174                      (delete-region (point-min) (point))
 175                      (while (re-search-forward "[^0-9a-fx]+" nil t)
 176                        (replace-match ""))
 177                      (goto-char (point-min))
 178                      (insert "\"")
 179                      (while (search-forward "0x" nil t)
 180                        (replace-match "\\\\x"))
 181                      (goto-char (point-max))
 182                      (insert "\"")
 183                      (goto-char (point-min))
 184                      (setq image (create-image (read (current-buffer))
 185                                                'xbm t
 186                                                ':width width
 187                                                ':height height)
 188                            width (/ (float width) (frame-char-width))
 189                            height (/ (float height) (frame-char-height)))
 190                      (let ((bg (face-background 'wl-highlight-logo-face))
 191                            (fg (face-foreground 'wl-highlight-logo-face)))
 192                        (when (stringp bg)
 193                          (plist-put (cdr image) ':background bg))
 194                        (when (stringp fg)
 195                          (plist-put (cdr image) ':foreground fg)))))
 196                  (insert (propertize " " 'display
 197                                      (list 'space ':align-to
 198                                            (max 0 (round (- (window-width)
 199                                                             width)
 200                                                          2)))))
 201                  (insert-image image)
 202                  (insert "\n")
 203                  (round height))))
 204       (save-restriction
 205         (narrow-to-region (point) (point))
 206         (insert wl-logo-ascii)
 207         (put-text-property (point-min) (point) 'face 'wl-highlight-logo-face)
 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         (indent-rigidly (point-min) (point-max)
 216                         (max 0 (/ (1+ (- (window-width) width)) 2)))
 217         (count-lines (point-min) (goto-char (point-max)))))))
 218
 219 (defun wl-demo-insert-text (height)
 220   "Insert a version and the copyright message after a logo image.  HEIGHT
 221 should be a number of lines that an image occupies in the buffer."
 222   (let* ((height (- (window-height) height 1))
 223          (text (format (cond ((<= height 2)
 224                               "version %s - \"%s\"\n%s")
 225                              ((eq height 3)
 226                               "version %s - \"%s\"\n\n%s")
 227                              (t
 228                               "\nversion %s - \"%s\"\n\n%s"))
 229                        (product-version-string (product-find 'wl-version))
 230                        (product-code-name (product-find 'wl-version))
 231                        wl-demo-copyright-notice))
 232          start)
 233     (goto-char (point-min))
 234     (insert-char ?\n (max 0 (/ (- height 4) 2)))
 235     (setq start (goto-char (point-max)))
 236     (if wl-on-emacs21
 237         (let ((bg (face-background 'wl-highlight-demo-face))
 238               (fg (face-foreground 'wl-highlight-demo-face)))
 239           (insert (propertize text
 240                               'face (nconc '(variable-pitch :slant oblique)
 241                                            (if (stringp bg)
 242                                                (list ':background bg))
 243                                            (if (stringp fg)
 244                                                (list ':foreground fg))))))
 245       (insert text)
 246       (put-text-property start (point) 'face 'wl-highlight-demo-face))
 247     (let ((fill-column (window-width)))
 248       (center-region start (point)))))
 249
 250 (defun wl-demo-image-type-alist ()
 251   "Return an alist of available logo image types on the current frame."
 252   (if (or (and (featurep 'xemacs)
 253                (device-on-window-system-p))
 254           window-system)
 255       (let ((selection (append (when (or (and (featurep 'xemacs)
 256                                               (featurep 'xpm))
 257                                          (and wl-on-emacs21
 258                                               (display-images-p)
 259                                               (image-type-available-p 'xpm)))
 260                                  '(("xpm" . xpm)))
 261                                (when (or (featurep 'xemacs)
 262                                          (and wl-on-emacs21
 263                                               (display-images-p)
 264                                               (image-type-available-p 'xbm)))
 265                                  '(("xbm" . xbm))))))
 266         (unless (or selection
 267                     (featurep 'xemacs))
 268           (condition-case nil
 269               (require 'bitmap)
 270             (error)))
 271         (when (featurep 'bitmap)
 272           (setq selection (append selection '(("bitmap" . bitmap)))))
 273         (append selection '(("ascii"))))
 274     '(("ascii"))))
 275
 276 (defun wl-demo (&optional image-type)
 277   "Demo on the startup screen.  IMAGE-TYPE should be a symbol which
 278 overrides the variable `wl-demo-display-logo'.  It will prompt user
 279 for the type of image when it is called interactively with a prefix
 280 argument."
 281   (interactive "P")
 282   (let ((selection (wl-demo-image-type-alist))
 283         type)
 284     (if (and image-type (interactive-p))
 285         (setq type (completing-read "Image type: " selection nil t)
 286               image-type (when (assoc type selection)
 287                            (cdr (assoc type selection))))
 288       (if (setq type (assoc (format "%s" (or image-type wl-demo-display-logo))
 289                             selection))
 290           (setq image-type (cdr type))
 291         (setq image-type (when wl-demo-display-logo
 292                            (cdr (car selection)))))))
 293   (when (eq 'bitmap image-type)
 294     ;; Composing a bitmap image takes a long time. :-<
 295     (wl-demo 'ascii))
 296   (let ((buffer (let ((default-enable-multibyte-characters t)
 297                       (default-mc-flag t)
 298                       (default-line-spacing 0))
 299                   (get-buffer-create "*WL Demo*"))))
 300     (switch-to-buffer buffer)
 301     (setq buffer-read-only nil)
 302     (erase-buffer)
 303     (setq truncate-lines t
 304           tab-width 8)
 305     (set (make-local-variable 'tab-stop-list)
 306          '(8 16 24 32 40 48 56 64 72 80 88 96 104 112 120))
 307     (wl-demo-insert-text (wl-demo-insert-image image-type))
 308     (set-buffer-modified-p nil)
 309     (goto-char (point-min))
 310     (sit-for (if (featurep 'lisp-float-type)
 311                  (/ (float 5) (float 10))
 312                1))
 313     buffer))
 314
 315 (require 'product)
 316 (product-provide (provide 'wl-demo) (require 'wl-version))
 317
 318 ;;; wl-demo.el ends here