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 (require 'wl-vars)
  33 (provide 'wl-demo)
  34 (if (featurep 'xemacs)
  35     (require 'wl-xmas))
  36
  37 (eval-when-compile
  38   (defun-maybe device-on-window-system-p ())
  39   (defun-maybe glyph-height (a))
  40   (defun-maybe glyph-width (a))
  41   (defun-maybe make-extent (a b))
  42   (defun-maybe make-glyph (a))
  43   (defun-maybe set-extent-end-glyph (a b))
  44   (defun-maybe startup-center-spaces (a))
  45   (defun-maybe window-pixel-height ())
  46   (defun-maybe window-pixel-width ())
  47   (condition-case nil
  48       (require 'bitmap)
  49     (error nil))
  50   (defun-maybe bitmap-compose (a))
  51   (defun-maybe bitmap-decode-xbm (a))
  52   (defun-maybe bitmap-read-xbm-file (a))
  53   (unless (boundp ':data)
  54     (set (make-local-variable ':data) nil))
  55   (unless (boundp ':type)
  56     (set (make-local-variable ':type) nil))
  57   (condition-case nil
  58       (require 'image)
  59     (error nil))
  60   (defun-maybe frame-char-height ())
  61   (defun-maybe frame-char-width ())
  62   (defun-maybe image-type-available-p (a)))
  63
  64 (static-condition-case nil
  65     (progn
  66       (insert-image '(image))
  67       (defalias 'wl-insert-image 'insert-image))
  68   (wrong-number-of-arguments
  69    (defun wl-insert-image (image)
  70      (insert-image image "x")))
  71   (void-function
  72    (defun wl-insert-image (image))))
  73
  74 ;;
  75 ;; demo ;-)
  76 ;;
  77 (eval-when-compile
  78   (cond ((or (featurep 'xemacs) (featurep 'image))
  79          (defmacro wl-title-logo ()
  80            (let ((file (expand-file-name "wl-logo.xpm" wl-icon-dir)))
  81              (if (file-exists-p file)
  82                  (let ((buffer (generate-new-buffer " *wl-logo*"))
  83                        (coding-system-for-read 'binary)
  84                        buffer-file-format format-alist
  85                        insert-file-contents-post-hook
  86                        insert-file-contents-pre-hook)
  87                    (prog1
  88                        (save-excursion
  89                          (set-buffer buffer)
  90                          (insert-file-contents file)
  91                          (buffer-string))
  92                      (kill-buffer buffer)))))))
  93         ((condition-case nil
  94              (require 'bitmap)
  95            (error nil))
  96          (defmacro wl-title-logo ()
  97            (let ((file (expand-file-name "wl-logo.xbm" wl-icon-dir)))
  98              (if (file-exists-p file)
  99                  (condition-case nil
 100                      (bitmap-decode-xbm (bitmap-read-xbm-file file))
 101                    (error (message "Bitmap Logo is not used.")))))))
 102         (t
 103          (defmacro wl-title-logo ()))))
 104
 105 (defconst wl-title-logo
 106   (cond ((or (and (featurep 'xemacs)
 107                   (featurep 'xpm)
 108                   (device-on-window-system-p))
 109              (and (eval-when-compile (featurep 'image))
 110                   (image-type-available-p 'xpm)))
 111          (wl-title-logo))
 112         ((and window-system
 113               (condition-case nil
 114                   (require 'bitmap)
 115                 (error nil)))
 116          (let ((cmp (wl-title-logo)))
 117            (if cmp
 118                (condition-case nil
 119                    (let ((len (length cmp))
 120                          (bitmap (bitmap-compose (aref cmp 0)))
 121                          (i 1))
 122                      (while (< i len)
 123                        (setq bitmap (concat bitmap "\n"
 124                                             (bitmap-compose (aref cmp i)))
 125                              i (1+ i)))
 126                      bitmap)
 127                  (error nil)))))))
 128
 129 (defun wl-demo ()
 130   (interactive)
 131   (let ((demo-buf (get-buffer-create "*WL Demo*"))
 132         logo-ext start)
 133     (switch-to-buffer demo-buf)
 134     (erase-buffer)
 135     (if (and wl-demo-display-logo wl-title-logo)
 136         (cond
 137          ((featurep 'xemacs)
 138           (let ((wl-logo (make-glyph (vector 'xpm :data wl-title-logo))))
 139             (insert-char ?\n (max 1 (/ (- (window-height) 6
 140                                           (/ (glyph-height wl-logo)
 141                                              (/ (window-pixel-height)
 142                                                 (window-height)))) 2)))
 143             (indent-to (startup-center-spaces wl-logo))
 144             (insert-char ?\ (max 0 (/ (- (window-width)
 145                                          (/ (glyph-width wl-logo)
 146                                             (/ (window-pixel-width)
 147                                                (window-width)))) 2)))
 148             (setq logo-ext (make-extent (point)(point)))
 149             (set-extent-end-glyph logo-ext wl-logo)))
 150          ((featurep 'image)
 151           (let ((wl-logo (list 'image :type 'xpm :data wl-title-logo))
 152                 pixel-width pixel-height)
 153             (with-temp-buffer
 154               (insert wl-title-logo)
 155               (goto-char (point-min))
 156               (skip-syntax-forward "^\"")
 157               (when (looking-at "\"[ \t]*\\([0-9]+\\)[ \t]*\\([0-9]+\\)")
 158                 (setq pixel-width (string-to-int (match-string 1))
 159                       pixel-height (string-to-int (match-string 2)))))
 160             (insert-char ?\n (max 1 (/ (- (window-height) 6
 161                                           (/ pixel-height
 162                                              (frame-char-height))) 2)))
 163             (insert-char ?\  (max 0 (/ (- (window-width)
 164                                           (/ pixel-width
 165                                              (frame-char-width))) 2)))
 166             (wl-insert-image wl-logo)
 167             (insert "\n")))
 168          (t
 169           (insert wl-title-logo)
 170           (indent-rigidly (point-min) (point-max)
 171                           (max 0 (/ (- (window-width) (current-column)) 2)))
 172           (insert "\n")
 173           (goto-char (point-min))
 174           (insert-char ?\n (max 0 (/ (- (window-height)
 175                                         (count-lines (point) (point-max))
 176                                         6) 2)))
 177           (goto-char (point-max))))
 178       (insert-char ?\n (max 1 (- (/ (window-height) 3) 2))))
 179     (setq start (point))
 180     (insert "\n" (if (and wl-demo-display-logo wl-title-logo)
 181                      ""
 182                    (concat wl-appname "\n")))
 183     (let ((fill-column (window-width)))
 184       (center-region start (point)))
 185     (setq start (point))
 186     (put-text-property (point-min) (point) 'face 'wl-highlight-logo-face)
 187     (insert (format "\nversion %s - \"%s\"\n\n"
 188                     wl-version wl-codename
 189                     ))
 190     (insert "Copyright (C) 1998-2000 Yuuichi Teranishi <teranisi@gohome.org>")
 191     (put-text-property start (point-max) 'face 'wl-highlight-demo-face)
 192     (let ((fill-column (window-width)))
 193       (center-region start (point)))
 194     (goto-char (point-min))
 195     (sit-for
 196      (if (featurep 'lisp-float-type) (/ (float 5) (float 10)) 1))
 197     ;;(if (featurep 'xemacs) (delete-extent logo-ext))
 198     demo-buf))
 199
 200 ;;; wl-demo.el ends here