;;; fuzzy-search.el --- fuzzy search methods.

;; Copyright (C) 2002 by Taiki SUGAWARA <taiki.s@cityfujisawa.ne.jp>

;; Author: Taiki SUGAWARA <taiki.s@cityfujisawa.ne.jp>
;; Version: $Id: fuzzy-search.el,v 1.7 2002/10/17 14:15:25 taiki Exp $
;; Keywords: search

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.


;;; Commentary:
;; 全角英数を簡単に検索したい人向け。
;; カタカナから半角カタカナを探す事もできるようになった。
;; migemo は重すぎるって人にもいいかも。

;;; Todo
;; もっと効率のいい正規表現を作れるようにしたい。
;; ↑少しなったかも。

;;; Code:

(eval-when-compile (require 'cl))

(put 'fuzzy-search-char-table 'char-table-extra-slots 0)
(defvar fuzzy-search-char-table nil)
(defvar fuzzy-search-japanese-char-table nil)
(defvar fuzzy-search-case-fold-char-table nil)
(defvar fuzzy-search-enable-p nil)
(defvar fuzzy-search-extra-char-alist
  '((?\[ ?「 ?『 ?【)
    (?\] ?」 ?』 ?】)
    (?. ?・ ?．)
    (?, ?，)
    (?- ?ー ?〜)))
(defvar fuzzy-search-extra-japanese-char-alist nil)
(defvar fuzzy-search-syntax-char-list
  '(?\[ ?\] ?- ?^))

(defun fuzzy-search-regexp-opt (chars)
  (when chars
    (let (normal-chars syntax-chars regexp)
      (dolist (c chars)
	(if (memq c fuzzy-search-syntax-char-list)
	    (push c syntax-chars)
	  (push c normal-chars)))
      (when normal-chars
	(setq regexp (concat "[" (apply 'string (nreverse normal-chars)) "]")))
      (when syntax-chars
	(setq regexp
	      (concat
	       "\\("
	       (mapconcat 'identity
			  (cons regexp
				(mapcar (lambda (c)
					  (regexp-quote (string c)))
					(nreverse syntax-chars)))
			  "\\|")
	       "\\)")))
      regexp)))

(defun fuzzy-search-get-char-list (list)
  (let (char-list)
    (dolist (x list)
      (cond ((stringp x)
	     (setq char-list (append (string-to-char-list x) char-list)))
	    ((characterp x)
	     (setq char-list (cons x char-list)))))
    (nreverse char-list)))

(defun fuzzy-search-aset-add (table idx list)
  (aset table idx (append list (aref table idx))))

(defun fuzzy-search-init ()
  "char-table の初期化。"
  (setq fuzzy-search-char-table
	(make-char-table 'fuzzy-search-char-table))
  (setq fuzzy-search-case-fold-char-table
	(make-char-table 'fuzzy-search-char-table))
  (setq fuzzy-search-japanese-char-table
	(make-char-table 'fuzzy-search-char-table))

  ;; 半角英数 -> 全角英数
  (dolist (cell japanese-alpha-numeric-table)
    (let ((ascii (cdr cell))
	  (jp (car cell)))
      (aset fuzzy-search-char-table ascii (list ascii jp))

      (let ((key (if (eq (downcase ascii) ascii)
		     ascii
		   (downcase ascii))))
	(fuzzy-search-aset-add fuzzy-search-case-fold-char-table
			       key (list ascii jp)))))

  ;; 全角カナ -> 半角カナ
  (dolist (cell japanese-kana-table)
    (aset fuzzy-search-japanese-char-table (cadr cell) (cdr cell)))

  ;; 全角記号 <-> 半角記号
  (dolist (cell japanese-symbol-table)
    (when (cadr cell)
      (aset fuzzy-search-char-table (cadr cell)
	    (list (cadr cell) (car cell)))
      (aset fuzzy-search-case-fold-char-table (cadr cell)
	    (list (cadr cell) (car cell))))
    (aset fuzzy-search-japanese-char-table (car cell) cell))


  ;; 半角 -> その他
  (dolist (cell fuzzy-search-extra-char-alist)
    (fuzzy-search-aset-add fuzzy-search-char-table
			   (car cell) (cdr cell))
    (fuzzy-search-aset-add fuzzy-search-case-fold-char-table
			   (car cell) (cdr cell)))

  ;; 全角 -> その他
  (dolist (cell fuzzy-search-extra-japanese-char-alist)
    (fuzzy-search-aset-add fuzzy-search-japanese-char-table
			   (car cell) (cdr cell)))

  (dolist (table (list fuzzy-search-char-table
		       fuzzy-search-case-fold-char-table
		       fuzzy-search-japanese-char-table))
    (map-char-table (lambda (char value)
		      (aset table char (fuzzy-search-regexp-opt
					(fuzzy-search-get-char-list value))))
		    table)))

(defun fuzzy-search-string-to-regexp (string)
  "STRING を fuzzy-search の正規表現に。"
  (let ((char-table (if case-fold-search
			fuzzy-search-case-fold-char-table
		      fuzzy-search-char-table)))
    (apply 'concat
	   (mapcar (lambda (char)
		     (or (aref char-table char)
			 (aref fuzzy-search-japanese-char-table char)
			 (string char)))
		   string))))

(defun fuzzy-search-forward (string &optional bound noerror count)
  "STRING を fuzzy-search で前方検索。"
  (interactive "sSearch: ")
  (re-search-forward (fuzzy-search-string-to-regexp string)
		     bound noerror count))

(defun fuzzy-search-backword (string &optional bound noerror count)
  "STRING を fuzzy-search で後方検索。"
  (interactive "sSearch: ")
  (re-search-backward (fuzzy-search-string-to-regexp string)
		      bound noerror count))

(defun fuzzy-search-toggle (&optional arg)
  "fuzzy-search をトグル。"
  (interactive "P")
  (setq fuzzy-search-enable-p
	(if (numberp arg)
	    (> arg 0)
	  (or arg (not fuzzy-search-enable-p))))
  (when fuzzy-search-enable-p
    (fuzzy-search-init))
  (message (if fuzzy-search-enable-p
	       "fuzzy search enabled!"
	     "fuzzy search disabled!")))

(defun fuzzy-search-enable ()
  "fuzzy-search を有効にする。"
  (interactive)
  (fuzzy-search-toggle 1))

(defun fuzzy-search-disable ()
  "fuzzy-search を無効にする。"
  (interactive)
  (fuzzy-search-toggle 0))

(defadvice isearch-search (around fuzzy-search-ad activate)
  "isearch で fuzzy-search できるようにする。"
  (let ((orig-search-forward  (make-symbol "orig-search-forward"))
	(orig-search-backward (make-symbol "orig-search-backward")))
    (if fuzzy-search-enable-p
	(progn
	  (fset orig-search-forward  (symbol-function 'search-forward))
	  (fset orig-search-backward (symbol-function 'search-backward))
	  (fset 'search-forward  (symbol-function 'fuzzy-search-forward))
	  (fset 'search-backward (symbol-function 'fuzzy-search-backword))))
    (unwind-protect
	ad-do-it
      (if fuzzy-search-enable-p
	  (progn
	    (fset 'search-forward  (symbol-function orig-search-forward))
	    (fset 'search-backward (symbol-function orig-search-backward)))))))

(provide 'fuzzy-search)

;;; fuzzy-search.el ends here