;;;; Copyright (c) 2001--2020 Stephan Oepen (oe@ifi.uio.no);
;;;   see `LICENSE' for conditions.

(in-package :mrs)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (shadow '(ed)))

;;;
;;; ToDo
;;;
;;; - identify more wellformedness conditions: e.g. mark all connected pieces 
;;;   of the graph and check for remaining fragments, or stipulate that certain
;;;   relations minimally require certain roles (with certain types, say).
;;;

(defparameter *eds-debug-p* nil)

(defparameter *eds-pretty-print-p* t)

(defparameter *eds-normalize-p* nil)

(defparameter *eds-vpm* nil)

(defparameter *eds-include-messages-p* nil)

(defparameter *eds-include-quantifiers-p* t)

(defparameter *eds-include-icons-p* t)

(defparameter *eds-include-vacuous-relations-p* t)

(defparameter *eds-message-relation* (vsym "message_m_rel"))

(defparameter *eds-fragment-relation* (vsym "unknown_rel"))
 
(defparameter *eds-bleached-relations* (list (vsym "selected_rel")))

(defparameter *eds-predicate-filter* nil)

(defparameter *eds-argument-filter*
  (list
   (list (vsym "L-INDEX") (vsym "L-HNDL") "^h")
   (list (vsym "R-INDEX") (vsym "R-HNDL") "^h")))

(defparameter *eds-quantifier-argument* (vsym "BV"))

(defparameter *eds-untensed* (list (cons (vsym "TENSE") (vsym "untensed"))))

(defparameter *eds-non-representatives*
  (list (vsym "appos_rel") (vsym "id_rel")
        (vsym "focus_d_rel") (vsym "parg_d_rel")))

(defparameter *eds-predicate-modifiers*
  (list (ppcre:create-scanner "_x_deg_rel$|^neg_rel$|^_quite_x_rel$")))

(defparameter *eds-show-lnk-p* t)

(defparameter *eds-show-properties-p* t)

(defparameter *eds-show-status-p* nil)

(defparameter %eds-variable-counter% 0)

(defparameter %eds-symbol-table% (make-hash-table))

(defparameter %eds-representatives-table% (make-hash-table :test #'equal))

(defparameter %eds-equivalences% (make-hash-table :test #'equal))

(defparameter %eds-filter% nil)

(defparameter %eds-relevant-features% 
  '("ARG" "ARG1" "ARG2" "ARG3" "ARG4" "BV" 
    "L-HNDL" "L-INDEX" "R-HNDL" "R-INDEX" "CARG"
    "SOA" "CONST_VALUE" "TERM1" "TERM2" "FACTOR1" "FACTOR2"
    "MARG" "L-HANDEL" "R-HANDEL" "MAIN" "SUBORD" "ROLE" "HINST" "NHINST"))

(defstruct eds
  top relations hcons raw status)

(defmethod print-object ((object eds) stream)
  (if *eds-pretty-print-p*
    (let ((cyclicp (eds-cyclic-p object))
          (fragmentedp (eds-fragmented-p object)))
      (loop
          initially
            (format 
             stream 
             "{~@[~(~a~):~]~
              ~:[~3*~; (~@[cyclic~*~]~@[ ~*~]~@[fragmented~*~])~]~@[~%~]" 
             (eds-top object) 
             (and *eds-show-status-p* (or cyclicp fragmentedp) )
             cyclicp (and cyclicp fragmentedp) fragmentedp
             (eds-relations object))
          for ed in (eds-relations object)
          unless (or (and (null (ed-status ed))
                          (or (ed-bleached-p ed) (ed-vacuous-p ed)))
                     (member ed %eds-filter% :test #'eq))
          do
            (format 
             stream 
             "~c~a~%"
             (cond
              ((null *eds-show-status-p*) #\Space)
              ((member :cyclic (ed-status ed)) #\|)
              ((member :fragmented (ed-status ed)) #\|)
              (t #\Space))
             ed)
          finally
            (format stream "}~%")))
    (call-next-method)))

(defstruct ed
  handle id properties type variable
  predicate arguments carg
  lnk inverse raw status mark abstraction)

(defmethod print-object ((object ed) stream)
  (if *eds-pretty-print-p*
    (loop
        with carg = (vsym "CARG")
        initially
          (format
           stream 
           "~(~a~):~(~a~)~@[(~s)~]" 
           (ed-id object) (ed-linked-predicate object) (ed-carg object))
          (when (and *eds-show-properties-p* (ed-properties object))
            (loop
                with *package* = (find-package *mrs-package*)
                with type = (first (ed-properties object))
                with properties = (if (extrapair-p type)
                                    (ed-properties object)
                                    (rest (ed-properties object)))
                initially
                  (format 
                   stream "{~@[~(~a~)~]~@[ ~]"
                   (unless (extrapair-p type) type) properties)
                finally (format stream "}")
                for property in properties
                do
                  (format
                   stream "~:[~;, ~]~a ~(~a~)"
                   (not (eq property (first properties)))
                   (extrapair-feature property)
                   (extrapair-value property))))
          (format stream "[")
        for (role . value) in (ed-arguments object)
        unless (eq role carg) do
          (format 
           stream 
           "~:[, ~;~]~:@(~a~) ~@[~(~a~)~]~@[:~(~a~)~]~@[(~s)~]"
           (eq role (first (first (ed-arguments object))))
           role (if (ed-p value) (ed-id value) "")
           (unless *eds-include-vacuous-relations-p*
             (if (ed-p value) (ed-predicate value) value))
           (unless *eds-include-vacuous-relations-p*
             (when (ed-p value) (ed-carg value))))
        finally
          (format stream "]"))
    (call-next-method)))

(defun ed-linked-predicate (ed &key (lnkp *eds-show-lnk-p*))
  (let ((predicate (or (ed-predicate ed) "_"))
        (lnk (ed-lnk ed)))
    ;;
    ;; _fix_me_
    ;; why not use output-lnk(), to avoid code duplication?    (27-feb-16; oe)
    ;;
    (case (and lnkp (first (ed-lnk ed)))
      (:id
       (format nil "~a<@~a>" predicate (second lnk)))
      (:characters
       (format nil "~a<~a:~a>" predicate (second lnk) (third lnk)))
      (:vertices
       (format nil "~a<~a-~a>" predicate (second lnk) (third lnk)))
      (:tokens
       (format nil "~a<~{~a~^,~}>" predicate (rest lnk)))
      (t 
       (format nil "~a" (ed-predicate ed))))))

(defun ed-linked-abstraction (ed &key (lnkp t))
  (let ((abstraction (ed-abstraction ed))
        (lnk (ed-lnk ed)))
    (when abstraction
      (case (and lnkp (first (ed-lnk ed)))
        (:characters
         (format nil "_~(~a~)_<~a:~a>" abstraction (second lnk) (third lnk)))
        (:vertices
         (format nil "_~(~a~)_<~a-~a>" abstraction (second lnk) (third lnk)))
        (:tokens
         (format nil "_~(~a~)_<~{~a~^,~}>" abstraction (rest lnk)))
        (t 
         (format nil "_~(~a~)_" abstraction))))))

(defun eds-output-psoa (psoa &key (stream t) (format :ascii)
                                  (lnkp *eds-show-lnk-p*)
                                  (propertiesp *eds-show-properties-p*)
                                  cargp collocationp abstractp sentinelp
                                  (vpm *eds-vpm*)
                                  (normalizep *eds-normalize-p*)
                                  sortp dmrsp (n 0) 
                                  (filter *eds-predicate-filter*)
                                  input id debug
                                  (prefix "") (columns *print-right-margin*))

  (when (null stream)
    (return-from eds-output-psoa
      (with-output-to-string (stream)
        (eds-output-psoa
         psoa :stream stream :format format :lnkp lnkp :propertiesp propertiesp
         :cargp cargp :collocationp collocationp :abstractp abstractp
         :sentinelp sentinelp :vpm vpm :normalizep normalizep
         :sortp sortp :dmrsp dmrsp :n n :filter filter
         :input input :id id :debug debug :prefix prefix :columns columns))))
  (when (eq format :svg)
    (return-from eds-output-psoa
      (let* ((tmp #+:logon (getenv "LOGONTMP") #-:logon nil)
             (tmp (or (and tmp (namestring (parse-namestring tmp))) "/tmp"))
             (user (or #+(and :allegro-version>= (version>= 5 0)) 
                       (sys:user-name)
                       #+(and :allegro
                              (not (and :allegro-version>= (version>= 5 0))))
                       (system:getenv "USER")
                       #+(and :mcl :powerpc) 
                       (ccl:process-name ccl:*current-process*)
                       #+:lucid 
                       (lcl:environment-variable "USER")
                       "nobody"))
             (id (gensym ""))
             (dot (format nil "~a/.eds.dot.~a.~a" tmp user id))
             (svg (format nil "~a/.eds.svg.~a.~a" tmp user id))
             (command (format nil "dot -Gstylesheet=\"dot.css\" -Gcolor=\"#1a04a5\" -Gbgcolor=\"#f5f5f5\" -Nfontname=\"helvetica, arial, sans-serif\" -Nfontsize=8 -Efontname=\"helvetica, arial, sans-serif\" -Efontsize=8 -Tsvg '~a'" dot)))
        (with-open-file (stream dot :direction :output :if-exists :supersede)
          (eds-output-psoa
           psoa :stream stream :format :dot :lnkp lnkp :propertiesp propertiesp
           :cargp cargp :collocationp collocationp :abstractp abstractp
           :sentinelp sentinelp :vpm vpm :normalizep normalizep
           :sortp sortp :dmrsp dmrsp :n n :filter filter
           :input input :id id :debug debug :prefix prefix :columns columns))
        ;;
        ;; _fix_me_
        ;; it would seem desirable to directly send the generated SVG to our
        ;; own output .stream., but (at least in ACL), run-shell-command() is
        ;; restricted to a sub-set of stream types only.
        ;;
        (run-process command :wait t :output svg)
        (with-open-file (svg svg)
          (loop
              for line = (read-line svg nil nil)
              while line do (write-string line stream) (terpri stream))))))
    
  (let ((eds (if (eds-p psoa)
               psoa
               (eds-convert-psoa psoa :vpm vpm :normalizep normalizep)))
        (%eds-filter% nil)
        (*eds-show-lnk-p* lnkp)
        (*eds-show-properties-p* propertiesp))
    (when filter
      (when (stringp filter) (setf filter (ppcre::create-scanner filter)))
      (loop
          for ed in (eds-relations eds)
          when (and (ppcre:scan filter (ed-predicate ed))
                    (null (ed-inverse ed))
                    (not (string= (ed-id ed) (eds-top eds))))
          do (push ed %eds-filter%)))

    (case format
      ((:ascii :native)
       (cond
        ((eds-p psoa)
         (format stream "~a~%" psoa))
        ((eds-p eds)
         (format stream "~a~%" eds))
        (t
         (format stream "{}~%"))))
      (:triples
       (let* ((triples
               (if dmrsp
                 (dmrs-explode (rmrs-to-dmrs (mrs-to-rmrs psoa)))
                 (eds-explode
                  eds
                  :cargp cargp
                  :collocationp collocationp :abstractp abstractp))))
         (when sortp
           (setf triples
             (sort
              triples
              #'(lambda (foo bar)
                  (or (string< (first foo) (first bar))
                      (and (string= (first foo) (first bar))
                           (string< (second foo) (second bar))))))))
         (loop
             with *package* = (find-package :lkb)
             initially (unless sentinelp (format stream "{~%"))
             for triple in triples
             do
               (format
                stream
                "~:[  ~;<s> ~]~{~a~^ ~}~:[  ~; </s>~]~%"
                sentinelp triple sentinelp)
             finally (unless sentinelp (format stream "}~%~%")))
         (length triples)))
      (:lui
       (let ((attic (make-hash-table :test #'equal))
             (id 0))
         (labels ((record (object)
                    (or (gethash object attic)
                        (let ((n id))
                          (setf (gethash object attic) n)
                          (incf id)
                          n))))
           (format 
            stream
            "#X[~a \"{~(~a~)\" \":\" newline~%\"    \" #X["
            (record (eds-top eds)) (eds-top eds))
           (loop
               with carg = (vsym "CARG")
               with firstp = t
               for ed in (eds-relations eds)
               do
                 (format
                  stream
                  "~@[newline~*~] ~a \"~(~a~)\" \":~(~a~)~@[(~a)~][\" #X["
                  (not firstp)
                  (record (ed-id ed)) (ed-id ed)
                  (ed-linked-predicate ed) (ed-carg ed))
                 (setf firstp nil)
                 (loop
                     with firstp = t
                     for (role . value) in (ed-arguments ed)
                     unless (eq role carg) do
                       (format
                        stream
                        "~@[\", \" ~*~]~@[wrap ~*~]\"~a \" ~
                         ~@[~a ~]~@[\"~(~a~)\" ~]~
                         ~@[\":~(~a~)\"~]~@[\"(~(~a~))\"~]"
                        (not firstp)
                        (and (not firstp)
                             (null *eds-include-vacuous-relations-p*))
                        role
                        (and (ed-p value) (record (ed-id value)))
                        (and (ed-p value) (ed-id value))
                        (unless *eds-include-vacuous-relations-p*
                          (if (ed-p value) (ed-predicate value) value))
                        (unless *eds-include-vacuous-relations-p*
                          (and (ed-p value) (ed-carg value))))
                       (setf firstp nil)
                     finally (format stream "] \"]\"~%"))
               finally 
                 (format 
                  stream
                  "] newline \"}\"]~%~
                     #M[]")))))
      (:html
       (format stream "<table class=mrsEds>~%")
       (format stream "<tr><td>")
       (mrs-variable-html (eds-top eds) nil n nil stream)
       (format stream ":</td></tr>~%")
       (loop
           for ed in (eds-relations eds)
           for lnk = (ed-lnk ed)
           for properties
           = (when (and propertiesp (ed-properties ed))
               (let* ((string (make-string-output-stream)))
                 (format string "<table class=mrsProperties>")
                 (loop
                     with type = (first (ed-properties ed))
                     with properties
                     = (if (extrapair-p type) 
                         (ed-properties ed)
                         (rest (ed-properties ed)))
                     initially
                       (unless (extrapair-p type)
                         (format
                          string
                          "<tr><td class=mrsPropertyFeature>~(~a~)</td>~
                           <td class=mrsPropertyValue>&nbsp;</td></tr>"
                          type))
                     for property in properties
                     do
                       (format 
                        string 
                        "<tr><td class=mrsPropertyFeature>~a~
                           <td class=mrsPropertyValue>~(~a~)</td></tr>"
                        (extrapair-feature property)
                        (extrapair-value property)))
                 (format string "</table>")
                 (get-output-stream-string string)))
           unless (or (ed-bleached-p ed) (ed-vacuous-p ed))
           do
             (format stream "<tr><td nowrap>&nbsp;")
             (mrs-variable-html (ed-id ed) properties n nil stream)
             (format
              stream
              "<span~:[~*~*~; onMouseOver=\"highlight(~a, ~a)\" ~
                              onMouseOut=\"highlight()\"~]>:~(~a~)~a</span>"
              (and lnk (eq (first lnk) :characters)) (second lnk) (third lnk)
              (ed-predicate ed)
              (output-lnk (ed-lnk ed) :stream nil :format :html))
             (format stream "~@[(~s)~][" (ed-carg ed))
             (loop
                 with firstp = t
                 for (role . value) in (ed-arguments ed)
                 when (ed-p value)
                 do
                   (format stream "~:[,&nbsp;~;~]~a&nbsp;" firstp role)
                   (mrs-variable-html (ed-id value) nil n nil stream)
                   (setf firstp nil))
             (format stream "]</td></tr>~%"))
       (format stream "</table>~%"))
      (:latex
       (labels ((variable (id &optional properties)
                  (let ((type (latex-escape-string (subseq id 0 1)))
                        (index (parse-integer id :start 1 :junk-allowed t)))
                    (format
                     nil "\\svar{~a}{~a}{~@[~a~]}"
                     type index properties))))
         (loop
             initially
               (format stream "\\eds{~a}{~%" (variable (eds-top eds)))
             for relations on (eds-relations eds)
             for ed = (first relations)
             for predicate = (latex-escape-string (ed-predicate ed))
             for carg = (and (ed-carg ed) (latex-escape-string (ed-carg ed)))
             for lnk = (when (ed-lnk ed)
                         (output-lnk (ed-lnk ed) :format :latex :stream nil))
             unless (ed-bleached-p ed) do
               (format
                stream "  \\sep{~a}{\\spred{~a~@[~a~]~@[(~a)~]}}{"
                (variable (ed-id ed)) predicate lnk carg)
               (loop
                   for (role . value) in (ed-arguments ed)
                   for firstp = t then nil 
                   when (ed-p value) do
                     (format
                      stream "~:[, ~;~%    ~]\\srole{~a}{~a}"
                      firstp role (variable (ed-id value))))
               (format stream "}~@[~*\\\\~%~]" (rest relations))
             finally (format stream "}~%"))))
      (:amr
       (when id (format stream "~&# ::id ~a~%" id))
       (when input (format stream "~&# ::snt ~a~%" input))
       (let ((attic (make-hash-table :test #'eq))
             (*package* (find-package :lkb))
             (*print-right-margin* columns)
             (*standard-output* stream))
         (labels ((output (ed &optional ignore)
                    (let ((match (gethash ed attic)))
                      (if match
                        (write-string match)
                        (let* ((id (ed-id ed)))
                          (setf (gethash ed attic) id)
                          (write-char #\()
                          (pprint-logical-block (nil nil)
                            (write-string id)
                            (write-string " / ")
                            (if (position #\/ (ed-predicate ed))
                              (write (ed-predicate ed))
                              (write-string (ed-predicate ed)))
                            (when (and lnkp (ed-lnk ed))
                              (write-string " :lnk ")
                              (write (output-lnk (ed-lnk ed) :stream nil)))
                            (when (ed-carg ed)
                              (write-string " :carg ")
                              (write (ed-carg ed)))
                            (loop
                                for (role . value) in (ed-inverse ed)
                                for match = (find role ignore :key #'first)
                                unless (or (not (ed-p value))
                                           (member value %eds-filter%)
                                           (eq value (rest match)))
                                do 
                                  (write-char #\space)
                                  (pprint-newline :linear)
                                  (write-char #\:)
                                  (write role)
                                  (write-string "-of ")
                                  (output value (cons (cons role ed) ignore)))
                            (loop
                                for (role . value) in (ed-arguments ed)
                                for match = (find role ignore :key #'first)
                                unless (or (not (ed-p value))
                                           (member value %eds-filter%)
                                           (eq value (rest match)))
                                do 
                                  (write-char #\space)
                                  (pprint-newline :linear)
                                  (write-char #\:)
                                  (write role)
                                  (write-char #\space)
                                  (output value (cons (cons role ed) ignore)))
                            (write-char #\))))))))
           (let* ((top (find 
                        (eds-top eds) (eds-relations eds)
                        :key #'ed-id :test #'string=)))
             (when top (output top) (terpri stream) (terpri stream)))
           (when (and debug
                      (< (hash-table-count attic) (length (eds-relations eds))))
             (format 
              debug "eds-output-psoa(): lost in AMR syntax ~@[[~a]~]~%" 
              id))
             (loop
                 for ed in (eds-relations eds)
                 unless (gethash ed attic)
                 do (format debug "  ~a~%" ed)))))
      (:dot
       (loop
           initially 
             ;;
             ;; _fix_me_
             ;; validate that the top is a valid node?           (4-aug-19; oe)
             ;;
             (format stream "digraph \"\" {~%")
             (format 
              stream 
              "  root [ style=invis ];~%  root -> ~a;~%" (eds-top eds))
           finally (format stream "}~%")
           for ed in (eds-relations eds)
           for id = (ed-id ed)
           for predicate = (ed-predicate ed)
           for carg = (ed-carg ed)
           do
             (format 
              stream "  ~a [ label=~s ];~%"
              id
              (if (and carg (eq cargp :inline))
                (format nil "~a(~s)" predicate carg)
                predicate))
             (when (and carg cargp (not (eq cargp :inline)))
               (format
                stream "  ~a -> ~a [ label=\"CARG\" ];~%"
                id carg))
             (loop
                 for (role . value) in (ed-arguments ed)
                 when (ed-p value) do
                   (format 
                    stream
                    "  ~a -> ~a [ label=\"~a\" ];~%"
                    id (ed-id value) role))))
      (:json
       (loop
           initially (format 
                      stream 
                      "~a{~:[~2*~;\"id\": ~a,~%~a~]~
                       ~:[~3*~;~:[~; ~]\"input\": ~s,~%~a~]~
                       ~:[~; ~]\"top\": ~s,~%~a \"nodes\": {~%"
                      prefix (numberp id) id prefix
                      (stringp input) (numberp id) input prefix
                      (or (numberp id) (stringp input)) (eds-top eds) prefix)
           with last = (first (last (eds-relations eds)))
           for ed in (eds-relations eds)
           for predicate = (ed-predicate ed)
           for carg = (ed-carg ed)
           for lnk = (when (ed-lnk ed) 
                       (output-lnk (ed-lnk ed) :format :json :stream nil))
           unless (or (ed-bleached-p ed)
                      (member ed %eds-filter%))
           do
             (format 
              stream 
              "~a   ~s: {\"label\": ~s~@[, \"lnk\": ~a~]~@[, \"carg\": ~s~]"
              prefix (ed-id ed) predicate lnk carg)
             (when (and *eds-show-properties-p* (ed-properties ed))
               (loop
                   with type = (first (ed-properties ed))
                   with properties = (if (extrapair-p type)
                                       (ed-properties ed)
                                       (rest (ed-properties ed)))
                   initially
                     (format
                      stream "~@[, \"type\": ~s~], \"properties\": {"
                      (unless (extrapair-p type) type))
                   finally (format stream "}")
                   for property in properties
                   do
                     (format
                      stream "~:[, ~;~]\"~a\": \"~(~a~)\""
                      (eq property (first properties))
                      (extrapair-feature property)
                      (extrapair-value property))))
             (loop
                 initially (format stream ", \"edges\": {")
                 for (role . value) in (ed-arguments ed)
                 for firstp = t then nil 
                 when (and (ed-p value)
                           (not (member value %eds-filter% :test #'eq)))
                 do
                   (format
                    stream "~:[, ~;~]~s: ~s"
                    firstp (string-upcase role) (ed-id value))
                 finally (format stream "}}"))
             (unless (eq ed last) (format stream ",~%"))
           finally (format stream "}}"))))))

(defun eds-variable-html (name properties)
  (let ((string (make-string-output-stream)))
    (format string "<table class=mrsProperties>")
    (format string "<tr><td colspan=2>~a</td></tr>" name)
    (loop
        for property in properties
        do
          (format 
           string
           "<tr><td class=mrsPropertyFeature>~a~
                <td class=mrsPropertyValue>~(~a~)</td></tr>"
           (extrapair-feature property) (extrapair-value property)))
    (format string "</table>")
    (get-output-stream-string string)))
#+:lkb
(defun eds-convert-edge (edge &key (vpm *eds-vpm*)
                                   (normalizep *eds-normalize-p*))
  (when (lkb::edge-p edge)
    (let ((mrs (or (lkb::edge-mrs edge) (extract-mrs edge))))
      (eds-convert-psoa mrs :vpm vpm :normalizep normalizep))))

(defun eds-convert-psoa (psoa &key (vpm *eds-vpm*)
                                   (normalizep *eds-normalize-p*)
                                   (filter *eds-predicate-filter*))
  (when (psoa-p psoa)
    (when vpm (setf psoa (mt:map-mrs psoa vpm)))
    #+:lkb
    (when (and normalizep (fboundp 'normalize-mrs))
      (setf psoa
        (funcall (symbol-function 'normalize-mrs) (mt::clone-mrs psoa))))
    (loop
        with eds = (make-eds :hcons (psoa-h-cons psoa) :raw psoa)
        initially (ed-reset)
        ;;
        ;; in a first pass through the EPs of the input MRS, create EDS graph
        ;; nodes, one per EP.  these will have their key properties set
        ;; (predicate, handle, distinguished variable, CARG, LNK, et al.) but
        ;; not yet contain any outgoing arcs.
        ;;
        for relation in (psoa-liszt psoa)
        for ed = (ed-convert-relation relation psoa)
        when ed do (push ed (eds-relations eds))
        finally
          (when *eds-include-icons-p*
            (loop
                for icons in (psoa-icons psoa)
                for ed = (ed-convert-icons icons)
                when ed do (push ed (eds-relations eds))))
          (setf (eds-relations eds) (nreverse (eds-relations eds)))
          ;;
          ;; next, post-process the EDS graph: first, classify `special' EDs,
          ;; i.e. messages, quantifiers, and so-called fragment EDs (which are
          ;; pseudo relations, much like underspecified conjunctions, used in
          ;; the LOGON NoEn MT system, to glue together XLE fragment analyses).
          ;; in the case of messages, there is optional support to equate the
          ;; label of the message with its SOA or MARG argument, i.e. `bleach'
          ;; the message, in the sense of making it gratuitous for the graph.
          ;;
          (eds-bleach-eds eds)
          ;;
          ;; next, actually fill in argument arcs: for each role in each ED,
          ;; find the ED that is assumed to be the `representative' for the
          ;; value (i.e. MRS variable) of this role; in doing so, consider =q
          ;; handle constraints as if the top and bottom handle were equated.
          ;; in the case of multiple candidate representative EDs, various 
          ;; disambiguation heuristics apply, see ed-select-representative().
          ;;
          (eds-augment-eds eds)
          ;;
          ;; as a matter of convenience, for example to output in AMR syntax,
          ;; cache inverse argument relations in each node.
          ;;
          (eds-inverse eds)
          ;;
          ;; finally, we need to make sure that all EDs end up with unique
          ;; identifiers, which from here on only serve to uniquely name the
          ;; nodes of the EDS dependency graph.  seeing that, in the initial
          ;; ED creation phase, ED identifiers were locally determined by the
          ;; distinguished variable, there is no protection against multiple
          ;; EDs sharing one distinguished variable (even though, with current
          ;; versions of the ERG at least, that seems likely only in illformed
          ;; input MRSs). 
          ;;
          (eds-uniq-ids eds)
          ;;
          ;; finally, determine what should be the root node of the dependency
          ;; graph: until early 2012, we always used to grab the INDEX, but in
          ;; a recent moment of clarity, we realized that the root node should
          ;; be parallel to the structure we create for clause subordination,
          ;; e.g. pairs like: `[Kim knows that] Abrams probably arrived.'
          ;;
          (let* ((ltop (ed-find-representative eds (psoa-top-h psoa)))
                 (index (ed-find-representative eds (psoa-index psoa))))
            (setf (eds-top eds)
              (or (and (ed-p ltop) (ed-id ltop))
                  (and (ed-p index) (ed-id index))
                  (and (var-p (psoa-index psoa))
                       (var-string (psoa-index psoa))))))
          ;;
          ;; we used to only filter (e.g. the pesky discourse relations in 1214)
          ;; during output, but really when a filter is in effect, these nodes
          ;; should not be part of the EDS in the first place.
          ;;
          (when filter
            (when (stringp filter) (setf filter (ppcre::create-scanner filter)))
            (setf (eds-relations eds)
              (loop
                  for ed in (eds-relations eds)
                  unless (and (ppcre:scan filter (ed-predicate ed))
                              (null (ed-inverse ed))
                              (not (string= (ed-id ed) (eds-top eds))))
                  collect ed)))
          (ed-reset)
          (return eds))))

(defun ed-convert-relation (relation mrs)
  
  (let (type)
    (when (and *eds-quantifier-argument* (is-quant-rel relation))
      ;;
      ;; to simplify downstream treatment of quantifiers, make sure the role 
      ;; name label of the bound variable is not ARG0.  but avoid destructive 
      ;; changes to our original input; this is potentially hazardous, as the
      ;; hash of relations to variables (%eds-symbol-table%) now uses a local
      ;; copy; for all i can tell just now, access to the hash table is within
      ;; the scope of ed-convert-relation(), however.          (15-jun-12; oe)
      ;;
      (setf relation (copy-rel relation))
      (setf (rel-flist relation)
        (loop
            with inherent
            = (list (vsym "INST") (vsym "ARG0"))
            for fvpair in (rel-flist relation)
            when (member (fvpair-feature fvpair) inherent :test #'eq)
            collect (make-fvpair
                     :feature *eds-quantifier-argument*
                     :value (fvpair-value fvpair))
            else collect fvpair))
      (setf type :quantifier))
    ;;
    ;; arguably hacky: in the ERG analysis of degree specifiers on quantifiers,
    ;; say ‘nearly all’, there is no connection other than label identification
    ;; between the degree specifier and the quantifier.  this means there is no
    ;; connection in terms of an argument relation or actual logical variables,
    ;; and by default degree specifiers come out unconnected to the dependency
    ;; graph.  our somewhat hand-wavy interpretation of this analysis for some
    ;; ten years now has been in term of ‘predicate modification’, i.e. roughly
    ;; like ‘nearly(all)[x, h1, h2]’.  one may think the degree specifier should
    ;; take the (label of the) quantifier as its ARG1, but that structure cannot
    ;; be scope-resolved within current assumptions.  hence, mimic that argument
    ;; relation on the degree specifier in EDS conversion.       (8-feb-14; oe)
    ;;
    (when *eds-predicate-modifiers*
      (let* ((predicate (when (rel-pred relation)
                          (string-downcase (string (rel-pred relation)))))
             (arg1 (loop
                       with arg1 = (vsym "ARG1")
                       for argument in (rel-flist relation)
                       when (eq (fvpair-feature argument) arg1)
                       return argument)))
        (when (and predicate
                   (loop
                       for pattern in *eds-predicate-modifiers*
                       thereis
                         (if (functionp pattern)
                           (ppcre:scan pattern predicate)
                           (ed-compare-predicates
                            predicate pattern :type :subsumption)))
                   (or (null arg1)
                       (and arg1 (var-p (fvpair-value arg1)) 
                            (string-equal (var-type (fvpair-value arg1)) "u"))))
          (let* ((label (rel-handel relation)))
            ;;
            ;; _fix_me_
            ;; as pointed out by mike on the 'developers' list (15-jul-18),
            ;; there can be more than predication involved, as for example in
            ;; |quite nearly all] [chairs arrived].  maybe extract the full set
            ;; and prefer quantifiers as the target of predicate modification?
            ;; or maybe just stack them in surface order, but avoid cyclic
            ;; modifications, e.g. quite(nearly)(all)[...] for the above?
            ;;                                                   (1-aug-20; oe)
            (when (loop
                      for relation in (psoa-liszt mrs)
                      thereis (eq (rel-handel relation) label))
              (setf relation (copy-rel relation))
              (setf (rel-flist relation)
                (if arg1
                  (loop
                      with arg1 = (vsym "ARG1")
                      for argument in (rel-flist relation)
                      when (eq (fvpair-feature argument) arg1)
                      collect (make-fvpair :feature arg1 :value label)
                      else collect argument)
                  (append 
                   (rel-flist relation) 
                   (list (make-fvpair :feature (vsym "ARG1") :value label)))))
              (setf type :specifier))))))

    (let* ((*package* (find-package :lkb))
           (handle (let ((handle (rel-handel relation)))
                     (when (ed-handle-p handle) (var-string handle))))
           (identifier (ed-find-identifier relation))
           (predicate (when (rel-pred relation)
                        (string-downcase (string (rel-pred relation)))))
           (abstraction
            #+:cl-ppcre
            (when predicate
              (cond
               ((ppcre:scan "_a(?:_[^_]+)?_rel" predicate) :a)
               ((ppcre:scan "_n(?:_[^_]+)?_rel" predicate) :n)
               ((ppcre:scan "_p(?:_[^_]+)?_rel" predicate) :p)
               ((ppcre:scan "_q(?:_[^_]+)?_rel" predicate) :q)
               ((ppcre:scan "_v(?:_[^_]+)?_rel" predicate) :v)
               (t :x))))
           (predicate (if (and predicate (stringp *sem-relation-suffix*))
                        (remove-right-sequence 
                         (string-downcase *sem-relation-suffix*) predicate)
                        predicate))
           (flist (rel-flist relation))
           (carg (loop
                     with carg = (list (vsym "CARG") 
                                       (vsym "NAMED")
                                       (vsym "CONST_VALUE"))
                     for fvpair in flist
                     when (member (fvpair-feature fvpair) carg :test #'eq)
                     return (fvpair-value fvpair)))
           (lnk (let* ((lnk (rel-lnk relation))
                       (from (rel-cfrom relation))
                       (to (rel-cto relation)))
                  (or lnk
                      (and (numberp from) (numberp to) (>= from 0) (>= to 0)
                           (list :characters from to))))))
      (make-ed
       :handle handle
       :id (first identifier) :properties (rest identifier)
       :predicate predicate :lnk lnk :carg carg :abstraction abstraction
       :type type :raw relation))))

(defun ed-convert-icons (icons)
  (let* ((id (format nil "_~d" (incf %eds-variable-counter%)))
         (predicate (icons-relation icons))
         (predicate
          (cond
           ((string-equal predicate "topic") ">t")
           ((string-equal predicate "non-topic") "!t")
           ((string-equal predicate "focus") ">f")
           ((string-equal predicate "non-focus") "!f")
           (predicate (string-downcase predicate)))))
    (make-ed
     :id id :predicate predicate :type :icons :raw icons)))

(defun eds-bleach-eds (eds)
  (loop
      for ed in (eds-relations eds)
      when (and (null (ed-type ed)) (ed-message-p ed)) do
        (let* ((handle (ed-handle ed))
               (relation (ed-raw ed))
               (soa (loop
                        with soa = (list (vsym "SOA") (vsym "MARG"))
                        for fvpair in (rel-flist relation)
                        thereis 
                          (when (member (fvpair-feature fvpair) soa :test #'eq)
                            (fvpair-value fvpair)))))
          (when (ed-handle-p soa)
            (setf (gethash handle %eds-equivalences%) soa))
          (setf (ed-type ed) :message))
      when (and (null (ed-type ed)) (ed-quantifier-p ed))
      do (setf (ed-type ed) :quantifier)
      when (and (null (ed-type ed)) (ed-fragment-p ed))
      do (setf (ed-type ed) :fragment)))

(defun eds-augment-eds (eds)
  (loop
      for ed in (eds-relations eds)
      when (eq (ed-type ed) :icons) do
        (let* ((icons (ed-raw ed))
               (left (ed-find-representative eds (icons-iarg1 icons)))
               (right (ed-find-representative eds (icons-iarg2 icons))))
          (when (ed-p right)
            (push (cons (vsym "LO") right) (ed-arguments ed)))
          (when (ed-p left)
            (push (cons (vsym "HI") left) (ed-arguments ed))))
      unless (or (ed-bleached-p ed) (eq (ed-type ed) :icons)) do
        (loop
            with old = (vsym "CONST_VALUE")
            with relation = (ed-raw ed)
            with flist = (rel-flist relation)
            for feature in %eds-relevant-features%
            for key = (vsym feature)
            for filter = (rest (assoc key *eds-argument-filter*))
            for match =
              (when filter
                (let* ((match (find (first filter) flist :key #'fvpair-feature))
                       (value (and match (fvpair-value match))))
                  (when value
                    (ppcre:scan (second filter) (var-string value)))))
            for value = (loop
                            for fvpair in flist
                            thereis 
                              (when (eq (fvpair-feature fvpair) key)
                                (fvpair-value fvpair)))
            for representative = (when (and value (not match))
                                   (ed-find-representative 
                                    eds value ed))
            when representative do
              (when (eq key old) (setf key (vsym "CARG")))
              #+:null
              (when (ed-p representative)
                (setf (ed-variable representative) value))
              (push (cons key representative) (ed-arguments ed)))
        (setf (ed-arguments ed) (nreverse (ed-arguments ed)))))

(defun eds-inverse (eds)
  (loop
      for ed in (eds-relations eds)
      do
        (loop
            for (role . value) in (ed-arguments ed)
            when (ed-p value)
            do (push (cons role ed) (ed-inverse value)))))

(defun eds-uniq-ids (eds)
  (loop
      for ed in (eds-relations eds)
      for id = (ed-id ed)
      for collisions
      = (loop
            for ed in (eds-relations eds)
            when (equal (ed-id ed) id) collect ed)
      when (rest collisions) do
        (let ((representative
               (loop
                   for foo being each hash-key in %eds-representatives-table%
                   when (and (var-p foo) (string= (var-string foo) id))
                   return (gethash foo %eds-representatives-table%))))
          (when representative
            (setf collisions (delete representative collisions)))
          (setf collisions
            (sort
             collisions #'>
             :key #'(lambda (ed) (length (ed-arguments ed)))))
          (loop
              for ed in (if representative collisions (rest collisions))
              do
                (setf (ed-id ed)
                  (format nil "_~d" (incf %eds-variable-counter%)))))))

(defun ed-find-identifier (relation)
  (or (gethash relation %eds-symbol-table%)
    (let* ((flist (and (rel-p relation) (rel-flist relation)))
           instance event)
      (loop
          for fvpair in flist
          for feature = (fvpair-feature fvpair)
          when (eq feature (vsym "EVENT"))
          do (setf event (fvpair-value fvpair))
          when (unless (ed-message-p relation)
                 (or (eq feature (vsym "INST")) 
                     (eq feature (vsym "ARG0"))
                     (eq feature (vsym "C-ARG"))))
          do (setf instance (fvpair-value fvpair)))
      (let* ((variable (or (and (var-p instance) instance)
                           (and (var-p event) event)))
             (name (if variable
                     (var-string variable)
                     (format nil "_~d" (incf %eds-variable-counter%))))
             (type (and variable (var-type variable)))
             (properties (and variable (cons type (var-extra variable)))))
        (setf (gethash relation %eds-symbol-table%) (cons name properties))))))

(defun eds-arguments (node eds &key (type :all) transitive cache)
  ;;
  ;; _fix_me_
  ;; this function (like a few others, no doubt), is a little funny in that it
  ;; conceptually operates over the MRS, still, but needs to take advantage of
  ;; some of the notions used in conversion to EDS, notably the identification
  ;; of the distinguished variable and interpretation of =q handle constraints
  ;; as a kind of equality.  review more thoroughly, one day.   (2-jul-16; oe)
  ;;
  (loop
      for fvpair 
      in (unless (eq (ed-type node) :icons) (rel-flist (ed-raw node)))
      for value = (fvpair-value fvpair)
      for id = (and (var-p value) (var-string value))
      when (and id (not (string= id (ed-id node))))
      append
        (loop
            with cache = (cons node cache)
            with key 
            = (if (is-handel-var value) 
                (and (member type '(:handle :all) :test #'eq) #'ed-handle)
                (and (member type '(:variable :all) :test #'eq) #'ed-id))
            with qeq 
            = (when (and (is-handel-var value) 
                         (member type '(:handle :all) :test #'eq))
                (let ((qeq (ed-hcons-qeq eds value)))
                  (and (is-handel-var qeq) (var-string qeq))))
            for ed in (eds-relations eds)
            when (and (not (eq node ed))
                      key
                      (or (string= id (funcall key ed))
                          (and qeq (string= qeq (ed-handle ed)))))
            append (cons 
                    ed 
                    (when (and transitive
                               (not (member node (rest cache) :test #'eq)))
                      (eds-arguments
                       ed eds 
                       :type type :transitive transitive :cache cache))))))

(defun ed-find-representative (eds variable &optional functor)
  (or (gethash variable %eds-representatives-table%)
      (setf (gethash variable %eds-representatives-table%)
        (cond
         ((ed-handle-p variable)
          (loop
              with alternate = (ed-variable-equivalence variable)
              with name = (var-string (or alternate variable))
              with qeq = (ed-hcons-qeq eds name)
              for ed in (eds-relations eds)
              for handle = (ed-handle ed)
              when (and (not (ed-bleached-p ed))
                        (or (equal name handle) 
                            (and (ed-handle-p qeq) 
                                 (equal (var-string qeq) handle)))
                        (not (eq (ed-type ed) :specifier)))
              collect ed into candidates
              finally 
                (return
                  (if (and candidates (null (rest candidates)))
                    (first candidates)
                    (ed-select-representative
                     eds
                     (append
                      (when (ed-handle-p qeq)
                        (ed-find-representative qeq nil))
                      (when (var-p alternate)
                        (ed-find-representative alternate nil))
                      candidates)
                     functor)))))
         ((var-p variable)
          (loop
              with foo = (var-string variable)
              with name = (let ((bar (ed-variable-equivalence foo)))
                            (if  bar (var-string bar) foo))
              for ed in (eds-relations eds)
              for id = (unless (or (ed-bleached-p ed)
                                   (ed-quantifier-p ed))
                         (ed-id ed))
              when (equal name id) collect ed into candidates
              finally 
                (return
                  (if (and candidates (null (rest candidates)))
                    (first candidates)
                    (ed-select-representative eds candidates functor)))))
         ((stringp variable) variable)))))

(defun ed-select-representative (eds candidates functor
                                 &key (debug *eds-debug-p*))
  ;;
  ;; given a set of candidate representatives (typically corresponding to EPs
  ;; within one LF conjunct, i.e. sharing the same handle), heuristically find
  ;; one to stand in for the conjunction: give preference to EPs with a `real'
  ;; intrinsic variable (i.e. ones introducing an event or instance variable) 
  ;; or look at the dependency topology among the candidate EPs and choose one
  ;; that occurs as an argument to the other(s).
  ;;
  (labels ((filter (predicate list)
             (let ((result (remove-if predicate list)))
               #+:null
               (format t "filter(): ~a --> ~a~%" predicate result)
               (if (null result) list result)))
           (modifierp (node eds)
             (loop
                 for fvpair in (rel-flist (ed-raw node))
                 for value = (fvpair-value fvpair)
                 for id = (and (var-p value) (var-string value))
                 thereis (when (and id (not (string= id (ed-id node))))
                           (loop
                               for ed in eds
                               thereis (unless (eq ed node)
                                         (string= id (ed-id ed)))))))
           (argumentp (node target)
             (loop
                 for fvpair in (rel-flist (ed-raw node))
                 for value = (fvpair-value fvpair)
                 for id = (and (var-p value) (var-string value))
                 thereis (and id (not (string= id (ed-id node)))
                              (string= id (ed-id target)))))
           (report (context candidates)
             (when debug
               (format
                t "ed-select-representative(): ~a after ~a filter:~%  ~w~%~%"
                (length candidates) context candidates))))
    ;;
    ;; a singleton .candidates. set presents a trivial selection problem
    ;;
    (when (null (rest candidates))
      (return-from ed-select-representative (first candidates)))
    ;;
    ;; if we were ‘bleaching’ select nodes, these cannot be representatives
    ;;
    (report :no candidates)
    (setf candidates (filter #'ed-bleached-p candidates))
    (report :bleach candidates)
    (when (null (rest candidates))
      (return-from ed-select-representative (first candidates)))
    ;;
    ;; dis-prefer any candidates that are on the grammar-specific `black list’
    ;;
    (setf candidates (filter #'ed-non-representative-p candidates))
    (report :non-representative candidates)
    (when (null (rest candidates))
      (return-from ed-select-representative (first candidates)))
    ;;
    ;; the following two disambiguation attempts are only historically relevant,
    ;; dis-preferring messages and nodes whose identifier was synthesized (i.e.
    ;; where there was no distinguished variable available, or it was shared
    ;; with another node, who got to own it); for the special case of predicate
    ;; modifiers (a .functor. of type :specifier), these will often look for a
    ;; quantifier, hence disable disambiguation heuristics that would disprefer
    ;; quantifiers.
    ;;
    (setf candidates (filter #'ed-message-p candidates))
    (report :message candidates)
    (when (null (rest candidates))
      (return-from ed-select-representative (first candidates)))
    (unless (and functor (eq (ed-type functor) :specifier))
      (setf candidates
        (filter #'(lambda (ed) (char= (char (ed-id ed) 0) #\_)) candidates))
      (report :identifier candidates)
      (when (null (rest candidates))
        (return-from ed-select-representative (first candidates))))
    ;;
    ;; also mostly in the spirit of historic backwards compatibility (where we
    ;; never expect to trigger this case, actually), dis-prefer quantifiers.
    ;;
    (unless (and functor (eq (ed-type functor) :specifier))
      (setf candidates
        (filter #'(lambda (ed) (eq (ed-type ed) :quantifier)) candidates))
      (report :quantifier candidates)
      (when (null (rest candidates))
        (return-from ed-select-representative (first candidates))))
    ;;
    ;; as a general policy, try to avoid cyclic dependencies, i.e. do not pick
    ;; a representative that has .functor. among its own arguments.
    ;;
    (when functor
      (let ((acycles
             (filter #'(lambda (ed) (argumentp ed functor)) candidates)))
        (report :cycles acycles)
        (when (null (rest acycles))
          (return-from ed-select-representative (first acycles)))
        (when acycles (setf candidates acycles))))
    ;;
    ;; the most common cause of one-to-many correspondences between a variable
    ;; and a set of EPs are handles shared with (intersective) modifiers, e.g.
    ;; in a structure like [believe that] `she arrived very quickly.'  here,
    ;; the degree specifier is an intersective modifier on the adverb, which in
    ;; turn is an intersective modifier on the arriving event; thus, all three
    ;; share one label, and `arrive' is the ARG1 of `quickly', which is the
    ;; ARG1 of `very'.  to pick out `arrive' in this scenario, dis-prefer any
    ;; predications that take other .candidates. elements as their arguments.
    ;;
    (setf candidates 
      (filter #'(lambda (ed) (modifierp ed candidates)) candidates))
    (report :modifier candidates)
    (when (null (rest candidates))
      (return-from ed-select-representative (first candidates)))
    ;;
    ;; as part of the grand unification of EDS implementations (with bec and
    ;; mike, mid-2016), we found that non-scopal modifiers can also attach to
    ;; scopal modifiers, e.g. in csli/795: ‘browne merely doesn't work.’  at
    ;; first, we explored whether linkage counts into or out of the candidate
    ;; nodes might suffice to prefer the scopal modifier over the non-scopal
    ;; one (i.e. make predicate–argument dominance relations mirror the scope
    ;; hierarchy), but that turns out to not differentiate in this case at all.
    ;; hence, we need to detect ‘merely’ as a non-scopal modifier on one of the
    ;; scopal arguments of ‘neg’, and in principle that argument relation could
    ;; be transitively nested, of course.
    ;;
    ;; _fix_me_
    ;; in this form, the code below can trigger on a non-empty intersection of
    ;; the two sets of descendants for the same predication; probably, we need
    ;; to guard against that.                                   (2-jul-16; oe)
    ;; 
    (let* ((scopal 
            (loop 
                for ed in candidates
                collect (eds-arguments ed eds :type :handle :transitive t)))
           (predicate 
            #'(lambda (ed)
                (loop
                    with arguments
                    = (eds-arguments ed eds :type :variable :transitive nil)
                    for targets in scopal
                    thereis (intersection arguments targets :test #'eq)))))
      (setf candidates (filter predicate candidates)))
    (report :scopal candidates)
    (when (null (rest candidates))
      (return-from ed-select-representative (first candidates)))
    ;;
    ;; in 1214 at least, mrs/991 (‘there were cats in the garden’) has ‘in_p’
    ;; share its label with the existential be, but the external argument of
    ;; the preposition actually is the instance variable of ‘cats’.  not sure
    ;; this really is the intended (or correct) analysis, as it fails to give a
    ;; parallel structure for ‘in the garden, there were cats’.  but either
    ;; way, to pick the existential ‘be’ over the preposition, we need to
    ;; dis-prefer untensed events.
    ;;
    (setf candidates (filter #'ed-untensed-p candidates))
    (report :untensed candidates)
    (when (null (rest candidates))
      (return-from ed-select-representative (first candidates)))
    ;;
    ;; from here on, we are grasping at straws (and likely looking at input
    ;; structures that are not perfectly well-formed).  if there still is a
    ;; need for disambiguation at this point, we used to give preference to
    ;; nodes that have more incoming links, i.e. are more connected to the
    ;; structure at large (as arguments), and then (if need) consider outgoing
    ;; link counts as a final tie-breaker.  
    ;;
    (report :final candidates)
    (first candidates)
    #+:null
    (labels ((referrers (target candidates)
               (loop
                   with id = (ed-id target)
                   for ed in candidates
                   for flist = (unless (eq ed target) (rel-flist (ed-raw ed)))
                   unless (ed-bleached-p ed)
                   when (loop
                            for fvpair in flist
                            for value = (fvpair-value fvpair)
                            thereis (when (var-p value) 
                                      (equal (var-string value) id)))
                   append
                     (cons ed (referrers ed (remove target candidates)))))
             (incoming (candidates &optional (eds candidates))
               (let ((referrers
                      (loop
                          for candidate in candidates
                          for referrers = (referrers candidate eds)
                          when referrers
                          collect (cons (length referrers) candidate))))
                 (setf referrers (sort referrers #'> :key #'first))
                 (loop
                     with n = (first (first referrers))
                     for referrer in referrers
                     while (= (first referrer) n)
                     collect (rest referrer))))
             (outgoing (candidates)
               (let ((references
                      (loop
                          for candidate in candidates
                          for n = (length (ed-arguments candidate))
                          collect (cons n candidate))))
                 (setf references (sort references #'> :key #'first))
                 (loop
                     with n = (first (first references))
                     for reference in references
                     while (= (first reference) n)
                     collect (rest reference))))))))

(defun ed-handle-p (variable)
  (when (var-p variable)
    (is-handel-var variable)))

(defun ed-hcons-qeq (eds handle)
  (loop
      with name = (if (stringp handle) 
                    handle
                    (when (ed-handle-p handle) (var-string handle)))
      for hcons in (eds-hcons eds)
      for scarg = (when (string-equal (hcons-relation hcons) "qeq")
                    (var-string (hcons-scarg hcons)))
      thereis 
        (when (equal name scarg) (hcons-outscpd hcons))))

(defun ed-variable-equivalence (variable)
  (if (var-p variable)
    (gethash (var-string variable) %eds-equivalences%)
    (gethash variable %eds-equivalences%)))

(defun ed-quantifier-p (ed)
  (or
   (eq (ed-type ed) :quantifier)
   (let* ((raw (ed-raw ed))
          (flist (and (rel-p raw) ; JAC 16-Feb-2022 - was (psoa-p raw)
                      (rel-flist raw))))
     (find *scope-feat* flist :key #'fvpair-feature))
   (let ((pred (ed-predicate ed)))
     (and (stringp pred) (eql (mismatch "_q" pred :from-end t) 0)))))

(defun ed-compare-predicates (predicate1 predicate2 &key (type :equivalence))
  (if *normalize-predicates-p*
    (let ((predicate1 (normalize-predicate predicate1))
          (predicate2 (normalize-predicate predicate2)))
      (or (string= predicate1 predicate2)
          (when (eq type :subsumption)
            (mt:semi-compare-predicates predicate1 predicate2 :type type))))
     (or (eq predicate1 predicate2)
         (when (and (stringp predicate1) (stringp predicate2))
           (string-equal predicate1 predicate2))
         (when (eq type :subsumption)
           (let ((type1 (vsym predicate1))
                 (type2 (vsym predicate2)))
             (or (eq type1 type2)
                 (when (and (is-valid-type type1) (is-valid-type type2))
                   (ignore-errors (mrs:equal-or-subtype type1 type2)))))))))

(defun ed-message-p (thing)
  (when *eds-message-relation*
    (typecase thing
      (ed
       (let ((predicate (ed-predicate thing)))
         (or (eq (ed-type thing) :message)
             (ed-compare-predicates
              predicate *eds-message-relation* :type :subsumption)
             (and (ed-raw thing) (ed-message-p (ed-raw thing)))
             (eql (mismatch "_m" predicate :from-end t) 0))))
      (rel
       (let ((predicate (rel-pred thing)))
         (or (eq predicate *eds-message-relation*)
             (and (stringp predicate)
               (eql (mismatch "_m_rel" predicate :from-end t) 0))
             (ignore-errors
              (equal-or-subtype predicate *eds-message-relation*))))))))

(defun ed-untensed-p (properties)
  (if (ed-p properties)
    (ed-untensed-p (ed-properties properties))
    (loop
        for pair in properties
        for property = (and (extrapair-p pair) (extrapair-feature pair))
        for test = (and property (rest (assoc property *eds-untensed*)))
        when test return (eq (extrapair-value pair) test)
        ;;
        ;; also, consider variables untensed when there is no TENSE property
        ;;
        finally (return t))))

(defun ed-fragment-p (ed)
  (when *eds-fragment-relation*
    (or (eq (ed-type ed) :fragment)
        (ed-compare-predicates
         (ed-predicate ed) *eds-fragment-relation* :type :subsumption)
        (let ((pred (and (rel-p (ed-raw ed)) (rel-pred (ed-raw ed)))))
          (when pred
            (ignore-errors 
             (equal-or-subtype pred (vsym *eds-fragment-relation*))))))))

(defun ed-bleached-p (ed)
  (or
   (and (null *eds-include-messages-p*) (eq (ed-type ed) :message))
   (and (null *eds-include-quantifiers-p*) (eq (ed-type ed) :quantifier))
   (when (and *eds-bleached-relations* (not (eq (ed-type ed) :icons)))
     (loop
         with predicate = (ed-predicate ed)
         with pred = (and (rel-p (ed-raw ed)) (rel-pred (ed-raw ed)))
         for relation in *eds-bleached-relations*
         thereis (or (ed-compare-predicates
                      predicate relation :type :subsumption)
                     (ignore-errors
                      (equal-or-subtype pred (vsym relation))))))))

(defun ed-non-representative-p (ed)
  (when (and *eds-non-representatives* (not (eq (ed-type ed) :icons)))
    (loop
        with predicate = (ed-predicate ed)
        with pred = (and (rel-p (ed-raw ed)) (rel-pred (ed-raw ed)))
        for relation in *eds-non-representatives*
        thereis (or (ed-compare-predicates
                     predicate relation :type :subsumption)
                    (ignore-errors 
                     (equal-or-subtype pred (vsym relation)))))))

(defun ed-vacuous-p (ed)
  (unless *eds-include-vacuous-relations-p*
    (unless (and *eds-include-quantifiers-p* (eq (ed-type ed) :quantifier))
      (or (null (ed-arguments ed))
          (and (null (rest (ed-arguments ed)))
               (eq (first (first (ed-arguments ed))) (vsym "CARG")))))))

(defun eds-suspicious-p (eds)
  (append (when (eds-cyclic-p eds) '(:cyclic))
          (when (eds-fragmented-p eds) '(:fragmented))))

(defun eds-cyclic-p (eds)
  (loop
      with return = nil
      for ed in (eds-relations eds)
      unless (or (ed-bleached-p ed) (null (ed-arguments ed))) do
        (unless (ed-walk ed)
          (pushnew :cyclic (ed-status ed))
          (setf return t))
      finally 
        (when return (pushnew :cyclic (eds-status eds)))
        (return return)))

(defun ed-walk (ed &optional (start (list (ed-id ed)) startp))
  ;;
  ;; _fix_me_
  ;; on certain platforms (notably Linux), Allegro CL 6.2 will fail to detect a
  ;; stack overflow in (certain) recursive functions; this was pointed out to
  ;; Franz as [spr27625] in apr-03, and soon my favourite tech person, Lois 
  ;; Wolf, suggested to make those functions not-inline.       (19-may-03; oe)
  ;;
  #+:null
  (declare (notinline ed-walk))
  ;;
  ;; _fix_me_
  ;; why not use the actual ED structures, to protect against cycles?
  ;;                                                           (25-feb-12; oe)
  (unless (and startp (member (ed-id ed) start))
    (loop
        for (role . value) in (unless (ed-bleached-p ed) (ed-arguments ed))
        when (ed-p value) do
          (setf role role)
          (unless (ed-walk value (adjoin (ed-id ed) start)) (return nil))
        finally (return t))))

(defun eds-fragmented-p (eds)
  (let ((mark (gensym))
        (agenda (loop
                    with top = (eds-top eds)
                    for ed in (eds-relations eds)
                    when (string= (ed-id ed) top) collect ed)))
    ;;
    ;; put .mark. on all EDs that are `reachable' from the top variable
    ;;
    (loop
        for ed = (pop agenda)
        for id = (and ed (ed-id ed))
        while ed do
          (unless (or (eq (ed-mark ed) mark) (ed-bleached-p ed))
            (setf (ed-mark ed) mark)
            ;;
            ;; put all arguments of current ED on agenda (for future marking)
            ;;
            (loop
                for argument in (ed-arguments ed)
                when (ed-p (rest argument)) do (push (rest argument) agenda))
            ;;
            ;; also, add all EDs for which the current one is an argument, i.e.
            ;; the inverse link.
            ;;
            (loop
                for ed in (eds-relations eds)
                unless (or (eq (ed-mark ed) mark) (ed-bleached-p ed)) do
                  (loop
                      for argument in (ed-arguments ed)
                      when (and (ed-p (rest argument))
                                (equal (ed-id (rest argument)) id)) do
                        (push ed agenda)))))

    (loop
        with return = nil
        for ed in (eds-relations eds)
        when (and (not (ed-bleached-p ed)) 
                  (not (eq (ed-mark ed) mark)))
        do
          (pushnew :fragmented (ed-status ed))
          (setf return t)
        else when (eq (ed-mark ed) mark)
        do (setf (ed-status ed) (delete :fragmented (ed-status ed)))
        finally 
          (loop
              for ed in (eds-relations eds)
              when (eq (ed-type ed) :fragment) do (setf return nil))
          (when return (pushnew :fragmented (eds-status eds)))
          (return return))))

(defun eds-explode (eds &key (lnkp *eds-show-lnk-p*)
                             (propertiesp *eds-show-properties-p*)
                             (cargp t) collocationp
                             tagp abstractp)
  
  ;;
  ;; _fix_me_
  ;; to be more informative, particularly when predicates occur more than once
  ;; in an MRS, this would have to include characterization.   (23-jan-04; oe)
  ;; --- or another way of linking to surface positions, e.g. the new LNK set
  ;; of surface token identifiers (in the VM and YY spirit :-).
  ;;
  
  ;;
  ;; _fix_me_
  ;; not sure what the `variable' slot was intended for, but it appears to be
  ;; exclusively used in eds-explode(); make sure all EDs have a correct value.
  ;;                                                           (26-nov-04; oe)
  (loop
      with key = (vsym "ARG0")
      for ed in (eds-relations eds)
      for raw = (ed-raw ed)
      for roles = (and (rel-p raw) (rel-flist raw))
      for arg0 = (loop
                     for role in roles
                     when (eq (fvpair-feature role) key)
                     return (fvpair-value role))
      do (setf (ed-variable ed) arg0))

  (nconc
   (loop
       for ed in (eds-relations eds)
       for functor = (format
                      nil
                      "~a~@[(~a)~]"
                      (ed-linked-predicate ed :lnkp lnkp)
                      (and cargp (ed-carg ed)))
       unless (and (null (ed-status ed)) 
                   (or (ed-bleached-p ed) (ed-vacuous-p ed)))
       nconc
         (nconc
          ;;
          ;; _fix_me_
          ;; this is getting somewhat baroque: we want a way of including
          ;; quantifiers in this list, jointly with the EP introducing the
          ;; variable bound by the quantifier.                 (13-aug-04; oe)
          ;;
          (when (ed-quantifier-p ed)
            (let* ((target (loop
                               with id = (ed-id ed)
                               for ed in (eds-relations eds)
                               when (and (equal (ed-id ed) id)
                                         (not (ed-quantifier-p ed)))
                               return ed))
                   (result (when target
                             (list functor (vsym "ARG0")
                                   (format
                                    nil
                                    "~a~@[(~a)~]"
                                    (ed-linked-predicate target :lnkp lnkp)
                                    (and cargp (ed-carg target))))))
                   (abstraction (when (and target abstractp)
                                  (ed-linked-abstraction target :lnkp lnkp)))
                   (abstraction (when abstraction
                                  (list functor (vsym "ARG0") abstraction))))
              (nconc
               (when result (list (append (and tagp '(:ep)) result)))
               (when abstraction
                 (list (append (and tagp '(:ap)) abstraction))))))
          (loop
              for (role . value) in (ed-arguments ed)
              when (and (null tagp) (ed-p value)) collect
                (let ((argument (format
                                 nil
                                 "~a~@[(~a)~]"
                                 (ed-linked-predicate value :lnkp lnkp)
                                 (and cargp (ed-carg value)))))
                  (list functor role argument))
              into eps
              when (and abstractp (null tagp)
                        (ed-p value) (ed-abstraction value)) collect
                (let ((argument (format
                                 nil
                                 "~a~@[(~a)~]"
                                 (ed-linked-abstraction value :lnkp lnkp)
                                 (and cargp (ed-carg value)))))
                  (list functor role argument))
              into abstractions
              when (and tagp (ed-p value)) nconc
                (let ((argument (format
                                 nil
                                 "~a~@[(~a)~]"
                                 (ed-linked-predicate value :lnkp lnkp)
                                 (and cargp (ed-carg value)))))
                  (list role argument))
              into eps
              when (and abstractp tagp
                        (ed-p value) (ed-abstraction value)) nconc
                (let ((argument (format
                                 nil
                                 "~a~@[(~a)~]"
                                 (ed-linked-abstraction value :lnkp lnkp)
                                 (and cargp (ed-carg value)))))
                  (list role argument))
              into abstractions
              finally (return
                        (nconc
                         (if tagp
                           (and eps (list (append (list :ep functor) eps)))
                           eps)
                         (if tagp
                           (and abstractions
                                (list (append (list :ap functor) abstractions)))
                           abstractions))))))
                         
   
   (when propertiesp
     (loop
         for ed in (eds-relations eds)
         unless (or (and (null (ed-status ed)) (ed-bleached-p ed))
                    (ed-quantifier-p ed)
                    (ed-message-p ed)
                    (not (var-p (ed-variable ed))))
         nconc
           (loop
               with id = (format
                          nil
                          "~a~@[(~a)~]"
                          (ed-linked-predicate ed :lnkp lnkp)
                          (and cargp (ed-carg ed)))
               with ad = (ed-linked-abstraction ed :lnkp lnkp)
               for extra in (var-extra (ed-variable ed))
               for value = (format nil "~(~a~)" (extrapair-value extra))
               when (and (null tagp) value) collect 
                 (list id (extrapair-feature extra) value)
               into indices
               when (and abstractp ad (null tagp) value) collect 
                 (list ad (extrapair-feature extra) value)
               into abstractions
               when (and tagp value) nconc
                 (list (extrapair-feature extra) value)
               into indices
               when (and abstractp ad tagp value) nconc
                 (list (extrapair-feature extra) value)
               into abstractions
               finally
                 (return
                   (nconc
                    (if tagp
                      (and indices (list (append (list :index id) indices)))
                      indices)
                    (if tagp
                      (and abstractions
                           (list (append (list :andex ad) abstractions)))
                      abstractions))))))
                    
   (when collocationp
     (loop
         with functors
         = (loop
               for ed in (eds-relations eds)
               for functor = (format
                              nil
                              "~a~@[(~a)~]"
                              (ed-linked-predicate ed :lnkp lnkp)
                              (and cargp (ed-carg ed)))
               for abstraction = (ed-linked-abstraction ed :lnkp lnkp)
               unless (and (null (ed-status ed)) (ed-bleached-p ed))
               collect (cons functor abstraction) into functors
               finally
                 (return (sort functors #'string< :key #'first)))
         for functor in functors
         for i from 1
         nconc
           (loop
               for match in (nthcdr i functors)
               collect (list (first functor) (first match))
               when (and abstractp (rest functor))
               collect (list (rest functor) (first match))
               when (and abstractp (rest match))
               collect (list (first functor) (rest match))
               when (and abstractp (rest functor) (rest match))
               collect (list (rest functor) (rest match)))))))

(defun ed-reset ()
  (setf %eds-variable-counter% 0)
  (unless *eds-debug-p*
    (clrhash %eds-symbol-table%)
    (clrhash %eds-representatives-table%)
    (clrhash %eds-equivalences%)))

(defun ed-flag (eds &optional ed 
                &key (up t) (down t) n top bottom (mark (gensym "")))
  (loop for ed in (eds-relations eds) do (setf (ed-mark ed) nil))
  (labels ((prefixp (prefix list &key (test #'eql))
             (loop
                 for foo in prefix
                 for bar in list
                 always (funcall test foo bar))))
    (let* ((ed (or ed (find
                       (eds-top eds) (eds-relations eds)
                       :key #'ed-id :test #'string=)))
           (agenda (and ed (list (list ed)))))
      ;;
      ;; put .mark. on all EDs that are `reachable' from the top-level .ed.
      ;;
      (loop
          with *package* = (find-package :lkb)
          for bucket = (pop agenda)
          for current = (first bucket)
          for path = (rest bucket)
          while bucket
          unless (or (ed-bleached-p current)
                     (when (eq (first (ed-mark current)) mark)
                       (member path (rest (ed-mark current)) :test #'prefixp)))
          do
            #-:null
            (format
             t "~a [~{~a~^ ~}] <-- ~a~%"
             (ed-predicate current) (rest (ed-mark current)) path)
            (if (ed-mark current)
              (push path (rest (ed-mark current)))
              (setf (ed-mark current) (list mark path)))
          when (and down
                    (or (null n) (<= (length path) n))
                    (not (and bottom (funcall bottom eds current)))) do
            ;;
            ;; put all arguments of current ED on agenda (for future marking)
            ;;
            (loop
                for (role . value) in (ed-arguments current)
                when (and (ed-p value)
                          (not (and (consp (first path))
                                    (eq role (first (first path))))))
                do (push (cons value (cons role path)) agenda))
          when (and up
                    (or (null n) (<= (length path) n))
                    (not (and top (funcall top eds current)))) do
            ;;
            ;; also, add all EDs for which the current one is an argument, i.e.
            ;; the inverse link.
            ;;
            (loop
                for ed in (eds-relations eds)
                unless (or (ed-bleached-p ed) (eq (first (ed-mark ed)) mark))
                do
                  (loop
                      for (role . value) in (ed-arguments ed)
                      when (eq value current)
                      do (push (cons ed (cons (list role) path)) agenda)))))
    (loop
        for ed in (eds-relations eds)
        when (eq (first (ed-mark ed)) mark)
        do
          (setf (rest (ed-mark ed))
            (loop
                for path in (rest (ed-mark ed))
                collect (reverse path))))
    eds))

(defun ed-heads (eds ed &optional (type :direct))
  (let ((mark (gensym "")))
    (ed-flag
     eds ed
     :up t :down nil :n (and (eq type :direct) 1) :mark mark)
    (loop
        for ed in (eds-relations eds)
        when (and (consp (ed-mark ed)) (eq (first (ed-mark ed)) mark))
        collect ed)))

(defun ed-dependents (eds ed &optional (type :direct))
  (let ((mark (gensym "")))
    (ed-flag
     eds ed
     :up nil :down t :n (and (eq type :direct) 1) :mark mark)
    (loop
        for ed in (eds-relations eds)
        when (and (consp (ed-mark ed))
                  (eq (first (ed-mark ed)) mark))
        collect ed)))

(defun dmrs-explode (dmrs)
  (labels ((label (id)
             (loop
                 for node in (dmrs-nodes dmrs)
                 when (= (dmrs-node-id node) id)
                 return
                   (let* ((pred (dmrs-node-pred node))
                          (pred (if (realpred-p pred)
                                  (format
                                   nil "_~a_~a~@[_~a~]"
                                   (realpred-lemma pred)
                                   (realpred-pos pred)
                                   (realpred-sense pred))
                                  (ppcre::regex-replace "_rel$" pred "")))
                          (from (dmrs-node-cfrom node))
                          (to (dmrs-node-cto node))
                          (carg (dmrs-node-carg node)))
                     (format
                      nil "~a~:[~*~*~;<~a:~a>~]~@[(~a)~]"
                      pred (and from to) from to carg)))))
    (loop
        with rstr = (vsym "RSTR") with arg0 = (vsym "ARG0")
        for link in (dmrs-links dmrs)
        for from = (label (dmrs-link-from link))
        for to = (label (dmrs-link-to link))
        for role = (let* ((role (dmrs-link-pre link))
                          (role 
                           (cond
                            ((null role)
                             (vsym (format nil "/~a" (dmrs-link-post link))))
                            ((stringp role)
                             (vsym role))
                            (t role))))
                     (if (eq role rstr) arg0 role))
        when role
        collect (list from role to))))

(defun eds-to-mrs (eds &key semi (errorp t))
  (declare (special mt:*semis*))
  (unless (mt:semi-p semi) (setf semi (first mt:*semis*)))
  (unless (mt:semi-p semi)
    (mt:construct-semi)
    (unless (mt:semi-p (setf semi (first mt:*semis*)))
      (if errorp
        (error "eds-to-mrs(): unable to locate or construct a SEM-I.")
        (return-from eds-to-mrs))))
  (let ((mrs (make-psoa))
        (variables (make-hash-table :test #'eq))
        (relations (make-hash-table :test #'eq))
        (generator (create-variable-generator))
        (bv (vsym "BV"))
        (arg0 (vsym "ARG0")))
    (labels ((quantifierp (ed)
               (member (vsym "BV") (ed-arguments ed) :key #'first))
             (canonical-role (label)
               (cond
                ((eq label bv) arg0)
                (t label)))
             (variable (&optional (type "u") properties)
               (make-var :type type :id (funcall generator) :extra properties)))
      (setf (psoa-top-h mrs) (variable "h"))
      (loop
          for node in (eds-relations eds)
          for predicate = (ed-predicate node)
          for sps
          = (mt:semi-lookup :semi semi :predicate predicate :alias predicate)
          for lnk = (ed-lnk node)
          for properties = (ed-properties node)
          for arguments = (ed-arguments node)
          when sps do
            (let* ((synopses (mt::sps-synopses sps))
                   (synopsis (first synopses))
                   (pred (and synopses (mt::ep-pred synopsis)))
                   (variable
                    (or (gethash node variables)
                        (setf (gethash node variables)
                          (let* ((type (first properties))
                                 (type (unless (extrapair-p type) type)))
                            (variable
                             (or type "i")
                             (if type (rest properties) properties))))))
                   (roles
                    (unless (quantifierp node)
                      (list
                       (make-fvpair :feature (vsym "ARG0") :value variable))))
                   (relation
                    (make-rel
                     :handel (variable "h") :pred pred :lnk lnk :flist roles)))
              (when (ed-carg node)
                (push
                 (make-fvpair :feature (vsym "CARG") :value (ed-carg node))
                 (rel-flist relation)))
              (loop
                  for (dependency . value) in arguments
                  when (ed-p value) 
                  do
                    (let* ((variable
                            (or (gethash value variables)
                                (setf (gethash value variables)
                                  (let* ((properties (ed-properties value))
                                         (type (first properties))
                                         (type 
                                          (unless (extrapair-p type) type)))
                                    (variable
                                     (or type "i")
                                     (if type (rest properties) properties))))))
                           (role
                            (make-fvpair
                             :feature (canonical-role dependency)
                             :value (or variable value))))
                      (push role (rel-flist relation))))
              (setf (gethash node relations) relation)
              (setf (rel-flist relation)
                (sort
                 (rel-flist relation)
                 #'(lambda (foo bar)
                     (let ((foo (position foo *feat-priority-list*))
                           (bar (position bar *feat-priority-list*)))
                       (if foo
                         (if bar (< foo bar) t)
                         bar)))
                 :key #'fvpair-feature))
              (push relation (psoa-liszt mrs)))
          else do
            (if errorp
              (error "eds-to-mrs(): invalid predicate ‘~a’." predicate)
              (return-from eds-to-mrs)))
      (let* ((top (find 
                   (eds-top eds) (eds-relations eds)
                   :key #'ed-id :test #'string=))
             (index (or (gethash top variables) (variable "i"))))
        (when top
          (let* ((larg (rel-handel (gethash top relations)))
                 (qeq (make-hcons
                       :relation "QEQ" :scarg (psoa-top-h mrs) :outscpd larg)))
            (push qeq (psoa-h-cons mrs))))
        (setf (psoa-index mrs) index))
      mrs)))

(defun eds-read (file &key decoder)
  (cond
   (decoder
    (multiple-value-bind (stream foo pid)
        (run-process 
         decoder :wait nil 
         :input file :output :stream :error-output nil)
      (declare (ignore foo #-:allegro pid))
      (let ((eds (eds-read stream)))
        (close stream)
        #+:allegro
        (sys:os-wait nil pid)
        eds)))
   ((streamp file)
    (labels ((|{|-reader (stream char)
                 (declare (ignore char))
                 (read-delimited-list #\} stream t))
             (|[|-reader (stream char)
                 (declare (ignore char))
                 (read-delimited-list #\] stream t))
             (read-ed (stream)
               (let ((c (peek-char t stream nil nil)))
                 (unless (and c (char= c #\}))
                   (let ((ed (make-ed)))
                     (setf (ed-id ed) (read stream nil nil))
                     (setf (ed-predicate ed) (read stream nil nil))
                     (setf (ed-lnk ed) (read-lnk stream))
                     (let ((c (peek-char t stream nil nil)))
                       (when (and c (char= c #\())
                         (read-char stream nil nil)
                         (setf (ed-carg ed) (read stream nil nil))
                         (read-char stream nil nil)))
                     (let ((c (peek-char t stream nil nil)))
                       (when (and c (char= c #\{))
                         (setf (ed-properties ed) (read stream nil nil))))
                     (let ((c (peek-char t stream nil nil)))
                       (when (and c (char= c #\[))
                         (setf (ed-arguments ed) (read stream nil nil))))
                     (when (and (ed-id ed) (ed-predicate ed))
                       (setf (ed-id ed) (string (ed-id ed)))
                       (setf (ed-predicate ed) (string (ed-predicate ed)))
                       (let ((type (when (oddp (length (ed-properties ed)))
                                     (first (ed-properties ed)))))
                         (setf (ed-properties ed)
                           (loop
                               with properties
                               = (if type 
                                   (rest (ed-properties ed))
                                   (ed-properties ed))
                               while (rest properties)
                               collect
                                 (let* ((feature (pop properties))
                                        (value (pop properties))
                                        (value 
                                         (if (or (symbolp value)
                                                 (stringp value))
                                           value
                                           (format nil "~a" value))))
                                   (make-extrapair 
                                    :feature (vsym feature)
                                    :value (vsym value)))))
                         (when type (push type (ed-properties ed))))
                       (setf (ed-arguments ed)
                         (loop
                             with arguments = (ed-arguments ed)
                             while (rest arguments)
                             collect (cons 
                                      (vsym (pop arguments))
                                      (pop arguments))))
                       ed))))))
               
      (loop
          with *package* = (find-package *mrs-package*)
          with *readtable* = (copy-readtable)
          with eds = (make-eds)
          initially
            (setf (readtable-case *readtable*) :preserve)
            (set-macro-character #\{ #'|{|-reader nil)
            (set-macro-character #\} (get-macro-character #\) nil))
            (set-macro-character #\[ #'|[|-reader nil)
            (set-macro-character #\] (get-macro-character #\) nil))
            (set-syntax-from-char #\: #\space)
            (set-syntax-from-char #\< #\")
            (set-syntax-from-char #\> #\")
            (set-syntax-from-char #\, #\space)
            (unless (char=
                     #\{
                     (loop
                         for c = (read-char file nil nil)
                         while (and c (not (char= c #\{)))
                         finally (return c)))
              (error "eds-read(): missing or invalid preamble."))
            (unless (setf (eds-top eds) (read file nil nil))
              (error "eds-read(): missing or invalid top node."))
          for ed = (read-ed file)
          while ed 
          do (push ed (eds-relations eds))
          finally
            (setf (eds-top eds) (string (eds-top eds)))
            (setf (eds-relations eds) (nreverse (eds-relations eds)))
            (loop
                with nodes = (eds-relations eds)
                for node in nodes
                do
                  (setf (ed-arguments node)
                    (loop
                        for (role . id) in (ed-arguments node)
                        for value = (when id 
                                      (find 
                                       (string id) nodes 
                                       :key #'ed-id :test #'string=))
                        when value collect (cons role value))))
            (eds-inverse eds)
            (return eds))))
   ((and (stringp file)
         (let ((c (with-input-from-string (stream file)
                    (peek-char t  stream nil nil))))
           (and c (char= c #\{))))
    (with-input-from-string (stream file)
      (eds-read stream)))
   ((and (or (stringp file) (pathnamep file)) (probe-file file))
    (with-open-file (stream file :direction :input)
      (eds-read stream)))
   (t
    (error "eds-read(): invalid input source ‘~a’." file))))

(defun eds (edge)
  (with-output-to-string (stream)
    (let ((*package* (find-package *mrs-package*))
          (*eds-show-properties-p* t))
      (write (eds-convert-edge edge) :stream stream))))

#+:null
(labels ((iid (item)
           (tsdb:get-field :i-id item))
         (output (profile stream
                  &optional (format :amr) active)
           (loop
               with filter = "^focus_d$|^parg_d$"
               with items 
               = (tsdb::analyze
                  profile :condition "readings > 0 && t-active > 0"
                  :thorough '(:mrs))
               for item in items
               for id = (tsdb:get-field :i-id item)
               for results = (tsdb:get-field :results item)
               for mrs = (tsdb:get-field :mrs (first results))
               when (and (mrs::psoa-p mrs)
                         (or (null active)
                             (member id active :key #'iid)))
               do
                 (if (eq format :ascii)
                   (let ((file
                          (format
                           nil "~~/lib/sdp/release/2015/eds/~a.eds" id)))
                     (with-open-file (stream file :direction :output
                                      :if-exists :supersede)
                       (mrs:eds-output-psoa
                        mrs :format format :stream stream
                        :lnkp t :propertiesp nil
                        :filter filter
                        :id id :input (tsdb:get-field :i-input item))))
                   (mrs:eds-output-psoa
                    mrs :format format :stream stream
                    :lnkp t :propertiesp nil
                    :filter filter
                    :id id :input (tsdb:get-field :i-input item))))
           (tsdb::purge-profile-cache profile)))
  (let* ((format :ascii)
         (dm (when (eq format :ascii)
               (tsdb::read-items-from-conll-file
                "~/lib/sdp/train/en.dm.sdp" :type :sdp+ :cycle t :rawp t))))
    (with-open-file (stream "/tmp/train.amr" :direction :output
                     :if-exists :supersede)
      (loop
          with dm
          = (tsdb::read-items-from-conll-file
             "~/lib/sdp/train/en.dm.sdp" :type :sdp+ :cycle t :rawp t)
          for segment
          in '("wsj00a" "wsj00b" "wsj00c" "wsj00d" 
               "wsj01a" "wsj01b" "wsj01c" "wsj01d"
               "wsj02a" "wsj02b" "wsj02c" "wsj02d" 
               "wsj03a" "wsj03b" "wsj03c" 
               "wsj04a" "wsj04b" "wsj04c" "wsj04d" "wsj04e" 
               "wsj05a" "wsj05b" "wsj05c" "wsj05d" "wsj05e" 
               "wsj06a" "wsj06b" "wsj06c" "wsj06d"
               "wsj07a" "wsj07b" "wsj07c" "wsj07d" "wsj07e"
               "wsj08a" 
               "wsj09a" "wsj09b" "wsj09c" "wsj09d"
               "wsj10a" "wsj10b" "wsj10c" "wsj10d"
               "wsj11a" "wsj11b" "wsj11c" "wsj11d" "wsj11e"
               "wsj12a" "wsj12b" "wsj12c" "wsj12d"
               "wsj13a" "wsj13b" "wsj13c" "wsj13d" "wsj13e"
               "wsj14a" "wsj14b" "wsj14c" "wsj14d" "wsj14e"
               "wsj15a" "wsj15b" "wsj15c" "wsj15d" "wsj15e"
               "wsj16a" "wsj16b" "wsj16c" "wsj16d" "wsj16e" "wsj16f"
               "wsj17a" "wsj17b" "wsj17c" "wsj17d"
               "wsj18a" "wsj18b" "wsj18c" "wsj18d" "wsj18e"
               "wsj19a" "wsj19b" "wsj19c" "wsj19d"
               "wsj20a" "wsj20b" "wsj20c" "wsj20d")
          do
            (output (format nil "gold/erg/~a" segment) stream format dm)))
    (with-open-file (stream "/tmp/test.amr" :direction :output
                     :if-exists :supersede)
      (loop
          for segment in '("wsj21a" "wsj21b" "wsj21c" "wsj21d")
          do
            (output (format nil "gold/erg/~a" segment) stream format dm)))))
#+:null
(let ((train (tsdb::read-items-from-conll-file
              "~/lib/sdp/train/en.dm.sdp" :type :sdp+ :cycle t :rawp t))
      (test (tsdb::read-items-from-conll-file
             "~/lib/sdp/test/en.id.dm.sdp" :type :sdp+ :cycle t :rawp t))
      (path "~/lib/sdp/release/2015/eds/")
      (decoder "gzip -d -c"))
  (labels ((output (items stream format)
             (loop
                 with filter = "^focus_d$|^parg_d$"
                 for item in items
                 for id = (tsdb:get-field :i-id item)
                 for input 
                 = (let ((file (format nil "~a~a.txt.gz" path id)))
                     (multiple-value-bind (stream foo pid)
                         (run-process 
                          decoder :wait nil
                          :input file :output :stream :error-output nil)
                       (declare (ignore foo))
                       (let ((line (read-line stream nil nil)))
                         (close stream)
                         #+:allegro
                         (sys:os-wait nil pid)
                         line)))
                 for mrs 
                 = (let ((file (format nil "~a~a.mrs.gz" path id)))
                     (read-mrs-from-file file :decoder decoder))
                 when stream do 
                   (eds-output-psoa
                    mrs :format format :stream stream
                    :lnkp t :propertiesp (eq format :json)
                    :filter filter
                    :id id :input input :columns 79)
                   (when (eq format :json) (terpri stream))
                 else do
                   (with-open-file (stream (format nil "~a~a.eds" path id)
                                    :direction :output :if-exists :supersede)
                     (eds-output-psoa
                      mrs :format format :stream stream
                      :lnkp t :propertiesp t
                      :filter filter
                      :id id :input input)))))
    (output train nil :ascii)
    (output test nil :ascii)
    (with-open-file (stream "~/lib/sdp/release/2015/eds/train.amr"
                     :direction :output :if-exists :supersede)
      (output train stream :amr))
    (with-open-file (stream "~/lib/sdp/release/2015/eds/test.amr"
                     :direction :output :if-exists :supersede)
      (output test stream :amr))
    (with-open-file (stream "~/lib/sdp/release/2015/eds/train.json"
                     :direction :output :if-exists :supersede)
      (output train stream :json))
    (with-open-file (stream "~/lib/sdp/release/2015/eds/test.json"
                     :direction :output :if-exists :supersede)
      (output test stream :json))))