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