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 ;; Time-stamp: <2000-03-30 15:56:54 teranisi>
   8
   9 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25 ;;
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31 ;;
  32
  33 (require 'wl-vars)
  34 (provide 'wl-demo)
  35 (if (featurep 'xemacs)
  36     (require 'wl-xmas))
  37
  38 (eval-when-compile
  39   (defun-maybe device-on-window-system-p ())
  40   (defun-maybe glyph-height (a))
  41   (defun-maybe glyph-width (a))
  42   (defun-maybe make-extent (a b))
  43   (defun-maybe make-glyph (a))
  44   (defun-maybe set-extent-end-glyph (a b))
  45   (defun-maybe startup-center-spaces (a))
  46   (defun-maybe window-pixel-height ())
  47   (defun-maybe window-pixel-width ())
  48   (condition-case nil
  49       (require 'bitmap)
  50     (error nil))
  51   (defun-maybe bitmap-compose (a))
  52   (defun-maybe bitmap-decode-xbm (a))
  53   (defun-maybe bitmap-read-xbm-file (a))
  54   (unless (boundp ':data)
  55     (set (make-local-variable ':data) nil))
  56   (unless (boundp ':type)
  57     (set (make-local-variable ':type) nil))
  58   (condition-case nil
  59       (require 'image)
  60     (error nil))
  61   (defun-maybe frame-char-height ())
  62   (defun-maybe frame-char-width ())
  63   (defun-maybe image-type-available-p (a)))
  64
  65 (static-condition-case nil
  66     (progn
  67       (insert-image '(image))
  68       (defalias 'wl-insert-image 'insert-image))
  69   (wrong-number-of-arguments
  70    (defun wl-insert-image (image)
  71      (insert-image image "x")))
  72   (void-function
  73    (defun wl-insert-image (image))))
  74
  75 ;;
  76 ;; demo ;-)
  77 ;;
  78 (eval-when-compile
  79   (cond ((or (featurep 'xemacs) (featurep 'image))
  80          (defmacro wl-title-logo ()
  81            (let ((file (expand-file-name "wl-logo.xpm" wl-icon-dir)))
  82              (if (file-exists-p file)
  83                  (let ((buffer (generate-new-buffer " *wl-logo*"))
  84                        (coding-system-for-read 'binary)
  85                        buffer-file-format format-alist
  86                        insert-file-contents-post-hook
  87                        insert-file-contents-pre-hook)
  88                    (prog1
  89                        (save-excursion
  90                          (set-buffer buffer)
  91                          (insert-file-contents file)
  92                          (buffer-string))
  93                      (kill-buffer buffer)))))))
  94         ((condition-case nil
  95              (require 'bitmap)
  96            (error nil))
  97          (defmacro wl-title-logo ()
  98            (let ((file (expand-file-name "wl-logo.xbm" wl-icon-dir)))
  99              (if (file-exists-p file)
 100                  (condition-case nil
 101                      (bitmap-decode-xbm (bitmap-read-xbm-file file))
 102                    (error (message "Bitmap Logo is not used.")))))))
 103         (t
 104          (defmacro wl-title-logo ()))))
 105
 106 (defconst wl-title-logo
 107   (cond ((or (and (featurep 'xemacs)
 108                   (featurep 'xpm)
 109                   (device-on-window-system-p))
 110              (and (eval-when-compile (featurep 'image))
 111                   (image-type-available-p 'xpm)))
 112          (wl-title-logo))
 113         ((and window-system
 114               (condition-case nil
 115                   (require 'bitmap)
 116                 (error nil)))
 117          (let ((cmp (wl-title-logo)))
 118            (if cmp
 119                (condition-case nil
 120                    (let ((len (length cmp))
 121                          (bitmap (bitmap-compose (aref cmp 0)))
 122                          (i 1))
 123                      (while (< i len)
 124                        (setq bitmap (concat bitmap "\n"
 125                                             (bitmap-compose (aref cmp i)))
 126                              i (1+ i)))
 127                      bitmap)
 128                  (error nil)))))))
 129
 130 (defun wl-demo ()
 131   (interactive)
 132   (let ((demo-buf (get-buffer-create "*WL Demo*"))
 133         logo-ext start)
 134     (switch-to-buffer demo-buf)
 135     (erase-buffer)
 136     (if (and wl-demo-display-logo wl-title-logo)
 137         (cond
 138          ((featurep 'xemacs)
 139           (let ((wl-logo (make-glyph (vector 'xpm :data wl-title-logo))))
 140             (insert-char ?\n (max 1 (/ (- (window-height) 6
 141                                           (/ (glyph-height wl-logo)
 142                                              (/ (window-pixel-height)
 143                                                 (window-height)))) 2)))
 144             (indent-to (startup-center-spaces wl-logo))
 145             (insert-char ?\ (max 0 (/ (- (window-width)
 146                                          (/ (glyph-width wl-logo)
 147                                             (/ (window-pixel-width)
 148                                                (window-width)))) 2)))
 149             (setq logo-ext (make-extent (point)(point)))
 150             (set-extent-end-glyph logo-ext wl-logo)))
 151          ((featurep 'image)
 152           (let ((wl-logo (list 'image :type 'xpm :data wl-title-logo))
 153                 pixel-width pixel-height)
 154             (with-temp-buffer
 155               (insert wl-title-logo)
 156               (goto-char (point-min))
 157               (skip-syntax-forward "^\"")
 158               (when (looking-at "\"[ \t]*\\([0-9]+\\)[ \t]*\\([0-9]+\\)")
 159                 (setq pixel-width (string-to-int (match-string 1))
 160                       pixel-height (string-to-int (match-string 2)))))
 161             (insert-char ?\n (max 1 (/ (- (window-height) 6
 162                                           (/ pixel-height
 163                                              (frame-char-height))) 2)))
 164             (insert-char ?\  (max 0 (/ (- (window-width)
 165                                           (/ pixel-width
 166                                              (frame-char-width))) 2)))
 167             (wl-insert-image wl-logo)
 168             (insert "\n")))
 169          (t
 170           (insert wl-title-logo)
 171           (indent-rigidly (point-min) (point-max)
 172                           (max 0 (/ (- (window-width) (current-column)) 2)))
 173           (insert "\n")
 174           (goto-char (point-min))
 175           (insert-char ?\n (max 0 (/ (- (window-height)
 176                                         (count-lines (point) (point-max))
 177                                         6) 2)))
 178           (goto-char (point-max))))
 179       (insert-char ?\n (max 1 (- (/ (window-height) 3) 2))))
 180     (setq start (point))
 181     (insert "\n" (if (and wl-demo-display-logo wl-title-logo)
 182                      ""
 183                    (concat wl-appname "\n")))
 184     (let ((fill-column (window-width)))
 185       (center-region start (point)))
 186     (setq start (point))
 187     (put-text-property (point-min) (point) 'face 'wl-highlight-logo-face)
 188     (insert (format "\nversion %s - \"%s\"\n\n"
 189                     wl-version wl-codename
 190                     ))
 191     (insert "Copyright (C) 1998-2000 Yuuichi Teranishi <teranisi@gohome.org>")
 192     (put-text-property start (point-max) 'face 'wl-highlight-demo-face)
 193     (let ((fill-column (window-width)))
 194       (center-region start (point)))
 195     (goto-char (point-min))
 196     (sit-for
 197      (if (featurep 'lisp-float-type) (/ (float 5) (float 10)) 1))
 198     ;;(if (featurep 'xemacs) (delete-extent logo-ext))
 199     demo-buf))
 200
 201 ;;; wl-demo.el ends here