;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: pidginize.lsp
;;;;    System: FIRE
;;;;   Version: 1.0
;;;;    Author: Sven E. Kuehne
;;;;   Created: January 15, 2001 16:47:50
;;;;   Purpose: 
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Monday, May 17, 2004 at 22:31:47 by Madeline
;;;; ---------------------------------------------------------------------------

(in-package :fire)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Enable/disable Cyc prettyNames
(defparameter *use-prettyNames* nil)
(defparameter *pretty-name-fn* 'get-prettyname-for)


;;; Keywords

(defparameter *conjunction-keywords* '(:AND :OR :AND-OR))

;;; PIDGINIZE 
;;; - should probably be part of the API.

(defun pidginize (expression &key (prettynames? nil) 
                                  (prettyname-fn 'get-prettyname-for))
  "If pretty-name-fn, is provided, it should be a function of one argument --
   the term whose prettyname should be found.  Must return a string that is 
   the term's prettyname."
  (when (listp expression)
    (let ((*use-prettyNames* prettynames?)
          (*pretty-name-fn* prettyname-fn)
          (*package* (find-package :data)))
      (beautify-pidgin-string (pidginize-expression expression)))))


;;; PIDGINIZE-EXPRESSION
;;; - generates genFormat string for a nested expression

(defun pidginize-expression (expression)
  "Pidginizes an expression using Cyc's genFormat strings"
  (cond ((not (some #'consp expression))
         (pidginize-flat-expression expression))
        (t 
         (let ((pidginized-args nil))
           (dolist (arg (cdr expression))
             (cond ((or (symbolp arg) (numberp arg))
                    (push arg pidginized-args))
                   ((listp arg)
                    (push (pidginize-expression arg) pidginized-args))
                   (t nil)))
           (pidginize-flat-expression 
            (cons (car expression) (nreverse pidginized-args)))))))


;;; PIDGINIZE-FLAT-EXPRESSION
;;; - generates genFormat string for a flat expression
;;; - returns string of unmodified expression if no genFormat can be found 
;;;   in kb

(defun pidginize-flat-expression (expression)
  "Pidginizes a flat expression using Cyc's genFormat strings."
  (cond (nil ;; (n-ary-expression? expression)  ;; THIS BRANCH BROKEN!!!!!! KDF
         (pidginize-n-ary-expression expression))
        ((listp expression)
         (pidginize-fixed-arity-expression expression))
        (t
         (pidginize-default expression))))

(defun pidginize-fixed-arity-expression (expression)
  (multiple-value-bind (gf-string gf-argorder)
      (genformat-string-and-arg-order-list expression)
    (cond ((and gf-string gf-argorder) 
           (let ((arglist (get-arglist (cdr expression) gf-argorder))
                 (string (format nil "~a~a~a" "~1{" gf-string "~}")))
             (format nil string arglist)))
          (t
           (pidginize-default expression)))))

(defun pidginize-default (expression)
  (format nil "~s" expression))



(defun pidginize-n-ary-expression (expression)
  "Pidginize the n-ary expression EXPRESSION."
  (multiple-value-bind (format-string arg-order-list)
      (genformat-string-and-arg-order-list expression)
    (cond ((and format-string arg-order-list)
           (format nil format-string 
             (pidginize-n-ary-expression-args (cdr expression) 
                                              arg-order-list)))
          (t
           (pidginize-default expression)))))

(defun pidginize-n-ary-expression-args (arg-list arg-order-list &optional (first? t))
  "Pidginize the arguments of an n-ary relation, ARG-LIST, with ARG-ORDER-LIST."
  (let* ((args-format (when (listp arg-order-list) (first arg-order-list)))
         (conjunction (find-conjunction-keyword arg-order-list)))
    (case (length arg-list) 
      (0 "")
      (1
       (if first? 
         (pidginize-term (car arg-list))
         (concatenate 'string
           " "
           (pidginize-conjunction-keyword conjunction)
           " "
           (format-argument (car arg-list) args-format))))
      (otherwise
       (concatenate 'string
         (if first? "" ", ")
         (format-argument (car arg-list) args-format)
         (pidginize-n-ary-expression-args (cdr arg-list) arg-order-list nil))))))

(defun pidginize-term (thing) ;; KDF: Added stub since it wasn't defined.
  (cond ((not (consp thing)) (format nil "~A" thing))
        (t (pidginize-expression thing))))

(defun conjunction-keywordp (obj)
  "Is OBJ a conjunction keyword (:AND, :AND-OR, or :OR)?"
  (member obj *conjunction-keywords*))

(defun find-conjunction-keyword (format-list)
  "Find a conjunction keyword (:AND, :AND-OR, or :OR) in FORMAT-LIST."
  (when (and (listp format-list) (listp (car format-list)))
    (find-if 'conjunction-keywordp
             (append format-list
                     ;; hack b/c the genformat syntax is inconsistent
                     (car format-list)))))

(defun pidginize-conjunction-keyword (keyword)
  "The realization of conjunction keyword KEYWORD in English."
  (case keyword
    (:OR "or")
    (:AND-OR "and/or")
    (t "and")))

(defun beautify-pidgin-string (string)
  "Beautifies the raw genFormat results by capitalizing the first char 
   and adding a period at the end."
  (let ((last-char (char string (1- (length string))))
        (str (nstring-upcase string :start 0 :end 1)))
    (if (char= last-char #\?)
      str
      (concatenate 'string str "."))))



(defun genformat-string-and-arg-order-list (expr)
  "Both GENFORMAT's format string and GENFORMAT's arg-order-list (values)."
  (let ((genformat (get-genformat-for expr)))
    (cond ((eq (first genformat) 'd::genFormat)
           (values (third genformat) (fourth genformat)))
          ((eq (first genformat) 'd::genQuestion)
           (values (fourth genformat) (fifth genformat)))
          (t nil))))

(defun get-genformat-for (expr)
  "Retrieve genFormat data for an expression from the KB"
  (let ((pred (car expr))
        (var-pos (variable-arg-pos expr)))
    (or (and var-pos
             (first (retrieve `(d::genQuestion ,pred ,var-pos ?x ?y))))
        (first (retrieve `(d::genFormat ,pred ?x ?y))))))

(defun variable-arg-pos (expr)
  ;; If the expression has one (and only one) variable in it, returns an 
  ;; integer indicating the position of that argument (1-indexed from the
  ;; beginning of the arg-list).
  (let ((arg-pos nil)
        (j 1))
    (dolist (arg (cdr expr))
      (when (variable? arg)
        (if arg-pos
          ;; then already found one variable -- too many!  return nil
          (return-from variable-arg-pos nil)
          ;; otherwise record the position
          (setq arg-pos j)))
      (incf j))
    arg-pos))



;;; (defun get-arglist (args order)
;;;   "Pairs arguments with their position in the genFormat string (if order is given
;;;    by genFormat, otherwise just use args as in expression)."
;;;   (cond (order
;;;          (let ((pairs (nconc (mapcar #'cons args order)))
;;;                (arglist nil))
;;;            (dolist (pair (sort pairs 
;;;                                (lambda (p1 p2) 
;;;                                  (> (if (listp (cdr p1)) (cadr p1) (cdr p1))
;;;                                     (if (listp (cdr p2)) (cadr p2) (cdr p2))))))
;;;              (if (listp (cdr pair))
;;;                (push (format-argument (car pair) (cddr pair)) arglist)
;;;                (push (format-argument (car pair)) arglist)))
;;;            arglist))
;;;         (t
;;;          args)))
;;;
;;; This new version below is smart about the optional information for the
;;; pluralization of arguments. Works for both numbers and terms.

(defun get-arglist (args positions)
  "Pair arguments with their position in the genFormat string (if order is given
   by genFormat, otherwise just use args as in expression."
  (cond ((listp positions)
         (let ((arglist nil)
               (last-position nil)
               (last-arg))
           (dolist (position positions)
             (cond ((and (numberp position) (atom position))
                    ;;; no additional format information, just position
                    (let ((arg (nth (1- position) args)))
                      (push (format-argument arg) arglist)
                      (setf last-position position)
                      (setf last-arg arg)))
                   ((and (consp position) (numberp (car position)))
                    ;;; additional formatting required by genFormat
                    (let ((arg (nth (1- (car position)) args)))
                      (push (format-argument arg (cdr position)) arglist)
                      (setf last-position position)
                      (setf last-arg arg)))
                   ((and (consp position) (stringp (car position)))
                    ;;; optional pluralization based on previous argument
                    (if (or (and (consp last-position)
                                 (nunion '(:plural :pn-plural :agentive-pl) (cadr last-position)))
                            (and (integerp last-arg) (/= last-arg 1)))
                      (push (cadr position) arglist)
                      (push (car position) arglist)))
                   ))
           (nreverse arglist)))
        (t
         (mapcar #'format-argument args))))


;;; FORMAT-ARGUMENT
;;; - this is the hook for modifications of the individual arguments
;;;   before they are plugged into the genFormat string.
;;; - for example, genFormat returns the following information for the 
;;;   two arguments of GENLS:
;;;     arg1: (SINGULAR GERUND (MASS-NUMBER ALL-THE-WORD) AGENTIVE-SG PN-SINGULAR EVERY-THE-WORD)
;;;     arg2: (SINGULAR GERUND AGENTIVE-SG PN-SINGULAR (MASS-NUMBER) A-THE-WORD)
;;; - what can we do with this extra format information?

(defun format-argument (arg &optional (format-info nil))
  "Format the argument depending on additional genFormat information, 
   e.g. article and plurals"
  ;;; Use the strange, pluralized prettyNames only on request
  (let ((term (if (and *use-prettyNames* *pretty-name-fn*)
                (funcall *pretty-name-fn* arg)
                arg)))
    (cond ((is-massnoun? term)
           (format-mass-noun-term term format-info))
          (format-info
           (add-determiner term format-info))
          (t
           term))))


;;; prettyNames are a fine idea, but the flat file we have uses strange plural
;;; form, resulting in rather ugly strings.

(defun get-prettyname-for (term)
  "Retrieves the prettyName for a term (if available)"
  (let ((prettyname (first (fire:retrieve `(data::prettyName ,term data::?x)))))
    (cond (prettyname
           (third prettyname))
          (t 
           term))))


;;; We might have to redo the determiners once we have access to the full cyc 
;;; lexicon. Right now we cannot make a decision when genFormat returns two 
;;; possible determiners, because we don't have the lexicon information for 
;;; the term. For now we use the least restricted default determiner in such 
;;; cases.

(defun add-determiner (term format-info)
  (cond ((member :A-THE-WORD format-info)
         (a-or-an term))
        ((member :THE-THE-WORD format-info)
         (format nil "the ~a" term))
        ((member :EVERY-THE-WORD format-info)
         (format nil "every ~a" term))
        ((member :ALL-THE-WORD format-info)
         (format nil "all ~a" term))
        ((member :SOME-THE-WORD format-info)
         (format nil "some ~a" term))
        ((member :POSSESSIVE format-info)
         (format nil "~a's" term))
        (t
         (a-or-an term))))


(defun is-massnoun? (term)
  "Checks if term is labeled as a mass noun."
  (fire:retrieve `(data::genMassNoun ,term)))


(defun format-mass-noun-term (term format-info)
  "Modifies mass noun term"
  (let ((mass-noun-format (find-in-tree :MASS-NUMBER format-info)))
    (if mass-noun-format
      (add-determiner term mass-noun-format)
      (format nil "~a" term))))


(defun find-in-tree (item tree)
  "Returns first cons of tree containing item."
  (cond ((null tree) nil)
        ((atom tree) 
         (when (eq tree item) tree))
        ((member item tree)
         tree)
        (t
         (or (find-in-tree item (car tree))
             (find-in-tree item (cdr tree))))))


(defun a-or-an (term)
  "Simplification of a-to-an conversion."
  (cond ((member (char (string term) 0) '(#\a #\e #\i #\o #\u) :test 'char-equal)
         (format nil "an ~a" term))
        (t
         (format nil "a ~a" term))))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; End of Code