;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: XLE; Base: 10 -*-


;;;; XLE-Web users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.

;;;; Author: Paul Meurer (paul.meurer@aksis.uib.no) and Helge Dyvik (helge.dyvik@lili.uib.no)
;;;; Aksis, Unifob, University of Bergen, Norway
;;;; http://www.aksis.uib.no

(in-package :XLE)

(defun determine-variable-type (type)
  (cond 
   ((string-equal type "event") "e")
   ((string-equal type "ref-ind") "x")
   ((string-equal type "handle") "h") 
   ((or (null type) (string-equal type "individual")) "i")
   (t "u")))

(defun construct-path (prefix suffix)
  (collecting
   (loop for foo in prefix do (collect (string foo)))
   (loop for foo in suffix do (collect (string foo)))))

(defmethod calculate-scope-relations ((graph xle-graph) var-array)
  (let ((sc-rels ())
	(qeqs ())
	(prpstn_m ())
	(rels ())
	(rels-el ())
	(h-cons ())
	(inverse-m-projections ())
	(inverse-attributes ())
	(adv-embedded ())
	(msg-qeq ())
	(leftscope ())
	(rightscope ())
	(semform-alist ())
	(inverse-semform-alist ())
	(semform-att-alist ()))
    ;; collect lists of variables having equivalent semforms
    (loop for terms across var-array
	  for i from 0 ;; debug
	  do (mapc (lambda (context.term)
		     (let ((term (cdr context.term)))
		       ;;(print (list :id i term))
		       (when (eq (car term) 'eq)
			 (unless (eq (caadr term) 'var)
			   (destructuring-bind (%eq (%attr (%var var) attr) right) term
			     (declare (ignore %eq %var))
			     (when (and (eq %attr 'attr)
					(string= attr "relation")
					(consp right))
			       #+debug(print (list :var var :right right)) 
			       (cond ((eq (car right) 'semform)
				      (pushnew var (getf semform-alist (caddr right))))
				     ((eq (car right) 'var)
				      (let ((semform (find-var-value var-array (cadr right))))
					(when semform
					  (pushnew var (getf semform-alist (caddr semform)))))))))))))
		   terms))
    #+debug(print (list :eq-semforms semform-alist))
    ;; remove semforms associated to one var only (not strictly necessary); build inverse relation
    (setf semform-alist
      (collecting
       (loop for (s l) on semform-alist by #'cddr
	   when (cdr l)
	   do (collect s)
	      (collect l)
	      (dolist (v l)
		(push s (getf inverse-semform-alist v))
		(assert (not (cdr (getf inverse-semform-alist v))))))))
    ;; for each semform, collect list of var values for each attribute
    (loop for terms across var-array
	do (mapc (lambda (context.term)
		   (let ((term (cdr context.term)))
		     (when (and (eq (car term) 'eq)
				(not (eq (caadr term) 'var))) 
		       (destructuring-bind (%eq (%attr (%var var) attr) right) term
			 (declare (ignore %eq %var))
			 (when (and (eq %attr 'attr)
				    (getf inverse-semform-alist var)
				    (string/= attr "relation")
				    (consp right)
				    (eq (car right) 'var))
			   (let ((att-var (cadr right)))
			     (pushnew att-var (getf (getf semform-att-alist
							  (car (getf inverse-semform-alist var)))
						    (intern attr :xle)))))))))
		 terms))
    ;; Do unification by replacing vars
    (labels ((var-replacement (var)
	       (let ((rep (or (car (find-if (lambda (obj) (and (consp obj) (find var obj))) semform-alist))
			      (car (loop for alist in (cdr semform-att-alist) by #'cddr
				       thereis (find-if (lambda (obj) (and (consp obj) (find var obj))) alist)))
			      var)))
		 rep)))
      (loop for terms across var-array
	  do (mapc (lambda (context.term)
		     (let ((term (cdr context.term)))
		       #+debug(print term)
		       (cond ((find (car term) '(scopes in_set))
			      (destructuring-bind (v1 v2) (cdr term)
				(when (and (consp v1) (eq (car v1) 'var))
				  (setf (cadr v1) (var-replacement (cadr v1)))
				  (when (and (consp v2) (eq (car v2) 'var))
				    (setf (cadr v2) (var-replacement (cadr v2)))))))
			     ((and (eq (car term) 'eq)
				   (not (eq (caadr term) 'var)))
			      (destructuring-bind (%eq (%attr var attr) right) term
				(declare (ignore %eq attr))
				(setf (cadr var) (var-replacement (cadr var)))
				(case %attr
				  ((attr proj)
				   (when (and (consp right) (eq (car right) 'var))
				     (setf (cadr right) (var-replacement (cadr right)))))))))))
		   terms)))
    #+debug(loop for i from 0 for terms across var-array do (print (cons i terms)))
    ;; build some auxiliary lists
    (loop for terms across var-array
  	do (mapc (lambda (context.term)
		   (let ((term (cdr context.term)))
		     #+debug(print (list :term term))
		     (cond ((eq (car term) 'scopes)
			    (destructuring-bind (%sc (%v1 id1) (%v2 id2)) term
			      (declare (ignore %sc %v1 %v2))
			      ;; construct partial ordering
			      (push id2 (getf sc-rels id1))))
			   ((and (eq (car term) 'eq)
				 (not (eq (caadr term) 'var)))
			    (destructuring-bind (%eq (%attr (%var var) attr) right) term
			      (declare (ignore %eq %var))
			      (case %attr
				(attr
				 (when (and (consp right) (eq (car right) 'var))
				   (push (cons attr var) (getf inverse-attributes (cadr right))))
				 #+orig
				 (cond ((string= attr "relation")
					(cond ((consp right)
					       (when (and (eq (car right) 'semform)
							  (or (string= (cadr right) "prpstn_m_")
							      (string= (cadr right) "imp_m")))
						 (push (find-att-value var-array var "MARG") prpstn_m)))
					      ((or (string= right "prpstn_m_")
						   (string= right "imp_m"))
					       ;; collect MARGs of prpstn_m
					       (push (find-att-value var-array var "MARG") prpstn_m)) ;; = MA
					      ((string= right "qeq")
					       ;; collect relevant HCONS information
					       (push (list :var var
							   :sc_arg (find-att-value var-array var "SC_ARG")
							   :outscpd (find-att-value var-array var "OUTSCPD"))
						     qeqs))))
				       ((string= attr "_SUPMSG")
					(pushnew var adv-embedded))
				       ((string= attr "RELS")
					(unless (equal (find-att-value var-array var "_XCLUDERELS") "+")
					  (pushnew (cadr right) rels)))
				       ((string= attr "RELS_EL")
					(unless (equal (find-att-value var-array var "_XCLUDERELS") "+")
					  (pushnew (cadr right) rels-el)))
				       ((string= attr "H-CONS")
					(unless (equal (find-att-value var-array var "_XCLUDERELS") "+")
					  (pushnew (cadr right) h-cons))))
				 (cond ((string= attr "relation")
					(cond ((consp right)
					       (when (and (eq (car right) 'semform)
							  (or (string= (cadr right) "prpstn_m_")
							      (string= (cadr right) "imp_m")))
						 (push (find-att-value var-array var "MARG") prpstn_m)))
					      ((or (string= right "prpstn_m_")
						   (string= right "imp_m"))
					       ;; collect MARGs of prpstn_m
					       (push (find-att-value var-array var "MARG") prpstn_m)) ;; = MA
					      ((string= right "qeq")
					       ;; collect relevant HCONS information
					       (push (list :var var
							   :sc_arg (find-att-value var-array var "SC_ARG")
							   :outscpd (find-att-value var-array var "OUTSCPD"))
						     qeqs))))
				       ((string= attr "_LEFTSCOPE")
					(push (list :left var
						    :var (cadr right)
						    :l-hndl (find-att-value var-array (cadr right) "L-HNDL"))
					      leftscope))
				       ((string= attr "_RIGHTSCOPE")
					(push (list :left var
						    :var (cadr right)
						    :r-hndl (find-att-value var-array (cadr right) "R-HNDL"))
					      rightscope))
				       ((string= attr "_MSGQEQ")
					(pushnew (cadr right) msg-qeq))
				       ((string= attr "_SUPMSG")
					(pushnew var adv-embedded))
				       ((string= attr "RELS")
					(unless (equal (find-att-value var-array var "_XCLUDERELS") "+")
					  (pushnew (cadr right) rels)))
				       ((string= attr "RELS_EL")
					(unless (equal (find-att-value var-array var "_XCLUDERELS") "+")
					  (pushnew (cadr right) rels-el)))
				       ((string= attr "H-CONS")
					(unless (equal (find-att-value var-array var "_XCLUDERELS") "+")
					  (pushnew (cadr right) h-cons)))))
				(proj
				 (when (string= attr "m::")
				   (pushnew var (getf inverse-m-projections (cadr right)))))))))))
  		 terms))
    (let ((po ())
	  (eliminate ()))
      (labels ((build-po (id)
		 (or (getf po id)
		     (setf (getf po id)
		       (if-let (outscoped (getf sc-rels id))
			       (mapcar (lambda (o)
					 (pushnew o eliminate)
					 (list id (build-po o)))
				       outscoped)
			       (list (list id)))))))
	(loop for id in sc-rels by #'cddr
	    do (build-po id)))
      (let ((*print-circle* t))
	(dolist (el eliminate)
	  (remf po el))
	(loop for rest on (cdr po) by #'cddr
	    do (let ((longest-chain ()))
		 (labels ((get-longest-chain (rels &optional chain)
			    (cond ((null (cdr rels))
				   (when (> (1+ (length chain)) (length longest-chain))
				     (setf longest-chain (reverse (cons (car rels) chain)))))
				  (t
				   (mapc (lambda (sub-rels)
					   (get-longest-chain sub-rels (cons (car rels) chain)))
					 (cadr rels)))))
			  (check-consistency (rels &optional (lc longest-chain))
			    (cond ((null (cdr rels))
				   (unless (find (car rels) lc)
				     (error "Ambiguous scoping relation: ~d not found in longest chain ~s."
					    (car rels) longest-chain)))
				  (t
				   (let ((tail (member (car rels) lc)))
				     (unless tail
				       (error "Ambiguous scoping relation: ~d not found in longest chain tail ~s of longest chain ~s."
					      (car rels) lc longest-chain))
				     (mapc (lambda (sub-rels)
					     (check-consistency sub-rels (cons (car rels) tail)))
					   (cadr rels)))))))
		   
		   (mapc #'get-longest-chain (car rest))
		   (mapc #'check-consistency (car rest)))
		 (setf (car rest) longest-chain))))
      (let* ((scope-relations
	      (collecting
	       (loop for partition in (cdr po) by #'cddr
		   do (collect
		       (mapcar (lambda (id)
				 (let ((mrs-lbl (or (path var-array id
							  (construct-path '("m::" "RELS_EL")
									  mrs::*rel-handel-path*))
						    (path var-array id
							  (construct-path '("m::") mrs::*rel-handel-path*))))
				       (mrs-rel (path var-array id '("m::" "RELS_EL" "relation")))
				       (mrs-outscpd (path var-array id '("m::" "H-CONS_EL" "OUTSCPD"))))
				   (assert (integerp mrs-lbl))
				   (list id
					 mrs-lbl
					 mrs-outscpd
					 (equal (find-att-value var-array mrs-lbl "handle") "NXTLBL")
					 mrs-rel)))
			       partition))))))
	#+debug(print (list :sc-rels sc-rels :scope-relations scope-relations :po po :qeqs qeqs))
	;; now scope-relations are available; we do the NXTLBL thing
	(dolist (qeq qeqs)
	  (when-let (outscpd (get-outscoped-label scope-relations (getf qeq :oustscpd) :outscpd))
	    (setf (getf qeq :oustscpd) outscpd)))
	#+debug(print (list :qeqs qeqs))
	;; algorithm for embedded adverbial sentences
	(let ((supmsg-partitions
	       (delete-if #'null
			  (mapcar (lambda (partition)
				    (collecting
				     (dolist (sc-list partition)
				       (let ((pro (find-projection var-array (car sc-list) "m::")))
					 (when (find pro adv-embedded)
					   (collect (car sc-list))
					   (setf adv-embedded (delete pro adv-embedded)))))))
				  scope-relations))))
	  #+debug(print (list :adv-embedded adv-embedded))
	  (when adv-embedded ;; f-structs not in any scope hierarchy
	    (setf supmsg-partitions
		  (append (collecting
			    (dolist (ae adv-embedded)
			      #+debug(print (list :ae ae :inverse-m (getf inverse-m-projections ae)))
			      (collect (getf inverse-m-projections ae))))
			  supmsg-partitions)))
	  #+debug(print (list :supmsg-partitions supmsg-partitions))
	  #+debug(let ((*package* (find-package :xle)))
		   (loop for i from 0 for terms across var-array do (print (cons i terms))))
      	  (dolist (partition supmsg-partitions)
	    (loop for (f . rest) on partition ;; (remove-duplicates partition)
		do (let* ((hndl-a (path var-array f '("m::" "_SUBJNCT" "MAIN"))))
		     #+debug
		     (print (list :f (or (car rest) f)
				  :path (if rest
					    (construct-path '("m::" "_SBJQEQ" "SC_ARG") nil)
					    (construct-path '("m::" "_SUPPTR" "SC_ARG")  nil))
				  :value (if rest
					     (get-path var-array (car rest)
						       (construct-path '("m::" "_SBJQEQ" "SC_ARG") nil))
					     (get-path var-array f
						       (construct-path '("m::" "_SUPPTR" "SC_ARG")  nil)))
				  :hndl-a hndl-a))
		     (if rest
			 (set-path var-array (car rest)
				   (construct-path '("m::" "_SBJQEQ" "SC_ARG") nil) hndl-a)
			 (set-path var-array f
				   (construct-path '("m::" "_SUPPTR" "SC_ARG")  nil) hndl-a))))))
	#+debug(let ((*package* (find-package :xle)))
		 (loop for i from 0 for terms across var-array do (print (cons i terms))))
      	(values scope-relations
		qeqs
		prpstn_m
		msg-qeq
		leftscope
		rightscope
		inverse-attributes
		inverse-m-projections
		rels
		h-cons
		rels-el)))))

(defun set-path (var-array id atts-or-projections value)
  #+debug(print (list :id id :atts-or-projections atts-or-projections :value value))
  (let ((aop (car atts-or-projections)))
    (cond ((null id)
	   nil)
	  ((and (= (length aop) 3)
		(string= aop "::" :start1 1))
	   (multiple-value-bind (id right) (find-projection var-array id aop)
	     (cond ((cdr atts-or-projections)
		    (set-path var-array id (cdr atts-or-projections) value))
		   ((eq (car right) 'var)
		    #+debug(print (list :replacing id right :with value))
		    (setf (cadr right) value))
		   (t
		    (error "Could not set (projection) var of ~s." right)))))
	  (t
	   (multiple-value-bind (id right) (find-att-value var-array id aop)
	     (cond ((cdr atts-or-projections)
		    (set-path var-array id (cdr atts-or-projections) value))
		   ((eq (car right) 'var)
		    #+debug(print (list :replacing id right :with value))
		    (setf (cadr right) value))
		   (t
		    #+debug(print (list atts-or-projections var-array id aop))
		    #+ignore
		    (error "Could not set (attribute) var of ~s." right))))))))

;; for debugging
(defun get-path (var-array id atts-or-projections)
  #+debug(print (list :id id :atts-or-projections atts-or-projections))
  (let ((aop (car atts-or-projections)))
    (cond ((null id)
	   nil)
	  ((and (= (length aop) 3)
		(string= aop "::" :start1 1))
	   (multiple-value-bind (id right) (find-projection var-array id aop)
	     (cond ((cdr atts-or-projections)
		    (get-path var-array id (cdr atts-or-projections)))
		   ((eq (car right) 'var)
		    right)
		   (t
		    (error "Could not set (projection) var of ~s." right)))))
	  (t
	   (multiple-value-bind (id right) (find-att-value var-array id aop)
	     (cond ((cdr atts-or-projections)
		    (get-path var-array id (cdr atts-or-projections)))
		   ((eq (car right) 'var)
		    right)
		   (t
		    #+debug(print (list atts-or-projections var-array id aop))
		    #+ignore
		    (error "Could not set (attribute) var of ~s." right))))))))

(defun find-projections (var-array type)
  (collecting
   (loop for terms across var-array for i from 0
       do (mapc (lambda (ctx.term)
		  (let ((term (cdr ctx.term)))
		    (destructuring-bind (left right) (cdr term)
		      (when (and (eq (car term) 'eq)
				 (eq (car left) 'proj)
				 (string= (caddr left) type))
			(collect (cons i (cadr right)))))))
		terms))))

;; used only in packed rep.
(defun find-var-value (var-array id)
  (mapc (lambda (ctx.term)
	  (let ((term (cdr ctx.term)))
	    (destructuring-bind (left right) (cdr term)
	      (when (and (eq (car term) 'eq)
			 (eq (car left) 'var))
		(return-from find-var-value right)))))
	(aref var-array id))
  nil)

(defun get-outscoped-label (scope-relations id type)
  (let ((outscoped-list
	 (block tail
	   (dolist (partition scope-relations)
	     (when-let (tail (member id partition :key (case type (:outscpd #'caddr) (:lbl #'cadr))))
		       (return-from tail tail))))))
    (cadr (find-if-not #'identity (cdr outscoped-list) :key #'cadddr))))

(defun get-lemma+nr (lemma+nr)
  (let ((1-nr-pos (position-if-not (lambda (c) (find c "1234567890")) lemma+nr :from-end t)))
    (if (eql 1-nr-pos (length lemma+nr))
	(values (subseq lemma+nr 0 (1+ 1-nr-pos))
		(subseq lemma+nr (1+ 1-nr-pos)))
	lemma+nr)))

(defmethod build-mrs ((graph xle-graph) var-array &key &allow-other-keys)
  (declare (ignore var-array))
  (values nil t))

(defparameter *debug-mrs* nil)

#+debug
(defparameter *mrs* nil)

(defmethod build-mrs ((graph xle-mrs-graph) var-array &key unpack-normalized-p &allow-other-keys)
  (let ((nodes ())
	(count 0)
	(valid-p t)
	(prpstn_m-scope ())
	(_leftscope ())
	(_rightscope ()))
    (multiple-value-bind (scope-relations qeqs prpstn_m msg-qeq leftscope rightscope
					  inverse-attributes inverse-m-projections rels h-cons rels-el)
	(calculate-scope-relations graph var-array)
      #+debug(print (list :qeqs qeqs :_msgqeq msg-qeq :leftscope leftscope :rightscope rightscope
			  :prpstn_m prpstn_m :scope-relations scope-relations))
      (labels ((node-type (term-list)
		 (if (find-if-not (lambda (ctx.term) (eq (cadr ctx.term) 'in_set)) term-list)
		     (progn (mapc (lambda (ctx.term)
				    (let ((term (cdr ctx.term)))
				      (destructuring-bind (left right) (cdr term)
					(when (and (eq (car term) 'eq)
						   (eq (car left) 'attr))
					  (cond ((string= (caddr left) "relation")
						 (return-from node-type
						   (if (equal right "qeq")
						       :hcons
						       :rel)))
						((and (string= (caddr left) "type")
						      (string= right "handle"))
						 (return-from node-type :handle-var))
						((and (string= (caddr left) "type")
						      (string= right "event"))
						 (return-from node-type :event-var))
						((string= (caddr left) "TOP")
						 (return-from node-type :psoa)))))))
				  term-list)
			    :var)
		     :list))
	       (build (var &optional top-p)
		 (cond ((integerp var)
			(or (getf nodes var)
			    (let* ((term-list (aref var-array var))
				   (node-type (node-type term-list)))
			      ;; Fixme: if var subsumes an atomic value replace var by that value
			      #+test(assert (not (null term-list)))
			      #+test(when (null term-list) (warn "term-list of var ~d is empty." var))
			      (when (and top-p (not (eq node-type :psoa)))
				(setf node-type :psoa-incomplete valid-p nil))
			      (let ((node
				     (if (eq node-type :list)
					 ()
				       (setf (getf nodes var)
					 (ecase node-type
					   (:psoa-incomplete
					    (mrs::make-psoa
					     :top-h (mrs::make-var
						     :type "h"
						     :id 0)))
					   (:psoa (mrs::make-psoa))
					   (:handle-var
					    (incf count)
					    (mrs::make-var
					     :type "h"
					     :id (if *debug-mrs*
						     (format nil "~d|~d" count var)
						     count)))
					   (:event-var
					    (incf count)
					    (mrs::make-var :id (if *debug-mrs*
								   (format nil "~d|~d" count var)
								   count)))
					   (:var 
					    (incf count)
					    (mrs::make-var :id (if *debug-mrs*
								   (format nil "~d|~d" count var)
								   count)
							   ))
					   (:hcons (mrs::make-hcons
						    :relation (intern "QEQ" (find-package mrs::*mrs-package*))))
					   (:rel (mrs::make-rel)))))))
				(dolist (ctx.term term-list)
				  (let ((term (cdr ctx.term)))
				    (destructuring-bind (left right) (cdr term)
				      (ecase (car term)
					(eq
					 (ecase (car left)
					   (attr
					    (let ((attribute (caddr left)))
					      (cond ((char= (char attribute 0) #\_)
						     ;; convention: suppress att if it starts with #\_
						     nil)
                                                    ((string-equal attribute "LNK")
                                                     ;; suppress the former LNK mechanism
                                                     ;;
                                                     nil)
						    ((string= attribute "relation")
						     (cond ((not (or (stringp right)
								     (eq (car right) 'semform)))
							    (build right))
							   ((equal right "qeq")
							    nil)
							   (t ;; predicate name
							    (labels ((make-pred-string (att &optional (hyphen "_"))
								       (if-let (val (find-att-value var-array var att))
									 (concat hyphen val)
									 "")))
							      (multiple-value-bind (lemma nr)
								  (get-lemma+nr (if (stringp right) right (cadr right)))
								(let* ((cat (make-pred-string "_CAT"))
								       (catsuff (make-pred-string "_CATSUFF"))
								       (prt (make-pred-string "_PRT" "*"))
								       (prt2 (make-pred-string "_PRT2" "*"))
								       (nr (if nr (concat "_" nr) ""))
								       (pred-stem (substitute #\+ #\Space
											      (concat (if (eq cat "") "" "_")
												      lemma prt prt2 cat catsuff nr))))
								  #+debug(print (list :right right :lemma lemma :prt prt :prt2 prt2 :cat cat :catsuff catsuff :nr nr))
								  (setf (mrs::rel-pred node)
									(concat pred-stem
										(if (char= (char pred-stem (1- (length pred-stem))) #\_)
										    "rel" "_rel")
										(if *debug-mrs*
										    (format nil "|~d" var)
										    "")))
								  (when (consp right)
                                                                    (let ((lnk (semform-string-positions graph (caddr right))))
								      (when lnk
									(setf (mrs::rel-lnk node) lnk))
								      #+stephans-version
                                                                      (multiple-value-bind (start junk)
                                                                          (parse-integer lnk :junk-allowed t)
                                                                        (when (and (numberp start) junk)
                                                                          (let ((end (parse-integer lnk :start (+ junk 1))))
                                                                            (when (numberp end)
                                                                              (setf (mrs::rel-lnk node)
                                                                                (list :characters start end))))))))))))))
						    ((and (string= attribute "handle")
							  (or (string= right "index")
							      (string= right "NXLBL")))
						     nil)
						    ((string= attribute "SC_ARG")
						     (setf (mrs:hcons-scarg node) (build right)))
						    ((string= attribute "type")
						     (setf (mrs::var-type node) (determine-variable-type (build right))))
						    ((string= attribute "OUTSCPD")
						     (setf (mrs:hcons-outscpd node) (build-outscpd var right prpstn_m-scope)))
						    #+newnew
						    ((string= attribute "L-HNDL")
						     (print node)
						     (setf (mrs:rel-handel node) (print (build-outscpd var right))))
						    #+newnew
						    ((string= attribute "R-HNDL")
						     (setf (mrs:rel-handel node) (build-outscpd var right)))
						    ((string= attribute "TOP")
						     (setf (mrs:psoa-top-h node) (build right)))
						    ((string= attribute "INDEX")
						     (setf (mrs:psoa-index node) (build right)))
						    ((string= attribute "RELS")
						     (when rels 
						       (dolist (rel rels)
							 (dolist (rel-node (build rel))
							   #+debug(pprint (list :rel rel :rel-node rel-node))
							   (pushnew rel-node (mrs:psoa-liszt node))))
						       (setf rels nil)))
						    ((string= attribute "H-CONS")
						     (when h-cons
						       (dolist (h h-cons)
							 (dolist (h-cons-node (build h))
							   (pushnew h-cons-node (mrs:psoa-h-cons node))))
						       (setf h-cons nil)))
						    ((and (eq node-type :rel)
							  (string= attribute "LBL"))
						     (setf (mrs:rel-handel node) (build-handel right)))
						    ((eq node-type :rel)
						     (push (mrs::make-fvpair
							    :feature (mrs::vsym attribute)
							    :value (let ((value (if (integerp right)
										    right
										    (let ((val
											   (or (cond ((string= attribute "L-HNDL")
												      (build-outscpd var right _leftscope))
												     ((string= attribute "R-HNDL")
												      (build-outscpd var right _rightscope))
												     (t
												      (build right)))
											       (mrs::make-var
												:id (incf count)
												:type (determine-variable-type nil) ))))
										      #+kbn
										      (when (and (eq (mrs::vsym attribute) 'lkb::arg0)
												 (not (find 'lkb::domain (mrs:var-extra val)
													    :key #'mrs::extrapair-feature)))
											(push (mrs::make-extrapair
											       :feature 'lkb::domain
											       :value 'lkb::fin)
											      (mrs:var-extra val)))
										      val))))
								     (cond ((or (not unpack-normalized-p)
										(not (and (consp value)
											  (not (eq (car value) 'semform)))))
									    value)
									   (t
									    (let ((pos (position (mapcar #'mrs::var-id value)
												 (normalized-pairs graph)
												 :test #'equal))) ;; is 0 or 1
									      (cond ((null pos)
										     (push (mapcar #'mrs::var-id value) (normalized-pairs graph))
										     (car value))
										    ((zerop (logand 1 (ash (sub-solution-nr graph) (- pos))))
										     (car value))
										    (t
										     (cadr value))))))))
							   (mrs:rel-flist node)))
						    (t ;; var
						     (when (mrs::var-p node)
						       (push (mrs::make-extrapair
							      :feature (mrs::vsym attribute)
							      :value (let ((value (build right)))
                                                                       (if (or (symbolp value) (stringp value))
                                                                         (mrs:vsym value) value)))
							     (mrs:var-extra node)))))))
					   (var
					    nil)))
					(in_set	;; left is element in right, which is var
					 (push (build left) node))))))
				node))))
		       ((eq var :outscpd)
			(mrs::make-var :type "handle"))
		       ((atom var)
			var)
		       ((eq (car var) 'var)
			(build (cadr var)))
		       (t
			var)))
	       (build-handel (right)
		 (let ((lbl-id (cadr right)))
		   (cond ((equal (find-att-value var-array lbl-id "handle") "NXTLBL")
			  (let ((outscoped-label (get-outscoped-label scope-relations lbl-id :lbl))) 
			    (if outscoped-label
				(build (list 'var outscoped-label))
			      (build :outscpd))))
			 (t
			  (build right)))))
	       (build-outscpd (var right targets)
		 (let* ((lbl-id (cadr right))
			(target-list (find var targets :key #'car))
			(target (cdr target-list)))
		   #+debug(print (list :var var :prpstn_m-scope targets :target-list target-list))
		   (cond (target
			  #+debug(print (list :target target))
			  ;; make MARG of _prpstn_m QEQ to highest-scoping handle
			  (build `(var ,target)))
			 ((equal (find-att-value var-array lbl-id "handle") "NXTLBL")
			  (let ((outscoped-label (get-outscoped-label scope-relations lbl-id :outscpd))) 
			    #+debug(print (list :outscoped-label (get-outscoped-label scope-relations lbl-id :outscpd) scope-relations lbl-id))
			    (if outscoped-label
				(build (list 'var outscoped-label))
			      (build :outscpd))))
			 (t
			  (build right))))))
	(dolist (marg msg-qeq #+orig prpstn_m)
	  (let* (#+old(qeq (find marg qeqs :key (lambda (qeq) (getf qeq :sc_arg)))) ;; qeq = HCNS
		 (qeq (find marg qeqs :key (lambda (qeq) (getf qeq :var)))) ;; qeq = HCNS
		 (qeq-var (getf qeq :var))
		 (outscpd (getf qeq :outscpd))
		 (vrb (find-if (lambda (rel-var)
				 #+debug(print (list outscpd (find-att-value var-array rel-var "LBL")))
				 (and (eq outscpd (find-att-value var-array rel-var "LBL"))
				      ;; new 17.2.2006
				      (getf inverse-m-projections rel-var)))
			       rels-el))
		 (f-vrb (car (getf inverse-m-projections vrb)))
		 (scope-relation
		  (block partition
		    #+debug(print (list :outscpd outscpd :vrb vrb :f-vrb f-vrb :imp inverse-m-projections :ia inverse-attributes))
		    (dolist (partition scope-relations)
		      (when (find f-vrb partition :key #'car)
			(return-from partition partition)))))
		 (target (cadr (find-if-not #'identity scope-relation :key #'cadddr))))
	    #+debug(print (list :qeq qeq :vrb vrb :f-vrb f-vrb))
	    (when target (push (cons qeq-var target) prpstn_m-scope))))

	(dolist (marg leftscope)
	  (let* (;;(qeq (find marg qeqs :key (lambda (qeq) (getf qeq :var)))) ;; qeq = HCNS
		 (qeq-var (getf marg :var))
		 (outscpd (getf marg :l-hndl))
		 (vrb (find-if (lambda (rel-var)
				 #+debug(print (list outscpd (find-att-value var-array rel-var "LBL")))
				 (and (eq outscpd (find-att-value var-array rel-var "LBL"))
				      (getf inverse-m-projections rel-var)))
			       rels-el))
		 (f-vrb (car (getf inverse-m-projections vrb)))
		 (scope-relation
		  (block partition
		    #+debug(print (list :outscpd outscpd :vrb vrb :f-vrb f-vrb :imp inverse-m-projections :ia inverse-attributes))
		    (dolist (partition scope-relations)
		      (when (find f-vrb partition :key #'car)
			(return-from partition partition)))))
		 (target (cadr (find-if-not #'identity scope-relation :key #'cadddr))))
	    #+debug(print (list :outscpd outscpd :qeq-var qeq-var :vrb vrb :f-vrb f-vrb :target target))
	    (when target (push (cons qeq-var target) _leftscope))))
	(dolist (marg rightscope)
	  (let* (;;(qeq (find marg qeqs :key (lambda (qeq) (getf qeq :var)))) ;; qeq = HCNS
		 (qeq-var (getf marg :var))
		 (outscpd (getf marg :r-hndl))
		 (vrb (find-if (lambda (rel-var)
				 #+debug(print (list outscpd (find-att-value var-array rel-var "LBL")))
				 (and (eq outscpd (find-att-value var-array rel-var "LBL"))
				      (getf inverse-m-projections rel-var)))
			       rels-el))
		 (f-vrb (car (getf inverse-m-projections vrb)))
		 (scope-relation
		  (block partition
		    #+debug(print (list :outscpd outscpd :vrb vrb :f-vrb f-vrb :imp inverse-m-projections :ia inverse-attributes))
		    (dolist (partition scope-relations)
		      (when (find f-vrb partition :key #'car)
			(return-from partition partition)))))
		 (target (cadr (find-if-not #'identity scope-relation :key #'cadddr))))
	    #+debug(print (list :outscpd outscpd :qeq-var qeq-var :vrb vrb :f-vrb f-vrb :target target))
	    (when target (push (cons qeq-var target) _rightscope))))

	(incf (sub-solution-nr graph))
	(values (let ((mrs (build (find-projection var-array (top-f-node-var graph) "m::") :psoa)))
		  #+debug(setf *mrs* mrs)
		  #+debug(print (list :psoa-p (mrs::psoa-p mrs)))
		  mrs)
		valid-p)))))

;; Code for automatically extracting SMIs from MRS objects

(defmethod extract-smis ((obj mrs::psoa) &key smi-list &allow-other-keys)
  (dolist (rel (mrs::psoa-liszt obj))
    (extract-smis rel :smi-list smi-list)))

(defmethod extract-smis ((obj mrs::rel) &key smi-list &allow-other-keys)
  (let* ((*package* (find-package mrs::*mrs-package*))
	 (first t)
	 (smi (with-output-to-string (stream)
		(write (mrs::rel-pred obj) :stream stream)
		(write-string " : " stream)
		(dolist (fvpair (mrs::rel-flist obj))
		  (let ((var (mrs::extrapair-value fvpair)))
		    (unless (or (integerp var) (stringp var))
		      (if first
			  (setf first nil)
			  (write-string ", " stream))
		      (write (mrs::extrapair-feature fvpair) :stream stream)
		      (write-char #\space stream)
		      (write-string (or (mrs::var-type var) "?") stream))))
		(write-char #\. stream))))
    (incf (dat:string-tree-get smi-list smi 0))))

(defmethod extract-smis ((obj mrs::var) &key &allow-other-keys)
  (warn "MRS:REL type expected instead of ~s" obj))

#||
 prpstn_m skal ha rekkevidde over høyeste EP i scope-hierarkiet. Som default (fra XLE) får den nå scope over verbet [eller adjektivet etc. i copula-konstruksjoner] i den setningen den tilhører. Algoritmen for å få dette på plass blir da slik:

For hvert element EPi i RELS, hvis (EPi relation) = prpstn_m , gjør:
  set MA = (EPi MARG).
    set HC = blant elementene HCNS1 - HCNSn i H-CONS, finn det første (som også vil være det eneste) HCNSi der (HCNSi SC_ARG)=MA.
   set OUTS = (HCNSi OUTSCPD).
     set VRB = blant elementene EP1 - EPn i RELS, finn det første EPj der (EPj LBL) = OUTS og som kommer fra en m-projeksjon.
  set f-vrb = blant samtlige f-strukturer f1 - fn, finn den første (og dermed eneste) fi der m::fi = VRB.
Hvis f-vrb inngår i et scope-hierarki SH = [f'1 >s ... >s f'n], gjør:
           set target = (m::f'1 RELS_EL LBL) (altså LBL til øverste element i hierarkiet).
        Erstatt OUTS - altså verdien av (HCNSi OUTSCPD) - med target.
   Hvis f-vrb ikke inngår i noe scope-hierarki, ikke gjør noen forandring.



||#

;; is here because only relevant for Bokmål, maybe move. Perhaps obsolete?
(defun update-and-reload-grammar (&key force-p reload-only-p grammar-path)
  #+allegro
  (let* ((files '("bokmal-mrs.lfg" "bokmal-lex-mrs.lfg" "bokmal-templates-mrs.lfg"
		  "bokmal-nkllex.lfg" "bokmal-nklvrblex.lfg" ;;"bokmal-mwe.lfg"
		  "performance-vars.txt"
		  ))
	 (paths (mapcar (lambda (file)
			  (concatenate 'string *pargram-path* "norwegian/bokmal/" file))
			files))
	 (dates (mapcar (lambda (path)
			  (when (probe-file path)
			    (file-write-date path)))
			paths)))
    (unless reload-only-p
      (loop for file in files for path in paths
	  do (cl-user::run-shell-command
	      (concat "rsync --rsync-path=/usr/local/bin/rsync --archive --rsh=ssh "
		      "ling.uib.no:/space/opt/xledir/pargram/norwegian/bokmal/"
		      file " " path))))
    (when (or force-p
	      reload-only-p
	      (loop for date in dates
		  for path in paths
		  thereis (or (null date)
			      (and (probe-file path)
				   (< date (file-write-date path))))))
      (print "Reloading grammar ...")
      (mapc (lambda (parser) (setf (parser-valid-p parser) nil)) (parsers *grammar*))
      (setf *grammar* nil)
      (foreign-functions:unload-foreign-library +xle-module-path+)
      (load +xle-module-path+)
      (init-xle 1 0)
      (setf *grammar* (make-instance 'grammar
			:grammar-path (concat *pargram-path*
					      (or grammar-path 
						  "norwegian/bokmal/bokmal-mrs.lfg"))
			:name "bokmål"))
      #+disabled
      (read-xle-performance-vars-from-file (concat *pargram-path* "/norwegian/bokmal/performance-vars.txt")))))

(defmethod extract-mrs ((graph xle-graph) solution &key &allow-other-keys)
  (declare (ignore solution))
  nil)

#+orig
(defmethod extract-mrs ((graph xle-mrs-graph) solution &key (packed-p t))
  (when packed-p
    (assert (= (solution-nr graph) (1- solution)))
    #+ignore
    (setf (solution-nr graph) (1- solution)))
  ;; obs: this works only if extract-c-structure() has been called previously on the same solution!!! fix!
  (let* ((va (var-array graph))
	 (mrs (unless (zerop (fill-pointer va))
		(build-mrs graph va))))
    #+debug(print mrs)
    #+debug(print (list :extract-mrs :count (solution-count graph) :solution solution)) 
    (and (mrs::psoa-p mrs) mrs)))

(defmethod extract-mrs ((graph xle-mrs-graph) solution &key (packed-p t))
  (when packed-p
    (assert (= (solution-nr graph) (1- solution))))
  ;; obs: this works only if extract-c-structure() has been called previously on the same solution!!! fix!
  (let* ((va (var-array graph))
	 (mrs (unless (zerop (fill-pointer va))
		(build-mrs graph va :unpack-normalized-p t))))
    (values (and (mrs::psoa-p mrs) mrs)
	    (< (1+ (sub-solution-nr graph))
	       (expt 2 (length (normalized-pairs graph)))))))

#+test
(let ((*grammar* (find-grammar "Norwegian bokmål")))
  (loop
   with graph = (parse "Han spiser bananer i sengen i huset.")
   do (get-next-solution graph)
   until (zerop (print (solution graph)))
   do
   (loop with mrs and more-mrs-p
	 do (multiple-value-setq (mrs more-mrs-p) (extract-mrs graph (solution graph)))
	 ;;(print (list mrs more-mrs-p))
	 while more-mrs-p)
   finally (return graph)))

:eof