(in-package "KPML")

;;; File: features.lisp
;;; Licheng Zeng, 1992 (was: ml-penman-feature-class.lisp)

;/*-----------------------------------------------------------------------
;                Implentation of Feature-Information Class
;/*-----------------------------------------------------------------------
;
;struct feature_info :: system {
;
;	struct exact-feature-def {
;
;		symbol		feature-name;
;		struct {	
;			symbol	ls;
;			list	waiting-systems;
;		        } 	waiting[number-of-languages];
;		struct {	
;			symbol	ls;
;			list	feature-list-as-preselections-of-a-feature;
;		        } 	preselection-features[number-of-languages];
;		struct {	
;			symbol	ls;
;			list	list-of-systems-chosing-this-feature;
;		        } 	chosen-by [number-of-languages];
;
;		logical		voidness;
;		list		eligible-languages; /* list of languages that are eligible for accessing this feature, new */
;		} 	feature-information[number-of-all-features];
;
;	/*-- special data structures for features. They are replacements for original Penman code --*/
;
;	list		path-features; 	
;	list		feature-selections;
;
;       /* functions on the data structure */
;
;	list		get_features_of_one_language(ls);
;	list		fetch-exact-feature-def-field(field, feature-name, &optional ls);
;	list		replace-exact-feature-def-field(field, feature-name, &optional ls);
;       list            fetch-input-features(system-name, &optional ls);
;	void		compute-paths(void);      /* replacement for Penman compute-paths functions */
;
;	}
;/*----------------------------------------------------------------------------------------------------------------------*/

(defstruct exact-feature-def "entry of feature-information"
	   (waiting nil)
	   (preselection-features nil)
	   (chosen-by nil)
	   (voidness nil))

;-------------------------------------------------------------------------------------------------------------------------
; syntax: fetch-exact-feature-def-field(field-name, feature-name, &optional language specifier)
; return: value of a feature in the field-name domain, under the situation of language specifier
; assume: CurLan. Replacing old function. existence of feature-information DB;
; target: as the name implies; If both CurLan and ls are nil, the function is exactly the same as the original code.
; global: All_languages, feature-information DB;
; symbol: DB = feature-information;
;         ftr-info = an instance of DB;
; pseudo: search DB for feature-name; if no found return nil, else we obtain ftr-info;
;         case field-name of:
;         waiting: return (cdr (assoc ls ftr-info.waiting)) if ls exists in the field, otherwise nil;
;         preselection-features: return (cdr (assoc ls ftr-info.preselection)) if ls exists, otherwise nil;
;         chosen-by: (cdr (assoc ls ftr-info.chosen-by)) if ls exists, otherwise nil;
;         language-set: get union of all different LSs in waiting, preselection and chosen-by;
;         otherwise: nil
;------------------------------------------------------------------------------------------------------------------------

(defun fetch-exact-feature-def-field (field feature &optional ls)
  (let ((ftr-info (gethash feature feature-information)) info)

    (unless ftr-info (return-from fetch-exact-feature-def-field nil))
    (unless ls (setq ls CurLan))
    (unless ls
      (case field
	(waiting (return-from fetch-exact-feature-def-field (exact-feature-def-waiting ftr-info )))
	(preselection-features (return-from fetch-exact-feature-def-field(exact-feature-def-preselection-features ftr-info)))
	(chosen-by (return-from fetch-exact-feature-def-field (exact-feature-def-chosen-by ftr-info)))
	(t (return-from fetch-exact-feature-def-field nil)))
      ) ; use the old code when ls = curlan = nil

    (case field
      (waiting (setq info (assoc ls (exact-feature-def-waiting ftr-info)))
	       (if info (return-from fetch-exact-feature-def-field (cdr info)) nil))
      (preselection-features (setq info (assoc ls (exact-feature-def-preselection-features ftr-info)))
	       (if info (return-from fetch-exact-feature-def-field (cdr info)) nil))
      (chosen-by (setq info (assoc ls (exact-feature-def-chosen-by ftr-info)))
	       (if info (return-from fetch-exact-feature-def-field (cdr info)) nil))
      (language-set (union 
		      (for each in (exact-feature-def-waiting ftr-info) collect (car each))
		      (union
			(for each in (exact-feature-def-preselection-features ftr-info) collect (car each))
			(for each in (exact-feature-def-chosen-by ftr-info) collect (car each))
			))) ; a luxury of ML-Penman
      (t nil))
))


;-------------------------------------------------------------------------------------------------------------------------
; syntax: replace-exact-feature-def-field(field-name, feature-name, new-value, &optional language specifier)
; return: new-value; Also a new entry in feature-information might be inserted;
; assume: CurLan.  existence of feature-information DB;
; target: as the name implies; If both CurLan and ls are nil, the function is exactly the same as the original code.
; global: feature-information DB; ALL_LANGUAGES
; symbol: DB = feature-information;
;         ftr-info = an instance of DB;
; pseudo: we are using object-oriented methodology here. A feature-info may be viewed as: a row consisting of columns of
;         waiting, preselection, chosen-by etc., and a column consisting of several items sorted according to LS. Hence
;         the algorithm naturally becomes: replace row, replace column and replace item. This strategy may result in longer
;         source code or low efficiency, but quite clear. 
;         To summarize, the general strategy here is: if a (LS.ftr) pair exists, ftr gets replaced, 
;         otherwise, the pair is inserted into one of the columns.
;------------------------------------------------------------------------------------------------------------------------

(defun replace-exact-feature-def-field (field feature new-value &optional ls)
  (let ((ftr-info (gethash feature feature-information)))

    (unless ftr-info (setq ftr-info (make-exact-feature-def)))
    (unless ls (setq ls CurLan))
    (unless ls (setq ls ALL_LANGUAGES))
    (case field
      (waiting (setf (exact-feature-def-waiting ftr-info) 
		     (replace-feature-info-column (exact-feature-def-waiting ftr-info) new-value ls)))
      (preselection-features (setf (exact-feature-def-preselection-features ftr-info) 
				   (replace-feature-info-column (exact-feature-def-preselection-features ftr-info) new-value ls)))
      (chosen-by (setf (exact-feature-def-chosen-by ftr-info) 
		       (replace-feature-info-column (exact-feature-def-chosen-by ftr-info) new-value ls)))
      (t nil)
      )
    (setf (gethash feature feature-information) ftr-info)
))

(defun replace-feature-info-column (value-list value ls)
  (if (atom ls) (setq ls (list ls)))
  (for eachLS in ls do 
       (if (assoc eachLS value-list) (rplacd (assoc eachLS value-list) value)(push (cons eachLS value) value-list))) ;replace item
  value-list)

;
; setf fetch-exact-feature-def-field: to be compatible with the original usage;
;

(defsetf fetch-exact-feature-def-field 
    (field-name feature-name &optional LS) (new-value) 
  `(replace-exact-feature-def-field ,field-name ,feature-name ,new-value ,LS) )

;;; ----------------------------------------------------------------------
;;; 1.0 addition...

(defun FEATURE-DEFINED-FOR-LG-P (feature lg)
  (let ((curlan lg))
    (if (who-has-as-output feature)
	T
      nil)))

;;; 2.0
(defun NEGATIVE-FEATURE-P (feature)
  (let ((f (string-downcase (string feature))))
    (loop for negs in *negative-feature-prefixes*
	thereis (let ((s (search negs f)))
		  (and s (numberp s) (= s 0))))))

;;; ----------------------------------------------------------------------

(defun LIST-GRAMMATICAL-FEATURES ()
  (hashtable-to-list all-output-features))


;;; ----------------------------------------------------------------------
;;; Following function takes a list of features and returns those
;;; grammatical functions that are affected differentially by the
;;; feature set... that is, if all features do some operation that
;;; is the same for all features, these functions are not returned.
;;; 
;;; 3.0 was returning the first parameter of commented realization
;;;     statements (because the first element is a * which pushes
;;;     the rest along a position). Fixed.

(defun GET-USED-MICROFUNCTIONS (feature-list)
  (when (consp feature-list)
    (let* ((realizations 
	    (mapcar #'(lambda (f)
                        (remove-if #'(lambda (rs) (equal (first rs) '*))
			           (cdr (assoc f 
				               (mapcar #'cdr
					               (fetch-system-outputs 
					                (first 
					                 (who-has-as-output f))))))))
		    feature-list))
	   (common 
	    (reduce #'(lambda (x y) (intersection x y :test #'equal)) 
		    realizations))
	   (different
	    (if (> (length feature-list) 1)
		(mapcar 
		 #'(lambda (rs-set)
		   (set-difference rs-set common :test #'equal))
	       realizations)
	    realizations))
	   (rs-set (loop for x in different append x)))
    
    (remove-duplicates
     (loop for rs in rs-set
	 as rs-type = (realization-op-type (first rs))
	 when (eq rs-type :fu-fu)
	 collect (second rs) and collect (third rs)
	 else
	 collect (second rs))))))


;;; 4.0 some classify and inflecty utilities...

(defun GET-CLASSIFY-INFLECTIFY-FEATURES (&optional (language curlan))
  (let ((curlan language))
    (sort
     (remove-duplicates
      (loop for (f realizations) 
            in (append (who-can-classify) (who-can-inflectify) (who-can-out-classify))
            append (loop for r in realizations append (cddr r))))
     #'string<)))


