1 ;;; wl-demo.el -- Opening demo on Wanderlust.
3 ;; Copyright (C) 1998,1999,2000,2001 Yuuichi Teranishi <teranisi@gohome.org>
4 ;; Copyright (C) 2000,2001 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 'window-pixel-height 'ignore)
64 (defalias-maybe 'window-pixel-width 'ignore))
70 (defvar wl-logo-ascii " o$ oo$$$$$$ooo
71 oo$$$ o$$ o$$$\"\"\"\"\"\"$$$$$o
72 $$$$$$\" o$$$\" o$\"\" \"$$$
76 o$$ oo$\" \"$$$o $ o$$
77 $$$$\"\" \"$$oo$ o o$\"
78 \"$$o \"$$$o oooo$\"\"
82 Yet Another Message Interface On Emacsen")
85 (defmacro wl-demo-with-temp-file-buffer (file &rest forms)
86 "Create a temporary buffer, insert FILE's contents without
87 any conversions and evaluate FORMS there like `progn'."
89 (let ((coding-system-for-read 'binary)
90 (input-coding-system '*noconv*)
92 file-name-handler-alist
94 insert-file-contents-access-hook
95 insert-file-contents-post-hook
96 insert-file-contents-pre-hook
97 interpreter-mode-alist)
98 (insert-file-contents (, file))
100 (put 'wl-demo-with-temp-file-buffer 'lisp-indent-function 1))
103 (defmacro wl-logo-xpm ()
104 ;; (WIDTH HEIGHT DATA)
105 (let ((file (expand-file-name (concat wl-demo-icon-name ".xpm")
107 (if (file-exists-p file)
108 (wl-demo-with-temp-file-buffer file
110 (concat "\"[\t ]*\\([0-9]+\\)[\t ]+\\([0-9]+\\)"
111 "[\t ]+[0-9]+[\t ]+[0-9]+[\t ]*\""))
113 (string-to-number (match-string 1))
114 (string-to-number (match-string 2))
116 (defmacro wl-logo-xbm ()
117 ;; (WIDTH HEIGHT DATA)
118 (let ((file (expand-file-name (concat wl-demo-icon-name ".xbm")
120 (if (file-exists-p file)
121 (wl-demo-with-temp-file-buffer file
122 (let ((case-fold-search t)
124 (search-forward "width")
125 (setq width (read (current-buffer)))
126 (goto-char (point-min))
127 (search-forward "height")
128 (setq height (read (current-buffer)))
129 (goto-char (point-min))
131 (delete-region (point-min) (point))
132 (while (re-search-forward "[^0-9a-fx]+" nil t)
134 (goto-char (point-min))
136 (while (search-forward "0x" nil t)
137 (replace-match "\\\\x"))
138 (goto-char (point-max))
140 (goto-char (point-min))
141 (list 'list width height (read (current-buffer))))))))
142 (defmacro wl-logo-bitmap ()
143 ;; (DECODED-P . DATA)
144 (let ((file (expand-file-name (concat wl-demo-icon-name ".xbm")
146 (if (file-exists-p file)
147 (if (condition-case nil
150 (list 'cons t (bitmap-decode-xbm (bitmap-read-xbm-file file)))
151 (wl-demo-with-temp-file-buffer file
152 (list 'cons nil (buffer-string))))))))
154 (let ((xpm (wl-logo-xpm)))
156 (or (and (featurep 'xemacs)
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)))
168 (let ((image-types '(xpm)))
169 (create-image (nth 2 xpm) 'xpm t))
171 (put 'wl-logo-xpm 'width nil)
172 (put 'wl-logo-xpm 'height nil)
176 (let ((xbm (wl-logo-xbm)))
177 (setq width (car xbm)
180 (or (featurep 'xemacs)
185 (put 'wl-logo-xbm 'width width)
186 (put 'wl-logo-xbm 'height height)
187 (put 'wl-logo-xbm 'image
188 (if (featurep 'xemacs)
189 (make-glyph (vector 'xbm ':data xbm))
191 (let ((image-types '(xbm)))
192 (create-image (nth 2 xbm) 'xbm t
193 ':width (car xbm) ':height (nth 1 xbm)))
195 (put 'wl-logo-xbm 'width nil)
196 (put 'wl-logo-xbm 'height nil)
199 (not (featurep 'xemacs))
204 (put 'wl-logo-bitmap 'width width)
205 (put 'wl-logo-bitmap 'height height)
206 (let ((default-enable-multibyte-characters t)
209 (let* ((bm (wl-logo-bitmap))
214 (bitmap-decode-xbm (bitmap-read-xbm-buffer
219 (insert (bitmap-compose (aref cmp 0)))
221 (insert "\n" (bitmap-compose (aref cmp i)))
223 (put 'wl-logo-bitmap 'image (buffer-string))))))))
226 (defmacro wl-demo-image-type-alist ()
227 '(append (if (and (get 'wl-logo-xpm 'width)
228 (or (and (featurep 'xemacs)
230 (device-on-window-system-p))
233 (image-type-available-p 'xpm))))
235 (if (and (get 'wl-logo-xbm 'width)
236 (or (and (featurep 'xemacs)
237 (device-on-window-system-p))
240 (image-type-available-p 'xbm))))
242 (if (and (get 'wl-logo-bitmap 'width)
243 (not (featurep 'xemacs))
246 '(("bitmap" . bitmap)))
249 (defun wl-demo (&optional image-type)
250 "Demo on the startup screen.
251 Optional IMAGE-TYPE overrides the variable `wl-demo-display-logo'."
253 (let ((selection (wl-demo-image-type-alist))
255 (if (and image-type (interactive-p))
256 (setq type (completing-read "Image type: " selection nil t)
257 image-type (if (assoc type selection)
258 (cdr (assoc type selection))))
259 (if (setq type (assoc (format "%s" (or image-type wl-demo-display-logo))
261 (setq image-type (cdr type))
262 (setq image-type (cdr (car selection))))))
264 (setq image-type (intern (format "wl-logo-%s" image-type))))
265 (let ((demo-buf (let ((default-enable-multibyte-characters t)
267 (default-line-spacing 0))
268 (get-buffer-create "*WL Demo*"))))
269 (switch-to-buffer demo-buf)
271 (setq truncate-lines t
273 (set (make-local-variable 'tab-stop-list)
274 '(8 16 24 32 40 48 56 64 72 80 88 96 104 112 120))
275 (cond ((featurep 'xemacs)
276 (if (device-on-window-system-p)
278 (if (boundp 'default-gutter-visible-p)
279 (set-specifier (symbol-value 'default-gutter-visible-p)
281 (set-specifier (symbol-value 'scrollbar-height) 0 demo-buf)
282 (set-specifier (symbol-value 'scrollbar-width) 0 demo-buf))))
285 (make-local-hook 'kill-buffer-hook)
286 (let* ((frame (selected-frame))
287 (toolbar (frame-parameter frame 'tool-bar-lines)))
288 (modify-frame-parameters frame '((tool-bar-lines)))
292 (let ((frame (, frame)))
293 (when (frame-live-p frame)
294 (, (if (and toolbar (> toolbar 0))
295 (` (modify-frame-parameters
296 frame '((tool-bar-lines . (, toolbar)))))))
298 'fringe (, (face-background 'fringe frame)) frame)))))
300 (set-face-background 'fringe (face-background 'default frame)
302 (let ((ww (window-width))
306 (let ((lw (get image-type 'width))
307 (lh (get image-type 'height))
308 (image (get image-type 'image)))
311 (if (eq 'wl-logo-xbm image-type)
312 (set-glyph-face image 'wl-highlight-logo-face))
313 (setq rest (- wh 1 (/ (+ (* lh wh) (window-pixel-height) -1)
314 (window-pixel-height))))
315 (insert-char ?\ (max 0 (/ (- (* (window-pixel-width) (1+ ww))
317 2 (window-pixel-width))))
318 (set-extent-end-glyph (make-extent (point) (point)) image))
321 (not (eq 'wl-logo-bitmap image-type)))
322 (if (eq 'wl-logo-xbm image-type)
323 (let ((bg (face-background 'wl-highlight-logo-face))
324 (fg (face-foreground 'wl-highlight-logo-face)))
326 (plist-put (cdr image) ':background bg))
328 (plist-put (cdr image) ':foreground fg))))
329 (setq rest (/ (- (* wh (frame-char-height)) lh 1)
330 (frame-char-height)))
331 (insert (propertize " " 'display
332 (list 'space ':align-to
333 (max 0 (/ (- (* (frame-char-width)
335 2 (frame-char-width))))))
336 (insert-image image))
339 (put-text-property (point-min) (point) 'face
340 'wl-highlight-logo-face)
341 (setq rest (/ (- (* 16 wh) lh 8) 16))
342 (indent-rigidly (point-min) (point-max)
343 (/ (- (* 8 (1+ ww)) lw) 16))))
344 (goto-char (point-min)))
345 (insert (or wl-logo-ascii (product-name (product-find 'wl-version))))
346 (put-text-property (point-min) (point) 'face 'wl-highlight-logo-face)
347 (setq rest (- wh (count-lines (point-min) (point)) 1))
348 (let ((lw (current-column))
349 (lh (count-lines (point-min) (point))))
350 (while (progn (beginning-of-line) (not (bobp)))
352 (setq lw (max lw (current-column))))
353 (indent-rigidly (point) (point-max) (max 0 (/ (- ww lw) 2)))))
354 (insert-char ?\n (max 0 (/ (- rest 4) 2)))
355 (goto-char (point-max))
357 (let ((start (point))
358 (text (format (cond ((<= rest 2)
359 "version %s - \"%s\"\n%s")
361 "version %s - \"%s\"\n\n%s")
363 "\nversion %s - \"%s\"\n\n%s"))
364 (product-version-string (product-find 'wl-version))
365 (product-code-name (product-find 'wl-version))
366 wl-demo-copyright-notice)))
368 (let ((bg (face-background 'wl-highlight-demo-face))
369 (fg (face-foreground 'wl-highlight-demo-face)))
370 (insert (propertize text
371 'face (nconc '(variable-pitch :slant oblique)
373 (list ':background bg))
375 (list ':foreground fg))))))
377 (put-text-property start (point) 'face 'wl-highlight-demo-face))
378 (let ((fill-column ww))
379 (center-region start (point))))
380 (goto-char (point-min))
381 (sit-for (if (featurep 'lisp-float-type) (/ (float 5) (float 10)) 1))
385 (product-provide (provide 'wl-demo) (require 'wl-version))
387 ;;; wl-demo.el ends here