(in-package "KPML")

;;; File: basic-realizations.lisp
;;; (was buried in Penman's traverse.lisp).
;;; 
;;; KPML 0.8; John: March95.
;;;           ...code tidied up
;;;           ...agreement domains added (0.7.33?)
;;; KPML 2.0; John: March98
;;;           ... cleared of all use of CLISP.
;;;
;;; Basic realization statements that are defined for KPML-style
;;; systemic networks. Mostly Penman-inherited, with agreement domains
;;; added. Code commenting added in its entiriety! Main changes
;;; are moves towards providing more user access to defining new
;;; realization statements.

;;;========================================================================
;;; Make the treatment of realization operators in (ISI-)Penman at bit
;;; more flexible. Too often the list of realization operators and their
;;; checks are hardcoded into functions, such as is still the case in
;;; the following function. This should be changed by a more user-flexible
;;; means of defining new realization operators and dynamically creating
;;; the corresponding who-can-X functions. 
;;;
;;; (Note: old variable operators in variables.lisp used by the following:)

(defvar *register-microfunction-inserts* nil)

(defvar *public-realization-ops* nil)
;;; Following macro defines allowable realization operators...
;;; 
;;; 1.1
;;;  should be in a separate realization-statement declaration part...

;;; Syntax of following extended so that instead of single operators
;;; can also specify information concerning parameters. This information
;;; is necessary if the operator is going to appear appropriately in the
;;; editing windows, etc.
;;;  Eg.
;;;  (define-realization-operators (preselect :fn :fe)
;;;                                (order     :fn :fn)
;;;                                (span      :fn :p))

(defvar *real-op-parameters* (make-hash-table))

(defmacro DEFINE-REALIZATION-OPERATORS (&rest new-ops)
  `(loop for op in (quote ,new-ops) 
       when (symbolp op) do (pushnew op operators)
       else
       do 
       (progn ()
	      (if (member :private op)
		  (setf op (remove :private op))
		(pushnew (first op) *public-realization-ops*))
	      (pushnew (first op) operators)
	      (setf (gethash (first op) *real-op-parameters*)
		    (cond ((equal (cdr op) '(:fu :fe))
			   :fu-fe)
			  ((equal (cdr op) '(:fu :fu))
			   :fu-fu)
			  ((equal (cdr op) '(:fu :l))
			   :fu-l)
			  (t :fu))))))

(defun REALIZATION-OP-TYPE (op)
  (gethash op *real-op-parameters*))

;;; ----------------------------------------------------------------------
;;; Following info is added to the definition of
;;; realization operators: (1.1)
;;;
;;;  (i)  public or not. 
;;;  (ii) args (1 function; or 2 functions; or 1 function and
;;;       1 feature)


(define-realization-operators 
  (preselect :fu :fe )
  (order     :fu :fu  )
  (span      :fu :private)
  (classify  :fu :fe  )
  (conflate  :fu :fu  )
  (expand    :fu :fu  )
  (inflectify :fu :fe  )
  (insert     :fu  )
  (lexify     :fu :l  )
  (order      :fu :fu  )
  (orderatend :fu  )
  (orderatfront :fu  )
  (outclassify :fu :fe  )
  (partition :fu :fu)
  (preselect :fu :fe  ))
  
(defun PUBLIC-REALIZATION-OP-P (op)
  (member op *public-realization-ops*))


(DEFUN Number-Functions (Object-List)
  (cond
    ((listp Object-List)
     (loop for Object in Object-List collect (Number-Functions Object)))
    (Object-List
     (Tag-Fn-Name Object-List))))


;;; ----------------------------------------------------------------------
;;; 2.1 the previous function was just applied to the entries of the blackboard
;;;     and it was luck whether or not a realization operator or a function
;;;     or a lexical feature comes back numbered for its cycle. Surprising that
;;;     that it caused so few problems: however for lexical and classify features
;;;     (and of course preselections) you cannot just throw on a tag and hope
;;;     for the best. The following function therefore uses its knowledge about
;;;     the structure of the blackboard to make sure that it does not try to 
;;;     number a grammatical or lexical feature as if it were a function.
;;;     This bug must have been in the code for a very long time since none
;;;     of this area is new: it was probably just not seen because the internal
;;;     classifies and lexifies etc. were not so visible until the details option
;;;     was added to the structure grapher!
;;; ----------------------------------------------------------------------

(defun NUMBER-ONLY-FUNCTIONS (blackboard-object-List)
  (flet ((processed-blackboard-list 
          (object-list)
          (cond
           ((listp Object-List)
            (case (first object-list)
              (conflate (cons 'conflate (number-functions (cdr object-list))))
              (otherwise (cons (first object-list)
                               (cons (number-functions (second object-list))
                                     (cddr object-list))))))
           (object-list
            (Tag-Fn-Name Object-List)))))
    (loop for Object in blackboard-Object-List 
          collect (processed-blackboard-list object))))



;;; 2.0 (John:Feb98) was interning in common-lisp, changed to KPML.
;;;     (John:Mar98) added number offsets for independent generation
;;;                  of subconstituents with the coder.
(defun TAG-FN-NAME (Elt)
	;;; John: IPSI: April 94; note the following Penman speedup trick
	;;;	   bombed when we had more than 40 constituents. Added a
	;;;        test to use the shortcut for less than 200, and
	;;;        then to go over to the slower one.

  (let ((index (+ constituent-index *function-numbering-offset*)))
    (if (gethash Elt hash-table-of-all-functions)
	(if (> index 200)
	    (intern 
	     (concatenate 
		 'string (symbol-name elt) "#" (princ-to-string  index))
	     "KPML")
	  ;; if <200 use the prestored strings...
	  (intern (concatenate 
		      'string (symbol-name elt) 
		      (cadr (assoc index constituent-index-to-string-alist)))
		  "KPML"))
      elt)))


(defun number-functions-in-brownboard (old-brownboard)
  (loop for element in old-brownboard
      collect
	(make-brownboard-elt
	 :functionlist 
	 (make-conflation
	  :alias (tag-fn-name 
		  (conflation-alias (brownboard-elt-functionlist element)))
	  :othernodes 
	  (loop for node 
	      in (conflation-othernodes (brownboard-elt-functionlist element))
	      collect (tag-fn-name node)))
	 :featurespecs (loop for spec in (brownboard-elt-featurespecs element)
			   collect (make-selection-def
				    :id (selection-def-id spec)
				    :fn (tag-fn-name (selection-def-fn spec))
				    :features (selection-def-features spec))
				   ))))



;;; ----------------------------------------------------------------------
;;; All realization operators record their constraints on the
;;; blackboard, which is bound during traversal and calling of the
;;; realization functions. There are also a large number of functions
;;; and variables that can also be used during traversal (and only
;;; then):
;;;   message-sender -- the current system
;;;   blackboard     -- list of inserted grammatical functions
;;;   conflate-demons - list of pairs of functions where one is
;;;                     waiting for the other to be inserted so
;;;                     that it can be conflated
;;;   ordering-relations -- holds the ordering statements that are
;;;                     called for during one traversal
;;;
;;; Following traversal, the blackboard is processed to give the
;;; brownboard (by bundle-blackboard) and the brownboard is further
;;; processed to give the whiteboard (process-brownboard). The
;;; brownboard simply collects all realizations of the same type
;;; together and packages these in a datastructure of type
;;; selection-def. The whiteboard deals with all realizations that
;;; are not to be handled by further network traversal and collects
;;; together constraints relevant for further traversals.
;;; 
;;; KPML 0.8: note that the preparation of the whiteboard (via 
;;; bundle-blackboard and process-brownboard) relies on hardcoding
;;; of the distinct types of realization statements and cannot
;;; be simply parameterized as it is.
;;; 
;;; --------------------------------------
;;; Basic structure building...

(defun INSERT (&rest Body)
  (loop for x in Body 
      do (cond
	  ((Find-Object x)
	   (Warning "The grammatical function named " x 
		    " is being inserted more than once, now by "
		    Message-Sender))
	  (T (push x blackboard)
	     (Try-Merge x)))))


(defun TRY-MERGE ( x )
;;; called when a new function is inserted -- checks whether the
;;; insertion triggers any waiting conflations.
  (loop for y on Conflate-Demons
      when (Eq (CAAR y) x)
      do (conflate
	  (CAAR y)
	  (CDAR y) )
	 (rplaca y NIL)
      finally (SETQ Conflate-Demons (Dremove NIL Conflate-Demons))))


;;; 1.1 Following function had the usual Interlisp conversion of optional
;;; args. But the second arg appeared never to be used in any call. This
;;; should then have blown up as being nonbound. On the assumption that
;;; it was always nil, replaced here.

(defun FIND-OBJECT (x &optional (Not-Item nil))
  (loop for y in Blackboard
      when (not(equal y Not-Item))
      do (cond
	    ((Eq x y)
	     (RETURN x))
	    ((And (Eq (CAR (value-if-listp  y))
		      'Complex-Object)
		  (member x (CDR (value-if-listp y))))
	     (RETURN y)))))


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



(defun CONFLATE (Left Right)
  (incf Conflate-Count)
  (PROG ((Left-Collection 
	  (loop for Node in Blackboard
	      when (Or (Eq Node Left)
		       (And (Eq (CAR (value-if-listp Node)) 'Complex-Object)
			    (member Left (CDR Node))))
	      collect Node))
	 (Right-Collection 
	  (loop for Node in Blackboard
	      when (Or (Eq Node Right)
		       (And (Eq (CAR (value-if-listp Node)) 'Complex-Object)
			    (member Right (CDR Node))))
	      collect Node)))
	(cond
	 ((And Left-Collection Right-Collection)
	  (loop for Node in Left-Collection do 
		(loop for n in Right-Collection
		    do (Merge-blackboard-object Node n)))
	  T)
	 (Left-Collection (Create-Conflate-Demon Right Left)
			  'Waiting)
	 (T (Create-Conflate-Demon Left Right)
	    'Waiting))))

(defun CREATE-CONFLATE-DEMON (x y)
  (Or (loop for Pair in Conflate-Demons 
	  when (And (Eq (CAR Pair) x)
		    (Eq (CDR Pair) y))
	  return pair)
      (Push (Cons x y) Conflate-Demons )))

(defun MERGE-BLACKBOARD-OBJECT (x y)
  (cond
    ((Eq x y)
     NIL)
    ((nigel-NLISTP x)
     (cond
       ((NIGEL-NLISTP y)
	(add-to-blackboard (LIST 'Complex-Object x y) )
	(Delete-from-blackboard x)
	(Delete-from-blackboard y))
       ((member x (CDR y))
	NIL)
       (T (RplacD y (Cons x (CDR y)))
	  (Delete-from-blackboard x))))
    ((NIGEL-NLISTP y)
     (cond
       ((member y (CDR x))
	NIL)
       (T (RplacD x (Cons y (CDR x)))
	  (Delete-from-blackboard y))))
    ((loop for z in (CDR x) thereis (member z (CDR y)))
     NIL)
    (T (RplacD (last x)
		(CDR y))
       (Delete-from-blackboard y))))


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

(DEFUN Expand (&rest Body)
  (incf Expansion-Count)
  (PROG ((t0 (loop for Symbol in Blackboard
		 when (And (Eq (CAR (value-if-listp Symbol))
				     'Expanded-Object)
				 (Eq (Second Symbol)
				     (CAR Body)))
		 return symbol)))
	(RETURN (cond
		  (t0 (loop for Symbol in (CDR Body)
			  unless (member Symbol (CDDR t0))
			  do (RplacD (CDR t0)
				     (Cons Symbol (CDDR t0)))))
		  (T (cond
		       ((Not (Find-Object (CAR Body)))
			(Add-to-blackboard (car Body))
			(Try-Merge (CAR Body))))
		     (Add-to-blackboard (Cons 'Expanded-Object
					      (copy-list Body))))))))


  ;;
  ;; 4.0 possibly not the best place for this utility, but while
  ;;     we are on the subject of the expand operator...
  ;;
(defun EXTRACT-PASS-EXPANSION-INFO ()
  (loop for i in blackboard 
	when (and (consp i)(equal (first i) 'expanded-object))
	collect
	(cons
	 (extract-index (string (second i)))
	 (cdr i)))
  )

;;; ------------------------------
;;; Cross-rank dependencies: inflectify, preselect, lexify, classify,
;;; etc. Basic work is the same in  all cases, an object of the form
;;; (REALIZATION-OP args) is added to the blackboard for later
;;; processing.
;;; 



(defun INFLECTIFY (&rest Body)
  (let ((fn (car body)))
    (when (or (find-association fn 'termset)                        ;; 3.1
              (find-association fn 'term))                          ;; 3.2 downgraded warning
      (unless (classifying-lexicalized-entries-p curlan)            ;; 4.1 warning parameterized on language
        (warning "In system " message-sender ", inflectifying for a function " fn
                 " which has already received a lexicalization.")))
    (add-to-blackboard (Cons 'Inflectify
			     (COPY-LIST Body)))
    (Second Body)))


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

(defun PRESELECT (&rest Body)
  (PROG ((t0 (loop for x in Blackboard 
		 when (And (Eq (CAR (value-if-listp x)) 'Preselect)
			   (Eq (Second x) (CAR Body)))
		 return x)))
	(cond
	  (t0 (Nconc t0 (COPY-LIST (CDR Body))))
	  (T (cond
	       ((Not (In-Blackboard-P (CAR Body)))
		(Caution "In system " Message-Sender ", preselecting for a function " (CAR Body)
			 " which has never been inserted.")))
	     (add-to-blackboard (Cons 'Preselect
			   (COPY-LIST Body )))))))

(DEFUN In-Blackboard-P (Function)
  (loop for N in Blackboard when (Or (Eq N Function)
				     (And (value-if-listp N)
					  (Eq (CAR N) 'Complex-Object)
					  (member Function (CDR N))))
      return N))


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

(defun LEXIFY (&rest Body)
;;; 0.7.12 A lexify did not leave any record of itself in the association
;;;        table, which meant that it could not serve as a basis for
;;;        morphological or further operations.
;;; 3.1    Warn on lexification of an already lexicalised function...
    (let* ((fn (car body))
           (Word  (Second Body))
	   (t0 (loop for x in Blackboard 
		     when (And (Eq (CAR (value-if-listp x)) 'Lexify)
			     (Eq (Second x) fn))
		     return x)))
      (when (or (find-association fn 'termset)                                      ;; 3.1
                (find-association fn 'term))
        (unless (classifying-lexicalized-entries-p curlan)                          ;; 4.1 see above
          (warning "In system " message-sender ", lexifying for a function " fn
                 " which has already received a lexicalization.")))
      (cond
       (t0 (Warning "Multiple lexify of " fn ": Old Word is " (Third t0) ", New Word is "
                    (Second Body) "under " Message-Sender))
       (T (cond
           ((Not (In-Blackboard-P fn))
            (Caution "In system " Message-Sender ", lexifying for a function " fn
                     " which has never been inserted.")))
          (associate (car body) Word 'term)
          (add-to-blackboard (Cons 'Lexify (COPY-LIST Body)))))
      (cond
       ((Not (gethash word lexicon))
        (Warning "The word " Word " has been lexified but is not known as a word.")))
      Word))

(defun OUTCLASSIFY (&rest Body)
  "The realization (OUTCLASSIFY FOO BAR) will add the feature OUTCLASSIFY-BAR to the classify
   bundle for function FOO in the blackboard"
  (let* ((fn (car body))
         (t0 (loop for x in Blackboard 
		   when (And (Eq (CAR (value-if-listp x)) 'Classify)
			     (Eq (Second x) fn))
		   return x)))
    (when (or (find-association fn 'termset)                                      ;; 3.1
                (find-association fn 'term))
      (unless (classifying-lexicalized-entries-p curlan)                          ;; 4.1 see above
        (warning "In system " message-sender ", outclassifying for a function " fn
                 " which has already received a lexicalization.")))
    (cond
     (t0 (Nconc t0 (copy-list
		    (list (intern
			   (concat "OUTCLASSIFY-"
				   (symbol-name (CaDR Body)))
			   (find-package 'penman))))))   ;;;add outclassify feature to existing classify
     (T (unless (In-Blackboard-P fn)  ;;;add new outclassify to blackboard.
          (Caution "In system " Message-Sender ", outclassifying for a function " fn
                   " which has never been inserted."))
	(add-to-blackboard 
	 (Cons 'Classify 
	       (copy-list (list fn  ;the function
				(intern     ;the feature
				 (concat "OUTCLASSIFY-"
					 (symbol-name (CaDR Body)))
				 (find-package "KPML"))))))))))


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

(defun CLASSIFY (&rest body)
  (let* ((fn (car body))
         (t0 (loop for x in Blackboard 
		   when (And (Eq (CAR (value-if-listp x)) 'Classify)
			     (Eq (Second x) fn))
		   return x)))
    (when (or (find-association fn 'termset)                                      ;; 3.1
              (find-association fn 'term))
      ;; 4.0 the following warning is only relevant if we have a language
      ;;     that does not call for any modification of lexicalized
      ;;     entries morphologically. This applies in English just about
      ;;     but does not apply, for example, in the German grammar.
      ;;     We therefore add a rather arcane flag internally that
      ;;     links this warning to particular languages. This may be
      ;;     changed as required by users if they know how.
      ;;
      (unless (classifying-lexicalized-entries-p curlan)
        (warning "In system " message-sender ", classifying for a function " fn     
               " which has already received a lexicalization.")))
    (cond
     (t0 (Nconc t0 (copy-list (CDR Body))))   ;;;add the new feature to existing classify in blackboard.
     (T (unless (In-Blackboard-P fn)  ;;;add new classify to blackboard.
          (Caution "In system " Message-Sender ", classifying for a function " fn
                   " which has never been inserted."))
        (add-to-blackboard (Cons 'Classify (copy-list Body )))))))




;;; ------------------------------
;;; ORDERING realizations...

(defun ORDER (Fn1 Fn2)
    (Check-And-Insert-Order-Relation (LIST 'Order
				       Fn1 Fn2)))
(defun ORDERATEND (Fn)
    (Check-And-Insert-Order-Relation (LIST 'Orderatend
				       Fn)))
(defun ORDERATFRONT (Fn)
    (Check-And-Insert-Order-Relation (LIST 'Orderatfront
				       Fn)))
(defun PARTITION (Fn1 Fn2)
    (Check-And-Insert-Order-Relation (LIST 'Partition
				       Fn1 Fn2)))
;;; 


(defun check-and-insert-order-relation (relation)
  (when show-ordering-events-flag
    (printwindow :display-pane " ")
    (printwindow :display-pane
		 (indent-and-fill (format nil "Under system ~a, inserting Ordering Relation: ~a." Message-sender relation ))))
  (if (member relation ordering-relations)
      (warning "This ordering relation already specified: " relation)
      (push relation ordering-relations)))


;;; ----------------------------------------------------------------------
;;; 2.1
;;;   for some fairly fancy inquiries the error of a missing association
;;;   is now reduced to a message in the case that the field is the Function
;;;   itself. The only answer that was ever possible from the user in this
;;;   case is in any case the function itself, and so it did not really make
;;;   sense for the user to specify this. I.e., if there was no association
;;;   for the function Process under the FAT-field function, then the only
;;;   thing that it could be is Process, so why make a big deal... if it is
;;;   necessary that other associations are present, then this in any case gets
;;;   picked up as soon as there is an attempt to access them.
;;; ----------------------------------------------------------------------

(defun GET-ASSOCIATION (Function-Name Field)
  (cond
    ((Find-Association Function-Name Field))
    ((equal field 'function)
     (message "Association requested for field Function " Function-Name
              " although there is no actual association registered.")
     function-name)
    ((not (equal field 'termset))
     (let ((message 
            (format 
             nil 
             "Under system ~A, there was no association for
Function Association Field ~A under grammatical
function ~A"
             message-sender Field  Function-Name)))
       (Warning message)
       (cond ((askwindow :yes-or-no 
                         (if window-interface-flag
                             (concatenate 'string message ": " 
                                          "Would you like to specify one?")
                           "Would you like to specify one?  "))
              (setf *last-inquiry-mentioned*  "")
              (setf *last-question-mentioned* nil)
              (funcall 'Associate
                       Function-Name
                       (askwindow :value "Enter desired association: ")
                       Field)
              (Find-Association Function-Name Field))
             (t 
              (warning "A lack of association could prove fatal; associating a minimal term graph for object type consistency.")
              (funcall 'associate Function-name 
                       (make-plan-term-graph 
                        `(,(intern (string (gensym "UC-")) 
                                   (find-package 'penman)) / unknown-type))
                       Field)
              nil))))
    (t 
     ;; a termset can be nil...
     nil)))

;;; John Wilkinson's speedups incorporated...

(DEFUN Find-Association (Function-Name Field-Name)
  "basic retrieval access function for grammatical function to hub associations"
  (cond ((equal field-name 'lexicalfeature)
         function-name)
        (t
         (let ((temp nil))
;speed-patch:  The (setq ...) below replaces a search of the
;Associations list
           (setq temp  (gethash function-name *associations-table*))
           (when temp
             (case field-name
               (function (function-association-function temp))
               (concept (function-association-concept  temp))
               (presentation-spec (function-association-presentation-spec  temp))
               (termset (function-association-term-set  temp))
               (term (function-association-term  temp))
               ;;;The next two are solely for Interlisp compatability, and should not be relied on in the future.
               (presentationspec (function-association-presentation-spec  temp))
               (modificationset (function-association-presentation-spec  temp))
               ))))))


;;; 1.1. locus added for better diagnostics...

(DEFUN Put-Association (Function-Name Field-Content Field Locus)
  "basic storage access function for function to hub associations"
;speed-patch:  The (gethash ...) below used to be a search of the
;Associations list
  (PROG ((Temp-List (gethash Function-Name *associations-table*)))
        (cond
          ((Not Temp-List)
;speed-patch:  The (Push ...) instruction has been superceded by the
;(setf ...) below; the former can probably be removed.
           (Push (SETQ Temp-List (make-Function-Association
                                  :Function  Function-Name))
                 Associations )
	   (setf (gethash function-name *associations-table*)
			temp-list)
           (push temp-list cumulative-associations)))
        (Case Field
	      (Function (setf (Function-Association-Function Temp-List) 
			  Field-Content))
	      (Concept (setf (Function-Association-Concept Temp-List) 
			 Field-Content))
	      (Presentation-Spec 
	       (setf (Function-Association-presentation-Spec Temp-List) 
		 Field-Content))
	      (Termset
	       (setf (Function-Association-Term-Set Temp-List) 
		 (if (atom Field-Content) (list field-content) field-content)))
	      (Term (setf (Function-Association-Term Temp-List) Field-Content))
          ;;;The next two are present for Interlisp compatability purposes; 
	  ;;;PresentationSpec and ModificationSet should
          ;;;not be used in future examples; rather Presentation-Spec 
	  ;;;should be used.
	      ((PresentationSpec Modificationset)
	       (setf (Function-Association-presentation-Spec Temp-List) 
		 Field-Content))
	      (otherwise 
	       (Warning "An illegal Function Association Field Name ("
			Field ") has been used"
			(if locus (concatenate 'string
				    " in inquiry " (string locus))
			  ".")))))
  Field-Content)






