[developers] predicate naming in MRS
Stephan Oepen
oe at ifi.uio.no
Tue Dec 29 15:32:17 CET 2015
hi again, ann,
> Anyway, I would prefer to make any changes to the main body of the Lisp MRS
> code myself, since I am currently working on this. I am, of course, not
> going to touch the MT code ...
glad to know you are coding! i will of course try to not get in your way :-).
as the ERG and other grammars are starting to introduce individual
constraints, i had toyed with the idea of adding ICONS support to the
MRS construction, visualization, input, and comparison. but maybe you
have that on your current ToDo list already? if so, i would be happy
to look into ICONS visualization in the non-CLIM browsers and ICONS
interpretation in MRS comparison, once you add the basic support to
the MRS structures.
i had played with generation from EDS over the past few weeks, with
promising results so far (see ‘EdsGeneration’ on the wiki). thus, i
had some pending local changes which included the periphery of core
MRS code (e.g. bug fixes in the ‘debug’ serialization format and
dispatching for various graphical browsers).
i just checked these changes into the main LKB repository, so we can
work on synchronized code. in case you have started your own
revisions already, i would recommend you ‘svn up’ as soon as possible,
and i hope of course there will be no conflicts. i attach a summary
of my commit below, for your convenience.
more soon, no doubt! oe
-------------- next part --------------
Index: mrs-package.lsp
===================================================================
--- mrs-package.lsp (revision 23203)
+++ mrs-package.lsp (revision 23212)
@@ -36,4 +36,7 @@
"HCONS-SCARG" "HCONS-OUTSCPD" "HCONS-RELATION"
"VSYM" "*MRS-PACKAGE*"
"PATH-VALUE" "IS-VALID-FS" "FS-ARCS" "FS-TYPE"
- "IS-VALID-TYPE" "IS-TOP-TYPE" "EQUAL-OR-SUBTYPE" "COMPATIBLE-TYPES"))
+ "IS-VALID-TYPE" "IS-TOP-TYPE" "EQUAL-OR-SUBTYPE" "COMPATIBLE-TYPES"
+ "EDS-P" "ED-P" "EDS-READ" "READ-MRS-OR-EDS-FROM-STRING" "EDS-TO-MRS"
+ "ED-CONVERT-EDGE" "ED-CONVERT-PSOA"
+ "*EDS-PRETTY-PRINT-P*" "*EDS-SHOW-PROPERTIES-P*" "*EDS-SHOW-STATUS-P*"))
Index: mt-package.lsp
===================================================================
--- mt-package.lsp (revision 23203)
+++ mt-package.lsp (revision 23212)
@@ -10,7 +10,9 @@
"READ-TRANSFER-RULES" "READ-TRANSFER-TYPES" "READ-VPM"
"TRANSFER-MRS" "MAP-MRS" "PARSE-INTERACTIVELY"
"FRAGMENTP" "GENERATE-FROM-FRAGMENTED-MRS"
- "READ-SEMI" "CONSTRUCT-SEMI" "PRINT-SEMI" "TEST-SEMI-COMPLIANCE"
+ "*SEMIS*" "SEMI-P"
+ "READ-SEMI" "CONSTRUCT-SEMI" "PRINT-SEMI"
+ "SEMI-LOOKUP" "TEST-SEMI-COMPLIANCE"
"TEST-INTEGRITY"
"UTOOL-PROCESS" "UTOOL-NET-P"))
Index: mrs/basemrs.lisp
===================================================================
--- mrs/basemrs.lisp (revision 23203)
+++ mrs/basemrs.lisp (revision 23212)
@@ -1179,9 +1179,8 @@
(defmethod mrs-output-rel-handel ((mrs debug) handle
&optional properties sort id)
(declare (ignore properties sort id))
- (when handle
(with-slots (stream memory) mrs
- (format stream "~a:~a(" handle memory memory))))
+ (format stream "~@[~a~]:~a(" handle memory memory)))
(defmethod mrs-output-label-fn ((mrs debug) label)
(declare (ignore label)))
@@ -1205,14 +1204,19 @@
(with-slots (stream) mrs
(format stream " }")))
-(defmethod mrs-output-start-h-cons ((mrs debug)))
+(defmethod mrs-output-start-h-cons ((mrs debug))
+ (with-slots (stream) mrs
+ (format stream "{ ")))
(defmethod mrs-output-outscopes ((mrs debug) relation higher lower firstp
higher-id higher-sort lower-id lower-sort)
- (declare (ignore relation higher lower firstp
- higher-id higher-sort lower-id lower-sort)))
+ (declare (ignore higher-id higher-sort lower-id lower-sort))
+ (with-slots (stream) mrs
+ (format stream "~:[, ~;~]~a ~(~a~) ~a" firstp higher relation lower)))
-(defmethod mrs-output-end-h-cons ((mrs debug)))
+(defmethod mrs-output-end-h-cons ((mrs debug))
+ (with-slots (stream) mrs
+ (format stream " }")))
(defmethod mrs-output-end-psoa ((mrs debug)))
@@ -1711,8 +1715,12 @@
|#
(defun make-mrs-break-table nil
- (lkb::define-break-characters '(#\< #\> #\:
- #\[ #\] #\, #\{ #\})))
+ (let ((temporary-readtable (copy-readtable *readtable*)))
+ (dolist (break-char '(#\< #\> #\: #\[ #\] #\, #\{ #\}))
+ (set-macro-character break-char
+ #'(lambda (stream x) (declare (ignore stream)) x)
+ nil temporary-readtable))
+ temporary-readtable))
(defun mrs-check-for (character istream)
(let ((next-char (peek-char t istream nil 'eof)))
Index: mrs/interface.lisp
===================================================================
--- mrs/interface.lisp (revision 23203)
+++ mrs/interface.lisp (revision 23212)
@@ -313,7 +313,7 @@
(test-gen-predict-on-parse *parse-record* sentence ostream)))
-;;; The following are primarily for the TSDB machinery
+;;; The following are primarily for the [incr tsdb()] machinery
;;; - they all take an edge and return a string related
;;; to the MRS in some way
;;; Functions are from mrsfns.lisp
@@ -362,6 +362,22 @@
(read-mrs stream)))))
(when (psoa-p mrs) mrs))))
+(defun read-mrs-or-eds-from-string (string)
+ (cond
+ ((psoa-p string) string)
+ ((eds-p string) string)
+ (t (let* ((*package* (find-package :lkb))
+ (mrs (ignore-errors
+ (with-input-from-string (stream string)
+ (read-mrs stream))))
+ (eds (unless mrs
+ (ignore-errors
+ (with-input-from-string (stream string)
+ (eds-read stream))))))
+ (if (psoa-p mrs)
+ mrs
+ (and (eds-p eds) eds))))))
+
(defun read-and-scope-mrs-from-string (string)
(let ((*package* (find-package :lkb))
(mrs (#+:debug progn #-:debug ignore-errors
@@ -438,12 +454,20 @@
(:simple (find-symbol "SHOW-MRS-WINDOW" :lkb))
(:indexed (find-symbol "SHOW-MRS-INDEXED-WINDOW" :lkb))
(:scoped (find-symbol "SHOW-MRS-SCOPED-WINDOW" :lkb))
- (:eds (find-symbol "SHOW-MRS-DEPENDENCIES-WINDOW" :lkb))))))
-
+ ((:eds :dependencies)
+ (find-symbol "SHOW-MRS-DEPENDENCIES-WINDOW" :lkb))))))
+ (when (eds-p mrs) (setf mrs (eds-to-mrs mrs)))
(if (functionp browser)
- (apply browser (list nil mrs title))
- (output-mrs mrs 'simple)))))
+ (funcall browser nil mrs title)
+ (output-mrs1 mrs 'simple *terminal-io*)))))
+(defun browse-mrs-or-eds (mrs &optional title)
+ (ignore-errors
+ (if (eds-p mrs)
+ (if #+:lui (lkb::lui-status-p :mrs) #-:lui nil
+ (funcall (symbol-function (find-symbol "LUI-DISPLAY-EDS" :lkb)) mrs title)
+ (format *terminal-io* "~a~%" mrs))
+ (browse-mrs mrs title))))
;;;
;;; initially mostly for HTML output, though maybe of general utility? LOGON
Index: mrs/lnk.lisp
===================================================================
--- mrs/lnk.lisp (revision 23203)
+++ mrs/lnk.lisp (revision 23212)
@@ -87,10 +87,10 @@
(let ((c (peek-char t stream nil nil))
(*readtable* (copy-readtable))
type)
- (set-syntax-from-char #\: #\" *readtable*)
- (set-syntax-from-char #\# #\" *readtable*)
- (set-syntax-from-char #\, #\" *readtable*)
- (set-syntax-from-char #\> #\" *readtable*)
+ (set-syntax-from-char #\: #\")
+ (set-syntax-from-char #\# #\")
+ (set-syntax-from-char #\, #\")
+ (set-syntax-from-char #\> #\")
(when (and c (char= c #\<))
(read-char stream nil nil)
(let ((c (peek-char t stream nil nil)))
Index: mrs/dependencies.lisp
===================================================================
--- mrs/dependencies.lisp (revision 23203)
+++ mrs/dependencies.lisp (revision 23212)
@@ -1,4 +1,4 @@
-;;; Copyright (c) 2001--2012 Stephan Oepen (oe at ifi.uio.no);
+;;; Copyright (c) 2001--2014 Stephan Oepen (oe at ifi.uio.no);
;;; see `LICENSE' for conditions.
(in-package :mrs)
@@ -29,9 +29,18 @@
(defparameter *eds-quantifier-argument* (vsym "BV"))
+(defparameter *eds-untensed* (list (cons (vsym "TENSE") (vsym "untensed"))))
+
(defparameter *eds-non-representatives*
- (list (vsym "appos_rel")))
+ (list (vsym "appos_rel") (vsym "focus_d_rel") (vsym "parg_d_rel")))
+(defparameter *eds-predicate-modifiers*
+ (list (ppcre:create-scanner "_x_deg_rel$")))
+
+(defparameter *eds-show-properties-p* t)
+
+(defparameter *eds-show-status-p* nil)
+
(defparameter %eds-variable-counter% 0)
(defparameter %eds-symbol-table% (make-hash-table))
@@ -41,10 +50,10 @@
(defparameter %eds-equivalences% (make-hash-table :test #'equal))
(defparameter %eds-relevant-features%
- '("ARG" "ARG1" "ARG2" "ARG3" "ARG4" "BV" "SOA"
- "CONST_VALUE" "CARG" "TERM1" "TERM2" "FACTOR1" "FACTOR2"
- "MARG" "L-INDEX" "R-INDEX" "L-HNDL" "R-HNDL" "L-HANDEL" "R-HANDEL"
- "MAIN" "SUBORD" "ROLE" "HINST" "NHINST"))
+ '("ARG" "ARG1" "ARG2" "ARG3" "ARG4" "BV"
+ "L-INDEX" "R-INDEX" "L-HNDL" "R-HNDL" "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)
@@ -60,7 +69,7 @@
"{~@[~(~a~):~]~
~:[~3*~; (~@[cyclic~*~]~@[ ~*~]~@[fragmented~*~])~]~@[~%~]"
(eds-top object)
- (or cyclicp fragmentedp)
+ (and *eds-show-status-p* (or cyclicp fragmentedp) )
cyclicp (and cyclicp fragmentedp) fragmentedp
(eds-relations object))
for ed in (eds-relations object)
@@ -70,6 +79,7 @@
stream
"~c~a~%"
(cond
+ ((null *eds-show-status-p*) #\Space)
((member :cyclic (ed-status ed)) #\|)
((member :fragmented (ed-status ed)) #\|)
(t #\Space))
@@ -90,8 +100,28 @@
initially
(format
stream
- "~(~a~):~(~a~)~@[(~s)~]["
+ "~(~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))
+ 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
@@ -141,11 +171,15 @@
sortp dmrsp (n 0))
(case format
(:ascii
- (if (psoa-p psoa)
- (format stream "~a~%" (ed-convert-psoa psoa))
- (format stream "{}~%")))
+ (cond
+ ((eds-p psoa)
+ (format stream "~a~%" psoa))
+ ((psoa-p psoa)
+ (format stream "~a~%" (ed-convert-psoa psoa)))
+ (t
+ (format stream "{}~%"))))
(:triples
- (let* ((eds (ed-convert-psoa psoa))
+ (let* ((eds (if (eds-p psoa) psoa (ed-convert-psoa psoa)))
(triples
(if dmrsp
(dmrs-explode (rmrs-to-dmrs (mrs-to-rmrs psoa)))
@@ -181,7 +215,7 @@
(setf (gethash object attic) n)
(incf id)
n))))
- (let ((eds (ed-convert-psoa psoa)))
+ (let ((eds (if (eds-p psoa) psoa (ed-convert-psoa psoa))))
(format
stream
"#X[~a \"{~(~a~)\" \":\" newline~%\" \" #X["
@@ -225,17 +259,10 @@
"] newline \"}\"]~%~
#M[]"))))))
(:html
- (let ((eds (ed-convert-psoa psoa)))
+ (let ((eds (if (eds-p psoa) psoa (ed-convert-psoa psoa))))
(format stream "<table class=mrsEds>~%")
(format stream "<tr><td>")
- (let ((properties (when propertyp
- (loop
- with top = (eds-top eds)
- for ed in (eds-relations eds)
- when (equal (ed-id ed) top)
- return (ed-properties ed)))))
- (declare (ignore properties))
- (mrs-variable-html (eds-top eds) nil n nil stream))
+ (mrs-variable-html (eds-top eds) nil n nil stream)
(format stream ":</td></tr>~%")
(loop
for ed in (eds-relations eds)
@@ -252,7 +279,19 @@
(let* ((string (make-string-output-stream)))
(format string "<table class=mrsProperties>")
(loop
- for property in (ed-properties ed)
+ 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 class=mrsPropertyValue> </td></tr>"
+ type))
+ for property in properties
do
(format
string
@@ -290,7 +329,7 @@
(properties (ed)
""))
(loop
- with eds = (ed-convert-psoa psoa)
+ with eds = (if (eds-p psoa) psoa (ed-convert-psoa psoa))
initially
(format stream "\\eds{~a}{~%" (variable (eds-top eds)))
for relations on (eds-relations eds)
@@ -325,12 +364,12 @@
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 key properties set
+ ;; 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)
+ for ed = (ed-convert-relation relation psoa)
when ed do (push ed (eds-relations eds))
finally
(setf (eds-relations eds) (nreverse (eds-relations eds)))
@@ -381,15 +420,17 @@
(ed-reset)
(return eds))))
-(defun ed-convert-relation (relation)
+(defun ed-convert-relation (relation mrs)
+
+ (let (type)
(when (and *eds-quantifier-argument* (is-quant-rel relation))
;;
- ;; to simplify the downstream treatment of quantifiers, make sure the label
- ;; of the bound variable is not ARG0. but avoid destructive changes to our
- ;; original input structure; 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).
+ ;; 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)
@@ -401,7 +442,56 @@
collect (make-fvpair
:feature *eds-quantifier-argument*
:value (fvpair-value fvpair))
- else collect 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
+ (typecase pattern
+ (function (ppcre:scan pattern predicate))
+ (string (string-equal pattern predicate))
+ (symbol (ignore-errors
+ (equal-or-subtype predicate pattern)))))
+ (and arg1 (var-p (fvpair-value arg1))
+ (string-equal (var-type (fvpair-value arg1)) "u")))
+ (let* ((label (rel-handel relation)))
+ (when (loop
+ for relation in (psoa-liszt mrs)
+ thereis (eq (rel-handel relation) label))
+ (setf relation (copy-rel relation))
+ (setf (rel-flist relation)
+ (loop
+ with arg1 = (vsym "ARG1")
+ for argument in (rel-flist relation)
+ when (eq (fvpair-feature argument) arg1)
+ collect (make-fvpair
+ :feature (vsym "ARG1")
+ :value label)
+ else collect argument))
+ (setf type :specifier))))))
+
(let* ((*package* (find-package :lkb))
(handle (let ((handle (rel-handel relation)))
(when (ed-handle-p handle) (var-string handle))))
@@ -440,7 +530,7 @@
:handle handle
:id (first identifier) :properties (rest identifier)
:predicate predicate :lnk lnk :carg carg :abstraction abstraction
- :raw relation)))
+ :type type :raw relation))))
(defun ed-bleach-eds (eds)
(loop
@@ -532,7 +622,8 @@
(name (if variable
(var-string variable)
(format nil "_~d" (incf %eds-variable-counter%))))
- (properties (and variable (var-extra variable))))
+ (type (and variable (var-type variable)))
+ (properties (and variable (cons type (var-extra variable)))))
(setf (gethash relation %eds-symbol-table%) (cons name properties))))))
(defun ed-find-representative (eds variable &optional (selectp t))
@@ -549,7 +640,8 @@
when (and (not (ed-bleached-p ed))
(or (equal name handle)
(and (ed-handle-p qeq)
- (equal (var-string qeq) handle))))
+ (equal (var-string qeq) handle)))
+ (not (eq (ed-type ed) :specifier)))
collect ed into candidates
finally
(return
@@ -593,14 +685,23 @@
;; or look at the dependency topology among the candidate EPs and choose one
;; that occurs as an argument to the other(s).
;;
- (or
(when *eds-non-representatives*
+ (return-from ed-select-representative
(let ((candidates (loop
for ed in candidates
unless (ed-non-representative-p ed)
collect ed))
(*eds-non-representatives* nil))
- (ed-select-representative eds candidates)))
+ (ed-select-representative eds candidates))))
+ (when (or (null candidates) (null (rest candidates)))
+ (return-from ed-select-representative (first candidates)))
+ (or
+ ;;
+ ;; 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).
+ ;;
(loop
for ed in candidates
unless (or (ed-message-p ed)
@@ -632,6 +733,7 @@
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)
@@ -650,7 +752,7 @@
(loop
with n = (first (first referrers))
for referrer in referrers
- while (= (first (first referrers)) n)
+ while (= (first referrer) n)
collect (rest referrer))))
(outgoing (candidates)
(let ((references
@@ -672,10 +774,29 @@
;; incoming links against the structure at large (see below); finally,
;; count outgoing links to break ties, if need be. note that, given a
;; non-empty list, outgoing() always returns a non-empty result, hence
- ;; we only need two sub-clauses in the or() below.
+ ;; we only need two sub-clauses in the or() below. actually, as long
+ ;; as .candidates. is a sub-set of the full list of relations (which in
+ ;; the context of converting one MRS will always be the case), it would
+ ;; seem impossible for .outgoing. to become empty, provided .local. is
+ ;; non-empty.
;;
(or (first outgoing) (first local)))
;;
+ ;; 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 make sure we pick the existential ‘be’ over the preposition,
+ ;; we need to dis-prefer untensed events.
+ ;;
+ (let ((tensed (loop
+ for ed in candidates
+ unless (ed-untensed-p ed) collect ed)))
+ (when tensed
+ (setf candidates tensed)
+ (when (null (rest tensed)) (first tensed))))
+ ;;
;; 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, give preference to nodes that
@@ -733,6 +854,15 @@
(ignore-errors
(equal-or-subtype type *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*)))
+ thereis (and test (eq (extrapair-value pair) test)))))
+
(defun ed-fragment-p (ed)
(when *eds-fragment-relation*
(let ((pred (and (rel-p (ed-raw ed)) (rel-pred (ed-raw ed)))))
@@ -1053,7 +1183,9 @@
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)))
+ (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.
@@ -1169,3 +1301,226 @@
(if (eq role rstr) arg0 role))
when role
collect (list from role to))))
+
+#+:lkb
+(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 :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)
+ (cond
+ ((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))))
+ (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))))
+
+#+:lkb
+(defun eds (edge)
+ (with-output-to-string (stream)
+ (let ((*package* (find-package *mrs-package*))
+ (*eds-show-properties-p* t))
+ (write (ed-convert-edge edge) :stream stream))))
Index: mrs/mrscorpus.lisp
===================================================================
--- mrs/mrscorpus.lisp (revision 23203)
+++ mrs/mrscorpus.lisp (revision 23212)
@@ -392,13 +392,13 @@
;; then handels ok
(let ((fv1 (loop
for role in (rel-flist rel1)
- unless (lkb::smember
+ unless (member
(fvpair-feature role)
*mrs-equalp-ignored-roles*)
collect role))
(fv2 (loop
for role in (rel-flist rel2)
- unless (lkb::smember
+ unless (member
(fvpair-feature role)
*mrs-equalp-ignored-roles*)
collect role)))
Index: mt/comparison.lisp
===================================================================
--- mt/comparison.lisp (revision 23203)
+++ mt/comparison.lisp (revision 23212)
@@ -45,11 +45,13 @@
;;
#+:debug
(setf %mrs1 mrs1 %mrs2 mrs2)
+ #+:lkb
(incf (lkb::statistics-comparisons lkb::*statistics*))
(let ((*mrs-comparison-ignore-roles* roles)
(*mrs-comparison-ignore-properties* properties)
(*mrs-comparison-equivalent-types* types)
(*mrs-comparison-equivalent-predicates* predicates)
+ #+:lkb
(*transfer-debug-p* (cons (and debug :solutions) *transfer-debug-p*))
(%transfer-solutions% nil)
(solution (copy-solution))
Index: mt/globals.lisp
===================================================================
--- mt/globals.lisp (revision 23203)
+++ mt/globals.lisp (revision 23212)
@@ -48,6 +48,8 @@
(defparameter *mtr-subsume-path* (list (mrs::vsym "SUBSUME")))
+(defparameter *mtr-call-path* (list (mrs::vsym "CALL")))
+
(defparameter *mtr-warn-path* (list (mrs::vsym "WARN")))
(defparameter *mtr-block-path* (list (mrs::vsym "BLOCK")))
Index: mt/clim.lisp
===================================================================
--- mt/clim.lisp (revision 23203)
+++ mt/clim.lisp (revision 23212)
@@ -581,6 +581,8 @@
with *transfer-edge-limit* = nil
for edge in edges
when (edge-p edge) collect edge
+ else when (mrs::eds-p edge)
+ collect (make-edge :mrs (mrs::eds-to-mrs edge :errorp nil))
else collect (make-edge :mrs edge)))))
(setf (clim:frame-pretty-name frame)
(or (transfer-title frame) "Transfer Input"))
Index: mt/transfer.lisp
===================================================================
--- mt/transfer.lisp (revision 23203)
+++ mt/transfer.lisp (revision 23212)
@@ -92,7 +92,7 @@
input output defaults
variables vector
avoids requires consumes provides
- flags special rank file)
+ call flags special rank file)
(defmethod print-object ((object mtr) stream)
(if %transfer-raw-output-p%
@@ -481,6 +481,19 @@
:id id :mtrs (nreverse rules)
:before before :after after
:pre pre :post post :in in :out out)))
+ (loop
+ for mtr in (mtrs-mtrs mtrs)
+ for id = (loop
+ for (value . key) in (mtr-special mtr)
+ when (eq key :call) return value)
+ for rule = (and id (find id (mtrs-mtrs mtrs) :key #'mtr-id))
+ when id do
+ (if rule
+ (setf (mtr-call mtr) rule)
+ (error
+ "read-transfer-rules(): ~
+ invalid call to `~(~a~)' in `~(~a~)'.~%"
+ id (mtr-id mtr))))
(setf (getf (mtrs-flags mtrs) :recurse) recurse)
(setf (getf (mtrs-flags mtrs) :filter)
(if filterp filter t))
@@ -746,6 +759,7 @@
(subsume (lkb::existing-dag-at-end-of dag *mtr-subsume-path*))
(block (mrs::path-value dag *mtr-block-path*))
(warn (mrs::path-value dag *mtr-warn-path*))
+ (call (mrs::path-value dag *mtr-call-path*))
(trigger (mrs::path-value dag *mtr-trigger-path*))
special)
(when (lkb::dag-p equal)
@@ -786,6 +800,10 @@
(when (mrs::is-valid-fs warn)
(let ((warn (mrs::fs-type warn)))
(when (stringp warn) (push (cons warn :warn) special))))
+ (when (and (mrs::is-valid-fs call)
+ (not (vacuous-constraint-p *mtr-call-path* call)))
+ (let ((id (mrs::vsym (mrs::fs-type call))))
+ (push (cons id :call) special)))
(when (mrs::is-valid-fs trigger)
(let ((le (mrs::vsym (mrs::fs-type trigger))))
(push id (gethash le *transfer-triggers*))
@@ -1009,7 +1027,6 @@
;; after hook, if any; ditch intermediate solutions for which there are
;; problems in VPM- or post-processing.
;;
- ;;
;; _fix_me_
;; in the same spirit, do something about the `post' SEM-I test.
;; (17-oct-06; oe)
@@ -1153,13 +1170,26 @@
collect (mrs::ep-shorthand ep))))))
for task = (pop agenda)
for rule = (and task (edge-rule task))
- for mtrs = (if (or (eq task edge) (null rule))
+ for mtrs
+ = (cond
;;
;; when we advance from one MTRS to another, the top .edge.
;; may have a non-empty rule, but taken from the other set.
;;
- all
- (member rule all))
+ ((or (eq task edge) (null rule)) all)
+ ;;
+ ;; branch, within the current rule set, if the rule calls for it
+ ;;
+ ((mtr-call rule)
+ #+:debug
+ (format
+ *transfer-debug-stream* "apply-mtrs(): call `~(~a~)'.~%"
+ (mtr-id (mtr-call rule)))
+ (member (mtr-call rule) all))
+ ;;
+ ;; otherwise, continue rewriting trying the same rule once more
+ ;;
+ (t (member rule all)))
while task
when (null (mtr-block (edge-rule task))) do
#+:debug
@@ -1332,16 +1362,16 @@
solutions)
(transfer-trace :component :context)
(setf solutions (unify-mtr-component mrs context nil :subsumesp subsumesp))
+ #+:debug
+ (format
+ t
+ "unify-mtr(): ~a solution~p for CONTEXT component.~%"
+ (length solutions) (length solutions))
(unless solutions
;;
;; trace
;;
(return-from unify-mtr))
- #+:debug
- (format
- t
- "unify-mtr(): ~a solution~p for CONTEXT component.~%"
- (length solutions) (length solutions))
(when input
(transfer-trace :component :input)
(setf solutions
@@ -1399,12 +1429,12 @@
(loop
for solution in solutions
unless (unify-mtr-component
- mrs filter solution :subsumesp subsumesp)
+ mrs filter solution :subsumesp subsumesp :hconsp t)
collect solution))
#+:debug
(format
t
- "unify-mtr(): ~a solution~p for FILTER component HCONS.~%"
+ "unify-mtr(): ~a solution~p for FILTER component.~%"
(length solutions) (length solutions)))
#+:null
solutions
@@ -1413,7 +1443,7 @@
(and solutions (list (first solutions))))))
(defun unify-mtr-component (mrs1 mrs2 &optional solution
- &key (disjointp t) subsumesp)
+ &key (disjointp t) hconsp subsumesp)
(if (null mrs2)
(list solution)
(let* ((solution (copy-solution solution))
@@ -1448,8 +1478,8 @@
;; re-order computation for better efficiency (and while there is no
;; good way of rejecting false results based on a cycle check).
;;
+ (if (null hconsp)
solutions
- #+:null
(let* ((hcons1 (mrs:psoa-h-cons mrs1))
(hcons2 (mrs:psoa-h-cons mrs2))
(solutions
@@ -1463,7 +1493,7 @@
;; trace
;;
(return-from unify-mtr-component))
- solutions)))))
+ solutions))))))
(defun unify-epss (eps1 eps2 solution &key (disjointp t) subsumesp)
;;
@@ -1866,7 +1896,7 @@
(defun expand-solution (mrs mtr solution)
;;
;; go through EPs from .mrs., ditching those that were aligned with one from
- ;; .mtr. during unification; then, through in EPs from .mtr. OUTPUT part and
+ ;; .mtr. during unification; then, throw in EPs from .mtr. OUTPUT part and
;; unify in all applicable information from .solution. eventually, do more
;; or less the same for HCONS.
;;
@@ -2037,6 +2067,7 @@
#+:debug
(setf %ep ep %default default)
(unless default (return-from merge-eps ep))
+ (merge-values (mrs:rel-handel ep) (mrs:rel-handel default) solution)
(when (mrs::rel-pred default)
(setf (mrs::rel-pred ep) (mrs::rel-pred default)))
(loop
@@ -2236,6 +2267,7 @@
for extra in (mrs:var-extra variable)
for feature = (mrs::extrapair-feature extra)
unless (or (eq feature *mtr-skolem-property*)
+ #-:null
(eq feature *mtr-mark-property*)
(eq feature *mtr-scratch-property*)
(eq feature *mtr-ditch-property*))
Index: mt/semi.lisp
===================================================================
--- mt/semi.lisp (revision 23203)
+++ mt/semi.lisp (revision 23212)
@@ -28,6 +28,7 @@
signature
(roles (make-hash-table))
(predicates (make-hash-table :test #'equal))
+ (aliases (make-hash-table :test #'equal))
(properties (make-hash-table))
(ges (make-hash-table)))
@@ -59,6 +60,14 @@
(defmacro lookup-predicate (predicate semi)
`(gethash ,predicate (semi-predicates ,semi)))
+(defmacro lookup-alias (predicate semi)
+ `(gethash (string-downcase ,predicate) (semi-aliases ,semi)))
+
+(defun semi-lookup (semi &key predicate alias)
+ (or
+ (and predicate (lookup-predicate predicate semi))
+ (and alias (lookup-alias alias semi))))
+
(defun read-synopsis (string &optional (offset 0))
(let ((stream (make-string-input-stream string offset)))
(labels ((read-role ()
@@ -109,6 +118,7 @@
(pathname-name file) (pathname-type file)))
(id (subseq name 0 (search ".smi" name)))
(id (intern (string-upcase id) :keyword))
+ (includep semi)
(semi (or semi (make-semi :name id))))
(with-open-file (stream file :direction :input)
#+:allegro
@@ -154,6 +164,7 @@
(read-from-string line nil nil)))
(pred
(if (stringp pred) (string-downcase pred) pred))
+ (alias (predicate-alias pred))
(colon (and pred (position #\: line)))
(synopsis
(and colon (read-synopsis line (+ colon 1))))
@@ -163,14 +174,15 @@
(setf (ep-pred synopsis) pred)
(if bucket
(push synopsis (sps-synopses bucket))
- (setf (lookup-predicate pred semi)
- (make-sps :synopses (list synopsis)))))
+ (let ((sps (make-sps :synopses (list synopsis))))
+ (setf (lookup-predicate pred semi) sps)
+ (when alias (setf (lookup-alias alias semi) sps)))))
(t
(format
t
"read-semi(): ignoring |~a|." line)))))))))))))
(when close (close-semi semi))
- (push semi *semis*)
+ (unless includep (push semi *semis*))
semi))
(defun close-semi (semi)
@@ -260,7 +272,8 @@
(test-ep ep))
collect ep)))
-(defun construct-semi (&key ids semi (rules t))
+(defun construct-semi (&key ids semi (rules t)
+ (warn '(:collision)) (stream t))
(let ((semi (or semi (make-semi)))
(ids (or ids (lkb::collect-psort-ids lkb::*lexicon*))))
(loop
@@ -289,6 +302,24 @@
for rule = (gethash id lkb::*lexical-rules*)
when rule do (record-rule semi id rule)))
;;
+ ;; when requested, provide some sanity tests on the predicate inventory
+ ;;
+ (when (member :collision warn :test #'eq)
+ (let* ((predicates
+ (loop
+ for predicate being each hash-key in (semi-predicates semi)
+ collect (string-downcase predicate)))
+ (predicates (remove-duplicates predicates :test #'string=))
+ (predicates (sort predicates #'string<)))
+ (loop
+ for predicate in predicates
+ for variant = (mrs:vsym predicate)
+ when (and (lookup-predicate predicate semi)
+ (lookup-predicate variant semi))
+ do (format
+ stream "construct-semi(): predicate collision for ‘~(~a~)’.~%"
+ predicate))))
+ ;;
;; finally, construct `generalized synopses' (i.e. folding multiple frames
;; into one, where possible using optionality and type underspecification).
;;
@@ -297,6 +328,12 @@
do (generalize-sps sps))
semi))
+(defun predicate-alias (predicate)
+ (let* ((string (string-downcase predicate))
+ (n (search mrs::*sem-relation-suffix* string :from-end t))
+ (alias (subseq string 0 n)))
+ (unless (string= predicate alias) alias)))
+
(defun record-le (semi id le)
(let* ((tdfs (lkb::lex-entry-full-fs le))
(dag (lkb::tdfs-indef tdfs))
@@ -345,6 +382,7 @@
for i from 0
for ep in (mrs-eps mrs)
for pred = (ep-pred ep)
+ for alias = (and pred (predicate-alias pred))
for sps = (or (lookup-predicate pred semi)
(setf (lookup-predicate pred semi) (make-sps)))
for spe = (make-spe
@@ -367,10 +405,12 @@
when (and (eq (role-name role) arg1)
(variable-p value))
do
+ #+:null
(setf (variable-type value) *semi-p-type*)
(setf (variable-optionality value) nil))))
(push spe (sps-spes sps))
(push spe (ges-spes ges))
+ (when alias (setf (lookup-alias alias semi) sps))
finally
(setf (ges-spes ges) (nreverse (ges-spes ges)))
(setf (gethash id (semi-ges semi)) ges)))))
@@ -420,6 +460,7 @@
for i from 0
for ep in (mrs-eps mrs)
for pred = (ep-pred ep)
+ for alias = (predicate-alias pred)
for sps = (or (lookup-predicate pred semi)
(setf (lookup-predicate pred semi) (make-sps)))
for spe = (make-spe
@@ -427,6 +468,7 @@
do
(push spe (sps-spes sps))
(push spe (ges-spes ges))
+ (when alias (setf (lookup-alias alias semi) sps))
finally
(setf (ges-spes ges) (nreverse (ges-spes ges)))
(setf (gethash id (semi-ges semi)) ges)))))
More information about the developers
mailing list