1 ;;; wl-demo.el -- Opening demo on Wanderlust.
3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
4 ;; Copyright (C) 2000 Katsumi Yamaoka <yamaoka@jpl.org>
6 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
7 ;; Katsumi Yamaoka <yamaoka@jpl.org>
8 ;; Keywords: mail, net news
10 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
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)
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.
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.
34 (defconst wl-demo-copyright-notice
35 "Copyright (C) 1998-2001 Yuuichi Teranishi <teranisi@gohome.org>")
39 (require 'wl-highlight)
41 (defconst wl-demo-icon-name (concat "wl-" (wl-version-status) "-logo"))
43 ;; Avoid byte compile warnings.
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 'tool-bar-mode 'ignore)
64 (defalias-maybe 'window-pixel-height 'ignore)
65 (defalias-maybe 'window-pixel-width 'ignore))
71 (defvar wl-logo-ascii " o$ oo$$$$$$ooo
72 oo$$$ o$$ o$$$\"\"\"\"\"\"$$$$$o
73 $$$$$$\" o$$$\" o$\"\" \"$$$
77 o$$ oo$\" \"$$$o $ o$$
78 $$$$\"\" \"$$oo$ o o$\"
79 \"$$o \"$$$o oooo$\"\"
83 Yet Another Message Interface On Emacsen")
86 (defmacro wl-demo-with-temp-file-buffer (file &rest forms)
87 "Create a temporary buffer, insert FILE's contents without
88 any conversions and evaluate FORMS there like `progn'."
90 (let ((coding-system-for-read 'binary)
91 (input-coding-system '*noconv*)
93 file-name-handler-alist
95 insert-file-contents-access-hook
96 insert-file-contents-post-hook
97 insert-file-contents-pre-hook
98 interpreter-mode-alist)
99 (insert-file-contents (, file))
101 (put 'wl-demo-with-temp-file-buffer 'lisp-indent-function 1))
104 (defmacro wl-logo-xpm ()
105 ;; (WIDTH HEIGHT DATA)
106 (let ((file (expand-file-name
107 (concat wl-demo-icon-name ".xpm")
109 (if (file-exists-p file)
110 (wl-demo-with-temp-file-buffer file
112 (concat "\"[\t ]*\\([0-9]+\\)[\t ]+\\([0-9]+\\)"
113 "[\t ]+[0-9]+[\t ]+[0-9]+[\t ]*\""))
115 (string-to-number (match-string 1))
116 (string-to-number (match-string 2))
118 (defmacro wl-logo-xbm ()
119 ;; (WIDTH HEIGHT DATA)
120 (let ((file (expand-file-name
121 (concat wl-demo-icon-name ".xbm")
123 (if (file-exists-p file)
124 (wl-demo-with-temp-file-buffer file
125 (let ((case-fold-search t)
127 (search-forward "width")
128 (setq width (read (current-buffer)))
129 (goto-char (point-min))
130 (search-forward "height")
131 (setq height (read (current-buffer)))
132 (goto-char (point-min))
134 (delete-region (point-min) (point))
135 (while (re-search-forward "[^0-9a-fx]+" nil t)
137 (goto-char (point-min))
139 (while (search-forward "0x" nil t)
140 (replace-match "\\\\x"))
141 (goto-char (point-max))
143 (goto-char (point-min))
144 (list 'list width height (read (current-buffer))))))))
145 (defmacro wl-logo-bitmap ()
146 ;; (DECODED-P . DATA)
147 (let ((file (expand-file-name (concat wl-demo-icon-name ".xbm")
149 (if (file-exists-p file)
150 (if (condition-case nil (require 'bitmap) (error nil))
151 (list 'cons t (bitmap-decode-xbm
152 (bitmap-read-xbm-file file)))
153 (wl-demo-with-temp-file-buffer file
154 (list 'cons nil (buffer-string))))))))
156 (let ((xpm (wl-logo-xpm)))
157 (if (and xpm (or (and (featurep 'xemacs)
159 (and (condition-case nil (require 'image) (error nil))
160 (image-type-available-p 'xpm))))
162 (put 'wl-logo-xpm 'width (car xpm))
163 (put 'wl-logo-xpm 'height (nth 1 xpm))
164 (put 'wl-logo-xpm 'image
165 (if (featurep 'xemacs)
166 (make-glyph (vector 'xpm ':data (nth 2 xpm)))
167 (create-image (nth 2 xpm) 'xpm t))))))
169 (let ((xbm (wl-logo-xbm))
170 (bm (wl-logo-bitmap)))
171 (if (and xbm (or (featurep 'xemacs)
173 (condition-case nil (require 'bitmap) (error nil))))
175 (put 'wl-logo-xbm 'width (car xbm))
176 (put 'wl-logo-xbm 'height (nth 1 xbm))
177 (put 'wl-logo-xbm 'image
180 (make-glyph (vector 'xbm ':data xbm)))
182 (create-image (nth 2 xbm) 'xbm t
183 ':width (car xbm) ':height (nth 1 xbm)))
185 (let ((default-enable-multibyte-characters t)
188 (let* ((cmp (if (car bm)
192 (bitmap-decode-xbm (bitmap-read-xbm-buffer
197 (insert (bitmap-compose (aref cmp 0)))
199 (insert "\n" (bitmap-compose (aref cmp i)))
201 (buffer-string))))))))))
203 (defun wl-demo (&optional image-type)
204 "Demo on the startup screen.
205 Optional IMAGE-TYPE overrides the variable `wl-demo-display-logo'."
207 (let ((demo-buf (let ((default-enable-multibyte-characters t)
209 (default-line-spacing 0))
210 (get-buffer-create "*WL Demo*"))))
211 (switch-to-buffer demo-buf)
212 (cond ((featurep 'xemacs)
213 (if (device-on-window-system-p)
215 (if (boundp 'default-gutter-visible-p)
216 (set-specifier (symbol-value 'default-gutter-visible-p)
218 (set-specifier (symbol-value 'scrollbar-height) 0 demo-buf)
219 (set-specifier (symbol-value 'scrollbar-width) 0 demo-buf))))
220 ((and (> emacs-major-version 20) (display-graphic-p))
221 (make-local-hook 'kill-buffer-hook)
222 (let* ((frame (selected-frame))
223 (toolbar (frame-parameter frame 'tool-bar-lines)))
224 (modify-frame-parameters frame '((tool-bar-lines)))
228 (let ((frame (, frame)))
229 (when (frame-live-p frame)
230 (, (if (and toolbar (> toolbar 0))
231 (` (modify-frame-parameters
232 frame '((tool-bar-lines . (, toolbar)))))))
234 'fringe (, (face-background 'fringe frame)) frame)))))
236 (set-face-background 'fringe (face-background 'default frame)
239 (setq truncate-lines t)
240 (let* ((wl-demo-display-logo
241 (if (and image-type (interactive-p))
242 (let* ((selection '(("xbm" . xbm) ("xpm" . xpm) ("ascii")))
243 (type (completing-read "Image type: " selection nil t)))
244 (if (assoc type selection)
245 (cdr (assoc type selection))
247 (or image-type wl-demo-display-logo)))
248 (logo (if (cond ((featurep 'xemacs)
249 (device-on-window-system-p))
253 (cond ((and (eq 'xbm wl-demo-display-logo)
254 (get 'wl-logo-xbm 'width))
256 (wl-demo-display-logo
257 (cond ((get 'wl-logo-xpm 'width)
259 ((get 'wl-logo-xbm 'width)
265 (let ((lw (get logo 'width))
266 (lh (get logo 'height))
267 (image (get logo 'image)))
270 (if (eq 'wl-logo-xbm logo)
271 (set-glyph-face image 'wl-highlight-logo-face))
272 (setq rest (- wh 1 (/ (+ (* lh wh) (window-pixel-height) -1)
273 (window-pixel-height))))
274 (insert-char ?\ (max 0 (/ (- (* (window-pixel-width) (1+ ww))
276 2 (window-pixel-width))))
277 (set-extent-end-glyph (make-extent (point) (point)) image))
279 (if (eq 'wl-logo-xbm logo)
280 (let ((bg (face-background 'wl-highlight-logo-face))
281 (fg (face-foreground 'wl-highlight-logo-face)))
283 (plist-put (cdr image) ':background bg))
285 (plist-put (cdr image) ':foreground fg))))
286 (setq rest (/ (- (* wh (frame-char-height)) lh 1)
287 (frame-char-height)))
288 (insert (propertize " " 'display
289 (list 'space ':align-to
290 (max 0 (/ (- (* (frame-char-width)
292 2 (frame-char-width))))))
293 (insert-image image))
296 (put-text-property (point-min) (point) 'face
297 'wl-highlight-logo-face)
298 (setq rest (/ (- (* 16 wh) lh 8) 16))
299 (indent-rigidly (point-min) (point-max)
300 (/ (- (* 8 (1+ ww)) lw) 16))))
301 (goto-char (point-min)))
302 (insert (or wl-logo-ascii (product-name (product-find 'wl-version))))
303 (put-text-property (point-min) (point) 'face 'wl-highlight-logo-face)
304 (setq rest (- wh (count-lines (point-min) (point)) 1))
305 (let ((lw (current-column))
306 (lh (count-lines (point-min) (point))))
307 (while (progn (beginning-of-line) (not (bobp)))
309 (setq lw (max lw (current-column))))
310 (indent-rigidly (point) (point-max) (max 0 (/ (- ww lw) 2)))))
311 (insert-char ?\n (max 0 (/ (- rest 4) 2)))
312 (goto-char (point-max))
314 (let ((start (point))
315 (text (format (cond ((<= rest 2)
316 "version %s - \"%s\"\n%s")
318 "version %s - \"%s\"\n\n%s")
320 "\nversion %s - \"%s\"\n\n%s"))
321 (product-version-string (product-find 'wl-version))
322 (product-code-name (product-find 'wl-version))
323 wl-demo-copyright-notice)))
325 (let ((bg (face-background 'wl-highlight-demo-face))
326 (fg (face-foreground 'wl-highlight-demo-face)))
327 (insert (propertize text
328 'face (nconc '(variable-pitch :slant oblique)
330 (list ':background bg))
332 (list ':foreground fg))))))
334 (put-text-property start (point) 'face 'wl-highlight-demo-face))
335 (let ((fill-column ww))
336 (center-region start (point))))
337 (goto-char (point-min))
338 (sit-for (if (featurep 'lisp-float-type) (/ (float 5) (float 10)) 1))
342 (product-provide (provide 'wl-demo) (require 'wl-version))
344 ;;; wl-demo.el ends here