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