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