+(defun wl-demo-insert-image (image-type)
+ "Insert a logo image at the point and position it to be centered.
+IMAGE-TYPE specifies what a type of image should be displayed.
+Return a number of lines that an image occupies in the buffer."
+ (let ((file (cond ((eq 'xpm image-type)
+ (concat (wl-demo-icon-name) ".xpm"))
+ ((eq 'bitmap image-type)
+ (concat (wl-demo-icon-name) ".img"))
+ ((eq 'xbm image-type)
+ (concat (wl-demo-icon-name) ".xbm"))))
+ image width height)
+ (when (featurep 'xemacs)
+ (when (boundp 'default-gutter-visible-p)
+ (set-specifier (symbol-value 'default-gutter-visible-p)
+ nil (current-buffer)))
+ (when (featurep 'scrollbar)
+ (set-specifier (symbol-value 'scrollbar-height) 0 (current-buffer))
+ (set-specifier (symbol-value 'scrollbar-width) 0 (current-buffer))))
+ (if (and file
+ (if (and wl-icon-directory
+ (file-directory-p wl-icon-directory))
+ (setq file (expand-file-name file wl-icon-directory))
+ (message "You have to specify the value of `wl-icon-directory'")
+ nil)
+ (if (file-exists-p file)
+ (if (file-readable-p file)
+ t
+ (message "Permission denied: %s" file)
+ nil)
+ (message "File not found: %s" file)
+ nil))
+ (progn
+ (cond ((featurep 'xemacs)
+ (setq width (window-pixel-width)
+ height (window-pixel-height)
+ image (make-glyph
+ (if (eq image-type 'xbm)
+ (vector image-type ':file file)
+ (vector image-type ':data
+ (wl-demo-image-filter
+ file image-type)))))
+ (when (eq 'xbm image-type)
+ (set-glyph-face image 'wl-highlight-logo-face))
+ (insert-char ?\ (max 0 (/ (+ (* (- width (glyph-width image))
+ (window-width)) width)
+ (* 2 width))))
+ (set-extent-end-glyph (make-extent (point) (point)) image)
+ (insert "\n")
+ (/ (+ (* 2 (glyph-height image) (window-height)) height)
+ (* 2 height)))
+ ((and wl-on-emacs21
+ (or (eq 'xpm image-type)
+ (and (eq 'xbm image-type)
+ (image-type-available-p 'xbm))))
+ ;; Use the new redisplay engine on Emacs 21.
+ (setq image (create-image (wl-demo-image-filter file
+ image-type)
+ image-type t)
+ width (image-size image)
+ height (cdr width)
+ width (car width))
+ (when (eq 'xbm image-type)
+ (let ((bg (face-background 'wl-highlight-demo-face))
+ (fg (face-foreground 'wl-highlight-logo-face)))
+ (when (stringp bg)
+ (plist-put (cdr image) ':background bg))
+ (when (stringp fg)
+ (plist-put (cdr image) ':foreground fg))))
+ (insert (propertize " " 'display
+ (list 'space ':align-to
+ (max 0 (round (- (window-width)
+ width)
+ 2)))))
+ (insert-image image)
+ (insert "\n")
+ (round height))
+ ((eq 'bitmap image-type)
+ ;; Use ready-composed bitmap image.
+ (require 'bitmap)
+ (let ((coding-system-for-read 'iso-2022-7bit)
+ (input-coding-system '*iso-2022-jp*))
+ (insert-file-contents file))
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert "\n"))
+
+ ;; Emacs 21.x may fail on computing the end of the
+ ;; column if there're bitmap characters.
+ ;;(setq width 0)
+ ;;(while (progn
+ ;; (end-of-line 0)
+ ;; (not (bobp)))
+ ;; (setq width (max width (current-column))))
+ (setq width 1024)
+ (while (progn
+ (end-of-line 0)
+ (not (bobp)))
+ (setq width (min width (current-column))))
+
+ ;; Emacs 21.1 would fail to decode composite chars
+ ;; if it has been built without fixing coding.c.
+ (when (and wl-on-emacs21
+ (>= width 80))
+ (erase-buffer)
+ (let ((coding-system-for-read 'raw-text))
+ (insert-file-contents file))
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert "\n"))
+ (setq width 0)
+ (while (progn
+ (end-of-line 0)
+ (not (bobp)))
+ ;; Decode bitmap data line by line.
+ (decode-coding-region (line-beginning-position)
+ (point)
+ 'iso-2022-7bit)
+ (setq width (max width (current-column)))))
+ (indent-rigidly (point-min) (point-max)
+ (max 0 (/ (1+ (- (window-width) width)) 2)))
+ (put-text-property (point-min) (point-max) 'fixed-width t)
+ (count-lines (point-min) (goto-char (point-max))))
+ ((eq 'xbm image-type)
+ (message "Composing a bitmap image...")
+ (require 'bitmap)
+ (bitmap-insert-xbm-file file)
+ (backward-char)
+ (indent-rigidly (point-min) (point-max)
+ (max 0 (/ (1+ (- (window-width)
+ (current-column)))
+ 2)))
+ (put-text-property (point-min) (point-max) 'fixed-width t)
+ (message "Composing a bitmap image...done")
+ (count-lines (point-min) (goto-char (point-max))))))
+ (insert wl-logo-ascii)
+ (unless (bolp)
+ (insert "\n"))
+ (setq width 0)
+ (while (progn
+ (end-of-line 0)
+ (not (bobp)))
+ (setq width (max width (current-column))))
+ (indent-rigidly (point-min) (point-max)
+ (max 0 (/ (1+ (- (window-width) width)) 2)))
+ (put-text-property (point-min) (point-max) 'fixed-width t)
+ (count-lines (point-min) (goto-char (point-max))))))
+
+(defun wl-demo-setup-properties ()
+ "Set up properties of the demo buffer."
+ (cond
+ (wl-on-emacs21
+ ;; I think there should be a better way to set face background
+ ;; for the buffer only. But I don't know how to do it on Emacs21.
+ (goto-char (point-max))
+ (dotimes (i (- (window-height)
+ (count-lines (point-min) (point))))
+ (insert ?\n))
+ (let* ((fg (face-foreground 'wl-highlight-demo-face))
+ (bg (face-background 'wl-highlight-demo-face))
+ (oblique (nconc '(variable-pitch :slant oblique)
+ (when (stringp bg)
+ (list ':background bg))
+ (when (stringp fg)
+ (list ':foreground fg))))
+ (start (text-property-any (point-min) (point-max) 'fixed-width t))
+ end)
+ (if start
+ (progn
+ (put-text-property (point-min) start 'face oblique)
+ (setq end (or (text-property-not-all start (point-max)
+ 'fixed-width t)
+ (point-max)))
+ (put-text-property start end 'face
+ (nconc '(wl-highlight-logo-face)
+ (when (stringp bg)
+ (list ':background bg))))
+ (put-text-property end (point-max) 'face oblique))
+ (put-text-property (point-min) (point-max) 'face oblique))))
+ ((and (featurep 'xemacs)
+ (face-background-name 'wl-highlight-demo-face))
+ (set-face-background 'default
+ (face-background-name 'wl-highlight-demo-face)
+ (current-buffer)))
+ (t
+ (goto-char (point-max))
+ (dotimes (i (- (window-height)
+ (count-lines (point-min) (point))))
+ (insert ?\n))
+ (let ((start (text-property-any (point-min) (point-max) 'fixed-width t))
+ end)
+ (if start
+ (progn
+ (put-text-property (point-min) start 'face 'wl-highlight-demo-face)
+ (setq end (or (text-property-not-all start (point-max)
+ 'fixed-width t)
+ (point-max)))
+ (put-text-property start end 'face 'wl-highlight-logo-face)
+ (put-text-property end (point-max) 'face 'wl-highlight-demo-face))
+ (put-text-property (point-min) (point-max)
+ 'face 'wl-highlight-demo-face))))))
+
+(defun wl-demo-insert-text (height)
+ "Insert a version and the copyright message after a logo image. HEIGHT
+should be a number of lines that an image occupies in the buffer."
+ (let* ((height (- (window-height) height 1))
+ (text (format (cond ((<= height 2)
+ "version %s - \"%s\"\n%s\n")
+ ((eq height 3)
+ "version %s - \"%s\"\n\n%s\n")
+ (t
+ "\nversion %s - \"%s\"\n\n%s\n"))
+ (product-version-string (product-find 'wl-version))
+ (product-code-name (product-find 'wl-version))
+ wl-demo-copyright-notice))
+ start)
+ (goto-char (point-min))
+ (insert-char ?\n (max 0 (/ (- height 4) 2)))
+ (setq start (goto-char (point-max)))
+ (insert text)
+ (let ((fill-column (window-width)))
+ (center-region start (point)))))