;;;   -*- Mode: LISP; Package: CGP; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;
;; Copyright (C) Paul Meurer 1999-2004. All rights reserved.
;; paul.meurer@aksis.uib.no
;; Aksis, University of Bergen
;;
;; Named entity constraints for Constraint Grammar Parser

;;-------------------------------------------------------------------------------------
;; TO DO:
;; - Simplify mapping code
;;-------------------------------------------------------------------------------------

(in-package "CGP")

(defmethod rule-type ((rule named-entity-mapping-rule))
  '=nm)

;; doubling method for constraint-grammar! fix!
(defmethod operator-to-rule-class ((cg ne-constraint-grammar) operator)
  (case operator
    ((=n!) (values 'named-entity-select-rule 0))
    ((=n0) (values 'named-entity-discard-rule 0))
    (otherwise (call-next-method))))

(defmethod define-named-entity-tag ((cg constraint-grammar) symbol)
  (declare (ignore symbol))
  nil)

(defmethod define-named-entity-tag ((cg ne-constraint-grammar) symbol)
  (setf (gethash symbol (named-entity-tags cg)) t))

(defun define-named-entity-tags (symbol-list &key (cg *cg*) (clearp t))
  (when clearp
    (clrhash (named-entity-tags cg))
    (setf (%named-entity-tag-codes cg) t))
  (mapc (lambda (symbol) (define-named-entity-tag cg symbol)) symbol-list))

#+test
(maphash (lambda (name cg)
	   (declare (ignore name))
	   (let ((*cg* cg))
	     (when (slot-exists-p cg 'named-entity-tags)
	       (define-named-entity-tags
		   '(&person &tittel &institusjon &sted)))))
	 *cg-table*)

(defmethod mapping-rule-class+accessor ((cg ne-constraint-grammar) labels)
  (if (gethash (car labels) (syntactic-functions cg))
      (values 'mapping-rule #'morphosyntactic-mappings #'syntactic-functions)
    (values 'named-entity-mapping-rule #'named-entity-mappings #'named-entity-tags)))

(defmethod named-entity-mapping-feature-codes ((cg ne-constraint-grammar))
  (with-slots (%named-entity-mapping-features named-entity-mappings) cg
    (when (eq %named-entity-mapping-features t)
      (setf %named-entity-mapping-features
            (loop for pos across (code-vector-sort-array cg)
                  for feature = (aref (feature-vector cg) pos)
                  when (gethash feature named-entity-mappings)
                  collect (feature-code feature))))
    %named-entity-mapping-features))

#-rule-tree-xx
(defmacro do-named-entity-mapping-rules ((rule reading cg) &body body)
  "Loops over the RULEs applicable for the given READING executing BODY."
  (let ((%rule (gensym)))
    `(with-slots (named-entity-mappings) ,cg
       (loop for code in (named-entity-mapping-feature-codes ,cg)
             when (has-feature-code-p (cdr ,reading) code)
             do (dolist (,%rule (gethash (code-feature code) named-entity-mappings))
                  (let ((,rule (when (feature-subset-p ,cg (car ,%rule) ,reading)
                                 (cdr ,%rule))))
                    (when ,rule
                      ,@body)))))))

(defmethod apply-named-entity-mapping-rules ((cg ne-constraint-grammar) sentence position)
  (let* ((cohort (cohort sentence position))
         (cohort-length (length cohort)))
    (dotimes (i cohort-length)
      (let ((reading (nth i cohort)))
        (when reading
          (block reading
	    (do-named-entity-mapping-rules (rule #+rule-tree-xx sentence
						 #+rule-tree-xx position reading cg)
              (when (apply-rule rule sentence position i)
		(return-from reading)))))))))

(defmethod named-entity-map-sentence ((cg ne-constraint-grammar) sentence)
  (dotimes (pos (sentence-length sentence))
    (apply-named-entity-mapping-rules cg sentence pos))
  sentence)

(defmethod named-entity-disambiguate-sentence ((cg ne-constraint-grammar) sentence
					       &optional (start-position 0))
  (loop with repeat-pos = start-position and repeat-p = nil
        do (loop for pos from repeat-pos to (1- (sentence-length sentence))
                 when (apply-named-entity-disambiguation-rules cg sentence pos)
                 do (setf repeat-pos pos repeat-p nil)) ;; set REPEAT-P to T for iteration!
        while repeat-p
        do (setf repeat-p nil))
  sentence)

(defmethod h-named-entity-disambiguate-sentence ((cg constraint-grammar) sentence &optional (level 1))
  (dotimes (pos (sentence-length sentence))
    (apply-named-entity-disambiguation-rules cg sentence pos level))
  sentence)

(defmethod named-entity-tag-codes ((cg ne-constraint-grammar))
  (with-slots (named-entity-tags %named-entity-tag-codes) cg
    (when (eq %named-entity-tag-codes t)
      (setf %named-entity-tag-codes ())
      (maphash (lambda (named-entity-tag value)
                 (declare (ignore value))
                 (push (feature-code named-entity-tag)
                       %named-entity-tag-codes))
               named-entity-tags))
    %named-entity-tag-codes))

(defmethod apply-named-entity-disambiguation-rules ((cg ne-constraint-grammar) sentence position
                                                           &optional (heuristic-level 0))
  (apply-syntactic-disambiguation-rules cg sentence position heuristic-level
                                        (named-entity-tag-codes cg)
                                        '(:domains-named-entity-select
                                          :domains-named-entity-discard
                                          :named-entity-select
                                          :named-entity-discard)))

(defmethod apply-rule ((rule named-entity-select-rule) sentence position reading)
  (declare (ignore sentence position))
  (dolist (code (named-entity-tag-codes *cg*))
    (setf (sbit (cdr reading) code) 
          (if (= code (feature-code (rule-target rule))) 1 0)))
  t)

(defmethod apply-rule ((rule named-entity-discard-rule) sentence position reading)
  (declare (ignore sentence position))
  (setf (sbit (cdr reading) (feature-code (rule-target rule))) 0)
  t)

:eof