;;
;; このファイルはデフォルトで読み込まれる物とほぼ同一。
;; UTF-8エンコーディングでなければならない。
;;
;; ユーザが~/.ochusha/ochusha-init.scmというファイルを持っている場合、
;; この内容の代わりにそれが読み込まれる。
;;
;; $Id: ochusha-init.scm.ja,v 1.1 2009/01/05 12:18:03 fuyu Exp $
;;

;; おちゅ〜しゃは色を表現するために以下の定数をあらかじめ定義しており、
;; スレ一覧の色付けに使われる。これらは「おちゅ〜しゃの設定」ダイアログの
;; 「一覧表示」タブで選択される色を参照する定数である。
;;                                                ↓現在定義されている値
;; `list-entry-fg-normal', `list-entry-bg-normal' GTK+/GNOMEテーマのデフォルト
;; `list-entry-fg-emph', `list-entry-bg-emph' テーマのデフォルト、lavender
;; `list-entry-fg-strong', `list-entry-bg-strong' red、テーマのデフォルト
;; `list-entry-fg-hidden', `list-entry-bg-hidden' gray75、テーマのデフォルト
;;
;; おちゅ〜しゃのデフォルト状態ではこれらの定数を使い、スレ一覧を以下の
;; ように色付けする。
;; 隠されたスレ
;;   => (list-entry-fg-hidden . list-entry-bg-hidden)
;; DAT落ちスレ
;;   => (list-entry-fg-normal . list-entry-bg-strong)
;; 新スレ
;;   => (list-entry-fg-emph . list-entry-bg-emph)
;; 既読かつ未読レスあり
;;   => (list-entry-fg-strong . list-entry-bg-strong)
;; 他のスレ
;;   => (list-entry-fg-normal . list-entry-bg-normal) これは'()で代用可

;; 色オブジェクトはgdk-color-parse関数によりschemeレベルで定義することも
;; できる。内部的にはCのgdk_color_parse()関数を呼んでいるので、
;; /usr/X11R6/lib/X11/rgb.txtあたりに書かれている色名や"#RRGGBB"みたいな
;; 文字列で色が指定できる。エラー時は黙ってデフォルトの色になる。
;(define test-fg (gdk-color-parse "yellow"))


;; 以下がデフォルトのスレ一覧用色選択関数の定義
(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 '()))))


;; おちゅ〜しゃはスレ一覧を飾り付けるためにdecorate-list-entryという
;; 名前の関数を呼び出す。
;; この関数が返した色オブジェクトのペアにより、スレ一覧の個々の要素の
;; 色が決まる。
;; (car (decorate-list-entry thread)) が前景色
;; (cdr (decorate-list-entry thread)) が背景色
;; になる。これが'()を返した場合、GTK+/GNOMEのテーマで決まるデフォルト
;; の色になる。
(define decorate-list-entry decorate-list-entry-default)


;; スレ一覧でのカーソル移動時に用いられる。
;; この関数が真を返したスレは読むべきものの存在するスレとして取り扱われる。
(define (interest-thread? thread)
  (and (> (thread-get-number-of-responses-got thread) 0)
       (> (thread-get-number-of-responses-to-read thread) 0)))


;; スレ一覧の表示規則を追加する。
;; (register-threadlist-rule NAME LABEL DESCRIPTION PROCEDURE)
;;
;; NAMEは内部的に規則を識別するために用いられる文字列。同じ名前の規則が
;; 存在していた場合、上書きされる。
;; LABELはGUIのメニューなどに表示される文字列。
;; DESCRIPTIONは規則の説明。
;; PROCEDUREは規則を実現する関数。スレ一覧は、この関数の返した数値
;; について昇順にソートされる。この関数が#fを返したスレは一覧に表示されない。
;; PROCEDUREは引数としてthreadオブジェクトを一つだけ取る関数でなければならない。
(register-threadlist-rule
 "ochusha-default-plain-all"
 "全部"
 "現存スレ→DAT落ちスレ"
 (lambda (thread)
   (if (thread-alive? thread) 0 10000)))


(register-threadlist-rule
 "ochusha-default-plain-live-only"
 "現存スレ"
 "現存スレ全部"
 (lambda (thread)
   (if (thread-alive? thread) 0 #f)))


(register-threadlist-rule
 "ochusha-default-plain-dead-only"
 "DAT落ちスレ"
 "DAT落ちスレ全部"
 (lambda (thread)
   (if (thread-alive? thread) #f 0)))


(register-threadlist-rule
 "ochusha-default-plain-all-newer-to-older"
 "全部新しい順"
 "スレ全部新しい順"
 (lambda (thread)
   (- #x7fffffff (thread-get-birthtime thread))))


(register-threadlist-rule
 "ochusha-default-plain-all-older-to-newer"
 "全部古い順"
 "スレ全部古い順"
 (lambda (thread)
   (thread-get-birthtime thread)))


(register-threadlist-rule
 "ochusha-default-importance-order"
 "全部重要度順"
 "既読(未読有)→新スレ→既読(未読無)→通常スレ→DAT落スレ"
 (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"
 "注目スレ"
 "既読(未読有)→新スレ→既読(未読無)→既読(DAT落ち)"
 (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"
 "未読有注目スレ"
 "既読(未読有)"
 (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"
 "現存注目スレ"
 "既読(未読有)→既読(未読無)"
 (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"
 "現存重要度順"
 "既読(未読有)→新スレ→既読(未読無)→通常スレ"
 (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"
 "現存新しい順"
 "現存スレ全部新しい順"
 (lambda (thread)
   (if (thread-alive? thread)
       (- #x7fffffff (thread-get-birthtime thread)) #f)))


(register-threadlist-rule
 "ochusha-default-live-only-older-to-newer"
 "現存古い順"
 "現存スレ全部古い順"
 (lambda (thread)
   (if (thread-alive? thread)
       (thread-get-birthtime thread) #f)))


(register-threadlist-rule
 "ochusha-default-mark-only"
 "印付"
 "印付スレのみ"
 (lambda (thread)
   (if (thread-marked? thread) 0 #f)))


(register-threadlist-rule
 "ochusha-default-only-mark-is-important"
 "印重要"
 "印付スレ→印無スレ"
 (lambda (thread)
   (if (thread-marked? thread) 0 1000)))


(register-threadlist-rule
 "ochusha-default-marked-unread-is-important"
 "印未読重要"
 "印付(未読有)→印付(未読無)→通常スレ→DAT落スレ"
 (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"
 "印最強重要度順"
 "印付→既読(未読有)→新スレ→既読(未読無)→通常スレ→DAT落スレ"
 (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は内部的に規則を識別するために用いられる文字列。同じ名前のツールが
;; 登録されていた場合、上書きされる。
;;
;; LABELはGUIのメニューなどに表示される文字列。
;;
;; DESCRIPTIONはツールの説明。
;;
;; TOOL-TYPEはツールの種別を示す。具体的には、どのメニューに現れるべきかを
;; 決めるシンボル。現在内部的には、'link-tool、'image-tool、'text-tool
;; が予約されており、それぞれリンクに対するポップアップメニュー、画像リンク
;; に対するポップアップメニュー、選択文字列に対するポップアップメニューの
;; ツールに対応する。
;;
;; TEMPLorPROCはコマンドラインのテンプレートを与える文字列か文字列を引数と
;; して受取り、テンプレート文字列を返すprocedureとなる予定。
;; テンプレートの"%ARG%"がURLや画像ファイルのパス名、選択中の文字列などで
;; 置き換えられる。
;; テンプレートに"%FILENAME_FROM_ARG%"もしくは"%FILENAME%"が現れた場合、
;; コマンドライン実行の前にファイル選択用のダイアログが現れ、そこで選択
;; されたファイル名で置き換えられる。"%FILENAME_FROM_ARG%"の場合には、
;; "%ARG%"がファイル名の初期値として用いられ、%FILENAME%の場合は、
;; localizeされた"untitled"相当の文字列がファイル名の初期値として用いられる。
(register-external-tool
 "save-image"
 "名前を付けて画像を保存"
 "名前を付けて画像を保存"
 'image-tool
 "cp %ARG% %FILENAME_FROM_ARG%")

;; eogの例では、引数として与えられたパス名を自前でコマンドラインに
;; 展開するprocedureをTEMPLorPROCとして登録している。
(register-external-tool
 "browse-image-with-eog"
 "Eye of GNOME"
 "eogで画像を開く"
 'image-tool
 (lambda (filename)
   (format "eog ~a" filename)))

(register-external-tool
 "browse-image-with-gimp"
 "Gimp"
 "gimpで画像を開く"
 'image-tool
 "gimp-remote %ARG%")


;; wgetの例では、おちゅ〜しゃが%ARG%をURLに置き換えるコマンドライン
;; のテンプレートをTEMPLorPROCとして登録している。
(register-external-tool
 "download-url-with-wget"
 "Wget"
 "WgetでURLを開く"
 'link-tool
 "xterm -e wget %ARG%")


(register-external-tool
 "open-url-with-d4x"
 "d4x"
 "d4xでURLを開く"
 'link-tool
 (lambda (url)
   (format "d4x ~a" url)))


;; Internet Archiveの例ではウェブブラウザで開くべきURLを返すprocedureを
;; TEMPLorPROCとして登録している。
(register-external-tool
 "search-archive-with-web-browser"
 "Internet Archive Wayback Machine"
 "Internet Archive Wayback MachineでURLを検索する"
 'link-tool
 (lambda (url)
   (format "%WEBBROWSER% http://web.archive.org/*/~a" url)))


;; Googleの例ではウェブブラウザで開くべきURLを返すprocedureを
;; TEMPLorPROCとして登録している。
;; %E6%A4%9C%E7%B4%A2はUTF-8な"検索"をURIエンコードしたもの。
(register-external-tool
 "google-text-in-japanese"
 "Google Search(日本語のページ)"
 "日本語のページでググる"
 '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(ウェブ全体)"
 "ウェブ全体でググる"
 '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(イメージ)"
 "イメージでググる"
 '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辞書(新英和中辞典)"
 "excite辞書で新英和中辞典を引く"
 '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辞書(新和英中辞典)"
 "excite辞書で新和英中辞典を引く"
 '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"
 "ウィキペディア（日本語版）で検索"
 "ウィキペディアを検索する"
 '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(英語版)で検索"
 "Wikipediaを検索する"
 'text-tool
 (lambda (text)
   (format "%WEBBROWSER% http://en.wikipedia.org/wiki/Special:Search?search=~a&fulltext=Search" (url-encode-string text))))



;; いずれ、ユーザの好みでime.nuの類を抜き去るなどのリンクの書き換えも
;; scheme関数で出来るようになる予定。
(define (rewrite-link-default link) link)


;; おちゅ〜しゃはリンクの書き換えなどを行うために、rewrite-linkという
;; 名前の関数を呼び出すようになる予定。現時点では未使用。
(define rewrite-link rewrite-link-default)


;; output-string-portの文字列を取り出し、portを閉じる。
(define (close-string-port string-port)
  (let ((result (get-output-string string-port)))
    (close-output-port string-port)
    result))


;; GtkToolbarの仕様から、GtkComboBoxがツールバーに表示しきれない場合
;; 完全に非表示になってしまうのが気にくわないので、
;; スレタイ用のGtkComboBoxに表示するスレタイの長さを制限する。
;; →おちゅ〜しゃのウィンドウ幅を広めに取っている人には無意味。
;; いずれ、GUI設定で制限文字数の設定やスレタイの短縮アルゴリズムの
;; 選択などを可能にしたいが、取り敢えず現状では文字数もアルゴリズムも
;; 固定。

;; いわゆる半角文字換算で、単純に先頭からn文字で打ち切るアルゴリズム
(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)))))


;; プロポーショナルフォントだと内容による幅の変化の方が大きいのは明らか
;; だが、pixel数なんてのを計算で出すのはほとんど不可能だし、フォントや
;; テーマ設定など外的要因で変化するので現実的にはGTK+に「描画させてみる」
;; 以外の単純な方法はなさげ。
;; ↓先頭から44文字で打ち切り
;(define (abbreviate-thread-title thread-title)
;  (abbreviate-thread-title-by-heading 44 thread-title))


;; ↓縮めない場合
(define (abbreviate-thread-title thread-title) thread-title)


;; デフォルトの本文書き換え関数で使う。
(define (caadddr x) (car (cadddr x)))
(define (cdadddr x) (cdr (cadddr x)))


;; これがデフォルトの本文書き換え関数。
;; - httpやftpなURLっぽい文字列をHTMLのa要素風に
;; - レスアンカーになっていない>数字みたいなのをレスアンカーに
;; - レスアンカーに続く,数字みたいなのをレスアンカーに
;; それぞれ書き換える。
(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))))


;; おちゅ〜しゃはスレ表示の直前に各レスのメッセージ本文を引数として
;; rewrite-messageという名前の関数を呼び出し、本文を書き換える。
(define rewrite-message rewrite-message-default)


;; おちゅ〜しゃはリンクが画像のものかどうかを判断するために
;; image-link?という名前の関数を呼び出す。
(define (image-link? url) #f)


;; おちゅ〜しゃは画像のものと判断されたリンクに対し、実際にアクセスする
;; URLに細工を加えることを許すためにrewrite-image-linkという名前の関数を
;; 呼び出す。
;; この関数の返り値はURLそのものを表す文字列もしくは
;; (URL . REFERER)というペアが期待され、それ以外の値の場合にはURLへの
;; 細工が必要ないものと判断される。
;; (URL . REFERER)というペアが返された場合、おちゅ〜しゃは
;; rewrite-image-linkの引数として与えたurlの代わりにURLにアクセスし、
;; その時にHTTPのリクエストヘッダのRefererとしてREFERERを設定する。
(define (rewrite-image-link url) #f)


;; おちゅ〜しゃは画像リンクと思ってアクセスした結果がHTMLだった時に
;; それが目的の画像を表示するためのページである可能性を確認するために
;; redirect-image-linkという名前の関数を呼び出す。
;; これはurlへのアクセスの結果page-sourceなHTMLソースが返されたという
;; ことを意味し、関数redirect-image-linkはurlとpage-sourceを元に画像
;; ファイルへのURL文字列を返すことが期待される。
(define (redirect-image-link url page-source) #f)