wl/wl-demo.el

   1 ;;; wl-demo.el -- Opening demo on Wanderlust.
   2
   3 ;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
   9
  10 ;; This program 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 ;; This program 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
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30 ;;
  31
  32 (defconst wl-demo-copyright-notice
  33   "Copyright (C) 1998-2000 Yuuichi Teranishi <teranisi@gohome.org>")
  34
  35 (require 'wl-vars)
  36 (require 'wl-version)
  37 (require 'wl-highlight)
  38 (require 'product)
  39 (product-provide (provide 'wl-demo) (require 'wl-version))
  40
  41 (defconst wl-demo-icon-name (concat "wl-" (wl-version-status) "-logo"))
  42
  43 ;; Avoid byte compile warnings.
  44 (eval-when-compile
  45   (defalias-maybe 'bitmap-compose 'ignore)
  46   (defalias-maybe 'bitmap-decode-xbm 'ignore)
  47   (defalias-maybe 'bitmap-read-xbm-buffer 'ignore)
  48   (defalias-maybe 'bitmap-read-xbm-file 'ignore)
  49   (defalias-maybe 'create-image 'ignore)
  50   (defalias-maybe 'device-on-window-system-p 'ignore)
  51   (defalias-maybe 'display-graphic-p 'ignore)
  52   (defalias-maybe 'fancy-splash-insert 'ignore)
  53   (defalias-maybe 'frame-char-height 'ignore)
  54   (defalias-maybe 'frame-char-width 'ignore)
  55   (defalias-maybe 'frame-parameter 'ignore)
  56   (defalias-maybe 'image-type-available-p 'ignore)
  57   (defalias-maybe 'insert-image 'ignore)
  58   (defalias-maybe 'make-extent 'ignore)
  59   (defalias-maybe 'make-glyph 'ignore)
  60   (defalias-maybe 'propertize 'ignore)
  61   (defalias-maybe 'set-extent-end-glyph 'ignore)
  62   (defalias-maybe 'set-glyph-face 'ignore)
  63   (defalias-maybe 'set-specifier 'ignore)
  64   (defalias-maybe 'tool-bar-mode 'ignore)
  65   (defalias-maybe 'window-pixel-height 'ignore)
  66   (defalias-maybe 'window-pixel-width 'ignore))
  67
  68 ;;
  69 ;; demo ;-)
  70 ;;
  71
  72 (defvar wl-logo-ascii "        o$                  oo$$$$$$ooo
  73      oo$$$      o$$      o$$$\"\"\"\"\"\"$$$$$o
  74   $$$$$$\"     o$$$\"    o$\"\"          \"$$$
  75     $$\"      o$\"\"    o$\"              $$$
  76    $\"      oo$\"     $\"                $$$
  77  o$     oo\"\"$$     $                  $$
  78 o$$  oo$\"  \"$$$o  $                 o$$
  79 $$$$\"\"       \"$$oo$    o          o$\"
  80                \"$$o   \"$$$o oooo$\"\"
  81                  $$       \"\"\"\"
  82                Wanderlust
  83                   \"$
  84 Yet Another Message Interface On Emacsen")
  85
  86 (eval-when-compile
  87   (defmacro wl-demo-with-temp-file-buffer (file &rest forms)
  88     "Create a temporary buffer, insert FILE's contents without
  89 any conversions and evaluate FORMS there like `progn'."
  90     ( `(with-temp-buffer
  91          (let ((coding-system-for-read 'binary)
  92                (input-coding-system '*noconv*)
  93                auto-mode-alist
  94                file-name-handler-alist
  95                format-alist
  96                insert-file-contents-access-hook
  97                insert-file-contents-post-hook
  98                insert-file-contents-pre-hook
  99                interpreter-mode-alist)
 100            (insert-file-contents (, file))
 101            (,@ forms)))))
 102   (put 'wl-demo-with-temp-file-buffer 'lisp-indent-function 1))
 103
 104 (eval-when-compile
 105   (defmacro wl-logo-xpm ()
 106     ;; (WIDTH HEIGHT DATA)
 107     (let ((file (expand-file-name
 108                  (concat wl-demo-icon-name ".xpm")
 109                  wl-icon-dir)))
 110       (if (file-exists-p file)
 111           (wl-demo-with-temp-file-buffer file
 112             (re-search-forward
 113              (concat "\"[\t ]*\\([0-9]+\\)[\t ]+\\([0-9]+\\)"
 114                      "[\t ]+[0-9]+[\t ]+[0-9]+[\t ]*\""))
 115             (list 'list
 116                   (string-to-number (match-string 1))
 117                   (string-to-number (match-string 2))
 118                   (buffer-string))))))
 119   (defmacro wl-logo-xbm ()
 120     ;; (WIDTH HEIGHT DATA)
 121     (let ((file (expand-file-name
 122                  (concat wl-demo-icon-name ".xbm")
 123                  wl-icon-dir)))
 124       (if (file-exists-p file)
 125           (wl-demo-with-temp-file-buffer file
 126             (let ((case-fold-search t)
 127                   width height)
 128               (search-forward "width")
 129               (setq width (read (current-buffer)))
 130               (goto-char (point-min))
 131               (search-forward "height")
 132               (setq height (read (current-buffer)))
 133               (goto-char (point-min))
 134               (search-forward "{")
 135               (delete-region (point-min) (point))
 136               (while (re-search-forward "[^0-9a-fx]+" nil t)
 137                 (replace-match ""))
 138               (goto-char (point-min))
 139               (insert "\"")
 140               (while (search-forward "0x" nil t)
 141                 (replace-match "\\\\x"))
 142               (goto-char (point-max))
 143               (insert "\"")
 144               (goto-char (point-min))
 145               (list 'list width height (read (current-buffer))))))))
 146   (defmacro wl-logo-bitmap ()
 147     ;; (DECODED-P . DATA)
 148     (let ((file (expand-file-name (concat wl-demo-icon-name ".xbm")
 149                                   wl-icon-dir)))
 150       (if (file-exists-p file)
 151           (if (condition-case nil (require 'bitmap) (error nil))
 152               (list 'cons t (bitmap-decode-xbm
 153                              (bitmap-read-xbm-file file)))
 154             (wl-demo-with-temp-file-buffer file
 155               (list 'cons nil (buffer-string))))))))
 156
 157 (let ((xpm (wl-logo-xpm)))
 158   (if (and xpm (or (and (featurep 'xemacs)
 159                         (featurep 'xpm))
 160                    (and (condition-case nil (require 'image) (error nil))
 161                         (image-type-available-p 'xpm))))
 162       (progn
 163         (put 'wl-logo-xpm 'width (car xpm))
 164         (put 'wl-logo-xpm 'height (nth 1 xpm))
 165         (put 'wl-logo-xpm 'image
 166              (if (featurep 'xemacs)
 167                  (make-glyph (vector 'xpm ':data (nth 2 xpm)))
 168                (create-image (nth 2 xpm) 'xpm t))))))
 169
 170 (let ((xbm (wl-logo-xbm))
 171       (bm (wl-logo-bitmap)))
 172   (if (and xbm (or (featurep 'xemacs)
 173                    (featurep 'image)
 174                    (condition-case nil (require 'bitmap) (error nil))))
 175       (progn
 176         (put 'wl-logo-xbm 'width (car xbm))
 177         (put 'wl-logo-xbm 'height (nth 1 xbm))
 178         (put 'wl-logo-xbm 'image
 179              (cond
 180               ((featurep 'xemacs)
 181                (make-glyph (vector 'xbm ':data xbm)))
 182               ((featurep 'image)
 183                (create-image (nth 2 xbm) 'xbm t
 184                              ':width (car xbm) ':height (nth 1 xbm)))
 185               (t
 186                (let ((default-enable-multibyte-characters t)
 187                      (default-mc-flag t))
 188                  (with-temp-buffer
 189                    (let* ((cmp (if (car bm)
 190                                    (cdr bm)
 191                                  (insert (cdr bm))
 192                                  (prog1
 193                                      (bitmap-decode-xbm (bitmap-read-xbm-buffer
 194                                                          (current-buffer)))
 195                                    (erase-buffer))))
 196                           (len (length cmp))
 197                           (i 1))
 198                      (insert (bitmap-compose (aref cmp 0)))
 199                      (while (< i len)
 200                        (insert "\n" (bitmap-compose (aref cmp i)))
 201                        (setq i (1+ i)))
 202                      (buffer-string))))))))))
 203
 204 (defun wl-demo (&optional image-type)
 205   "Demo on the startup screen.
 206 Optional IMAGE-TYPE overrides the variable `wl-demo-display-logo'."
 207   (interactive "P")
 208   (let ((demo-buf (let ((default-enable-multibyte-characters t)
 209                         (default-mc-flag t)
 210                         (default-line-spacing 0))
 211                     (get-buffer-create "*WL Demo*"))))
 212     (switch-to-buffer demo-buf)
 213     (cond ((featurep 'xemacs)
 214            (if (device-on-window-system-p)
 215                (progn
 216                  (if (boundp 'default-gutter-visible-p)
 217                      (set-specifier (symbol-value 'default-gutter-visible-p)
 218                                     nil demo-buf))
 219                  (set-specifier (symbol-value 'scrollbar-height) 0 demo-buf)
 220                  (set-specifier (symbol-value 'scrollbar-width) 0 demo-buf))))
 221           ((and (> emacs-major-version 20) (display-graphic-p))
 222            (make-local-hook 'kill-buffer-hook)
 223            (let* ((frame (selected-frame))
 224                   (toolbar (frame-parameter frame 'tool-bar-lines)))
 225              (modify-frame-parameters frame '((tool-bar-lines)))
 226              (add-hook
 227               'kill-buffer-hook
 228               (` (lambda ()
 229                    (let ((frame (, frame)))
 230                      (when (frame-live-p frame)
 231                        (, (if (and toolbar (> toolbar 0))
 232                               (` (modify-frame-parameters
 233                                   frame '((tool-bar-lines . (, toolbar)))))))
 234                        (set-face-background
 235                         'fringe (, (face-background 'fringe frame)) frame)))))
 236               nil t)
 237              (set-face-background 'fringe (face-background 'default frame)
 238                                   frame))))
 239     (erase-buffer)
 240     (setq truncate-lines t)
 241     (let* ((wl-demo-display-logo
 242             (if (and image-type (interactive-p))
 243                 (let* ((selection '(("xbm" . xbm) ("xpm" . xpm) ("ascii")))
 244                        (type (completing-read "Image type: " selection nil t)))
 245                   (if (assoc type selection)
 246                       (cdr (assoc type selection))
 247                     t))
 248               (or image-type wl-demo-display-logo)))
 249            (logo (if (cond ((featurep 'xemacs)
 250                             (device-on-window-system-p))
 251                            ((featurep 'image)
 252                             (display-graphic-p))
 253                            (t window-system))
 254                      (cond ((and (eq 'xbm wl-demo-display-logo)
 255                                  (get 'wl-logo-xbm 'width))
 256                             'wl-logo-xbm)
 257                            (wl-demo-display-logo
 258                             (cond ((get 'wl-logo-xpm 'width)
 259                                    'wl-logo-xpm)
 260                                   ((get 'wl-logo-xbm 'width)
 261                                    'wl-logo-xbm))))))
 262            (ww (window-width))
 263            (wh (window-height))
 264            rest)
 265       (if logo
 266           (let ((lw (get logo 'width))
 267                 (lh (get logo 'height))
 268                 (image (get logo 'image)))
 269             (cond
 270              ((featurep 'xemacs)
 271               (if (eq 'wl-logo-xbm logo)
 272                   (set-glyph-face image 'wl-highlight-logo-face))
 273               (setq rest (- wh 1 (/ (+ (* lh wh) (window-pixel-height) -1)
 274                                     (window-pixel-height))))
 275               (insert-char ?\  (max 0 (/ (- (* (window-pixel-width) (1+ ww))
 276                                             (* lw ww))
 277                                          2 (window-pixel-width))))
 278               (set-extent-end-glyph (make-extent (point) (point)) image))
 279              ((featurep 'image)
 280               (if (eq 'wl-logo-xbm logo)
 281                   (let ((bg (face-background 'wl-highlight-logo-face))
 282                         (fg (face-foreground 'wl-highlight-logo-face)))
 283                     (if (stringp bg)
 284                         (plist-put (cdr image) ':background bg))
 285                     (if (stringp fg)
 286                         (plist-put (cdr image) ':foreground fg))))
 287               (setq rest (/ (- (* wh (frame-char-height)) lh 1)
 288                             (frame-char-height)))
 289               (insert (propertize " " 'display
 290                                   (list 'space ':align-to
 291                                         (max 0 (/ (- (* (frame-char-width)
 292                                                         (1+ ww)) lw)
 293                                                   2 (frame-char-width))))))
 294               (insert-image image))
 295              (t
 296               (insert image)
 297               (put-text-property (point-min) (point) 'face
 298                                  'wl-highlight-logo-face)
 299               (setq rest (/ (- (* 16 wh) lh 8) 16))
 300               (indent-rigidly (point-min) (point-max)
 301                               (/ (- (* 8 (1+ ww)) lw) 16))))
 302             (goto-char (point-min)))
 303         (insert (or wl-logo-ascii (product-name (product-find 'wl-version))))
 304         (put-text-property (point-min) (point) 'face 'wl-highlight-logo-face)
 305         (setq rest (- wh (count-lines (point-min) (point)) 1))
 306         (let ((lw (current-column))
 307               (lh (count-lines (point-min) (point))))
 308           (while (progn (beginning-of-line) (not (bobp)))
 309             (backward-char)
 310             (setq lw (max lw (current-column))))
 311           (indent-rigidly (point) (point-max) (max 0 (/ (- ww lw) 2)))))
 312       (insert-char ?\n (max 0 (/ (- rest 4) 2)))
 313       (goto-char (point-max))
 314       (insert "\n")
 315       (let ((start (point))
 316             (text (format (cond ((<= rest 2)
 317                                  "version %s - \"%s\"\n%s")
 318                                 ((eq rest 3)
 319                                  "version %s - \"%s\"\n\n%s")
 320                                 (t
 321                                  "\nversion %s - \"%s\"\n\n%s"))
 322                           (product-version-string (product-find 'wl-version))
 323                           (product-code-name (product-find 'wl-version))
 324                           wl-demo-copyright-notice)))
 325         (if wl-on-emacs21
 326             (let ((bg (face-background 'wl-highlight-demo-face))
 327                   (fg (face-foreground 'wl-highlight-demo-face))
 328                   (face '(variable-pitch)))
 329               (if (stringp bg)
 330                   (setcdr face (list ':background bg)))
 331               (if (stringp fg)
 332                   (setq face (nconc face (list ':foreground fg))))
 333               (let (fancy-splash-help-echo)
 334                 (fancy-splash-insert ':face face text)))
 335           (insert text)
 336           (put-text-property start (point) 'face 'wl-highlight-demo-face))
 337         (let ((fill-column ww))
 338           (center-region start (point))))
 339       (goto-char (point-min))
 340       (sit-for (if (featurep 'lisp-float-type) (/ (float 5) (float 10)) 1))
 341       demo-buf)))
 342
 343 ;;; wl-demo.el ends here