;;; Functions for post-processing the AMR-ized ULFs into flatter structures.
;;; This is meant to simplify the parsing process by reducing the number symbols
;;; that need to be generated by the parser and reducing the distance between the
;;; relevant constituents.

(in-package :ulf2amr)

(defun atom? (x)
  (atom x))

(defparameter *flatten-tense-post-ttt*
  ; Tense
  ; (v2 / past
  ;     :arg0 (v3 / see.v))
  ; vvvvv
  ; (v3 / see.v
  ;     :tense (v2 / past))
  ; w/ complex
  '((/ ((!1 atom?) [/] complex
                   _*1
                   :instance ((!2 atom?) [/] (!3 lex-tense?)
                                         :arg0 ((!4 atom?) [/] _!4 _*2))
                   _*3)
       (!4 [/] _!4
           :tense (!2 [/] !3)
           _*2
           _*1 _*3))
    ; w/o complex
    (/ ((!1 atom?) [/] (!2 lex-tense?)
                   :arg0 ((!3 atom?) [/] _!4 _*1))
       (!3 [/] _!4
           :tense (!1 [/] !2)
           _*1))))

(defparameter *flatten-aspect-post-ttt*
  ; ASPECT (NB: that the above tense operation is already completed)
  ; (v1 / prog
  ;     :arg0 (v2 / see.v
  ;               :arg1 (v4 / him.pro))
  ;     :tense (v3 / past))
  ; vvvv
  ; (v2 / see.v
  ;     :aspect (v1 / prog)
  ;     :tense (v3 / past)
  ;     :arg1 (v4 / him.pro))
  ; w/ complex
  '((/ ((!1 atom?) [/] complex
                   _*1
                   :instance ((!2 atom?) [/] (!3 prog perf)
                                         _*2
                                         :arg0 ((!4 atom?) [/] _!5 _*3)
                                         _*4)
                   _*5)
       (!4 [/] _!5
           :aspect (!2 [/] !3)
           _*3 _*2 _*4 _*1 _*5))
    ; w/o complex
    (/ ((!1 atom?) [/] (!2 prog perf)
                   _*1
                   :arg0 ((!3 atom?) [/] _!4 _*2)
                   _*3)
       (!3 [/] _!4
           :aspect (!1 [/] !2)
           _*1 _*2 _*3))))

(defparameter *flatten-plur-post-ttt*
  ; PLUR
  ; (v1 / plur
  ;     :arg0 (v2 / friend-of.n
  ;               :arg0 (v3 / him.pro)))
  ; vvvvvv
  ; (v2 / friend-of.n
  ;     :plur (v1 / plur)
  ;     :arg0 (v3 / him.pro))
  '((/ ((!1 atom?) [/] plur
                   :arg0 ((!2 atom?) [/] _!3 _*2))
       (!2 [/] _!3
           :plur (!1 [/] plur)
           _*2))))

(defparameter *flatten-pasv-post-ttt*
  ; PASV
  ; (v1 / pasv
  ;     :arg0 (v2 / find.v))
  ; vvvv
  ; (v2 / find.v
  ;     :pasv (v1 / pasv))
  ; w/ complex
  '((/ ((!1 atom?) [/] complex
                   _*1
                   :instance ((!2 atom?) [/] pasv
                                         :arg0 ((!3 atom?) [/] _!4 _*2))
                   _*3)
       (!3 [/] _!4
           :pasv (!2 [/] pasv)
           _*2 _*1 _*3))
    ; w/o complex
    (/ ((!1 atom?) [/] pasv
                   :arg0 ((!2 atom?) [/] _!3 _*1))
       (!2 [/] _!3
           :pasv (!1 [/] pasv)
           _*1))))

(defparameter *flatten-aux-post-ttt*
  ; AUX
  ; (v1 / must.aux-v
  ;     :tense (v4 / pres)
  ;     :arg0 (v2 / see.v :arg1 (v3 / him.pro)))
  ; vvvv
  ; (v2 / see.v
  ;     :aux (v1 / must.aux-v)
  ;     :arg1 (v3 / him.pro)
  ;     :tense (v4 / pres))
  ; w/ complex
  '((/ ((!1 atom?) [/] complex
                   _*1
                   :instance ((!2 atom?) [/] (!3 lex-aux?)
                                         _*4
                                         :arg0 _!5
                                         _*5)
                   _*3)
       (lower-arg-into-vp-head!
         (!2 [/] !3) :aux
         (lower-arc-pairs-into-vp-head!
           _!5 _*1 _*3 _*4 _*5)))
    ; w/o complex
    (/ ((!1 atom?) [/] (!2 lex-aux?)
                   _*4
                   :arg0 _!3
                   _*5)
       (lower-arg-into-vp-head!
         (!1 [/] !2) :aux
         (lower-arc-pairs-into-vp-head!
           _!3 _*4 _*5)))))

(defparameter *flatten-reifiers-post-ttt*
  ; REIFIERS
  ; (v1 / k :arg0 (v2 / dog.n))
  ; vvvv
  ; (v1 / k :reified (v2 / dog.n))
  '((/ ((!1 atom?) [/] (!2 noun-reifier? verb-reifier? sent-reifier? tensed-sent-reifier?)
                   :arg0 _!3)
       (!1 [/] !2 :reified _!3))))

(defparameter *clean-complex-post-ttt*
  ; Remove COMPLEX over just verbs.
  ; This is needed to remove COMPLEXes that are no longer needed after
  ; the above transformations.
  ; (v1 / COMPLEX
  ;     X Y
  ;     :instance (v2 / *.v A B C)
  ;     Z1 Z2)
  ; vvvv
  ; (v2 / *.v
  ;     A B C
  ;     X Y Z1 Z2)
  '((/ ((!1 atom?) [/] complex
                   _*1
                   :instance ((!2 atom?) [/] (!3 lex-verb?) _*2)
                   _*3)
       (!2 [/] !3
           _*2 _*1 _*3))
    ))


(defun get-ulfamr-vp-head (ulfamr)
; NB: This has only been tested for the argstruct formatted verb phrases.
; Returns the verb head of ulfamr, assuming ulfamr is a verb phrase.
  (let* ((cur-label (get-label ulfamr))
         (arc-pairs (get-arc-pairs ulfamr))
         (arg0-pair (find-if #'(lambda (x) (eq ':arg0 (first x))) arc-pairs))
         (inst-pair (find-if #'(lambda (x) (eq ':instance (first x))) arc-pairs)))
    (cond
      ;; Found the verb.
      ((lex-verb? cur-label) ulfamr)
      ;; Adverb of some kind, and there's an arg0, get the arg0 head.
      ;; (v1 / quickly.adv-a :arg0 (v2 / run.v))
      ((and (lex-adv? cur-label) (not (null arg0-pair)))
       (get-ulfamr-vp-head (second arg0-pair)))
      ;; Complex adverb of some kind.
      ;; (v1 / COMPLEX
      ;;     :instance (v2 / adv-a :arg0 (...))
      ;;     :arg0 (v3 / see.v))
      ((and (eq 'complex cur-label) (not (null inst-pair))
            (advformer? (get-label (second inst-pair)))
            (not (null arg0-pair)))
       (get-ulfamr-vp-head (second arg0-pair)))
      ;; Otherwise, give up. Doesn't seem to be a verb phrase.
      (t nil))))

(defun ulfamr-vp-with-mod? (ulfamr)
; NB: This has only been tested for the argstruct formatted verb phrases.
; Returns whether the given ULFAMR is a verb with a modifier. This function assumes
; that the input follows type composition rules, so if it finds an adverb with an
; argument, it assumes the argument is a verb that it is modifying.
  (let* ((cur-label (get-label ulfamr))
         (arc-pairs (get-arc-pairs ulfamr))
         (arg0-pair (find-if #'(lambda (x) (eq ':arg0 (first x))) arc-pairs))
         (inst-pair (find-if #'(lambda (x) (eq ':instance (first x))) arc-pairs)))
    (or
      ;; Adverb of some kind, and there's an arg0, get the arg0 head.
      ;; (v1 / quickly.adv-a :arg0 (v2 / run.v))
      (and (lex-adv? cur-label) (not (null arg0-pair)))
      ;; Complex adverb of some kind.
      ;; (v1 / COMPLEX
      ;;     :instance (v2 / adv-a :arg0 (...))
      ;;     :arg0 (v3 / see.v))
      (and (eq 'complex cur-label) (not (null inst-pair))
           (advformer? (get-label (second inst-pair)))
           (not (null arg0-pair))))))

(defun lower-arg-into-vp-head! (arg arc vp)
; NB: This has only been tested for the argstruct formatted verb phrases.
  (let* ((result (copy-tree vp)) ; copy tree since we'll do destructive operations
         (vp-head (get-ulfamr-vp-head result)))
    (nconc vp-head (list arc arg)) ; insert argument to verb head
    result))

(defun lower-arc-pairs-into-vp-head! (vp &rest flat-arc-pairs)
; NB: This has only been tested for the argstruct formatted verb phrases.
; Inserts the ARC-PAIRS as arcs from the head of VP. ARC-PAIRS-LST allows
; the caller to supply multiple lists for ARC-PAIRS, which will all be made
; arcs from the head of VP.
  (let* ((result (copy-tree vp)) ; copy tree since we'll do destructive operations
         (vp-head (get-ulfamr-vp-head result)))
    ; insert arc-pairs to head
    (nconc vp-head flat-arc-pairs)
    result))

(defparameter *lower-arg0-post-ttt*
; NB: This has only been tested for the argstruct formatted verb phrases.
; Lowers the ARG0 arguments of verbs where there are verb modifiers.
; (v0 / COMPLEX
;     :instance (v1 / COMPLEX
;                   :instance (v2 / adv-a
;                                 :arg0 (v3 / with.p :arg0 (v4 / it.pro)))
;                   :arg0 (v5 / see.v
;                             :arg1 (v6 / him.pro)))
;     :arg0 (v7 / i.pro))
; VVVV
; (v1 / COMPLEX
;     :instance (v2 / adv-a
;                   :arg0 (v3 / with.p :arg0 (v4 / it.pro)))
;     :arg0 (v5 / see.v
;               :arg0 (v7 / i.pro)
;               :arg1 (v6 / him.pro)))
  '((/ ((!1 atom?) [/] complex
                   :instance (!2 ulfamr-vp-with-mod?)
                   :arg0 _!3)
       (lower-arg-into-vp-head! _!3 :arg0 !2))))

(defparameter *quote-s-minimization*
; Minimizes (QUOTE S) to 'S after AMR-ization.
; (v1 / QUOTE :arg0 (v2 / S)) -> (v1 / 'S)
  '((/ ((!1 atom?) [/] quote
                   :arg0 (atom? [/] s))
       (!1 [/] 's))))

(defparameter *lexop-flat-post-ttt*
  (append
    *flatten-pasv-post-ttt*
    *flatten-tense-post-ttt*
    *flatten-aspect-post-ttt*
    *flatten-plur-post-ttt*
    ))

(defparameter *argstruct-post-ttt*
  (append
    *flatten-pasv-post-ttt*
    *flatten-tense-post-ttt*
    *flatten-aspect-post-ttt*
    *flatten-plur-post-ttt*
    *flatten-aux-post-ttt*
    *flatten-reifiers-post-ttt*
    *clean-complex-post-ttt*
    *lower-arg0-post-ttt*
    ))

(defparameter *universal-post-ttt*
; Universal post-processing TTT rules.
  (append
    *quote-s-minimization*
    ))

(defun ulfamr-postprocess (ulfamr &key (method 'argstruct))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; Post-processes the PENMAN format ULF for argstruct formation to reverse the
; scopes of lexical markings (e.g. tense, aspect, etc.) and rename arc labels
; as necessary to make more informative.
;
; How this is performed is modulated by the :method keyword argument.
  (when *ulf2amr-debug*
    (format t "before ulfamr-postprocess: ~s~%" ulfamr)
    (format t "ulfamr-postprocess, :method ~s~%" method))
  (let ((ttt-rules
          (append
            (case method
              (argstruct *argstruct-post-ttt*)
              (lexop-flat-arcmap *lexop-flat-post-ttt*)
              (otherwise nil))
            *universal-post-ttt*)))
    (util:unhide-ttt-ops
      (ttt:apply-rules ttt-rules
                       (util:hide-ttt-ops ulfamr *package*)
                       :max-n 1000
                       :rule-order :slow-forward)
      *package*)))

