;;
;; This file is almost same as embeded one loaded by default.
;; This must be encoded in UTF-8.
;;
;; If user have a file "~/.ochusha/ochusha-init.scm", the file will be
;; loaded instead of the default one.
;;
;; $Id: ochusha-init.scm.en,v 1.1 2009/01/05 12:18:03 fuyu Exp $
;;

;; Descriptions below can be seen as examples.

;; The ochusha defines a set of constants to represent `color's and
;; use especially for coloring threadlists.  These constants actually are
;; `reference's to the `color's that can be changed by users through
;; Preferences dialog of the ochusha.
;;                                                THE DEFAULT DEFINITION
;; `list-entry-fg-normal', `list-entry-bg-normal' GTK+/GNOME theme's default
;; `list-entry-fg-emph', `list-entry-bg-emph'     theme's default, lavender
;; `list-entry-fg-strong', `list-entry-bg-strong' red, theme's default
;; `list-entry-fg-hidden', `list-entry-bg-hidden' gray75, theme's default
;;
;; By default, the ochusha paints threadlists like below using these constants.
;;
;; Hidden Threads
;;   => (list-entry-fg-hidden . list-entry-bg-hidden)
;; Threads DAT dropped
;;   => (list-entry-fg-normal . list-entry-bg-strong)
;; New threads
;;   => (list-entry-fg-emph . list-entry-bg-emph)
;; Threads you read and exists unread responses
;;   => (list-entry-fg-strong . list-entry-bg-strong)
;; The other threads
;;   => (list-entry-fg-normal . list-entry-bg-normal) can be abbreved by '()

;; The COLOR object can be defined at Scheme procedure level using
;; `gdk-color-parse' procedure like below.
;; The `gdk-color-parse' procedure calls the C function `gdk_color_parse()',
;; and thus you can refer common color names defined in
;; "/usr/X11R6/lib/X11/rgb.txt" or "/usr/share/X11/rgb.txt"
;; or specify RGB value like "#RRGGBB".  When error occurred during
;; color definition, default values will be refered.
;(define test-fg (gdk-color-parse "yellow"))


;; This is the default algorithm to paint threadlists.
(define (decorate-list-entry-default thread)
  (let ((new-responses (thread-get-number-of-new-responses thread))
	(n-got (thread-get-number-of-responses-got thread)))
    (cond ((thread-hidden? thread)
	   (cons list-entry-fg-hidden list-entry-bg-hidden))
	  ((not (thread-alive? thread))
	   (cons list-entry-fg-normal list-entry-bg-strong))
	  ((> n-got 0)
	   (if (> (thread-get-number-of-responses-on-server thread) n-got)
	       (cons list-entry-fg-strong list-entry-bg-strong) '()))
	  ((thread-new? thread)
	   (cons list-entry-fg-normal list-entry-bg-emph))
	  (else '()))))


;; The ochusha calls the Scheme procedure named `decorate-list-entry'
;; to see how to decorate threadlists and each rows of threadlists
;; are painted according to the `pair' returned by `decorate-list-entry'
;; procedure.
;;
;; (car (decorate-list-entry thread)) is used to specify the foreground color
;; (cdr (decorate-list-entry thread)) is used to specify the background color
;;
;; The ochusha paints rows using GTK+/GNOME theme's default when
;; `decorate-list-entry' returns '().
(define decorate-list-entry decorate-list-entry-default)


;; The `interest-thread?" procedure determines whether the given thread
;; is interesting one, i.e. to be read by user, or not.
;; This procedure is used especially by threadlists' action bound only
;; to key-presses such as 'p', 'n' and 'Space'.
(define (interest-thread? thread)
  (and (> (thread-get-number-of-responses-got thread) 0)
       (> (thread-get-number-of-responses-to-read thread) 0)))


;; The `register-threadlist-rule' procedure registers a rule for
;; sorting and filtering of threadlists.
;; (register-threadlist-rule NAME LABEL DESCRIPTION PROCEDURE)
;;
;; NAME is an identifier STRING.  If there's already a rule having
;; the same NAME registered, the older one will be replaced by the new one.
;;
;; LABEL is a STRING will be shown in GUI components like menus.
;;
;; DESCRIPTION is a STRING explains the rule.
;;
;; PROCEDURE is a scheme procedure that implements the rule.  Rows of
;; Threadlist will be sorted in ascending order of value returned by
;; this PROCEDURE and threads that are calculated as #f by this
;; PROCEDURE will be hidden from threadlists.  The PROCEDURE must
;; be of a scheme procedure that takes exacly one argument of
;; THREAD object.
(register-threadlist-rule
 "ochusha-default-plain-all"
 "All"
 "Threads alive->threads DAT dropped"
 (lambda (thread)
   (if (thread-alive? thread) 0 10000)))


(register-threadlist-rule
 "ochusha-default-plain-live-only"
 "Live threads"
 "All threads alive"
 (lambda (thread)
   (if (thread-alive? thread) 0 #f)))


(register-threadlist-rule
 "ochusha-default-plain-dead-only"
 "Dead threads"
 "All threads DAT dropped"
 (lambda (thread)
   (if (thread-alive? thread) #f 0)))


(register-threadlist-rule
 "ochusha-default-plain-all-newer-to-older"
 "All newer to older"
 "All threads in the order of newer to older"
 (lambda (thread)
   (- #x7fffffff (thread-get-birthtime thread))))


(register-threadlist-rule
 "ochusha-default-plain-all-older-to-newer"
 "All older to newer"
 "All threads in the order of older to newer"
 (lambda (thread)
   (thread-get-birthtime thread)))


(register-threadlist-rule
 "ochusha-default-importance-order"
 "All prioritized"
 "Read(with unread)->New->Read(w/o unread)->Live->Dead"
 (lambda (thread)
   (let ((n-res (thread-get-number-of-responses-on-server thread))
	 (n-got (thread-get-number-of-responses-read thread)))
     (+ (if (thread-hidden? thread) 10000 0)
	(if (thread-marked? thread) 0 5000)
	(if (> n-got 0)
	    (if (> n-res n-got) 0 2000)
	    (if (thread-new? thread) 1000 3000))
	(if (thread-alive? thread) 0 5000)))))


(register-threadlist-rule
 "ochusha-default-important-only"
 "Threads in interest"
 "Read(with unread)->New->Read(w/o unread)->Read(Dead)"
 (lambda (thread)
   (let ((n-res (thread-get-number-of-responses-on-server thread))
	 (n-got (thread-get-number-of-responses-read thread)))
     (if (and (= n-got 0) (not (thread-marked? thread)))
	 #f
	 (+ (if (thread-marked? thread) 0 5000)
	    (if (> n-got 0)
		(if (> n-res n-got) 0 2000)
		(if (thread-new? thread) 1000 3000))
	    (if (thread-alive? thread) 0 5000))))))


(register-threadlist-rule
 "ochusha-default-important-unread-only"
 "Unread in interest"
 "Threads read having unread responses"
 (lambda (thread)
   (let ((n-res (thread-get-number-of-responses-on-server thread))
	 (n-got (thread-get-number-of-responses-read thread)))
     (if (or (= n-got 0) (<= n-res n-got))
	 #f
	 (+ (if (thread-marked? thread) 0 5000)
	    (if (thread-alive? thread) 0 5000))))))


(register-threadlist-rule
 "ochusha-default-important-live-only"
 "Live in interest"
 "Threads read(with unread)->Threads read(w/o unread)"
 (lambda (thread)
   (let ((n-res (thread-get-number-of-responses-on-server thread))
	 (n-got (thread-get-number-of-responses-read thread)))
     (if (or (and (= n-got 0)
		  (not (thread-marked? thread)))
	     (not (thread-alive? thread)))
	 #f
	 (+ (if (thread-marked? thread) 0 5000)
	    (if (> n-got 0)
		(if (> n-res n-got) 0 2000)))))))


(register-threadlist-rule
 "ochusha-default-importance-order-live-only"
 "Live prioritized"
 "Read(with unread)->New->Read(w/o unread)->Other live threads"
 (lambda (thread)
   (let ((n-res (thread-get-number-of-responses-on-server thread))
	 (n-got (thread-get-number-of-responses-read thread)))
     (if (thread-alive? thread)
	 (+ (if (thread-hidden? thread) 10000 0)
	    (if (thread-marked? thread) 0 5000)
	    (if (> n-got 0)
		(if (> n-res n-got) 0 2000)
		(if (thread-new? thread) 1000 3000)))
	 #f))))


(register-threadlist-rule
 "ochusha-default-live-only-newer-to-older"
 "Live newer to older"
 "All threads alive in the order of newer to older"
 (lambda (thread)
   (if (thread-alive? thread)
       (- #x7fffffff (thread-get-birthtime thread)) #f)))


(register-threadlist-rule
 "ochusha-default-live-only-older-to-newer"
 "Live older to newer"
 "All threads alive in the order of older to newer"
 (lambda (thread)
   (if (thread-alive? thread)
       (thread-get-birthtime thread) #f)))


(register-threadlist-rule
 "ochusha-default-mark-only"
 "Marked"
 "Threads have marked"
 (lambda (thread)
   (if (thread-marked? thread) 0 #f)))


(register-threadlist-rule
 "ochusha-default-only-mark-is-important"
 "All marked to unmarked"
 "Marked threads->other threads"
 (lambda (thread)
   (if (thread-marked? thread) 0 1000)))


(register-threadlist-rule
 "ochusha-default-marked-unread-is-important"
 "All marked unread first"
 "Marked(with unread)->Marked(w/o unread)->Live->Dead"
 (lambda (thread)
   (if (thread-marked? thread)
       (if (> (thread-get-number-of-responses-on-server thread)
	      (thread-get-number-of-responses-read thread))
	   0 1000)
       2000)))


(register-threadlist-rule
 "ochusha-default-importance-order-mark-first"
 "All prioritized with mark"
 "Marked->Read(with unread)->New->Read(w/o unread)->Live->Dead"
 (lambda (thread)
   (let ((n-res (thread-get-number-of-responses-on-server thread))
	 (n-got (thread-get-number-of-responses-read thread)))
     (+ (if (thread-hidden? thread) 10000 0)
	(if (thread-marked? thread) 0 20000)
	(if (> n-got 0)
	    (if (> n-res n-got) 0 2000)
	    (if (thread-new? thread) 1000 3000))
	(if (thread-alive? thread) 0 5000)))))


;; (register-external-tool NAME LABEL DESCRIPTION TOOL-TYPE TEMPLorPROC)
;;
;; NAME is an identifier STRING.  If there's already a tool having
;; the same NAME registered, the older one will be replaced by the new one.
;;
;; LABEL is a STRING will be shown in GUI components like menus.
;;
;; DESCRIPTION is a STRING explains the tool.
;;
;; TOOL-TYPE specify the category of the tool.  This is a SYMBOL specifies
;; which menu should be include the tool in effect.
;; There's three types reserved in the ochusha as like below:
;;
;; 'link-tool	specifies the tool is for URLs.
;; 'image-tool	specifies the tool is for cached image files.
;; 'text-tool	specifies the tool is for selected texts.
;;
;; TEMPLorPROC is either a STRING that represents a commandline template
;; or a PROCEDURE that generates a commandline template based on the argument,
;; URL STRING or the pathname STRING of the target.
;; The substring "%ARG%" within template will be replaced by the URL, the
;; pathname or texts being selected as the target object of the tool.
;; When template contains "%FILENAME_FROM_ARG%" or "%FILENAME%" as
;; a substring, a filechooser dialog will be shown before execution of
;; commandline and those substrings will be replaced by the user's file
;; selection.  The only differences between "%FILENAME_FROM_ARG%" and
;; "%FILENAME%" is the initial filename setting of filechooser dialog.
(register-external-tool
 "save-image"
 "Save Image As ..."
 "Save Image As ..."
 'image-tool
 "cp %ARG% %FILENAME_FROM_ARG%")

;; In this example, a procedure that expands the STRING argument as
;; the pathname of commandline is registered as TEMPLorPROC.
(register-external-tool
 "browse-image-with-eog"
 "Eye of GNOME"
 "Open image with Eye of GNOME(eog)"
 'image-tool
 (lambda (filename)
   (format "eog ~a" filename)))


(register-external-tool
 "browse-image-with-gimp"
 "Gimp"
 "Open Image with gimp"
 'image-tool
 "gimp-remote %ARG%")


(register-external-tool
 "download-url-with-wget"
 "Wget"
 "Open URL with Wget"
 'link-tool
 "xterm -e wget %ARG%")


(register-external-tool
 "open-url-with-d4x"
 "d4x"
 "Open URL with d4x"
 'link-tool
 (lambda (url)
   (format "d4x ~a" url)))


(register-external-tool
 "search-archive-with-web-browser"
 "Internet Archive Wayback Machine"
 "Search URL at Internet Archive Wayback Machine"
 'link-tool
 (lambda (url)
   (format "%WEBBROWSER% http://web.archive.org/*/~a" url)))


(register-external-tool
 "google-text-in-japanese"
 "Google Search(Japanese Pages)"
 "Search text at Google for Japanese pages"
 'text-tool
 (lambda (text)
   (format "%WEBBROWSER% http://www.google.co.jp/search?hl=ja&q=~a&btnG=Google+%E6%A4%9C%E7%B4%A2&lr=lang_ja" (url-encode-string text))))


(register-external-tool
 "google-text-in-all"
 "Google Search(Entire Web)"
 "Search text at google for entire web pages"
 'text-tool
 (lambda (text)
   (format "%WEBBROWSER% http://www.google.co.jp/search?hl=ja&q=~a&btnG=Google+%E6%A4%9C%E7%B4%A2&lr=" (url-encode-string text))))


(register-external-tool
 "google-image"
 "Google Search(Images)"
 "Search text at google for images"
 'text-tool
 (lambda (text)
   (format "%WEBBROWSER% http://www.google.co.jp/images?hl=ja&q=~a&btnG=Google+%E3%82%A4%E3%83%A1%E3%83%BC%E3%82%B8%E6%A4%9C%E7%B4%A2&lr=" (url-encode-string text))))


(register-external-tool
 "excite-english-japanese-dictionary"
 "excite dictionaries(English-Japanese)"
 "Lookup text in excite English-Japanese dictionary"
 'text-tool
 (lambda (text)
   (format "%WEBBROWSER% http://www.excite.co.jp/dictionary/english_japanese/?search=~a&submit=+%E6%A4%9C+%E7%B4%A2+&match=beginswith&dictionary=NEW_EJJE" (url-encode-string text))))


(register-external-tool
 "excite-japanese-english-dictionary"
 "excite dictionaries(Japanese-English)"
 "Lookup text in excite Japanese-English dictionary"
 'text-tool
 (lambda (text)
   (format "%WEBBROWSER% http://www.excite.co.jp/dictionary/japanese_english/?search=~a&submit=+%E6%A4%9C+%E7%B4%A2+&match=beginswith" (url-encode-string text))))


(register-external-tool
 "wikipedia-ja-search"
 "Wikipedia(ja)"
 "Search text in Wikipedia(ja)"
 'text-tool
 (lambda (text)
   (format "%WEBBROWSER% http://ja.wikipedia.org/wiki/%E7%89%B9%E5%88%A5:Search?search=~a&fulltext=%E6%A4%9C%E7%B4%A2" (url-encode-string text))))


(register-external-tool
 "wikipedia-en-search"
 "Wikipedia(english)"
 "Search text in Wikipedia(english)"
 'text-tool
 (lambda (text)
   (format "%WEBBROWSER% http://en.wikipedia.org/wiki/Special:Search?search=~a&fulltext=Search" (url-encode-string text))))



;; Reserved procedure to rewrite URLs.
(define (rewrite-link-default link) link)

;; The ochusha will call `rewrite-link' procedure to rewrite URLs.
;; Not used at the time being.
(define rewrite-link rewrite-link-default)



;; Retrieves STRING from output-string-port and close the port.
(define (close-string-port string-port)
  (let ((result (get-output-string string-port)))
    (close-output-port string-port)
    result))



;; The implementation of GtkToolbar hides GtkComboBox if there's enough
;; space to show the entire GtkComboBox with in a toolbar.  This behavior
;; isn't good for user's experience, we add an ad-hoc work-around to
;; limit the length of `thread-title' shown on GtkComboBox.
;; If you have the ochusha window wide enough to show all thread title
;; as they are, this doesn't make sense.
;;
;; In the future, we will allow users to specify the parameter of
;; abbreviation of thread-title, e.g. number of characters, and/or
;; the algorithm to abbreviate the thread-title through GUI but
;; it is hard-coded at this time.

;; This procedure abbriviates thread-title simply by cutting STRING
;; according to the reduced number of so-called half-width characters.
(define (abbreviate-thread-title-by-heading n thread-title)
  (letrec ((char-width (lambda (char-string)
			 (if (eq? (string-length char-string) 1) 1 2)))
	   (append-chars
	    (lambda (string-port rest-len splitted-title)
	      (if (null? splitted-title) string-port
		  (let* ((next-char (car splitted-title))
			 (next-char-width (char-width next-char)))
		    (if (< rest-len next-char-width) string-port
			(begin
			  (display next-char string-port)
			  (append-chars string-port
					(- rest-len next-char-width)
					(cdr splitted-title)))))))))
    (close-string-port (append-chars
			(open-output-string)
			n
			(regexp-split #// thread-title)))))


;; Although it is clear that contents of STRING has more effects for
;; effective width of GUI representation than the differences between
;; so-called half-width characters and full-width characters if propotional
;; fonts are used, we don't try to see the contents because it is
;; almost impossible to calculate the pixel-size of contents.
;; The effective pixel-size of a STRING within GUI can only be calculated
;; by letting GTK+ show the STRING in the very context ;-<.
;;
;; If you uncomment this, thread-title will be abbreviated by heading
;; 44 characters.
;(define (abbreviate-thread-title thread-title)
;  (abbreviate-thread-title-by-heading 44 thread-title))


;; We don't abbreviate thread-title by default.
(define (abbreviate-thread-title thread-title) thread-title)


(define (caadddr x) (car (cadddr x)))
(define (cdadddr x) (cdr (cadddr x)))


;; This procedure rewrites messages of each responses as like below:
;; - substrings seem to be URLs will be rewritten as `a' elements of HTML.
;; - substrings that aren't treated as `anchor of responses' will be
;;   rewritten as response anchor if appropriate, e.g. >NUMBER.
(define (rewrite-message-default message)
  (letrec
      ((rewrite-additional-response-number
	(lambda (message output)
	  (let* ((match-pos
		  (regexp-match-positions #/^(?:[ ,､、，=＝]+)([0-9０-９]+)/
					  message))
		 (match-beg (if match-pos (caar match-pos) 0))
		 (match-end (if match-pos (cdar match-pos) 0))
		 (number-beg (if match-pos (caadr match-pos) 0))
		 (number-end (if match-pos (cdadr match-pos) 0)))
	    (if match-pos
		(begin (output "<a href=\"")
		       (output (substring message number-beg number-end))
		       (output "\">")
		       (output (substring message match-beg match-end))
		       (output "</a>")
		       (rewrite-additional-response-number
			(substring message match-end) output))
		(rewrite-message message output)))))
       (rewrite-non-link-response-number
	(lambda (message output)
	  (let* ((match-pos
		  (regexp-match-positions
		   #/(?:&gt;|[＞≫〉》])+([0-9０-９]+[-―ー─－〜]?[0-9０-９]*)/
		   message))
		 (match-beg (if match-pos (caar match-pos) 0))
		 (match-end (if match-pos (cdar match-pos) 0))
		 (numbers-beg (if match-pos (caadr match-pos) 0))
		 (numbers-end (if match-pos (cdadr match-pos) 0)))
	    (if match-pos
		(begin (output (substring message 0 match-beg))
		       (output "<a href=\"")
		       (output (substring message numbers-beg numbers-end))
		       (output "\">")
		       (output (substring message match-beg match-end))
		       (output "</a>")
		       (rewrite-additional-response-number
			(substring message match-end) output))
		(output message)))))
       (rewrite-non-link-url
	(lambda (message output)
	  (let* ((match-pos
		  (regexp-match-positions
		   #/(h?[ft]?)tp(s?):\/\/([0-9a-zA-Z\/#?;:@&%=+\-!*$,._~'()]+)/
		   message))
		 (match-beg0 (if match-pos (caar match-pos) 0))
		 (match-end0 (if match-pos (cdar match-pos) 0))
		 (match-beg1 (if match-pos (caadr match-pos) 0))
		 (match-end1 (if match-pos (cdadr match-pos) 0))
		 (match-beg2 (if match-pos (caaddr match-pos) 0))
		 (match-end2 (if match-pos (cdaddr match-pos) 0))
		 (match-beg3 (if match-pos (caadddr match-pos) 0))
		 (match-end3 (if match-pos (cdadddr match-pos) 0)))
	    (if match-pos
		(begin (rewrite-non-link-response-number
			(substring message 0 match-beg0) output)
		       (output "<a href=\"")
		       (if (eqv? (substring message match-beg1 match-end1) "f")
			   (output "f")
			   (output "ht"))
		       (output "tp")
		       (output (substring message match-beg2 match-end2))
		       (output "://")
		       (output (substring message match-beg3 match-end3))
		       (output "\">")
		       (output (substring message match-beg0 match-end0))
		       (output "</a>")
		       (rewrite-non-link-url
			(substring message match-end0) output))
		(rewrite-non-link-response-number message output)))))
       (rewrite-message
	(lambda (message output)
	  (let ((match-pos (regexp-match-positions
			    #/<[aA][[:space:]][^>]+>[^<]*<\/a>/ message)))
	    (if match-pos
		(begin (rewrite-non-link-url
			(substring message 0 (caar match-pos)) output)
		       (output (substring
				message (caar match-pos) (cdar match-pos)))
		       (rewrite-additional-response-number
			(substring message (cdar match-pos)) output))
		(rewrite-non-link-url message output))))))
    (let ((result-port (open-output-string)))
      (rewrite-message message (lambda (text) (display text result-port)))
      (close-string-port result-port))))



;; The ochusha calls the Scheme procedure named `rewrite-message' for
;; each responses during rendering of threads' view.
(define rewrite-message rewrite-message-default)



;; The ochusha calls the Scheme procedure named `image-link?' to determine
;; an URL is for image or not.
(define (image-link? url) #f)


;; The ochusha calls the Scheme procedure named `rewrite-image-link'
;; to allow users to manipulate URLs for images before networking.
;; The result of this procedure must be an URL STRING or a PAIR of
;; (URL . REFERER).  Other values let the ochusha use URLs as they are.
;; If a PAIR of (URL . REFERER) is returned, the ochusha accesses
;; returned URL instead of the url given as the argument of this
;; procedure and sets the REFERER as the value of Referer HTTP
;; request header.
(define (rewrite-image-link url) #f)


;; The ochusha calls the Scheme procedure named `redirect-image-link'
;; to look for the actual image URL if access result for image URL
;; returns a HTML text as successful access, i.e. status-code 200.
;; When this procedure returns a URL STRING, the ochusha will try
;; to download images from returned URL like HTTP redirection.
;; The argument `url' gives the URL as STRING that is used for
;; networking.  The argument `page-source' gives the HTML text as
;; STRING that is the resulting body of HTTP GET for `url'.
(define (redirect-image-link url page-source) #f)