;;  morph.scm
;;	形態素解析プログラムの基礎
;;
;;  with STk:	$ stk -f morph.scm
;;  with SCM:	$ scm -f morph.scm
;;  with Guile:	$ guile -s morph.scm
;;

;;  aliases
;;
(define str=?	string=?)
(define sref	string-ref)
(define sset!	string-set!)
(define substr	substring)
(define strlen	string-length)
(define vref	vector-ref)
(define vset!	vector-set!)
(define veclen	vector-length)
(define readln	read-line)
(define (makesp n) (make-string n #\space))

;;  stream 型 (タブ区切りのテキストファイルを 1行ずつ読む)
;;	(stream:open "ファイル名") … 開く。
;;	(stream:close #<stream>)   … 閉じる。
;;	(stream:read #<stream>)    … 1行を読みリストを返す。
;;
(define (stream:open f) (open-input-file f))
(define (stream:close s) (close-port s))
(define (stream:read s)
  (define (loop cs s1 rs)
    (define (srev l) 
      (and (not (null? l)) (list->string (reverse l))))
    (define (skip cs)
      (if (and (not (null? cs))
	       (char=? #\ht (car cs)))
	  (skip (cdr cs))
	  cs))
    (cond 
     ((null? cs) (reverse (cons (srev s1) rs)))
     ((char-whitespace? (car cs))
      (loop (skip cs) '() (cons (srev s1) rs)))
     (else
      (loop (cdr cs) (cons (car cs) s1) rs))))
  (let ((l (readln s)))
    (if (eof-object? l)
	#f
	(loop (string->list l)  '() '()))))

;;  morpheme 型 (ひとつの形態素)
;;	(morpheme:make "文字列" '品詞シンボル 意味オブジェクト)
;;		… 形態素オブジェクトを作成。
;;	(morpheme:str #<morpheme>) … 文字列を返す。
;;	(morpheme:len #<morpheme>) … 文字列の長さを返す。
;;	(morpheme:psp #<morpheme>) … 品詞シンボルを返す。
;;	(morpheme:sem #<morpheme>) … 意味オブジェクトを返す。
;;	(morpheme:proceed? #<morpheme> "文字列" 位置)
;;		… その文字列の指定された位置がその形態素とマッチするか?
;;
(define (morpheme:make str psp sem) (vector str psp sem))
(define (morpheme:str m) (vref m 0))
(define (morpheme:len m) (strlen (vref m 0)))
(define (morpheme:psp m) (vref m 1))
(define (morpheme:sem m) (vref m 2))
(define (morpheme:proceed? m str p0)
  (let* ((len (strlen str))
	 (s1 (vref m 0))
	 (p1 (+ p0 (strlen s1))))
    (and (<= p0 len) (<= p1 len)
	 (str=? s1 (substr str p0 p1)))))

;;  matrix 型 (形態素の解析結果保持用に特化された lattice)
;;	(matrix:make 最大長)		… matrix を作成する。
;;	(matrix:maxlen #<matrix>)	… matrix の最大長を返す。
;;	(matrix:size #<matrix>)		… 現在 matrix に入っている要素数。
;;	(matrix:ins! #<matrix> 開始位置i0 終了位置i1 #<morpheme>)
;;		… 範囲 [i0,i1] に形態素を挿入する。
;;	(matrix:retr #<matrix> (lambda (i0 i1 #<morpheme>) ..))
;;		… 与えた手続きが真を返す要素だけをリストとして取り出す。
;;	(matrix:elim! #<matrix> (lambda (i0 i1 #<morpheme>) ..))
;;		… 与えた手続きが真を返す要素を削除する。
;;	(matrix:foreach #<matrix> (lambda (i0 i1 #<morpheme>) ..))
;;		… 与えた手続きをすべての要素に対して適用する。
;;	(matrix:map! #<matrix> (lambda (i0 i1 #<morpheme>) ..))
;;		… 与えた手続きをすべての要素に対して適用し、各要素を更新。
;;
(define (matrix:make maxlen)
  (let ((mat '()))
    (define (retr p)
      (define (loop l r)
	(cond ((null? l) r)
	      ((apply p (vector->list (car l)))
	       (loop (cdr l) (cons (car l) r)))
	      (else (loop (cdr l) r))))
      (loop mat '()))
    (define (elim! p)
      (define (loop l r)
	(cond ((null? l) r)
	      ((apply p (vector->list (car l))) (loop (cdr l) r))
	      (else (loop (cdr l) (cons (car l) r)))))
      (set! mat (loop mat '())))
    (lambda (f i0 i1 x)
      (cond ((eq? f 'ins!)
	     (if (null? (retr (lambda (a b c)
				(and (= i0 a) (= i1 b) (eq? x c)))))
		 (set! mat (cons (vector i0 i1 x) mat))))
	    ((eq? f 'retr) (retr x))
	    ((eq? f 'elim!) (elim! x))
	    ((eq? f 'foreach) 
	     (for-each (lambda (e) (apply x (vector->list e))) mat))
	    ((eq? f 'map!) 
	     (set! mat (map (lambda (e) (apply x (vector->list e))) mat)))
	    ((eq? f 'len) (length mat))
	    ((eq? f 'maxlen) maxlen)))))
(define (matrix:maxlen lf) (lf 'maxlen #f #f #f))
(define (matrix:size lf) (lf 'len #f #f #f))
(define (matrix:ins! lf i0 i1 x) (lf 'ins! i0 i1 x))
(define (matrix:retr lf p) (lf 'refine! #f #f p))
(define (matrix:elim! lf p) (lf 'elim! #f #f p))
(define (matrix:foreach lf p) (lf 'foreach #f #f p))
(define (matrix:map! lf p) (lf 'map! #f #f p))

;;  thread 型 (ひとつの解析過程を表現する)
;;	(thread:make 位置 'ひとつ前の品詞) … オブジェクト作成。
;;	(thread:pos #<thread>)             … 位置を返す。
;;	(thread:prev #<thread>)            … ひとつ前の品詞シンボルを返す。
;;
(define (thread:make pos prev) (vector pos prev))
(define (thread:pos t) (vref t 0))
(define (thread:prev t) (vref t 1))

;;  queue 型 (複数の解析過程を入れておくキュー)
;;	(queue:make arg1 arg2 ...) … arg1, arg2.. を初期値としてキュー作成。
;;	(quene:empty? #<queue>)	   … キューは空か?
;;	(quene:enq! #<queue> x)	   … キューに入れる。
;;	(quene:deq! #<queue>)	   … キューから取り出す。
;;	(quene:disp #<queue>)	   … キューの表示 (デバッグ用)。
;;
(define (queue:make . qs)
  (lambda (f arg)
    (cond ((eq? f 'empty?) (null? qs))
	  ((eq? f 'enq!) (set! qs (append qs (list arg))))
	  ((eq? f 'deq!) (let ((x (car qs))) (set! qs (cdr qs)) x))
	  ((eq? f 'disp) (display qs) (newline)))))
(define (queue:empty? q) (q 'empty? #f))
(define (queue:enq! q x) (q 'enq! x))
(define (queue:deq! q)   (q 'deq! #f))
(define (queue:disp q)   (q 'disp #f))

;;  dict 型 (辞書…ただ形態素をリストで並べただけ)
;;	(dict:open "ファイル名")         … ファイルから辞書を読み込む。
;;	(dict:foreach #<dict> (lambda (要素) ..))
;;		… 辞書中の各要素に手続きを適用する。
;;
(define (dict:open f)
  (let ((s (stream:open f)))
    (define (loop dict)
      (let ((r (stream:read s)))
	(if r
	    (loop
	     (if (= 3 (length r))
		 (cons (morpheme:make
				 (car r)
				 (string->symbol (cadr r))
				 (caddr r)) dict)
		 dict))
	    (begin (stream:close s) dict))))
    (loop '())))
(define (dict:foreach dict proc)
  (for-each proc dict))

;;  ctable 型 (接続表…ある品詞がどの品詞に接続可能かを連想リストで表現)
;;	(ctable:open "ファイル名")  … ファイルから接続表を読み込む。
;;	(ctable:connectable? #<ctable> #<morpheme> #<morpheme>) 
;;		… 与えられた形態素 2つは接続可能か?
;;
(define (ctable:open f)
  (let ((s (stream:open f)))
    (define (loop ctab c0 cs)
      (let ((r (stream:read s)))
	(if r 
	    (cond
	     ((car r)
	      (loop (if ctab (cons (cons c0 cs) ctab) '())
		    (and (not (str=? "-" (car r))) 
			 (string->symbol (car r))) '()))
	     ((= 2 (length r))
	      (loop ctab c0 (cons (string->symbol (cadr r)) cs)))
	     (else
	      (loop ctab c0 cs)))
	    (begin (stream:close s) ctab))))
    (loop #f #f #f)))
(define (ctable:connectable? ctab m1 m2)
  (memv (morpheme:psp m2) 
	(cdr (assv (and m1 (morpheme:psp m1)) ctab))))

;;  (morph:analyze "文字列" #<dict> #<ctable>)
;;	形態素解析メイン。与えられた文字列を解析し、結果を matrix 型で返す。
;;
(define (morph:analyse str dict ctab)
  ; データを初期化する。
  (define thrdq (queue:make (thread:make 0 #f)))
  (define mat (matrix:make (strlen str)))
  
  ; proceed: 解析し matrix をつくる。
  (define (proceed)
    ;(queue:disp thrdq) ; for debug
    (if (not (queue:empty? thrdq))
	(let* ((t1 (queue:deq! thrdq))
	       (pos (thread:pos t1))
	       (prev (thread:prev t1)))
	  ; キューからひとつスレッドとりだし、それが進められるようならば
	  ; それをすすめてキューに入れる。キューが空になるまで繰り返す。
	  (dict:foreach
		dict
		(lambda (m1)
		  (if (and (morpheme:proceed? m1 str pos)
			   (ctable:connectable? ctab prev m1))
		      (let ((end (+ pos (morpheme:len m1))))
			(matrix:ins! mat pos end m1)
			(queue:enq! thrdq (thread:make end m1))))))
	  (proceed))))

  ; refine: できた matrix から余計なものをとり除く。
  (define (refine n)
    (matrix:elim!
	    mat
	    (lambda (b0 e0 m0)
	      (and (not (= e0 (strlen str)))
		   ; 途中で止まってしまった(末端の)解析結果をひとつ削除。
		   (null? (matrix:retr
				  mat
				  (lambda (b1 e1 m1)
				    (and (= e0 b1)
					 (ctable:connectable? ctab m0 m1))))))))
    (if (< (matrix:size mat) n)		; 数が減らなくなるまで繰り返す。
	(refine (matrix:size mat))))
  
  (proceed)
  (refine (matrix:size mat))
  mat)

;;  (morph:expand #<matrix> #<ctable>)
;;	解析結果をすべて展開して表示する。
;;
(define (morph:expand mat ctab)
  (define (loop i m0 r)
    (if (= i (matrix:maxlen mat))
	(begin
	  (for-each (lambda (m) (display (morpheme:sem m)))
		    (reverse r))
	  (newline))
	(matrix:foreach
		mat
		(lambda (beg end m1)
		  (if (and (= i beg) (ctable:connectable? ctab m0 m1))
		      (loop (+ i (morpheme:len m1)) m1 (cons m1 r)))))))
  (loop 0 #f '()))

;;  使用例
;;
(define dict (dict:open "dict1.txt"))
(define ctab (ctable:open "conn1.txt"))
(define (analyze str)
  (morph:expand (morph:analyse str dict ctab) ctab))

(analyze "うらにわにはにわにわにはにわにわとりがいる")
;(analyze "すもももももももものうち")