1;;; navi2ch-splash.el --- Navigator for 2ch for Emacsen -*- coding: iso-2022-7bit; -*-
2
3;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Navi2ch
4;; Project
5
6;; Author: UEYAMA Rui <rui314159@users.sourceforge.net>
7;; 110 $B$NL>L5$7$5$s(B http://pc.2ch.net/test/read.cgi/unix/1013457056/110
8;;
9;; Keywords: network, 2ch
10
11;; This file is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation; either version 2, or (at your option)
14;; any later version.
15
16;; This file is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs; see the file COPYING.  If not, write to
23;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24;; Boston, MA 02111-1307, USA.
25
26;;; Commentary:
27
28;; $B%3!<%I$O!"(BWanderlust $B$N(B wl-demo.el $B$+$i$b$i$$$^$7$?!#$[$H$s$I(B
29;; $BJQ$o$C$F$J$$$G$9!#(B
30;;
31;;; wl-demo.el --- Opening demo on Wanderlust
32;;
33;; Copyright (C) 1998,1999,2000,2001 Yuuichi Teranishi <teranisi@gohome.org>
34;; Copyright (C) 2000,2001 Katsumi Yamaoka <yamaoka@jpl.org>
35
36;;; Code:
37(provide 'navi2ch-splash)
38(defconst navi2ch-splash-ident
39  "$Id$")
40
41(eval-when-compile
42  (require 'cl))
43(require 'navi2ch-vars)
44(require 'navi2ch-face)
45(require 'navi2ch-util)
46(require 'navi2ch-version)
47
48(defconst navi2ch-splash-copyright-notice
49  (concat "Copyright (C) 2000-2008  Navi2ch Project.
50This software includes some fragments from other softwares;
51Copyright (C) 1993-2000 Free Software Foundation, Inc.
52Copyright (C) 1998-2001 Yuuichi Teranishi <teranisi@gohome.org>
53Copyright (C) 2000,2001 Katsumi Yamaoka <yamaoka@jpl.org>\n"
54	  (substitute-command-keys "
55Navi2ch comes with ABSOLUTELY NO WARRANTY; type \\[describe-no-warranty] for full details."))
56  "A declaration of the copyright on Navi2ch.")
57
58(defconst navi2ch-splash-logo-image-name
59  "navi2ch-logo"
60  "Basename of the logo file.")
61
62;; $B$3$l$O$5$9$,$K:9$7$+$($J$$$H!D!D(B
63(defvar navi2ch-splash-logo-ascii "\
64$B!!!!"#!!!!!!!!"#"#!!!!!!!!!!!!!!!!!!!!!!!!!!"#"#!!!!!!!!"#!!!!(B
65$B!!"#!!!!!!!!"#!!!!!!!!!!!!!!"#"#"#"#!!!!!!!!!!!!"#!!!!!!!!"#!!(B
66$B"#!!!!!!!!!!!!!!!!!!!!!!!!!!"#!!!!"#!!!!!!!!!!!!!!!!!!!!!!!!"#(B
67$B"#!!!!!!!!!!!!!!!!!!!!!!!!!!"#!!!!"#!!!!!!!!!!!!!!!!!!!!!!!!"#(B
68$B"#!!!!!!!!!!!!!!!!!!!!!!!!!!"#!!!!"#!!!!!!!!!!!!!!!!!!!!!!!!"#(B
69$B"#!!!!!!!!!!!!!!!!!!!!!!!!!!"#!!!!"#!!!!!!!!!!!!!!!!!!!!!!!!"#(B
70$B"#!!!!!!!!!!!!!!!!!!!!!!!!"#!!!!!!"#!!!!!!!!!!!!!!!!!!!!!!!!"#(B
71$B!!"#!!!!!!!!!!!!!!!!!!!!"#"#"#"#"#"#"#!!!!!!!!!!!!!!!!!!!!"#!!(B
72$B!!!!"#!!!!!!!!!!!!!!!!!!"#!!!!!!!!!!"#!!!!!!!!!!!!!!!!!!"#!!!!(B
73
74                            Navi2ch"
75  "Ascii picture used to splash the startup screen.")
76
77(eval-when-compile
78  (when navi2ch-on-emacs21
79    ;; `display-images-p' has not been available in Emacs versions
80    ;; prior to Emacs 21.0.105.
81    (navi2ch-defalias-maybe 'display-images-p 'display-graphic-p)))
82
83;; Avoid byte compile warnings.
84(eval-when-compile
85  (autoload 'bitmap-insert-xbm-file "bitmap" nil t)
86  (autoload 'create-image "image")
87  (autoload 'device-on-window-system-p "device")
88  (autoload 'image-type-available-p "image")
89  (autoload 'insert-image "image")
90  (autoload 'make-glyph "glyphs")
91  (autoload 'set-glyph-face "glyphs")
92  (autoload 'set-specifier "specifier")
93  (navi2ch-defalias-maybe 'frame-char-height 'ignore)
94  (navi2ch-defalias-maybe 'frame-char-width 'ignore)
95  (navi2ch-defalias-maybe 'glyph-height 'ignore)
96  (navi2ch-defalias-maybe 'glyph-width 'ignore)
97  (navi2ch-defalias-maybe 'image-size 'ignore)
98  (navi2ch-defalias-maybe 'make-extent 'ignore)
99  (navi2ch-defalias-maybe 'set-extent-end-glyph 'ignore)
100  (navi2ch-defalias-maybe 'window-pixel-height 'ignore)
101  (navi2ch-defalias-maybe 'window-pixel-width 'ignore))
102
103(defvar navi2ch-splash-bitmap-mule-available-p 'unknown
104  "Internal variable to say whether the BITMAP-MULE package is available.")
105
106(defun navi2ch-splash-image-type-alist ()
107  "Return an alist of available logo image types on the current frame."
108  (if (or (and (featurep 'xemacs)
109	       (device-on-window-system-p))
110	  window-system)
111      (let ((xpm
112             (when (or (and (featurep 'xemacs)
113                            (featurep 'xpm))
114                       (and navi2ch-on-emacs21
115                            (display-images-p)
116                            (image-type-available-p 'xpm)))
117               '("xpm" . xpm)))
118	    (xbm
119             (when (or (featurep 'xemacs)
120                       (and navi2ch-on-emacs21
121                            (display-images-p)
122                            (image-type-available-p 'xbm))
123                       (eq t navi2ch-splash-bitmap-mule-available-p)
124                       (and (eq 'unknown navi2ch-splash-bitmap-mule-available-p)
125                            (or (featurep 'bitmap)
126                                (locate-library "bitmap"))
127                            (setq navi2ch-splash-bitmap-mule-available-p t)))
128               '("xbm" . xbm)))
129	    (bitmap
130             (when (and (not (featurep 'xemacs))
131                        (or (eq t navi2ch-splash-bitmap-mule-available-p)
132                            (and (eq 'unknown navi2ch-splash-bitmap-mule-available-p)
133                                 (or (featurep 'bitmap)
134                                     (locate-library "bitmap"))
135                                 (setq navi2ch-splash-bitmap-mule-available-p t))))
136               '("bitmap" . bitmap))))
137	(if (and navi2ch-on-emacs21
138		 (image-type-available-p 'xbm))
139	    ;; Prefer xbm rather than bitmap on Emacs 21.
140	    (delq nil (list xbm bitmap xpm '("ascii")))
141	  (delq nil (list bitmap xbm xpm '("ascii")))))
142    '(("ascii"))))
143
144(defun navi2ch-splash-insert-image (image-type)
145  "Insert a logo image at the point and position it to be centered.
146IMAGE-TYPE specifies what a type of image should be displayed.
147Return a number of lines that an image occupies in the buffer."
148  (let ((file (cond ((eq 'xpm image-type)
149		     (concat navi2ch-splash-logo-image-name ".xpm"))
150		    ((eq 'bitmap image-type)
151		     (concat navi2ch-splash-logo-image-name ".img"))
152		    ((eq 'xbm image-type)
153		     (concat navi2ch-splash-logo-image-name ".xbm"))))
154	image width height)
155    (when (featurep 'xemacs)
156      (when (boundp 'default-gutter-visible-p)
157	(set-specifier (symbol-value 'default-gutter-visible-p)
158		       nil (current-buffer)))
159      (set-specifier (symbol-value 'scrollbar-height) 0 (current-buffer))
160      (set-specifier (symbol-value 'scrollbar-width) 0 (current-buffer)))
161    (if (and file
162	     (if (and navi2ch-icon-directory
163		      (file-directory-p navi2ch-icon-directory))
164		 (setq file (expand-file-name file navi2ch-icon-directory))
165	       (message "You have to specify the value of `navi2ch-icon-directory'")
166	       nil)
167	     (if (file-exists-p file)
168		 (if (file-readable-p file)
169		     t
170		   (message "Permission denied: %s" file)
171		   nil)
172	       (message "File not found: %s" file)
173	       nil))
174	(progn
175	  (cond ((featurep 'xemacs)
176		 (setq width (window-pixel-width)
177		       height (window-pixel-height)
178		       image (make-glyph (vector image-type ':file file)))
179		 (when (eq 'xbm image-type)
180		   (set-glyph-face image 'navi2ch-splash-screen-face))
181		 (insert-char ?\  (max 0 (/ (+ (* (- width (glyph-width image))
182						  (window-width)) width)
183					    (* 2 width))))
184		 (set-extent-end-glyph (make-extent (point) (point)) image)
185		 (insert "\n")
186		 (/ (+ (* 2 (glyph-height image) (window-height)) height)
187		    (* 2 height)))
188		((and navi2ch-on-emacs21
189		      (or (eq 'xpm image-type)
190			  (and (eq 'xbm image-type)
191			       (image-type-available-p 'xbm))))
192		 ;; Use the new redisplay engine on Emacs 21.
193		 (setq image (create-image file image-type)
194		       width (image-size image)
195		       height (cdr width)
196		       width (car width))
197		 (when (eq 'xbm image-type)
198		   (let ((bg (face-background 'navi2ch-splash-screen-face))
199			 (fg (face-foreground 'navi2ch-splash-screen-face)))
200		     (when (stringp bg)
201		       (plist-put (cdr image) ':background bg))
202		     (when (stringp fg)
203		       (plist-put (cdr image) ':foreground fg))))
204		 (insert (navi2ch-propertize " " 'display
205					     (list 'space ':align-to
206						   (max 0 (round (- (window-width)
207								    width)
208								 2)))))
209		 (insert-image image)
210		 (insert "\n")
211		 (round height))
212		((eq 'bitmap image-type)
213		 ;; Use ready-composed bitmap image.
214		 (require 'bitmap)
215		 (let ((coding-system-for-read 'iso-2022-7bit))
216		   (insert-file-contents file))
217		 (goto-char (point-max))
218		 (unless (bolp)
219		   (insert "\n"))
220		 (setq width 0)
221		 (while (progn
222			  (end-of-line 0)
223			  (not (bobp)))
224		   (setq width (max width (current-column))))
225		 ;; Emacs 21.1 would fail to decode composite chars
226		 ;; if it has been built without fixing coding.c.
227		 (when (and navi2ch-on-emacs21
228			    (>= width 80))
229		   (erase-buffer)
230		   (let ((coding-system-for-read 'raw-text))
231		     (insert-file-contents file))
232		   (goto-char (point-max))
233		   (unless (bolp)
234		     (insert "\n"))
235		   (setq width 0)
236		   (while (progn
237			    (end-of-line 0)
238			    (not (bobp)))
239		     ;; Decode bitmap data line by line.
240		     (decode-coding-region (navi2ch-line-beginning-position)
241					   (point)
242					   'iso-2022-7bit)
243		     (setq width (max width (current-column)))))
244		 (indent-rigidly (point-min) (point-max)
245				 (max 0 (/ (1+ (- (window-width) width)) 2)))
246		 (put-text-property (point-min) (point-max)
247				    'face 'navi2ch-splash-screen-face)
248		 (count-lines (point-min) (goto-char (point-max))))
249		((eq 'xbm image-type)
250		 (message "Composing a bitmap image...")
251		 (require 'bitmap)
252		 (bitmap-insert-xbm-file file)
253		 (backward-char)
254		 (indent-rigidly (point-min) (point-max)
255				 (max 0 (/ (1+ (- (window-width)
256						  (current-column)))
257					   2)))
258		 (put-text-property (point-min) (point-max)
259				    'face 'navi2ch-splash-screen-face)
260		 (message "Composing a bitmap image...done")
261		 (count-lines (point-min) (goto-char (point-max))))))
262      (insert navi2ch-splash-logo-ascii)
263      (put-text-property (point-min) (point) 'face 'navi2ch-splash-screen-face)
264      (unless (bolp)
265	(insert "\n"))
266      (setq width 0)
267      (while (progn
268	       (end-of-line 0)
269	       (not (bobp)))
270	(setq width (max width (current-column))))
271      (indent-rigidly (point-min) (point-max)
272		      (max 0 (/ (1+ (- (window-width) width)) 2)))
273      (count-lines (point-min) (goto-char (point-max))))))
274
275(defun navi2ch-splash-insert-text (height)
276  "Insert a version and the copyright message after a logo image.
277HEIGHT should be a number of lines that an image occupies in the buffer."
278  (let* ((height (- (window-height) height 1))
279	 (notice-height (length (split-string navi2ch-splash-copyright-notice
280					      "\n")))
281	 (text (format (cond ((<= (- height notice-height) 1)
282			      "version %s - \"%s\"\n%s")
283			     ((eq (- height notice-height) 2)
284			      "version %s - \"%s\"\n\n%s")
285			     (t
286			      "\nversion %s - \"%s\"\n\n%s"))
287                       navi2ch-version
288                       "$B%*%^%(%b%J!<(B"
289		       navi2ch-splash-copyright-notice))
290	 (text-height (length (split-string text "\n")))
291	 start)
292    (goto-char (point-min))
293    (insert-char ?\n (max 0 (/ (- height text-height) 2)))
294    (setq start (goto-char (point-max)))
295    (if navi2ch-on-emacs21
296	(let ((bg (face-background 'navi2ch-splash-screen-face))
297	      (fg (face-foreground 'navi2ch-splash-screen-face)))
298	  (insert (navi2ch-propertize text
299				      'face (nconc '(variable-pitch :slant oblique)
300						   (when (stringp bg)
301						     (list ':background bg))
302						   (when (stringp fg)
303						     (list ':foreground fg))))))
304      (insert text)
305      (put-text-property start (point) 'face 'navi2ch-splash-screen-face))
306    (let ((fill-column (window-width)))
307      (center-region start (point)))))
308
309;; shut up XEmacs warnings
310(eval-when-compile
311  (defvar default-enable-multibyte-characters)
312  (defvar default-mc-flag)
313  (defvar default-line-spacing))
314
315(defun navi2ch-splash (&optional image-type)
316  "Demo on the startup screen.
317IMAGE-TYPE should be a symbol which overrides the variable
318`navi2ch-splash-display-logo'.  It will prompt user for the type
319of image when it is called interactively with a prefix argument."
320  (interactive "P")
321  (let ((selection (navi2ch-splash-image-type-alist))
322	type)
323    (if (and image-type (interactive-p))
324	(setq type (completing-read "Image type: " selection nil t)
325	      image-type (when (assoc type selection)
326			   (cdr (assoc type selection))))
327      (if (setq type (assoc (format "%s" (or image-type navi2ch-splash-display-logo))
328			    selection))
329	  (setq image-type (cdr type))
330	(setq image-type (when navi2ch-splash-display-logo
331			   (cdr (car selection)))))))
332  (let ((buffer (let ((default-enable-multibyte-characters t)
333		      (default-mc-flag t)
334		      (default-line-spacing 0))
335		  (get-buffer-create "*navi2ch splash*"))))
336    (switch-to-buffer buffer)
337    (setq buffer-read-only nil)
338    (buffer-disable-undo)
339    (erase-buffer)
340    (setq truncate-lines t
341	  tab-width 8)
342    (set (make-local-variable 'tab-stop-list)
343	 '(8 16 24 32 40 48 56 64 72 80 88 96 104 112 120))
344    (navi2ch-splash-insert-text (navi2ch-splash-insert-image image-type))
345    (set-buffer-modified-p nil)
346    (goto-char (point-min))
347    (sit-for (if (featurep 'lisp-float-type)
348		 (/ (float 5) (float 10))
349	       1))
350    buffer))
351
352;;; navi2ch-splash.el ends here
353