;;; mule-category.el --- category functions for XEmacs/Mule.

;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc.
;; Copyright (C) 1995 Amdahl Corporation.
;; Copyright (C) 1995 Sun Microsystems.

;; This file is part of XEmacs.

;; XEmacs 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.

;; XEmacs 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 XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Commentary:

;; Functions for working with category tables, which are a particular
;; type of char table.  Some function names / arguments should be
;; parallel with syntax tables.

;; Written by Ben Wing <wing@666.com>.  The initialization code
;; at the end of this file comes from Mule.

;;; Code:

(defvar defined-category-hashtable (make-hashtable 50))

(defun define-category (designator doc-string)
  "Make a new category whose designator is DESIGNATOR.
DESIGNATOR should be a visible letter of ' ' thru '~'.
STRING is a doc string for the category.
Letters of 'a' thru 'z' are already used or kept for the system."
  (check-argument-type 'category-designator-p designator)
  (check-argument-type 'stringp doc-string)
  (puthash designator doc-string defined-category-hashtable))

(defun undefine-category (designator)
  "Undefine DESIGNATOR as a designator for a category."
  (check-argument-type 'category-designator-p designator)
  (remhash designator defined-category-hashtable))

(defun defined-category-p (designator)
  "Return non-nil if DESIGNATOR is a designator for a defined category."
  (and (category-designator-p designator)
       (gethash designator defined-category-hashtable)))

(defun defined-category-list ()
  "Return a list of the currently defined categories.
Categories are given by their designators."
  (let (list)
    (maphash #'(lambda (key value)
		 (setq list (cons key list)))
	     defined-category-hashtable)
    (nreverse list)))

(defun undefined-category-designator ()
  "Return an undefined category designator, or nil if there are none."
  (let ((a 32) found)
    (while (and (< a 127) (not found))
      (if (gethash a defined-category-hashtable)
	  (setq found a))
      (setq a (1+ a)))
    found))

(defun category-doc-string (designator)
  "Return the doc-string for the category denoted by DESIGNATOR."
  (check-argument-type 'defined-category-p designator)
  (gethash designator defined-category-hashtable))

(defun modify-category-entry (char-range designator &optional table reset)
  "Add a category to the categories associated with CHAR-RANGE.
CHAR-RANGE is a single character or a range of characters,
 as per `put-char-table'.
The category is given by a designator character.
The changes are made in TABLE, which defaults to the current buffer's
 category table.
If optional fourth argument RESET is non-nil, previous categories associated
 with CHAR-RANGE are removed before adding the specified category."
  (or table (setq table (category-table)))
  (check-argument-type 'category-table-p table)
  (check-argument-type 'defined-category-p designator)
  (if reset
      ;; clear all existing stuff.
      (put-char-table char-range nil table))
  (map-char-table
   #'(lambda (key value)
       ;; make sure that this range has a bit-vector assigned to it,
       ;; and set the appropriate bit in that vector.
       (if (not (bit-vector-p value))
	   (progn
	     (setq value (make-bit-vector 95 0))
	     (put-char-table key value table)))
       (aset value (- designator 32) 1))
   table char-range))

(defun char-category-list (char &optional table)
  "Return a list of the categories that CHAR is in.
TABLE defaults to the current buffer's category table.
The categories are given by their designators."
  (or table (setq table (category-table)))
  (check-argument-type 'category-table-p table)
  (let ((vec (get-char-table char table)))
    (if (null vec) nil
      (let ((a 32) list)
	(while (< a 127)
	  (if (= 1 (aref vec (- a 32)))
	      (setq list (cons a list)))
	  (setq a (1+ a)))
	(nreverse list)))))

(defun char-in-category-p (char category &optional table)
  "Return non-nil if CHAR is in CATEGORY.
TABLE defaults to the current buffer's category table.
Categories are specified by their designators."
  (or table (setq table (category-table)))
  (check-argument-type 'category-table-p table)
  (check-argument-type 'category-designator-p category)
  (let ((vec (get-char-table char table)))
    (if (null vec) nil
      (= 1 (aref vec (- category 32))))))

(defun describe-category ()
  "Describe the category specifications in the category table.
The descriptions are inserted in a buffer, which is then displayed."
  (interactive)
  (with-output-to-temp-buffer "*Help*"
    (describe-category-table (category-table) standard-output)))

(defun describe-category-table (table stream)
  (let (first-char
	last-char
	prev-val
	(describe-one #'(lambda (first last value stream)
			  (if (and (bit-vector-p value)
				   (> (reduce '+ value) 0))
			      (progn
				(if (equal first last)
				    (cond ((vectorp first)
					   (princ (format "%s, row %d"
							  (charset-name
							   (aref first 0))
							  (aref first 1))
						  stream))
					  ((charsetp first)
					   (princ (charset-name first) stream))
					  (t (princ first stream)))
				  (cond ((vectorp first)
					 (princ (format "%s, rows %d .. %d"
							(charset-name
							 (aref first 0))
							(aref first 1)
							(aref last 1))
						stream))
					(t
					 (princ (format "%s .. %s" first last)
						stream))))
				(describe-category-code value stream))))))
    (map-char-table
     #'(lambda (range value)
	 (if (and (or
		   (and (characterp range)
			(characterp first-char)
			(eq (char-charset range) (char-charset first-char))
			(= (char-int last-char) (1- (char-int range))))
		   (and (vectorp range)
			(vectorp first-char)
			(eq (aref range 0) (aref first-char 0))
			(= (aref last-char 1) (1- (aref range 1))))
		  (equal value prev-val)))
	     (setq last-char range)
	   (if first-char
	       (progn
		 (funcall describe-one first-char last-char prev-val stream)
		 (setq first-char nil)))
	   (funcall describe-one range range value stream))
	 nil)
     table)
    (if first-char
	(funcall describe-one first-char last-char prev-val stream))))

(defun describe-category-code (code stream)
  (let ((standard-output (or stream standard-output)))
    (princ "\tin categories: ")
    (if (not (bit-vector-p code))
	(princ "(none)")
      (let ((i 0)
	    already-matched)
	(while (< i 95)
	  (if (= 1 (aref code i))
	      (progn
		(if (not already-matched)
		    (setq already-matched t)
		  (princ " "))
		(princ (int-char (+ 32 i)))))
	  (setq i (1+ i)))
	(if (not already-matched)
	    (princ "(none)")))
      (let ((i 0))
	(while (< i 95)
	  (if (= 1 (aref code i))
	      (princ (format "\n\t\tmeaning: %s"
			    (category-doc-string (int-char (+ 32 i))))))
	  (setq i (1+ i)))))
    (terpri)))

(defconst predefined-category-list
  '((latin-1 ?l "Latin-1 through Latin-5 character set.")
    (latin-2 ?l)
    (latin-3 ?l)
    (latin-4 ?l)
    (latin-5 ?l)
    (greek ?g "Greek character set.")
    (arabic ?b "Arabic character set.")
    (hebrew ?w "Hebrew character set.")
    (japanese-kana ?k "Japanese 1-byte Katakana character set.")
    (japanese-roman ?r "Japanese 1-byte Roman character set.")
    (cyrillic ?y "Cyrillic character set.")
    (chinese-gb ?c "Chinese GB (China, PRC) 2-byte character set.")
    (japanese ?j "Japanese 2-byte character set.")
    (japanese-2 ?j)
    (chinese-cns-1 ?t "Chinese Taiwan (CNS or Big5) 2-byte character set.")
    (chinese-cns-2 ?t)
    (korean ?h "Hangul (Korean) 2-byte character set.")
    (chinese-big5-1 ?t)
    (chinese-big5-2 ?t))
  "List of predefined categories.
Each element is a list of a charset, a designator, and maybe a doc string.")

(let (i l)
  (define-category ?a "ASCII character set.")
  (setq i 32)
  (while (< i 127)
    (modify-category-entry i ?a)
    (setq i (1+ i)))
  (setq l predefined-category-list)
  (while l
    (if (nth 2 (car l))
	(define-category (nth 1 (car l)) (nth 2 (car l))))
    (modify-category-entry (car (car l)) (nth 1 (car l)))
    (setq l (cdr l))))

;;; At the present, I know Japanese and Chinese text can
;;; break line at any point under a restriction of 'kinsoku'.
(defvar word-across-newline "\\(\\cj\\|\\cc\\|\\ct\\)"
  "Regular expression of such characters which can be a word across newline.")
