;;; cmeta-ops (to go with release 4 grammar).

;;; NB. This file must be loaded using the Lisp function LOAD - do not
;;; apply the GDE 'READ' command. The operators must be compiled - just
;;; loading this file ensures that, but better would be to compile-file
;;; this file and then load the binary.

;;; Definitions for slash-operator-1, slash-operator-2 and slash-operator-3.
;;; These take expressions which don't contain (lambda (wh) .. and make
;;; new versions where (lambda (wh) is inserted in an appropriate
;;; place and where wh is given as an extra argument of an appropriate
;;; predicate.
;;; For example, this:
;;;
;;; (lambda (Q) (Q 
;;;     (lambda (e) (lambda (x) (1 e x (3 (lambda (prop)
;;;        (lambda (ta) (lambda (equa) (prop 
;;;            (uqe ((equa some) (e1) (NOTENSE (ta e1)))) 2))))))))
;;;     (lambda (e2) e2) (lambda (qu) qu)))
;;;
;;; becomes this:
;;;
;;; (lambda (Q) (Q 
;;;     (lambda (e) (lambda (x) (lambda (wh) (1 e x (3 (lambda (prop)
;;;        (lambda (ta) (lambda (equa) (prop 
;;;            (uqe ((equa some) (e1) (NOTENSE (ta e1)))) 2 wh))))))))) 
;;;    (lambda (e2) e2) (lambda (qu) qu)))
;;;
;;; and this:
;;;
;;; (lambda (Q) (Q 
;;;     (lambda (e) (lambda (x) (1 e x 3 2))) 
;;;     (lambda (e2) e2) (lambda (qu) qu)))
;;;
;;; becomes this:
;;;
;;; (lambda (Q) (Q 
;;;     (lambda (e) (lambda (x) (lambda (wh) (1 e x (3 wh) 2))))
;;;     (lambda (e2) e2) (lambda (qu) qu)))
;;;
;;; and this:
;;;
;;; (lambda (Q) (Q 
;;;     (lambda (e) (lambda (y) 
;;;       (1 e (uq (some (x1) (entity x1))) y
;;;         (2 (lambda (prop) (lambda (ta50) (lambda (equa51) 
;;;            (prop (uqe ((equa51 some) (e3) (ta50 e3))))))))))) 
;;;     (lambda (e2) e2) (lambda (qu) qu)))
;;; 
;;; becomes this:
;;;
;;; (lambda (Q) (Q 
;;;     (lambda (e) (lambda (y) (lambda (wh) 
;;;       (1 e (uq (some (x1) (entity x1))) y
;;;         (2 (lambda (prop) (lambda (ta50) (lambda (equa51) 
;;;            (prop (uqe ((equa51 some) (e3) (ta50 e3))) wh))))))))) 
;;;     (lambda (e2) e2) (lambda (qu) qu)))


(defun insert-lambda-into-semantic-form (form)
   ;; return the result of inserting a '(lambda (wh) ...' into form just
   ;; after the 1st (if only 1) or the 2nd (if 2) lambdas at start of form
   (cond
      ((atom form) form)
      ((or (eq (car form) '|lambda|) (eq (car form) 'LAMBDA))
         `(,(car form) ,(cadr form)
            ,(insert-lambda-into-semantic-form (caddr form))))
      (t
         `(|lambda| (|wh|) ,form))))


(defun get-predicate-semantic-form (form pred-name)
   ;; return the whole of the first predicate form with the given
   ;; name
   (cond
      ((atom form) nil)
      ((eql (car form) pred-name) form)
      (t
         (some
            #'(lambda (f)
               (get-predicate-semantic-form f pred-name))
            form))))


(defun get-atom-semantic-form-tail (form atom)
   ;; return the tail of the list containing the first occurrence of
   ;; given atom
   (cond
      ((atom form) nil)
      ((eql (car form) atom) form)
      (t
         (or (get-atom-semantic-form-tail (car form) atom)
            (get-atom-semantic-form-tail (cdr form) atom)))))

(defun insert-wh-into-semantic-form (form pos)
   ;; destructively insert 'wh' as the pos-th argument of form
   (do
      ((pred-tail form (cdr pred-tail))
         (n 1 (1+ n)))
      ((null pred-tail))
      (when (eql n pos)
         (setf (cdr pred-tail) (cons '|wh| (cdr pred-tail)))
         (return))))

;;;
;;; the code from here on was added or altered by AEK
;;;

;; destructively  inserts x as last elt of l
(defun insert-tail (l x)
  (if (= (length l) 1)
      (setf (cdr l) (list x))
      (insert-tail (cdr l) x)))

(defun pass-wh-argument (form) 
  (let ((first-in-form (car form)))
    (cond ((eq first-in-form '|lambda|)
	   (pass-wh-argument (caddr form)))
	  ((numberp first-in-form) 
	   (pass-wh-argument (cadr form)))
	  ((eq first-in-form '|prop|)
	   (insert-tail form '|wh|)))))

;; given '(|lambda| (Q) (Q pas ta qnt))
;; returns pas
(defun extract-pred-arg-structure (form)
  (cond ((and (eq (car form) '|lambda|)
	      (eq (caadr form) 'Q))
	 (cadr (caddr form)))
	((and (eq (car form) '|lambda|)
	      (not (eq (caadr form) 'Q)))
	 form)
	(t nil)))

;; given '(|lambda| (Q) (Q pas ta qnt))
;; returns ta
(defun extract-tense-aspect (form)
  (cond ((and (eq (car form) '|lambda|)
	      (eq (caadr form) 'Q))
	 (caddr (caddr form)))
	((and (eq (car form) '|lambda|)
	      (not (eq (caadr form) 'Q)))
	 ())
	(t nil)))

;; given '(|lambda| (Q) (Q pas ta qnt))  returns qnt
(defun extract-quantifier (form)
  (cond ((and (eq (car form) '|lambda|)
	      (eq (caadr form) 'Q))
	 (cadddr (caddr form)))
	((and (eq (car form) '|lambda|)
	      (not (eq (caadr form) 'Q)))
	 ())
	(t nil)))

(defmacro search-prop (pred-arg-struct)
  `(and 
    (listp (cadr ,pred-arg-struct))
    (eq (caadr ,pred-arg-struct) '|lambda|)
    (listp (cdadr ,pred-arg-struct))
    (eq (car (cadadr ,pred-arg-struct)) '|prop|)))

;;; slash-operator definitions ;;;
(eval-when (load eval)
   (setf (get '|slash-operator-1| 'metarule-operator)
	 (compile nil
		  '(lambda (form idrule-binding-nos)
		     (let* ((pred-arg-struct (extract-pred-arg-structure form))
			    (ta (extract-tense-aspect form))
			    (qnt (extract-quantifier form))
			    (predicate-index (nth 3 idrule-binding-nos))
			    (pred-arg-struct-lambda 
			     (insert-lambda-into-semantic-form pred-arg-struct))
			    (predicate-form
			     (get-predicate-semantic-form pred-arg-struct-lambda predicate-index)))
		       (when predicate-form        ;; this always succeeds
			   (if (search-prop predicate-form)
			       (pass-wh-argument predicate-form)
			       (insert-wh-into-semantic-form predicate-form 3)))
		       (if (and (eq (car form) '|lambda|)
				(eq (caadr form) 'Q))
			   `(|lambda| (Q) (Q ,pred-arg-struct-lambda ,ta ,qnt ))
			   pred-arg-struct-lambda))))))

(eval-when (load eval)
   (setf (get '|slash-operator-2| 'metarule-operator)
      (compile nil
	       '(lambda (form idrule-binding-nos)
		  (let* ((pred-arg-struct (extract-pred-arg-structure form))
			 (ta (extract-tense-aspect form))
			 (qnt (extract-quantifier form))
			 (predicate-index (nth 3 idrule-binding-nos))
			 (pred-arg-struct-lambda 
			  (insert-lambda-into-semantic-form pred-arg-struct))
			 (predicate-form
			  (get-predicate-semantic-form pred-arg-struct-lambda predicate-index)))
		    (if predicate-form     
			(if (search-prop predicate-form)
			    (pass-wh-argument predicate-form)
			    (insert-wh-into-semantic-form predicate-form 2))
		      (let ((predicate-form-tail
			     (get-atom-semantic-form-tail pred-arg-struct-lambda predicate-index)))   
			(when predicate-form-tail
			  (setf (car predicate-form-tail) (list predicate-index '|wh|)))))
		    (if (and (eq (car form) '|lambda|)
			     (eq (caadr form) 'Q))
			`(|lambda| (Q) (Q ,pred-arg-struct-lambda ,ta ,qnt))
		        pred-arg-struct-lambda))))))


(eval-when (load eval)
   (setf (get '|slash-operator-3| 'metarule-operator)
	 (compile nil
		  '(lambda (form idrule-binding-nos)
		     (let* ((pred-arg-struct (extract-pred-arg-structure form))
			    (ta (extract-tense-aspect form))
			    (qnt (extract-quantifier form))
			    (predicate-index (nth 2 idrule-binding-nos))
			    (pred-arg-struct-lambda 
			     (insert-lambda-into-semantic-form pred-arg-struct))
			    (predicate-form
			     (get-predicate-semantic-form pred-arg-struct-lambda predicate-index)))
		       (if predicate-form
			   (if (search-prop predicate-form)
			       (pass-wh-argument predicate-form)
			       (insert-wh-into-semantic-form predicate-form 2))
			   (let ((predicate-form-tail
				  (get-atom-semantic-form-tail pred-arg-struct-lambda predicate-index)))
			     (when predicate-form-tail
			       (setf (car predicate-form-tail) (list predicate-index '|wh|)))))
		       (if (and (eq (car form) '|lambda|)
				(eq (caadr form) 'Q))
			   `(|lambda| (Q) (Q ,pred-arg-struct-lambda ,ta ,qnt))
			   pred-arg-struct-lambda))))))

;;; End of file

