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.
31 (defconst wl-demo-copyright-notice
32 "Copyright (C) 1998-2004 Yuuichi Teranishi <teranisi@gohome.org>"
33 "A declaration of the copyright on Wanderlust.")
40 (require 'wl-highlight)
42 (defun wl-demo-icon-name ()
43 "A function to determine logo file name."
45 (dolist (pair wl-demo-icon-name-alist)
46 (when (eval (car pair))
47 (throw 'found (eval (cdr pair)))))))
49 (defvar wl-logo-ascii "\
51 oo$$$ o$$ o$$$\"\"\"\"\"\"$$$$$o
52 $$$$$$\" o$$$\" o$\"\" \"$$$
56 o$$ oo$\" \"$$$o $ o$$
57 $$$$\"\" \"$$oo$ o o$\"
58 \"$$o \"$$$o oooo$\"\"
62 Yet Another Message Interface On Emacsen"
63 "Ascii picture used to splash the startup screen.")
67 ;; `display-images-p' has not been available in Emacs versions
68 ;; prior to Emacs 21.0.105.
69 (defalias-maybe 'display-images-p 'display-graphic-p)))
71 ;; Avoid byte compile warnings.
73 (autoload 'bitmap-insert-xbm-file "bitmap" nil t)
74 (autoload 'create-image "image")
75 (autoload 'device-on-window-system-p "device")
76 (autoload 'image-type-available-p "image")
77 (autoload 'insert-image "image")
78 (autoload 'make-glyph "glyphs")
79 (autoload 'set-glyph-face "glyphs")
80 (autoload 'set-specifier "specifier")
81 (defalias-maybe 'face-background-name 'ignore)
82 (defalias-maybe 'frame-char-height 'ignore)
83 (defalias-maybe 'frame-char-width 'ignore)
84 (defalias-maybe 'glyph-height 'ignore)
85 (defalias-maybe 'glyph-width 'ignore)
86 (defalias-maybe 'image-size 'ignore)
87 (defalias-maybe 'make-extent 'ignore)
88 (defalias-maybe 'propertize 'ignore)
89 (defalias-maybe 'set-extent-end-glyph 'ignore)
90 (defalias-maybe 'window-pixel-height 'ignore)
91 (defalias-maybe 'window-pixel-width 'ignore))
93 (defvar wl-demo-bitmap-mule-available-p 'unknown
94 "Internal variable to say whether the BITMAP-MULE package is available.")
96 (defun wl-demo-image-type-alist ()
97 "Return an alist of available logo image types on the current frame."
98 (if (or (and (featurep 'xemacs)
99 (device-on-window-system-p))
102 (when (or (and (featurep 'xemacs)
106 (image-type-available-p 'xpm)))
109 (when (or (featurep 'xemacs)
112 (image-type-available-p 'xbm))
113 (eq t wl-demo-bitmap-mule-available-p)
114 (and (eq 'unknown wl-demo-bitmap-mule-available-p)
115 (module-installed-p 'bitmap)
116 (setq wl-demo-bitmap-mule-available-p t)))
119 (when (and (not (featurep 'xemacs))
120 (or (eq t wl-demo-bitmap-mule-available-p)
121 (and (eq 'unknown wl-demo-bitmap-mule-available-p)
122 (module-installed-p 'bitmap)
123 (setq wl-demo-bitmap-mule-available-p t))))
124 '("bitmap" . bitmap))))
125 (if (and wl-on-emacs21
126 (image-type-available-p 'xbm))
127 ;; Prefer xbm rather than bitmap on Emacs 21.
128 (delq nil (list xpm xbm bitmap '("ascii")))
129 (delq nil (list xpm bitmap xbm '("ascii")))))
132 (defun wl-demo-image-filter (file type)
133 "Get filtered image data.
134 FILE is the image file name.
135 TYPE is the filter function."
136 (let ((filter (catch 'found
137 (dolist (pair wl-demo-image-filter-alist)
138 (when (eq (car pair) type)
139 (throw 'found (cdr pair)))))))
141 (set-buffer-multibyte nil)
142 (insert-file-contents file)
143 (goto-char (point-min))
148 (defun wl-demo-insert-image (image-type)
149 "Insert a logo image at the point and position it to be centered.
150 IMAGE-TYPE specifies what a type of image should be displayed.
151 Return a number of lines that an image occupies in the buffer."
152 (let ((file (cond ((eq 'xpm image-type)
153 (concat (wl-demo-icon-name) ".xpm"))
154 ((eq 'bitmap image-type)
155 (concat (wl-demo-icon-name) ".img"))
156 ((eq 'xbm image-type)
157 (concat (wl-demo-icon-name) ".xbm"))))
159 (when (featurep 'xemacs)
160 (when (boundp 'default-gutter-visible-p)
161 (set-specifier (symbol-value 'default-gutter-visible-p)
162 nil (current-buffer)))
163 (when (featurep 'scrollbar)
164 (set-specifier (symbol-value 'scrollbar-height) 0 (current-buffer))
165 (set-specifier (symbol-value 'scrollbar-width) 0 (current-buffer))))
167 (if (and wl-icon-directory
168 (file-directory-p wl-icon-directory))
169 (setq file (expand-file-name file wl-icon-directory))
170 (message "You have to specify the value of `wl-icon-directory'")
172 (if (file-exists-p file)
173 (if (file-readable-p file)
175 (message "Permission denied: %s" file)
177 (message "File not found: %s" file)
180 (cond ((featurep 'xemacs)
181 (setq width (window-pixel-width)
182 height (window-pixel-height)
183 image (make-glyph (vector image-type ':data
184 (wl-demo-image-filter
186 (when (eq 'xbm image-type)
187 (set-glyph-face image 'wl-highlight-logo-face))
188 (insert-char ?\ (max 0 (/ (+ (* (- width (glyph-width image))
189 (window-width)) width)
191 (set-extent-end-glyph (make-extent (point) (point)) image)
193 (/ (+ (* 2 (glyph-height image) (window-height)) height)
196 (or (eq 'xpm image-type)
197 (and (eq 'xbm image-type)
198 (image-type-available-p 'xbm))))
199 ;; Use the new redisplay engine on Emacs 21.
200 (setq image (create-image (wl-demo-image-filter file
203 width (image-size image)
206 (when (eq 'xbm image-type)
207 (let ((bg (face-background 'wl-highlight-logo-face))
208 (fg (face-foreground 'wl-highlight-logo-face)))
210 (plist-put (cdr image) ':background bg))
212 (plist-put (cdr image) ':foreground fg))))
213 (insert (propertize " " 'display
214 (list 'space ':align-to
215 (max 0 (round (- (window-width)
221 ((eq 'bitmap image-type)
222 ;; Use ready-composed bitmap image.
224 (let ((coding-system-for-read 'iso-2022-7bit)
225 (input-coding-system '*iso-2022-jp*))
226 (insert-file-contents file))
227 (goto-char (point-max))
234 (setq width (max width (current-column))))
235 ;; Emacs 21.1 would fail to decode composite chars
236 ;; if it has been built without fixing coding.c.
237 (when (and wl-on-emacs21
240 (let ((coding-system-for-read 'raw-text))
241 (insert-file-contents file))
242 (goto-char (point-max))
249 ;; Decode bitmap data line by line.
250 (decode-coding-region (line-beginning-position)
253 (setq width (max width (current-column)))))
254 (indent-rigidly (point-min) (point-max)
255 (max 0 (/ (1+ (- (window-width) width)) 2)))
256 (put-text-property (point-min) (point-max)
257 'face 'wl-highlight-logo-face)
258 (count-lines (point-min) (goto-char (point-max))))
259 ((eq 'xbm image-type)
260 (message "Composing a bitmap image...")
262 (bitmap-insert-xbm-file file)
264 (indent-rigidly (point-min) (point-max)
265 (max 0 (/ (1+ (- (window-width)
268 (put-text-property (point-min) (point-max)
269 'face 'wl-highlight-logo-face)
270 (message "Composing a bitmap image...done")
271 (count-lines (point-min) (goto-char (point-max))))))
272 (insert wl-logo-ascii)
273 (put-text-property (point-min) (point) 'face 'wl-highlight-logo-face)
280 (setq width (max width (current-column))))
281 (indent-rigidly (point-min) (point-max)
282 (max 0 (/ (1+ (- (window-width) width)) 2)))
283 (count-lines (point-min) (goto-char (point-max))))))
285 (defun wl-demo-setup-properties ()
286 "Set up properties of the demo buffer."
289 ;; I think there should be a better way to set face background
290 ;; for the buffer only. But I don't know how to do it on Emacs21.
291 (goto-char (point-max))
292 (dotimes (i (- (window-height)
293 (count-lines (point-min) (point))))
295 (let ((fg (face-foreground 'wl-highlight-demo-face))
296 (bg (face-background 'wl-highlight-demo-face)))
297 (put-text-property (point-min) (point-max)
299 (nconc '(variable-pitch :slant oblique)
301 (list ':background bg))
303 (list ':foreground fg))))))
305 (set-face-background 'default
306 (face-background-name 'wl-highlight-demo-face)
309 (defun wl-demo-insert-text (height)
310 "Insert a version and the copyright message after a logo image. HEIGHT
311 should be a number of lines that an image occupies in the buffer."
312 (let* ((height (- (window-height) height 1))
313 (text (format (cond ((<= height 2)
314 "version %s - \"%s\"\n%s")
316 "version %s - \"%s\"\n\n%s")
318 "\nversion %s - \"%s\"\n\n%s"))
319 (product-version-string (product-find 'wl-version))
320 (product-code-name (product-find 'wl-version))
321 wl-demo-copyright-notice))
323 (goto-char (point-min))
324 (insert-char ?\n (max 0 (/ (- height 4) 2)))
325 (setq start (goto-char (point-max)))
327 (put-text-property start (point) 'face 'wl-highlight-demo-face)
328 (let ((fill-column (window-width)))
329 (center-region start (point)))))
331 (defun wl-demo (&optional image-type)
332 "Demo on the startup screen. IMAGE-TYPE should be a symbol which
333 overrides the variable `wl-demo-display-logo'. It will prompt user
334 for the type of image when it is called interactively with a prefix
337 (let ((selection (wl-demo-image-type-alist))
339 (if (and image-type (interactive-p))
340 (setq type (completing-read "Image type: " selection nil t)
341 image-type (when (assoc type selection)
342 (cdr (assoc type selection))))
343 (if (setq type (assoc (format "%s" (or image-type wl-demo-display-logo))
345 (setq image-type (cdr type))
346 (setq image-type (when wl-demo-display-logo
347 (cdr (car selection)))))))
348 (let ((buffer (let ((default-enable-multibyte-characters t)
350 (default-line-spacing 0))
351 (get-buffer-create "*WL Demo*"))))
352 (switch-to-buffer buffer)
353 (setq buffer-read-only nil)
354 (buffer-disable-undo)
356 (setq truncate-lines t
358 (set (make-local-variable 'tab-stop-list)
359 '(8 16 24 32 40 48 56 64 72 80 88 96 104 112 120))
360 (wl-demo-insert-text (wl-demo-insert-image image-type))
361 (wl-demo-setup-properties)
362 (set-buffer-modified-p nil)
363 (goto-char (point-min))
364 (sit-for (if (featurep 'lisp-float-type)
365 (/ (float 5) (float 10))
370 (product-provide (provide 'wl-demo) (require 'wl-version))
372 ;;; wl-demo.el ends here