[logon] merging LKB code from the LOGON tree and the upstream repository
Stephan Oepen
oe at ifi.uio.no
Mon May 16 22:38:05 CEST 2016
colleagues,
i merged the two branches of the LKB and [incr tsdb()] source trees
today, i.e. (a) propagated recent additions to the MRS code by ann
(notably emerging ICONS support) into the LOGON, tree and (b) pushed
accumulated LOGON changes upstream (in particularly the extended SEM-I
regime). i attach a diff(1) of changes against the upstream LKB
repository for your convenience.
ann, these changes introduce a new global parameter
*normalize-predicates-p* (off by default, for the time being) that
activates the normalizations discussed previously: treat quoted and
unquoted identifiers alike, always strip ‘_rel’, always downcase, and
use the SEM-I for predicate comparison. searching for the above
variable name should give a pretty complete picture of code changes
related to this new mechanism. i have not looked in full detail at
XML input and output or the conversion to and from RMRS and DMRS, but
i hope my changes are not breaking anything there! i would be very
grateful if you could test these parts a little more, though.
another minor change you should be aware of is in ‘rmrs-convert.lisp’,
where i have replaced a call to your addition mt::find-semi-entries()
with a call to a new, generalized interface for SEM-I look-up. your
implementation of mt::find-semi-entries() is still present, but
isolated now in ‘src/mt/aac.lisp’. once you have had a chance to
review these changes, please let me know if ‘aac.lisp’ can be
eventually removed.
—regarding ICONS support, i still need to add it to the various output
formats that i ‘own’, i reckon, e.g. LUI, LaTeX and JSON. also,
mt::compare-mrss() does not yet recognize the new set of constraints.
more on these before too long, i hope!
all best, oe
-------------- next part --------------
Index: src/ACL_specific/compare.lsp
===================================================================
--- src/ACL_specific/compare.lsp (revision 24124)
+++ src/ACL_specific/compare.lsp (working copy)
@@ -856,7 +856,7 @@
(ignore-errors
(mrs::extract-mrs edge))))))
(when mrs
- (mrs::ed-output-psoa
+ (mrs:eds-output-psoa
mrs :stream stream))))))))
(terpri stream)))))))
(when (and (compare-frame-trees frame)
@@ -970,7 +970,7 @@
(edge (ctree-edge tree))
(mrs (or (edge-mrs edge)
(ignore-errors (mrs::extract-mrs edge))))
- (eds (when mrs (ignore-errors (mrs::ed-convert-psoa mrs)))))
+ (eds (when mrs (ignore-errors (mrs:eds-convert-psoa mrs)))))
(multiple-value-bind (result condition)
(when (functionp hook) (ignore-errors (funcall hook edge mrs)))
@@ -1032,7 +1032,7 @@
(format stream "~a" eds)))))))))
(recolor-record
record
- (let ((status (mrs::ed-suspicious-p eds))
+ (let ((status (mrs:eds-suspicious-p eds))
(orange (or (clim:find-named-color
"orange" (clim:frame-palette frame)
:errorp nil)
Index: src/glue/lui.lsp
===================================================================
--- src/glue/lui.lsp (revision 24124)
+++ src/glue/lui.lsp (working copy)
@@ -504,7 +504,7 @@
(mrs::lui-indexed-mrs mrs :stream stream))
(:dependencies
(format stream "text 42 ")
- (mrs::ed-output-psoa
+ (mrs:eds-output-psoa
mrs :stream stream :format :lui))))))
(format %lui-stream% string)
(format %lui-stream% " ~s~a~%" title %lui-eoc%))
@@ -517,7 +517,7 @@
"~@[~a ~]Elementary Dependencies Display" title))
(string (with-output-to-string (stream)
(format stream "text ~a " id)
- (mrs::ed-output-psoa
+ (mrs:eds-output-psoa
eds :stream stream :format :lui))))
(format %lui-stream% string)
(format %lui-stream% " ~s~a~%" title %lui-eoc%))
Index: src/main/discriminants.lsp
===================================================================
--- src/main/discriminants.lsp (revision 24124)
+++ src/main/discriminants.lsp (working copy)
@@ -199,12 +199,12 @@
for child in (edge-children edge)
do (extract-discriminants-from-edge child top :mode mode)))
#+:mrs
- (let* ((eds (mrs::ed-convert-edge edge))
- (mrs::*eds-include-quantifiers-p* t)
- (mrs::*eds-include-vacuous-relations-p* t)
- (triples (mrs::ed-explode eds)))
- (declare (special mrs::*eds-include-quantifiers-p*
- mrs::*eds-include-vacuous-relations-p*))
+ (let* ((eds (mrs:eds-convert-edge edge))
+ (mrs:*eds-include-quantifiers-p* t)
+ (mrs:*eds-include-vacuous-relations-p* t)
+ (triples (mrs:eds-explode eds)))
+ (declare (special mrs:*eds-include-quantifiers-p*
+ mrs:*eds-include-vacuous-relations-p*))
(loop
for triple in triples
for key = (format nil "~{~a~^ ~}" triple)
Index: src/mrs/basemrs.lisp
===================================================================
--- src/mrs/basemrs.lisp (revision 24124)
+++ src/mrs/basemrs.lisp (working copy)
@@ -343,7 +343,7 @@
(declare (ignore properties type id))
(when (and handel-val *rel-handel-path*)
(with-slots (stream) mrsout
- (format stream " LTOP: ~(~a~)" handel-val))))
+ (format stream " TOP: ~(~a~)" handel-val))))
(defmethod mrs-output-index ((mrsout simple) index-val
&optional properties type id)
@@ -372,7 +372,7 @@
(declare (ignore first-p class str))
(with-slots (stream indentation) mrsout
(format stream "~%")
- (if (stringp pred)
+ (if (and (stringp pred) (null *normalize-predicates-p*))
(format stream "~VT[ ~s" indentation pred)
(format stream "~VT[ ~(~a~)" indentation (or pred "_")))
(output-lnk lnk :stream stream)))
@@ -498,7 +498,7 @@
(with-slots (stream indentation) mrsout
(format stream "~%")
(format stream "~VT[ " indentation)
- (lkb::add-mrs-pred-region stream pred)
+ (lkb::add-mrs-pred-region stream pred *normalize-predicates-p*)
(output-lnk lnk :stream stream)))
@@ -1016,6 +1016,148 @@
;;;
+;;; JSON output, using an alternative approach: the Common Lisp pretty printing
+;;; machinery, which gives us logical block structure and indentation.
+;;;
+(defun mrs-output-json (mrs &key (stream t)
+ (propertiesp t)
+ (columns *print-right-margin*)
+ prefix)
+ (if (null stream)
+ (with-output-to-string (stream)
+ (mrs-output-json
+ mrs :stream stream :propertiesp propertiesp :columns columns))
+ (let ((label (psoa-top-h mrs))
+ (index (psoa-index mrs))
+ (variables nil)
+ (*print-right-margin* columns))
+ (when prefix (write-string prefix stream))
+ (pprint-logical-block (stream nil :prefix "{" :suffix "}")
+ (when (var-p label)
+ (format
+ stream "\"top\": ~a, "
+ (mrs-variable-output-json label :objectp nil))
+ (pprint-newline :mandatory stream)
+ (pushnew label variables :test #'eq))
+ (when (var-p index)
+ (format
+ stream "\"index\": ~a, "
+ (mrs-variable-output-json index :objectp nil))
+ (pprint-newline :mandatory stream)
+ (pushnew index variables :test #'eq))
+ (format stream "\"relations\": ")
+ (pprint-newline :mandatory stream)
+ (pprint-logical-block (stream nil :prefix "[" :suffix "]")
+ (loop
+ with rels = (psoa-liszt mrs)
+ with last = (first (last rels))
+ for ep in rels
+ for label = (rel-handel ep)
+ for predicate = (rel-pred ep)
+ for lnk = (rel-lnk ep)
+ do
+ (pprint-logical-block (stream nil :prefix "{" :suffix "}")
+ (format
+ stream "\"label\": ~a, \"predicate\": ~s, \"lnk\": "
+ (mrs-variable-output-json label :objectp nil)
+ predicate)
+ (pushnew label variables :test #'eq)
+ (output-lnk lnk :stream stream :format :json)
+ (format stream ", \"arguments\":")
+ (pprint-newline :fill stream)
+ (format stream " ")
+ (pprint-logical-block (stream nil :prefix "{" :suffix "}")
+ (loop
+ with arguments = (rel-flist ep)
+ with last = (first (last arguments))
+ for argument in arguments
+ for role = (fvpair-feature argument)
+ for value = (fvpair-value argument)
+ do
+ (format
+ stream "~s: ~a"
+ (string-upcase role)
+ (cond
+ ((var-p value)
+ (pushnew value variables :test #'eq)
+ (mrs-variable-output-json value :objectp nil))
+ (t
+ (format nil "~s" (string value)))))
+ (unless (eq argument last)
+ (format stream ", ")
+ (pprint-newline :fill stream)))))
+ (unless (eq ep last)
+ (format stream ", ")
+ (pprint-newline :fill stream))))
+ (format stream ",")
+ (pprint-newline :mandatory stream)
+ (format stream "\"constraints\": ")
+ (pprint-newline :mandatory stream)
+ (pprint-logical-block (stream nil :prefix "[" :suffix "]")
+ (loop
+ with hconss = (psoa-h-cons mrs)
+ with last = (first (last hconss))
+ for hcons in hconss
+ for high = (hcons-scarg hcons)
+ for low = (hcons-outscpd hcons)
+ do
+ (format
+ stream "{\"relation\": \"qeq\", \"high\": ~a, \"low\": ~a}"
+ (mrs-variable-output-json high :objectp nil)
+ (mrs-variable-output-json low :objectp nil))
+ (pushnew high variables :test #'eq)
+ (pushnew low variables :test #'eq)
+ (unless (eq hcons last)
+ (format stream ", ")
+ (pprint-newline :fill stream))))
+ (format stream ",")
+ (pprint-newline :mandatory stream)
+ (format stream "\"variables\": ")
+ (pprint-newline :mandatory stream)
+ (pprint-logical-block (stream nil :prefix "{" :suffix "}")
+ (loop
+ with last = (first (last variables))
+ for variable in variables
+ do
+ (mrs-variable-output-json
+ variable :objectp t :propertiesp propertiesp :stream stream)
+ (unless (eq variable last)
+ (format stream ", ")
+ (pprint-newline :fill stream))))))))
+
+(defun mrs-variable-output-json (variable
+ &key stream objectp (propertiesp t))
+ (if (null stream)
+ (with-output-to-string (stream)
+ (mrs-variable-output-json
+ variable :stream stream :objectp objectp :propertiesp propertiesp))
+ (cond
+ (objectp
+ (format
+ stream "\"~a~a\": "
+ (var-type variable) (var-id variable))
+ (pprint-logical-block (stream nil :prefix "{" :suffix "}")
+ (format stream "\"type\": ~s" (var-type variable))
+ (when (and propertiesp (var-extra variable))
+ (format stream ", \"properties\": ")
+ (pprint-newline :fill stream)
+ (pprint-logical-block (stream nil :prefix "{" :suffix "}")
+ (loop
+ with properties = (var-extra variable)
+ with last = (first (last properties))
+ for property in properties
+ do
+ (format
+ stream "\"~a\": \"~(~a~)\"~@[, ~]"
+ (extrapair-feature property)
+ (extrapair-value property)
+ (not (eq property last)))
+ (unless (eq property last)
+ (pprint-newline :fill stream)))))))
+ (t
+ (format stream "\"~a~a\"" (var-type variable) (var-id variable))))))
+
+;;;
;;; LaTeX output-type class
;;;
(defun latex-escape-string (string)
@@ -1055,12 +1197,15 @@
(defmethod mrs-output-start-psoa ((mrs latex))
(with-slots (stream) mrs
- (format stream "\\sblock{")))
+ (format stream "\\siblock{")))
(defmethod mrs-output-top-h ((mrs latex) handle
&optional properties type id)
(declare (ignore properties type))
(with-slots (stream context) mrs
+ ;;
+ ;; temporarily prevent output of variable properties (top handle and index)
+ ;;
(push :mute context)
(when (and handle *rel-handel-path*)
(format stream "\\sh{~a}}" id))))
@@ -1069,10 +1214,7 @@
&optional properties type id)
(declare (ignore properties))
(with-slots (stream) mrs
- ;;; :mute will still be in effect so no properties
- ;;; will be output
- (when index
- (format stream "{\\svar{~a}{~a}{}}" type id))))
+ (when index (format stream "{\\svar{~a}{~a}{}}" type id))))
(defmethod mrs-output-start-liszt ((mrs latex))
(declare (special *already-seen-vars*))
@@ -1084,10 +1226,10 @@
;; AAC - included index now, as with other MRS output, following decision
;; 3017625 at the DELPH-IN Summit, but left the reset here
;; because better not to display the properties on the index in this
- ;; format
+ ;; format.
+ ;;
(setf *already-seen-vars* nil)
(with-slots (stream context) mrs
-;;; (format stream "}{%~%")
(format stream "{%~%")
(setf context nil)))
@@ -1815,13 +1957,14 @@
nil temporary-readtable))
temporary-readtable))
-(defun mrs-check-for (character istream)
+(defun mrs-check-for (character istream &key optionalp)
(let ((next-char (peek-char t istream nil 'eof)))
(if (char-equal next-char character)
(read-char istream)
+ (unless optionalp
(error
"~%Syntax error: ~A expected and not found at position ~A"
- character (file-position istream)))))
+ character (file-position istream))))))
@@ -1881,7 +2024,7 @@
(defun read-mrs-ltop (istream)
;;; LTOP -> top: VAR
- (mrs-check-for #\l istream)
+ (mrs-check-for #\l istream :optionalp t)
(mrs-check-for #\t istream)
(mrs-check-for #\o istream)
(mrs-check-for #\p istream)
@@ -1963,7 +2106,7 @@
;;; or
;;; REL -> [ PREDNAME FEATPAIR* ]
(mrs-check-for #\[ istream)
- (let* ((relpred (read-mrs-atom istream))
+ (let* ((relpred (read-mrs-predicate istream))
(lnk (read-lnk istream)))
(when *rel-handel-path*
(mrs-check-for #\l istream)
@@ -1984,6 +2127,10 @@
(make-rel :pred relpred :lnk lnk :handel hvar
:flist (sort featpairs #'feat-sort-func)))))
+(defun read-mrs-predicate (stream)
+ (let ((pred (read-mrs-atom stream)))
+ (if *normalize-predicates-p* (normalize-predicate pred) pred)))
+
(defun read-mrs-featpair (istream)
;; FEATPAIR -> FEATNAME: VAR | CFEATNAME: CONSTNAME
(let ((feature (read-mrs-atom istream)))
Index: src/mrs/dependencies.lisp
===================================================================
--- src/mrs/dependencies.lisp (revision 24124)
+++ src/mrs/dependencies.lisp (working copy)
@@ -27,6 +27,8 @@
(defparameter *eds-bleached-relations* (list (vsym "selected_rel")))
+(defparameter *eds-predicate-filter* nil)
+
(defparameter *eds-quantifier-argument* (vsym "BV"))
(defparameter *eds-untensed* (list (cons (vsym "TENSE") (vsym "untensed"))))
@@ -37,6 +39,8 @@
(defparameter *eds-predicate-modifiers*
(list (ppcre:create-scanner "_x_deg_rel$")))
+(defparameter *eds-show-lnk-p* t)
+
(defparameter *eds-show-properties-p* t)
(defparameter *eds-show-status-p* nil)
@@ -49,6 +53,8 @@
(defparameter %eds-equivalences% (make-hash-table :test #'equal))
+(defparameter %eds-filter% nil)
+
(defparameter %eds-relevant-features%
'("ARG" "ARG1" "ARG2" "ARG3" "ARG4" "BV"
"L-INDEX" "R-INDEX" "L-HNDL" "R-HNDL" "CARG"
@@ -60,8 +66,8 @@
(defmethod print-object ((object eds) stream)
(if *eds-pretty-print-p*
- (let ((cyclicp (ed-cyclic-p object))
- (fragmentedp (ed-fragmented-p object)))
+ (let ((cyclicp (eds-cyclic-p object))
+ (fragmentedp (eds-fragmented-p object)))
(loop
initially
(format
@@ -73,8 +79,10 @@
cyclicp (and cyclicp fragmentedp) fragmentedp
(eds-relations object))
for ed in (eds-relations object)
- unless (and (null (ed-status ed))
- (or (ed-bleached-p ed) (ed-vacuous-p ed))) do
+ 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~%"
@@ -91,7 +99,7 @@
(defstruct ed
handle id properties type variable
predicate arguments carg
- lnk raw status mark abstraction)
+ lnk inverse raw status mark abstraction)
(defmethod print-object ((object ed) stream)
(if *eds-pretty-print-p*
@@ -111,8 +119,8 @@
(rest (ed-properties object)))
initially
(format
- stream "{~@[~(~a~) ~]"
- (unless (extrapair-p type) type))
+ stream "{~@[~(~a~)~]~@[ ~]"
+ (unless (extrapair-p type) type) properties)
finally (format stream "}")
for property in properties
do
@@ -137,9 +145,13 @@
(format stream "]"))
(call-next-method)))
-(defun ed-linked-predicate (ed &key (lnkp t))
+(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)))
@@ -166,26 +178,53 @@
(t
(format nil "_~(~a~)_" abstraction))))))
-(defun ed-output-psoa (psoa &key (stream t) (format :ascii) (propertyp t)
- cargp markp lnkp collocationp abstractp
- sortp dmrsp (n 0))
+(defun eds-output-psoa (psoa &key (stream t) (format :ascii)
+ (lnkp *eds-show-lnk-p*)
+ (propertiesp *eds-show-properties-p*)
+ cargp collocationp abstractp sentinelp
+ 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 :sortp sortp :dmrsp dmrsp :n n :filter filter
+ :input input :id id :debug debug :prefix prefix :columns columns))))
+
+ (let ((eds (if (eds-p psoa) psoa (eds-convert-psoa psoa)))
+ (%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
+ ((:ascii :native)
(cond
((eds-p psoa)
(format stream "~a~%" psoa))
- ((psoa-p psoa)
- (format stream "~a~%" (ed-convert-psoa psoa)))
+ ((eds-p eds)
+ (format stream "~a~%" eds))
(t
(format stream "{}~%"))))
(:triples
- (let* ((eds (if (eds-p psoa) psoa (ed-convert-psoa psoa)))
- (triples
+ (let* ((triples
(if dmrsp
(dmrs-explode (rmrs-to-dmrs (mrs-to-rmrs psoa)))
- (ed-explode
+ (eds-explode
eds
- :lnkp lnkp :cargp cargp :propertyp propertyp
+ :cargp cargp
:collocationp collocationp :abstractp abstractp))))
(when sortp
(setf triples
@@ -197,14 +236,14 @@
(string< (second foo) (second bar))))))))
(loop
with *package* = (find-package :lkb)
- initially (unless markp (format stream "{~%"))
+ initially (unless sentinelp (format stream "{~%"))
for triple in triples
do
(format
stream
"~:[ ~;<s> ~]~{~a~^ ~}~:[ ~; </s>~]~%"
- markp triple markp)
- finally (unless markp (format stream "}~%~%")))
+ sentinelp triple sentinelp)
+ finally (unless sentinelp (format stream "}~%~%")))
(length triples)))
(:lui
(let ((attic (make-hash-table :test #'equal))
@@ -215,7 +254,6 @@
(setf (gethash object attic) n)
(incf id)
n))))
- (let ((eds (if (eds-p psoa) psoa (ed-convert-psoa psoa))))
(format
stream
"#X[~a \"{~(~a~)\" \":\" newline~%\" \" #X["
@@ -257,9 +295,8 @@
(format
stream
"] newline \"}\"]~%~
- #M[]"))))))
+ #M[]")))))
(:html
- (let ((eds (if (eds-p psoa) psoa (ed-convert-psoa psoa))))
(format stream "<table class=mrsEds>~%")
(format stream "<tr><td>")
(mrs-variable-html (eds-top eds) nil n nil stream)
@@ -275,7 +312,7 @@
onMouseOut=\"highlight()\"~]> "
(and lnk (eq (first lnk) :characters)) (second lnk) (third lnk))
(mrs-variable-html (ed-id ed) nil n nil stream)
- (if (and propertyp (ed-properties ed))
+ (if (and propertiesp (ed-properties ed))
(let* ((string (make-string-output-stream)))
(format string "<table class=mrsProperties>")
(loop
@@ -317,7 +354,7 @@
(mrs-variable-html (ed-id value) nil n nil stream)
(setf firstp nil))
(format stream "]</td></tr>~%"))
- (format stream "</table>~%")))
+ (format stream "</table>~%"))
(:latex
(labels ((variable (id &optional properties)
(let ((type (latex-escape-string (subseq id 0 1)))
@@ -324,12 +361,8 @@
(index (parse-integer id :start 1 :junk-allowed t)))
(format
nil "\\svar{~a}{~a}{~@[~a~]}"
- type index properties)))
- #+:null
- (properties (ed)
- ""))
+ type index properties))))
(loop
- 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)
@@ -350,14 +383,134 @@
stream "~:[, ~;~% ~]\\srole{~a}{~a}"
firstp role (variable (ed-id value))))
(format stream "}~@[~*\\\\~%~]" (rest relations))
- finally (format stream "}~%"))))))
+ 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-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)))
+ (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)))
+ (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)))))
+ (: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 ", \"properties\": {~@[\"type\": ~s~]"
+ (unless (extrapair-p type) type))
+ finally (format stream "}")
+ for property in properties
+ do
+ (format
+ stream "~:[, ~;~]\"~a\": \"~(~a~)\""
+ (and (extrapair-p type) (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 "}}"))))))
#+:lkb
-(defun ed-convert-edge (edge)
+(defun eds-convert-edge (edge)
(when (lkb::edge-p edge)
- (ed-convert-psoa (or (lkb::edge-mrs edge) (extract-mrs edge)))))
+ (eds-convert-psoa (or (lkb::edge-mrs edge) (extract-mrs edge)))))
-(defun ed-convert-psoa (psoa)
+(defun eds-convert-psoa (psoa)
(when (psoa-p psoa)
(loop
with eds = (make-eds :hcons (psoa-h-cons psoa) :raw psoa)
@@ -382,7 +535,7 @@
;; 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.
;;
- (ed-bleach-eds eds)
+ (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
@@ -391,8 +544,13 @@
;; in the case of multiple candidate representative EDs, various
;; disambiguation heuristics apply, see ed-select-representative().
;;
- (ed-augment-eds eds)
+ (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
@@ -402,7 +560,7 @@
;; versions of the ERG at least, that seems likely only in illformed
;; input MRSs).
;;
- (ed-uniq-ids eds)
+ (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
@@ -469,11 +627,10 @@
(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)))))
+ (if (functionp pattern)
+ (ppcre:scan pattern predicate)
+ (ed-compare-predicates
+ predicate pattern :type :subsumption)))
(and arg1 (var-p (fvpair-value arg1))
(string-equal (var-type (fvpair-value arg1)) "u")))
(let* ((label (rel-handel relation)))
@@ -532,7 +689,7 @@
:predicate predicate :lnk lnk :carg carg :abstraction abstraction
:type type :raw relation))))
-(defun ed-bleach-eds (eds)
+(defun eds-bleach-eds (eds)
(loop
for ed in (eds-relations eds)
when (ed-message-p ed) do
@@ -550,7 +707,7 @@
when (ed-quantifier-p ed) do (setf (ed-type ed) :quantifier)
when (ed-fragment-p ed) do (setf (ed-type ed) :fragment)))
-(defun ed-augment-eds (eds)
+(defun eds-augment-eds (eds)
(loop
for ed in (eds-relations eds)
unless (ed-bleached-p ed) do
@@ -575,9 +732,18 @@
(push (cons key representative) (ed-arguments ed)))
(setf (ed-arguments ed) (nreverse (ed-arguments ed)))))
-(defun ed-uniq-ids (eds)
+(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
@@ -838,21 +1004,39 @@
(let ((pred (ed-predicate ed)))
(and (stringp pred) (string= (subseq pred (- (length pred) 2)) "_q")))))
+(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 ((type (ed-predicate thing)))
+ (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)))
- (and (stringp type)
- (string= (subseq type (- (length type) 2)) "_m")))))
+ (string= (subseq predicate (- (length predicate) 2)) "_m"))))
(rel
- (let ((type (rel-pred thing)))
- (or (eq type *eds-message-relation*)
- (when (stringp type) (search "_m_rel" type))
+ (let ((predicate (rel-pred thing)))
+ (or (eq predicate *eds-message-relation*)
+ (when (stringp predicate) (search "_m_rel" predicate))
(ignore-errors
- (equal-or-subtype type *eds-message-relation*))))))))
+ (equal-or-subtype predicate *eds-message-relation*))))))))
(defun ed-untensed-p (properties)
(if (ed-p properties)
@@ -861,14 +1045,21 @@
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)))))
+ 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)))))
- (or (eq (ed-type ed) :fragment)
- (eq pred *eds-fragment-relation*)
- (ignore-errors (equal-or-subtype pred *eds-fragment-relation*))))))
+ (when pred
+ (ignore-errors
+ (equal-or-subtype pred (vsym *eds-fragment-relation*))))))))
(defun ed-bleached-p (ed)
(or
@@ -876,19 +1067,24 @@
(and (null *eds-include-quantifiers-p*) (eq (ed-type ed) :quantifier))
(when *eds-bleached-relations*
(loop
- with predicate = (and (rel-p (ed-raw ed)) (rel-pred (ed-raw ed)))
- for foo in *eds-bleached-relations*
- for type = (if (stringp foo) (vsym foo) foo)
- thereis (or (eq predicate type)
- (ignore-errors (equal-or-subtype predicate type)))))))
+ 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 *eds-non-representatives*
(loop
+ with predicate = (ed-predicate ed)
with pred = (and (rel-p (ed-raw ed)) (rel-pred (ed-raw ed)))
- for foo in *eds-non-representatives*
- for type = (if (stringp foo) (vsym foo) foo)
- thereis (ignore-errors (equal-or-subtype pred type)))))
+ 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*
@@ -897,11 +1093,11 @@
(and (null (rest (ed-arguments ed)))
(eq (first (first (ed-arguments ed))) (vsym "CARG")))))))
-(defun ed-suspicious-p (eds)
- (append (when (ed-cyclic-p eds) '(:cyclic))
- (when (ed-fragmented-p eds) '(:fragmented))))
+(defun eds-suspicious-p (eds)
+ (append (when (eds-cyclic-p eds) '(:cyclic))
+ (when (eds-fragmented-p eds) '(:fragmented))))
-(defun ed-cyclic-p (eds)
+(defun eds-cyclic-p (eds)
(loop
with return = nil
for ed in (eds-relations eds)
@@ -935,12 +1131,12 @@
(unless (ed-walk value (adjoin (ed-id ed) start)) (return nil))
finally (return t))))
-(defun ed-fragmented-p (eds)
+(defun eds-fragmented-p (eds)
(let ((mark (gensym))
(agenda (loop
with top = (eds-top eds)
for ed in (eds-relations eds)
- when (equal (ed-id ed) top) collect ed)))
+ when (string= (ed-id ed) top) collect ed)))
;;
;; put .mark. on all EDs that are `reachable' from the top variable
;;
@@ -986,7 +1182,9 @@
(when return (pushnew :fragmented (eds-status eds)))
(return return))))
-(defun ed-explode (eds &key (lnkp t) (cargp t) (propertyp t) collocationp
+(defun eds-explode (eds &key (lnkp *eds-show-lnk-p*)
+ (propertiesp *eds-show-properties-p*)
+ (cargp t) collocationp
tagp abstractp)
;;
@@ -1000,7 +1198,7 @@
;;
;; _fix_me_
;; not sure what the `variable' slot was intended for, but it appears to be
- ;; exclusively used in ed-explode(); make sure all EDs have a correct value.
+ ;; exclusively used in eds-explode(); make sure all EDs have a correct value.
;; (26-nov-04; oe)
(loop
with key = (vsym "ARG0")
@@ -1100,7 +1298,7 @@
abstractions))))))
- (when propertyp
+ (when propertiesp
(loop
for ed in (eds-relations eds)
unless (or (and (null (ed-status ed)) (ed-bleached-p ed))
@@ -1200,7 +1398,7 @@
(when (eq (first (ed-mark current)) mark)
(member path (rest (ed-mark current)) :test #'prefixp)))
do
- #+:null
+ #-:null
(format
t "~a [~{~a~^ ~}] <-- ~a~%"
(ed-predicate current) (rest (ed-mark current)) path)
@@ -1302,7 +1500,6 @@
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*)))
@@ -1331,7 +1528,7 @@
for node in (eds-relations eds)
for predicate = (ed-predicate node)
for sps
- = (mt:semi-lookup semi :predicate predicate :alias predicate)
+ = (mt:semi-lookup :semi semi :predicate predicate :alias predicate)
for lnk = (ed-lnk node)
for properties = (ed-properties node)
for arguments = (ed-arguments node)
@@ -1405,8 +1602,19 @@
(setf (psoa-index mrs) index))
mrs)))
-(defun eds-read (file)
+(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))
+ (let ((eds (eds-read stream)))
+ (close stream)
+ #+:allegro
+ (sys:os-wait nil pid)
+ eds)))
((streamp file)
(labels ((|{|-reader (stream char)
(declare (ignore char))
@@ -1448,7 +1656,8 @@
(let* ((feature (pop properties))
(value (pop properties))
(value
- (if (or (symbolp value) (stringp value))
+ (if (or (symbolp value)
+ (stringp value))
value
(format nil "~a" value))))
(make-extrapair
@@ -1505,6 +1714,7 @@
(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)
@@ -1518,9 +1728,139 @@
(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))))
+ (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 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 "^[^_].*_q$|^focus_d$|^parg_d$"
+ :id id :input (tsdb:get-field :i-input item))))
+ (mrs:eds-output-psoa
+ mrs :format format :stream stream
+ :lnkp t :propertiesp nil
+ :filter "^[^_].*_q$|^focus_d$|^parg_d$"
+ :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
+ 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 "^[^_].*_q$|^focus_d$|^parg_d$"
+ :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 "^[^_].*_q$|^focus_d$|^parg_d$"
+ :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))))
Index: src/mrs/edm.lisp
===================================================================
--- src/mrs/edm.lisp (revision 24124)
+++ src/mrs/edm.lisp (working copy)
@@ -46,7 +46,7 @@
(list tn ta tp gn ga gp cn ca cp)))))
(defun edm-explode-mrs (mrs
- &key (cargp t) (eds (ed-convert-psoa mrs)))
+ &key (cargp t) (eds (eds-convert-psoa mrs)))
;;
;; make sure the distinguished variable slot is available when it should be
Index: src/mrs/generate.lisp
===================================================================
--- src/mrs/generate.lisp (revision 24124)
+++ src/mrs/generate.lisp (working copy)
@@ -283,6 +283,9 @@
(if (mt:fragmentp mrs)
(mt:generate-from-fragmented-mrs mrs :signal signal)
+ #+:debug
+ (generate-from-mrs-internal mrs :nanalyses nanalyses)
+ #-:debug
(handler-case (generate-from-mrs-internal mrs :nanalyses nanalyses)
(condition (condition)
(setf %generator-condition% condition)
@@ -762,6 +765,7 @@
input-rels
(g-edge-rels-covered edge)))
+
(defun gen-chart-check-compatible (edge)
;; construct the MRS for edge
;; We test for 'compatibility' rather than equality - in
Index: src/mrs/interface.lisp
===================================================================
--- src/mrs/interface.lisp (revision 24124)
+++ src/mrs/interface.lisp (working copy)
@@ -342,7 +342,7 @@
(ecase info-type
(:simple (output-mrs1 mrs-struct 'simple stream))
(:indexed (output-mrs1 mrs-struct 'indexed stream))
- (:eds (ed-output-psoa mrs-struct :stream stream))
+ (:eds (eds-output-psoa mrs-struct :stream stream))
(:first-scoped
(let ((binding-sets (make-scoped-mrs mrs-struct)))
(when binding-sets
@@ -389,14 +389,28 @@
(defun read-mrs-from-file (file
&key #+:allegro
(external-format
- (excl:locale-external-format excl:*locale*)))
+ (excl:locale-external-format excl:*locale*))
+ decoder)
;;; called by oe
(when (probe-file file)
+ (if decoder
+ (multiple-value-bind (stream foo pid)
+ (run-process
+ decoder :wait nil
+ :input file :output :stream :error-output nil)
+ (declare (ignore foo))
+ #+:allegro
+ (setf (stream-external-format stream) external-format)
+ (let ((mrs (read-mrs stream)))
+ (close stream)
+ #+:allegro
+ (sys:os-wait nil pid)
+ mrs))
(#+:debug progn #-:debug ignore-errors
- (with-open-file (istream file :direction :input
+ (with-open-file (stream file :direction :input
#+:allegro :external-format #+:allegro external-format)
(let ((*package* (find-package :lkb)))
- (read-mrs istream))))))
+ (read-mrs stream)))))))
(defun read-mrss-from-file (file)
(when (probe-file file)
Index: src/mrs/lexindex.lisp
===================================================================
--- src/mrs/lexindex.lisp (revision 24124)
+++ src/mrs/lexindex.lisp (working copy)
@@ -324,8 +324,10 @@
(defun matches-rel-record (rel lexrec)
(and (rel-p rel)
(rel-p lexrec)
- (compatible-types (rel-pred rel)
- (rel-pred lexrec))
+ (if *normalize-predicates-p*
+ (mt:semi-compare-predicates
+ (rel-pred rel) (rel-pred lexrec) :type :unification)
+ (compatible-types (rel-pred rel) (rel-pred lexrec)))
(subsetp
(get-rel-parameter-strings rel)
(rel-parameter-strings lexrec)
@@ -396,9 +398,14 @@
;;; types by mistake, there's a maximum number of relations
;;; allowed, which is set quite high, because of all the glbtypes
(let ((returned-rels nil))
- (loop for reltype in reltype-list
+ (loop
+ for reltype in reltype-list
do
- (loop for compatible-rel in (lkb::get-compatible-rels reltype)
+ (loop
+ for compatible-rel
+ in (if mrs::*normalize-predicates-p*
+ (mt:semi-compatible-predicates reltype)
+ (lkb::get-compatible-rels reltype))
do
(pushnew compatible-rel returned-rels :test #'eq)))
(when (and *maximum-genindex-relations*
Index: src/mrs/lexutils.lisp
===================================================================
--- src/mrs/lexutils.lisp (revision 24124)
+++ src/mrs/lexutils.lisp (working copy)
@@ -6,10 +6,11 @@
;;; from lexindex
-(defparameter *get-compatible-rels-memo* (make-hash-table))
+(defparameter *get-compatible-rels-memo* nil)
(defun clear-generator-index nil
- (clrhash *get-compatible-rels-memo*)
+ (setf *get-compatible-rels-memo*
+ (make-hash-table :test (if mrs::*normalize-predicates-p* #'equal #'eq)))
(mrs::clear-semantic-indices)
(mrs::clear-lrule-globals)
(mrs::clear-grule-globals))
@@ -115,24 +116,8 @@
(when (typep lex 'psql-lex-database)
(dump-generator-indices-to-psql lex))
(when (typep lkb::lex 'lkb::cdb-lex-database)
- (mrs::serialize-semantics-indices))
+ (mrs::serialize-semantics-indices))))
- ;;
- ;; _fix_me_
- ;; the following seems undesirable to me, as if it were illegitime for a
- ;; grammar to use semantically vacuous entries. furthermore, the output
- ;; suggested by the code below assumes file and type names that are not
- ;; standardized, hence could be mis-leading. (2-jul-08; oe)
- ;;
-
- ;; [bmw] dump trigger tdl
- #-:logon
- (when mrs::*empty-semantics-lexical-entries*
- (format t "~%~%ADD THE FOLLOWING TO trigger.mtr:")
- (make-trigger-tdl mrs::*empty-semantics-lexical-entries*))
-
- ))
-
(defun reindex-lexicon nil ; <-- efficiency problem
(format t "~% (recompiling semantic indices)")
(mrs::clear-semantic-indices)
@@ -160,25 +145,9 @@
(format t "~%No feature structure for ~A~%"
(lex-entry-id entry)))))
(forget-psort *lexicon* (lex-entry-id entry))))
- (mrs::check-for-redundant-filter-rules)))
+ (mrs::check-for-redundant-filter-rules))))
- ;; [bmw] dump trigger tdl
- (when mrs::*empty-semantics-lexical-entries*
- (format t "~%~%ADD THE FOLLOWING TO trigger.mtr:")
- (make-trigger-tdl mrs::*empty-semantics-lexical-entries*))
- )
-;; [bmw] code to dump trigger tdl for rules which
-;; have 'no semantics and no filter rule'
-(defun make-trigger-tdl (empty-semantics-lexical-entries)
- (loop for x in empty-semantics-lexical-entries
- do
- (format t "~%~%~a_gr := generator_rule &
-[ CONTEXT.RELS <! [ PRED \"non_existing_rel\" ] !>,
- FLAGS.TRIGGER \"~a\" ]."
- (string-downcase x)
- (string-downcase x))))
-
(defun get-compatible-rels (reltype)
(or (gethash reltype *get-compatible-rels-memo*)
(let* ((type-entry (get-type-entry reltype))
Index: src/mrs/lkb-acl-mrs.lisp
===================================================================
--- src/mrs/lkb-acl-mrs.lisp (revision 24124)
+++ src/mrs/lkb-acl-mrs.lisp (working copy)
@@ -170,13 +170,13 @@
((mrs-type-thing 'mrs-type-thing :gesture :select))
(mrs-type-thing-command mrs-type-thing))
-(defun add-mrs-pred-region (stream val)
+(defun add-mrs-pred-region (stream val &optional normalizep)
(let ((pred-rec
(make-mrs-type-thing :value val)))
(clim:with-text-style (stream *bold*)
(clim:with-output-as-presentation
(stream pred-rec 'mrs-type-thing)
- (if (stringp val)
+ (if (and (stringp val) (null normalizep))
(format stream "~s" val)
(format stream "~(~a~)" val))))))
@@ -497,12 +497,12 @@
(defun show-mrs-dependencies (mframe stream &key max-width max-height)
(declare (ignore max-width max-height))
(let* ((mrsstruct (mrs-dependencies-mrsstruct mframe))
- (eds (mrs::ed-convert-psoa mrsstruct)))
+ (eds (mrs:eds-convert-psoa mrsstruct)))
(if eds
(let ((record (clim:with-new-output-record (stream)
(clim:with-text-style (stream (lkb-parse-tree-font))
(format stream "~a~%" eds))))
- (status (mrs::ed-suspicious-p eds))
+ (status (mrs:eds-suspicious-p eds))
(orange (or (clim:find-named-color
"orange" (clim:frame-palette mframe) :errorp nil)
clim:+yellow+)))
Index: src/mrs/lnk.lisp
===================================================================
--- src/mrs/lnk.lisp (revision 24124)
+++ src/mrs/lnk.lisp (working copy)
@@ -52,10 +52,12 @@
(labels ((open-lnk ()
(case format
(:html (format stream "⟨"))
+ (:json (format stream "{"))
(t (format stream "<"))))
(close-lnk ()
(case format
(:html (format stream "⟩"))
+ (:json (format stream "}"))
(t (format stream ">")))))
(case (first lnk)
(:characters
@@ -64,19 +66,43 @@
(when (and (numberp start) (numberp end)
(>= start 0) (>= end 0))
(open-lnk)
- (format stream "~a:~a" (second lnk) (third lnk))
+ (case format
+ (:json
+ (format
+ stream "\"from\": ~d, \"to\": ~d"
+ (second lnk) (third lnk)))
+ (t
+ (format stream "~a:~a" (second lnk) (third lnk))))
(close-lnk))))
(:vertices
(open-lnk)
- (format stream "~a#~a" (second lnk) (third lnk))
+ (case format
+ (:json
+ (format
+ stream "\"start\": ~d, \"end\": ~d"
+ (second lnk) (third lnk)))
+ (t
+ (format stream "~a#~a" (second lnk) (third lnk))))
(close-lnk))
(:tokens
(open-lnk)
- (format stream "~{~a~^ ~}" (rest lnk))
+ (case format
+ (:json
+ (format
+ stream "\"tokens\": [~{~d~^, ~}]"
+ (rest lnk)))
+ (t
+ (format stream "~{~a~^ ~}" (rest lnk))))
(close-lnk))
(:id
(open-lnk)
- (format stream "@~a" (second lnk))
+ (case format
+ (:json
+ (format
+ stream "\"id\": ~d"
+ (second lnk)))
+ (t
+ (format stream "@~a" (second lnk))))
(close-lnk))))))
(with-output-to-string (stream)
(output-lnk lnk :stream stream :format format))))
Index: src/mrs/lsp.lisp
===================================================================
--- src/mrs/lsp.lisp (revision 24124)
+++ src/mrs/lsp.lisp (working copy)
@@ -56,7 +56,7 @@
(format stream "~s" string)))
((eq format 'dependencies)
(let ((string (with-output-to-string (stream)
- (ed-output-psoa psoa :stream stream))))
+ (eds-output-psoa psoa :stream stream))))
(format stream "~s" string)))
(t
(setf return lkb::%lsp-invalid-format%))))
Index: src/mrs/mrsglobals.lisp
===================================================================
--- src/mrs/mrsglobals.lisp (revision 24124)
+++ src/mrs/mrsglobals.lisp (working copy)
@@ -166,6 +166,12 @@
order in the MRS output routines and also determines the order
of variables in the indexed representation")
+(defparameter *property-order*
+ (list
+ (vsym "SF") (vsym "TENSE") (vsym "MOOD") (vsym "PERF") (vsym "PROG")
+ (vsym "PERS") (vsym "NUM") (vsym "GEND")
+ (vsym "IND") (vsym "DIV") (vsym "PT")))
+
(defparameter *ignored-sem-features* `(,(vsym "IDIOMP")
,(vsym "LNK")
,(vsym "CFROM")
@@ -184,6 +190,24 @@
correspond to the value of the pred - so they could be the
type of the ep fs or the value of *rel-name-path*")
+;;;
+;;; finally, we are eliminating the symbol vs. string contrast on predicates;
+;;; whereas a grammar might use either one (or both, even for the abstractly
+;;; same predicate, e.g. _afterwards_p and "_afterwards_p" in the 1214 ERG),
+;;; these shall be treated as equivalent in the MRS universe. also, we will
+;;; now always strip the (optional) *sem-relation-suffix* (‘_rel’ in the ERG)
+;;; from predicate names, as this is a mechanism on the TFS side only (to give
+;;; the grammar something like a separate namespace for its predicates). in
+;;; the past, some MRS serializations suppressed the symbol vs. type contrast,
+;;; some exposed it; likewise, some stripped the suffix, and others kept it.
+;;; see the discussion on the ‘developers’ list from january 2016 for details.
+;;;
+;;; to make the transition into a better future less painful, we will preserve
+;;; the traditional behavior (still on by default) for at least a transition
+;;; period. however, ERG 1214 will ship with predicate normalization enabled.
+;;;
+(defparameter *normalize-predicates-p* nil)
+
;;; types for variable naming in mrsoutput
(defparameter *event-type* (vsym "event"))
Index: src/mrs/mrsoutput.lisp
===================================================================
--- src/mrs/mrsoutput.lisp (revision 24124)
+++ src/mrs/mrsoutput.lisp (working copy)
@@ -431,6 +431,7 @@
(pred (rest (assoc (car *rel-name-path*) label-list)))
(pred-type (if pred (fs-type pred))))
(when rawp (return-from extract-pred-from-rel-fs pred))
+ (let ((type
(if (and pred-type
(not (is-top-type pred-type))
#+:logon
@@ -437,7 +438,14 @@
(not (is-top-semantics-type pred-type)))
pred-type
(unless *rel-name-path* (fs-type rel-fs)))))
+ (if (and *normalize-predicates-p* type)
+ (normalize-predicate type)
+ type))))
+(defun normalize-predicate (predicate)
+ (when (and predicate (or (symbolp predicate) (stringp predicate)))
+ (remove-right-sequence *sem-relation-suffix* (string-downcase predicate))))
+
(defun extract-type-from-rel-fs (rel-fs)
(fs-type rel-fs))
Index: src/mrs/mrstoplevel.lisp
===================================================================
--- src/mrs/mrstoplevel.lisp (revision 24124)
+++ src/mrs/mrstoplevel.lisp (working copy)
@@ -166,6 +166,7 @@
#-:tty
(defun really-generate-from-edge (parser-edge)
+ (declare (special *dmrs-grammar-p*))
(let* ((input-sem (if *dmrs-grammar-p*
(mrs::extract-dmrs parser-edge)
(mrs::extract-mrs parser-edge))))
Index: src/mrs-package.lsp
===================================================================
--- src/mrs-package.lsp (revision 24124)
+++ src/mrs-package.lsp (working copy)
@@ -28,6 +28,7 @@
(:use #+:lkb :lkb :common-lisp #-:ecl :make)
(:export
"*LNKP*" "OUTPUT-LNK"
+ "*NORMALIZE-PREDICATES-P*" "NORMALIZE-PREDICATE"
"PSOA-P" "PSOA-TOP-H" "PSOA-INDEX" "PSOA-LISZT" "PSOA-H-CONS"
"REL-PRED" "REL-HANDEL" "REL-FLIST" "REL-EXTRA"
"CHAR-REL-CFROM" "CHAR-REL-CTO"
@@ -38,5 +39,9 @@
"PATH-VALUE" "IS-VALID-FS" "FS-ARCS" "FS-TYPE"
"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*"))
+ "EDS-CONVERT-EDGE" "EDS-CONVERT-PSOA" "EDS-EXPLODE"
+ "EDS-FRAGMENTED-P" "EDS-CYCLIC-P" "EDS-SUSPICIOUS-P"
+ "EDS-OUTPUT-PSOA"
+ "*EDS-INCLUDE-QUANTIFIERS-P*" "*EDS-INCLUDE-VACUOUS-RELATIONS-P*"
+ "*EDS-PRETTY-PRINT-P*" "*EDS-SHOW-STATUS-P*"
+ "*EDS-SHOW-PROPERTIES-P*" "*EDS-SHOW-LNK-P*"))
Index: src/mt/aac.lisp
===================================================================
--- src/mt/aac.lisp (revision 0)
+++ src/mt/aac.lisp (working copy)
@@ -0,0 +1,25 @@
+(in-package :mt)
+
+;;; added by AAC - called from rmrs-convert.lisp
+;;; takes a string and tries to look it up in the SEMI
+;;; could no doubt be improved by better understanding of the code
+
+(defun find-semi-entries (pred)
+;;; code adapted from test-semi-compliance
+ (unless *semis* (error "Semis not initialised"))
+ (let* ((semi (first *semis*))
+ (pred-symbol (mrs::vsym (string-upcase pred))))
+ (if
+ (or
+;;; (eql pred-symbol 'lkb::def_or_a_or_udef_q_rel)
+;;; we get errors if we let through a symbol which isn't in the SEM-I
+ (member pred-symbol *semi-fragment-relations* :test #'eq)
+ (member
+ pred-symbol
+ *semi-punctuation-relations* :test #'eq)
+ (member pred-symbol *semi-token-relations* :test #'eq)
+ (lookup-predicate pred-symbol semi))
+ pred-symbol
+ (if (lookup-predicate pred semi)
+ pred
+ nil))))
Index: src/mt/comparison.lisp
===================================================================
--- src/mt/comparison.lisp (revision 24124)
+++ src/mt/comparison.lisp (working copy)
@@ -1,7 +1,7 @@
(in-package :mt)
;;;
-;;; Copyright (c) 2004 -- 2008 Stephan Oepen (oe at ifi.uio.no)
+;;; Copyright (c) 2004 -- 2016 Stephan Oepen (oe at ifi.uio.no)
;;;
;;; This program is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU Lesser General Public License as published by
@@ -29,7 +29,7 @@
(predicates *mrs-comparison-equivalent-predicates*)
hcons debug)
(compare-mrss
- mrs1 mrs2 :type :equal :roles roles :properties properties
+ mrs1 mrs2 :type :equality :roles roles :properties properties
:types types :predicates predicates :hcons hcons :debug debug))
(defun compare-mrss (mrs1 mrs2
@@ -45,13 +45,11 @@
;;
#+: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))
@@ -183,14 +181,15 @@
(defun compare-preds (pred1 pred2 &key type)
(or
- (compare-types pred1 pred2 :type type)
+ (if mrs::*normalize-predicates-p*
+ (semi-compare-predicates pred1 pred2 :type type)
+ (compare-types pred1 pred2 :type type))
(loop
for (new . old) in *mrs-comparison-equivalent-predicates*
- when (and (loop
+ thereis (and (loop
for foo in old
thereis (compare-types pred1 foo :type type))
- (compare-preds new pred2 :type type))
- return t)))
+ (compare-preds new pred2 :type type)))))
(defun compare-values (value1 value2 solution &key type)
(if (mrs::var-p value1)
@@ -278,7 +277,6 @@
(t (compare-types constant1 constant2 :type type))))
(defun compare-types (type1 type2 &key internp type)
-
(or (eq type1 type2)
(and (stringp type1) (stringp type2) (string-equal type1 type2))
(ignore-errors
Index: src/mt/lm.lisp
===================================================================
--- src/mt/lm.lisp (revision 24124)
+++ src/mt/lm.lisp (working copy)
@@ -358,9 +358,9 @@
(with-open-file (stream file
:direction :output :if-exists :supersede)
(push
- (mrs::ed-output-psoa
+ (mrs:eds-output-psoa
mrs :format :triples :cargp nil :lnkp nil
- :collocationp t :abstractp t :markp t :stream stream)
+ :collocationp t :abstractp t :sentinelp t :stream stream)
lengths))
(format
*tm-input*
Index: src/mt/semi.lisp
===================================================================
--- src/mt/semi.lisp (revision 24124)
+++ src/mt/semi.lisp (working copy)
@@ -1,7 +1,7 @@
(in-package :mt)
;;;
-;;; Copyright (c) 2004 -- 2006 Stephan Oepen (oe at csli.stanford.edu)
+;;; Copyright (c) 2004 -- 2016 Stephan Oepen (oe at ifi.uio.no)
;;;
;;; This program is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU Lesser General Public License as published by
@@ -23,6 +23,8 @@
(defparameter *semi-generalize-ignore-properties* nil)
+(defparameter %semi-patches% nil)
+
(defstruct semi
name
signature
@@ -30,7 +32,8 @@
(predicates (make-hash-table :test #'equal))
(aliases (make-hash-table :test #'equal))
(properties (make-hash-table))
- (ges (make-hash-table)))
+ (ges (make-hash-table))
+ (types (make-hash-table :test #'eq)))
(defmethod print-object ((object semi) stream)
(declare (special %transfer-raw-output-p%))
@@ -46,8 +49,33 @@
ges ges roles roles predicates predicates properties properties))))
(defstruct sps
- i synopses forms spes active type context parents children)
+ predicate synopses forms spes active type flags context
+ parents children ancestors descendants compatible)
+(defmethod print-object ((object sps) stream)
+ (declare (special %transfer-raw-output-p%))
+ (if %transfer-raw-output-p%
+ (call-next-method)
+ (let ((*print-circle* nil)
+ (*print-readably* nil))
+ (format
+ stream
+ "#[SPS ~a~@[ < ~{~a~^ ~}~]~@[ > ~{~a~^ ~}~]~
+ ~@[ << ~{~a~^ ~}~]~@[ >> ~{~a~^ ~}~]]"
+ (sps-predicate object)
+ (loop
+ for parent in (sps-parents object)
+ collect (if (sps-p parent) (sps-predicate parent) parent))
+ (loop for child in (sps-children object) collect (sps-predicate child))
+ (loop
+ for ancestor in (sps-ancestors object)
+ unless (member ancestor (sps-parents object) :test #'eq)
+ collect (sps-predicate ancestor))
+ (loop
+ for descendant in (sps-descendants object)
+ unless (member descendant (sps-children object) :test #'eq)
+ collect (sps-predicate descendant))))))
+
(defstruct spe
id stem forms type ep index mrs)
@@ -57,6 +85,9 @@
(defmacro ignored-role-p (role)
`(member ,role *semi-ignore-roles* :test #'eq))
+(defmacro glbp (predicate)
+ `(ppcre:scan "^glbtype[0-9]+$" (string-downcase ,predicate)))
+
(defmacro lookup-predicate (predicate semi)
`(gethash ,predicate (semi-predicates ,semi)))
@@ -63,13 +94,51 @@
(defmacro lookup-alias (predicate semi)
`(gethash (string-downcase ,predicate) (semi-aliases ,semi)))
-(defun semi-lookup (semi &key predicate alias)
+(defun semi-lookup (&key (semi (first *semis*)) 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)))
+(defmacro patches-blocked-p (predicate)
+ `(when (stringp ,predicate)
+ (loop
+ for (key . rest) in %semi-patches%
+ thereis (and (eq key :block) (string= ,predicate (first rest))))))
+
+(defmacro patches-alias (predicate)
+ `(when (stringp ,predicate)
+ (loop
+ for (key . rest) in %semi-patches%
+ when (and (eq key :alias) (string= ,predicate (first rest)))
+ return (second rest))))
+
+(defmacro patches-parents ()
+ `(loop
+ for (key . rest) in %semi-patches%
+ when (eq key :parent) collect rest))
+
+(defmacro patches-links (name)
+ `(loop
+ for (key . rest) in %semi-patches%
+ when (and (eq key :link)
+ (eq (first rest) ,name))
+ collect (second rest)))
+
+
+(defun read-predicate (line &optional n)
+ (let* ((pred (if n (subseq line 0 n) line))
+ (pred (and pred (string-trim '(#\space #\tab) pred))))
+ (if mrs::*normalize-predicates-p*
+ (mrs::normalize-predicate pred)
+ (let ((i (length pred)))
+ (if (and (> i 2)
+ (char= (schar pred 0) #\")
+ (char= (schar pred (- i 1)) #\"))
+ (string-downcase (read-from-string pred nil nil))
+ pred)))))
+
+(defun read-synopsis (line &optional (offset 0))
+ (let ((stream (make-string-input-stream line offset)))
(labels ((read-role ()
(let ((c (peek-char t stream nil nil)))
(when (char= c #\.) (return-from read-role))
@@ -110,7 +179,9 @@
:name name :value variable :optionality optionality))))))
(make-ep :roles (loop for role = (read-role) while role collect role)))))
-(defun read-semi (file &key semi (encoding :utf-8) close)
+(defun read-semi (file &key semi (encoding :utf-8)
+ resetp (recordp t) (includep t) (finalizep t))
+ (when resetp (setf *semis* nil))
(let* ((file (pathname file))
(name (format
nil
@@ -118,7 +189,7 @@
(pathname-name file) (pathname-type file)))
(id (subseq name 0 (search ".smi" name)))
(id (intern (string-upcase id) :keyword))
- (includep semi)
+ (inclusionp semi)
(semi (or semi (make-semi :name id))))
(with-open-file (stream file :direction :input)
#+:allegro
@@ -126,9 +197,15 @@
(excl:find-external-format encoding))
(format t "read-semi(): reading file `~a'.~%" name)
(loop
- with *readtable* = (lkb::make-tdl-break-table)
+ with *readtable* = (copy-readtable)
with *package* = (find-package :lkb)
with context = :top
+ initially
+ (set-syntax-from-char #\: #\space)
+ (set-syntax-from-char #\, #\space)
+ (set-syntax-from-char #\. #\space)
+ (set-syntax-from-char #\[ #\space)
+ (set-syntax-from-char #\] #\space)
for c = (peek-char t stream nil nil)
while c do
(cond
@@ -155,51 +232,233 @@
(make-pathname
:directory (pathname-directory file))))))
(if (and path (probe-file path))
- (read-semi path :semi semi :encoding encoding)
+ (when includep
+ (read-semi path :semi semi :encoding encoding))
(format t "read-semi(): invalid `~a'.~%" line))))
(t
(case context
(:predicates
- (let* ((pred (ignore-errors
- (read-from-string line nil nil)))
- (pred
- (if (stringp pred) (string-downcase pred) pred))
- (alias (predicate-alias pred))
- (colon (and pred (position #\: line)))
+ (let* ((n (length line))
+ (i (search " <" line))
+ (j (search " :" line :start2 (if i (+ i 1) 0)))
+ (parents
+ (when i
+ (let ((strings
+ (ppcre:split
+ " ?& ?" line
+ :start (+ i 2) :end (or j n))))
+ (loop
+ for string in strings
+ for foo = (read-from-string string nil nil)
+ for pred
+ = (if mrs::*normalize-predicates-p*
+ (mrs::normalize-predicate foo)
+ (if (stringp foo)
+ (string-downcase foo)
+ foo))
+ collect pred))))
+ (pred (read-predicate line (or i j)))
+ (alias (and pred (predicate-alias pred)))
(synopsis
- (and colon (read-synopsis line (+ colon 1))))
- (bucket (and pred (lookup-predicate pred semi))))
+ (and pred j (read-synopsis line (+ j 2))))
+ (bucket
+ (and pred (lookup-predicate pred semi))))
+ (when synopsis (setf (ep-pred synopsis) pred))
+ (if (or parents synopsis)
(cond
- (synopsis
- (setf (ep-pred synopsis) pred)
- (if bucket
- (push synopsis (sps-synopses bucket))
- (let ((sps (make-sps :synopses (list synopsis))))
+ (bucket
+ (when synopsis
+ (push synopsis (sps-synopses bucket)))
+ (loop
+ for parent in parents
+ do
+ (pushnew
+ parent (sps-parents bucket)
+ :test #'string=)))
+ (t
+ (let ((sps (make-sps
+ :predicate pred
+ :synopses (and synopsis (list synopsis))
+ :parents parents)))
(setf (lookup-predicate pred semi) sps)
- (when alias (setf (lookup-alias alias semi) sps)))))
- (t
+ (when alias
+ (setf (lookup-alias alias semi) sps)))))
(format
t
- "read-semi(): ignoring |~a|." line)))))))))))))
- (when close (close-semi semi))
- (unless includep (push semi *semis*))
+ "read-semi(): ignoring |~a|.~%" line))))))))))))
+ (unless inclusionp
+ (anchor-semi semi)
+ (when finalizep (finalize-semi semi))
+ (when recordp (push semi *semis*)))
semi))
-(defun close-semi (semi)
- (declare (ignore semi))
+(defun anchor-semi (semi)
+ (loop
+ for sps being each hash-value in (semi-predicates semi)
+ do (anchor-sps semi sps)))
+
+(defun anchor-sps (semi sps)
+ #+:lkb
+ (unless (sps-type sps)
+ (let* ((predicate (sps-predicate sps))
+ (alias (patches-alias predicate))
+ (string
+ (concatenate 'string (string predicate) mrs::*sem-relation-suffix*))
+ (type (lkb::get-type-entry (or alias (mrs:vsym string)))))
+ (setf (sps-type sps) type)
+ (setf (gethash type (semi-types semi)) sps))))
+
+(defun embed-semi (semi &key (stream t))
+ (loop
+ for link in (patches-parents)
+ for child = (lookup-predicate (first link) semi)
+ for parent = (second link)
+ when (and child (lookup-predicate parent semi))
+ do (pushnew parent (sps-parents child))
+ else do
+ (format
+ stream "embed-semi(): invalid parent patch: ~a < ~a.~%"
+ (first link) parent))
+ ;;
+ ;; for just now, a naive pairwise comparison: we do not expect these sets
+ ;; to be large, as the SEM-I is selective about which nodes to expose in
+ ;; its external hierarchy.
+ ;; _fix_me_
+ ;; the current code is actually more naive than i originally realized; there
+ ;; is no need to drive the embedding of ‘pairwise comparison’; instead, one
+ ;; single traversal of all SEM-I entries, expanding parent links on visited
+ ;; entries, should suffice. (19-apr-16; oe)
+ ;;
+ (let ((cache (make-hash-table :test #'eq)))
+ (labels ((link (types)
+ (loop
+ for type in types
+ for match = (gethash type (semi-types semi))
+ when match collect match))
+ (minimize (ancestors)
+ (loop
+ for candidate in ancestors
+ for type = (sps-type candidate)
+ unless (loop
+ for ancestor in ancestors
+ thereis
+ (and (not (eq ancestor candidate))
+ (sps-type ancestor)
+ (member type (lkb::ltype-ancestors
+ (sps-type ancestor)))))
+ collect candidate))
+ (ancestors (sps)
+ (let* ((parents (sps-parents sps))
+ (ancestors (loop
+ for parent in parents
+ for sps = (lookup-predicate parent semi)
+ append (and sps (ancestors sps)))))
+ (append parents ancestors)))
+ (patch (type)
+ (loop
+ for name in (patches-links (lkb::ltype-name type))
+ for link = (lkb::get-type-entry name)
+ unless link
+ do
+ (format
+ t "embed-semi(): ignoring invalid link `~(~a~)'."
+ name)
+ else append (cons link (lkb::ltype-ancestors type))))
+ (embed (sps1 sps2)
+ (let* ((type1 (sps-type sps1))
+ (type2 (sps-type sps2))
+ (ancestors2 (lkb::ltype-ancestors type2))
+ (ancestors2
+ (append
+ ancestors2
+ (loop
+ for type in ancestors2
+ append (patch type))))
+ (parents
+ (when (member type1 ancestors2 :test #'eq)
+ (or (gethash type2 cache)
+ (setf (gethash type2 cache)
+ (minimize (link ancestors2)))))))
+ (loop
+ with ancestors
+ = (remove-duplicates (ancestors sps2) :test #'string=)
+ for parent in parents
+ for predicate = (sps-predicate parent)
+ unless (member predicate ancestors :test #'string=)
+ do
+ (format
+ t "embed-semi(): ~a < ~a.~%"
+ (sps-predicate sps2) predicate)
+ (push predicate (sps-parents sps2))))))
+ (loop
+ for sps1 being each hash-value in (semi-predicates semi)
+ when (and (sps-type sps1)
#+:null
+ (member :entity (sps-flags sps1) :test #'eq)) do
(loop
+ for sps2 being each hash-value in (semi-predicates semi)
+ when (and (sps-type sps2)
+ (not (eq sps1 sps2))
+ (member :entity (sps-flags sps2) :test #'eq))
+ do (embed sps1 sps2)))
+ ;;
+ ;; the above can result in ‘redundant’ parent links, e.g. ‘_at_p_temp’
+ ;; ending up with both ‘_at_p’ and ‘unspec_loc’, where the latter is the
+ ;; parent of ‘_at_p’ already. given we are not imposing any ordering
+ ;; constraints on the embedding (currently) such redundancy needs to be
+ ;; eliminated after the fact ...
+ ;;
+ (loop
+ for sps being each hash-value in (semi-predicates semi)
+ for parents = (loop
+ for parent in (sps-parents sps)
+ collect (lookup-predicate parent semi))
+ do
+ (setf (sps-parents sps)
+ (loop
+ for sps in (minimize parents)
+ collect (sps-predicate sps)))))))
+
+(defun finalize-semi (semi)
+ (loop
for sps being each hash-value
- using (hash-value pred) in (semi-predicates semi)
- for descendants
- = (and (lkb::is-valid-type pred) (lkb::retrieve-descendants pred))
- for ancestors
- = (and (lkb::is-valid-type pred) (lkb::retrieve-ancestors pred))
+ using (hash-key predicate) in (semi-predicates semi)
+ for parents = (sps-parents sps)
+ when (and parents (not (sps-p (first parents)))) do
+ (setf (sps-parents sps)
+ (loop
+ for name in (remove-duplicates parents :test #'string=)
+ for parent = (lookup-predicate name semi)
+ when parent
+ do (pushnew sps (sps-children parent) :test #'eq)
+ and collect parent
+ else
do
+ (format
+ t "finalize-semi(): ignoring invalid parent ‘~a’ for ‘~a’.~%"
+ name predicate))))
+ (labels ((walk (node ancestors)
(loop
- for type in descendants
- for descendant = (lkb::ltype-name type)
- for bucket = (lookup-predicate descendant semi))))
+ for ancestor in ancestors
+ do (pushnew ancestor (sps-ancestors node) :test #'eq))
+ (or (sps-descendants node)
+ (setf (sps-descendants node)
+ (append (sps-children node)
+ (loop
+ with ancestors = (cons node ancestors)
+ for child in (sps-children node)
+ append (walk child ancestors)))))))
+ (loop
+ for sps being each hash-value in (semi-predicates semi)
+ when (and (sps-children sps) (null (sps-parents sps)))
+ do (setf (sps-descendants sps) (walk sps nil))))
+ (loop
+ for sps being each hash-value in (semi-predicates semi)
+ do
+ (setf (sps-descendants sps)
+ (sort
+ (sps-descendants sps)
+ #'< :key #'(lambda (sps) (length (sps-descendants sps)))))))
(defun test-semi-compliance (mrs
&optional semi
@@ -210,7 +469,8 @@
(unless (semi-p semi)
(setf semi
(loop for foo in *semis* when (eq (semi-name foo) semi) return foo))))
- (unless (semi-p semi) (return-from test-semi-compliance))
+ (unless (and (semi-p semi) (mrs::psoa-p mrs))
+ (return-from test-semi-compliance))
(labels ((test-ep (ep)
(let* ((pred (mrs:rel-pred ep))
@@ -272,10 +532,16 @@
(test-ep ep))
collect ep)))
-(defun construct-semi (&key ids semi (rules t)
+(defun construct-semi (&key (ids t) semi (rules t) patches
+ embedp descendp finalizep
(warn '(:collision)) (stream t))
- (let ((semi (or semi (make-semi)))
- (ids (or ids (lkb::collect-psort-ids lkb::*lexicon*))))
+ (let* ((semi (or semi (make-semi)))
+ (ids (if (eq ids t) (lkb::collect-psort-ids lkb::*lexicon*) ids))
+ (%semi-patches% (if patches
+ (with-open-file (stream patches)
+ (let ((*package* (find-package :lkb)))
+ (read stream)))
+ %semi-patches%)))
(loop
for id in ids
for le = (lkb::get-lex-entry-from-id id :cache nil)
@@ -320,12 +586,28 @@
stream "construct-semi(): predicate collision for ‘~(~a~)’.~%"
predicate))))
;;
- ;; finally, construct `generalized synopses' (i.e. folding multiple frames
+ ;; now, construct `generalized synopses' (i.e. folding multiple frames
;; into one, where possible using optionality and type underspecification).
;;
(loop
for sps being each hash-value in (semi-predicates semi)
do (generalize-sps sps))
+ ;;
+ ;; connect the SEM-I Predicate Structures to the grammar-internal type
+ ;; hierarchy; when requested, descend into sub-types; add parent links
+ ;; among SEM-I entries according to the type hierarchy; and expand parent
+ ;; links into inverse children and transitive ancestor and descendant
+ ;; links.
+ ;;
+ (anchor-semi semi)
+ (when descendp
+ (loop
+ for sps being each hash-value in (semi-predicates semi)
+ when (and (find :entity (sps-flags sps))
+ (not (patches-blocked-p (sps-predicate sps))))
+ do (sps-descend semi sps)))
+ (when embedp (embed-semi semi))
+ (when finalizep (finalize-semi semi))
semi))
(defun predicate-alias (predicate)
@@ -334,7 +616,7 @@
(alias (subseq string 0 n)))
(unless (string= predicate alias) alias)))
-(defun record-le (semi id le)
+(defun record-le (semi id le &key (flags '(:entity)))
(let* ((tdfs (lkb::lex-entry-full-fs le))
(dag (lkb::tdfs-indef tdfs))
(type (lkb::type-of-fs dag))
@@ -384,11 +666,13 @@
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)))
+ (setf (lookup-predicate pred semi)
+ (make-sps :predicate pred)))
for spe = (make-spe
:id id :stem stem :forms forms
:type type :ep ep :index i :mrs mrs)
do
+ (setf (sps-flags sps) (union (sps-flags sps) flags :test #'equal))
;;
;; _fix_me_
;; for the current ERG, subjects to verbs are [OPT bool]. fix
@@ -395,7 +679,6 @@
;; this up here, so we get a more conventional looking SEM-I, but
;; really this should be adjusted in the grammar proper.
;; (27-jan-06; oe)
- #+:logon
(let ((arg1 (mrs::vsym "ARG1"))
(pred (string pred)))
(when (search "_v_" pred)
@@ -415,7 +698,7 @@
(setf (ges-spes ges) (nreverse (ges-spes ges)))
(setf (gethash id (semi-ges semi)) ges)))))
-(defun record-rule (semi id &optional rule)
+(defun record-rule (semi id &optional rule &key (flags '(:entity)))
(let* ((rule (or rule
(gethash id lkb::*rules*)
(gethash id lkb::*lexical-rules*)))
@@ -462,10 +745,12 @@
for pred = (ep-pred ep)
for alias = (predicate-alias pred)
for sps = (or (lookup-predicate pred semi)
- (setf (lookup-predicate pred semi) (make-sps)))
+ (setf (lookup-predicate pred semi)
+ (make-sps :predicate pred)))
for spe = (make-spe
:id id :type type :ep ep :index i :mrs mrs)
do
+ (setf (sps-flags sps) (union (sps-flags sps) flags :test #'equal))
(push spe (sps-spes sps))
(push spe (ges-spes ges))
(when alias (setf (lookup-alias alias semi) sps))
@@ -473,12 +758,54 @@
(setf (ges-spes ges) (nreverse (ges-spes ges)))
(setf (gethash id (semi-ges semi)) ges)))))
+(defun sps-descend (semi sps &optional (top sps) (type (sps-type sps)))
+ #+:lkb
+ (loop
+ for descendant in (and type (lkb::ltype-descendants type))
+ for predicate = (if mrs:*normalize-predicates-p*
+ (mrs:normalize-predicate (lkb::ltype-name descendant))
+ (lkb::ltype-name descendant))
+ for old = (lookup-predicate predicate semi)
+ for new = (unless (or (glbp predicate)
+ (patches-blocked-p predicate)
+ (when old
+ (member
+ (sps-predicate sps) (sps-parents old)
+ :test #'string=)))
+ (or old
+ (setf (lookup-predicate predicate semi)
+ (make-sps
+ :predicate predicate :synopses (sps-synopses sps)
+ :flags (acons :descend (list top) nil)))))
+ when new do
+ #-:debug
+ (format
+ t "sps-descend(): ~a > ~a.~%"
+ (sps-predicate sps) predicate)
+ (anchor-sps semi new)
+ (push (sps-predicate sps) (sps-parents new))
+ (when old
+ (loop
+ for flag in (sps-flags old)
+ when (and (consp flag) (eq (first flag) :descend))
+ do (push top (rest flag))))
+ do (sps-descend semi (or new sps) top (unless new descendant))))
+
(defun record-mrs (semi mrs)
(declare (ignore semi mrs)))
(defun print-semi (&optional (semi (first *semis*))
- &key (format :concise) (stream t))
- (labels ((print-roles (ep stream)
+ &key (format :concise) (predicates nil predicatesp)
+ filter (stream t))
+
+ (if (stringp stream)
+ (with-open-file (stream stream :direction :output :if-exists :supersede)
+ (print-semi semi :format format :filter filter :stream stream))
+ (labels ((print-predicate (predicate stream)
+ (if mrs::*normalize-predicates-p*
+ (format stream " ~(~a~) " predicate)
+ (format stream " ~(~s~) " predicate)))
+ (print-roles (ep stream)
(loop
with last = (first (last (ep-roles ep)))
for role in (ep-roles ep)
@@ -524,9 +851,10 @@
(eq tag (first (first forms))) tag strings))
(when bracketp (format stream "]")))))
(let* ((predicates
+ (or predicates
(loop
for pred being each hash-key in (semi-predicates semi)
- collect pred))
+ collect pred)))
(predicates (sort predicates #'string<)))
(format stream "predicates:~%~%")
(loop
@@ -541,7 +869,8 @@
for index = (spe-index spe)
for stem = (spe-stem spe)
do
- (format stream " ~(~s~) : " pred)
+ (print-predicate pred stream)
+ (format stream ": ")
(print-roles (spe-ep spe) stream)
(format
stream
@@ -550,18 +879,49 @@
#+:null
(print-forms (spe-forms spe) stream t)
(format stream "~%"))
- when (eq format :compact) do
+ when (and (eq format :compact)
+ (or (null filter) (ppcre:scan filter pred)))
+ do
(loop
with *package* = (find-package :lkb)
- for synopsis in (sps-synopses sps) do
- (format stream " ~(~s~) : " pred)
+ with parents = (sps-parents sps)
+ for synopsis in (sps-synopses sps)
+ do
+ (print-predicate pred stream)
+ #+:null
+ (when parents
+ (loop
+ initially (format stream "< ")
+ with last = (first (last parents))
+ for parent in parents
+ do
+ (format
+ stream "~(~a~)~:[ & ~;~]"
+ (sps-predicate parent) (eq parent last)))
+ (format stream " "))
+ (format stream ": ")
(print-roles synopsis stream)
(format stream "~%"))
when (eq format :forms) do
(let ((*package* (find-package :lkb)))
- (format stream " ~(~s~) : " pred)
+ (print-predicate pred stream)
+ (format stream ": ")
(print-forms (sps-forms sps) stream)
- (format stream "~%"))))))
+ (format stream "~%"))
+ when (eq format :hierarchy) do
+ (let ((parents (sps-parents sps)))
+ (when (or parents predicatesp)
+ (print-predicate pred stream)
+ (when parents
+ (loop
+ initially (format stream "< ")
+ with last = (first (last parents))
+ for parent in parents
+ do
+ (format
+ stream "~(~a~)~:[ & ~;~]"
+ (sps-predicate parent) (eq parent last))))
+ (format stream ".~%"))))))))
(defun generalize-types (type1 type2)
(or
@@ -719,10 +1079,8 @@
(return ep))))
(defun generalize-sps (sps)
- (setf (sps-type sps) :object)
(loop
for spe in (sps-spes sps)
- for mrs = (spe-mrs spe)
for ep1 = (spe-ep spe)
for synopses
= (list (generalize-ep ep1))
@@ -735,8 +1093,6 @@
else collect ep2 into result
finally
(return (nconc result (list (generalize-ep ep1)))))
- when (and (mrs-p mrs) (rest (mrs-eps mrs)))
- do (setf (sps-type sps) :meta)
finally (setf (sps-synopses sps) synopses))
(loop
for spe in (sps-spes sps)
@@ -754,29 +1110,52 @@
finally (setf (sps-forms sps) (nreverse (sps-forms sps)))))
sps)
+(defun semi-compare-predicates (predicate1 predicate2
+ &key (type :subsumption)
+ (semi (first *semis*)))
+ (or
+ (when (eq predicate1 predicate2) predicate1)
+ (when (and (stringp predicate1) (stringp predicate2)
+ (string= predicate1 predicate2))
+ predicate1)
+ (when (or (eq type :subsumption) (eq type :unification))
+ (let ((sps1 (semi-lookup
+ :semi semi :predicate predicate1
+ :alias (unless mrs::*normalize-predicates-p* predicate1)))
+ (sps2 (semi-lookup
+ :semi semi :predicate predicate2
+ :alias (unless mrs::*normalize-predicates-p* predicate2))))
+ (when (and sps1 sps2)
+ (or
+ (first (member sps1 (sps-descendants sps2) :test #'eq))
+ (when (eq type :unification)
+ (or
+ (first (member sps2 (sps-descendants sps1) :test #'eq))
+ (first (intersection
+ (sps-descendants sps1) (sps-descendants sps2)
+ :test #'eq))))))))))
-;;; added by AAC - called from rmrs-convert.lisp - added here because
-;;; I don't want to add yet another file to lkb.system or mess around
-;;; with the file ordering there.
-;;; takes a string and tries to look it up in the SEMI
-;;; could no doubt be improved by better understanding of the code
-
-(defun find-semi-entries (pred)
-;;; code adapted from test-semi-compliance
- (unless *semis* (error "Semis not initialised"))
- (let* ((semi (first *semis*))
- (pred-symbol (mrs::vsym (string-upcase pred))))
- (if
- (or
-;;; (eql pred-symbol 'lkb::def_or_a_or_udef_q_rel)
-;;; we get errors if we let through a symbol which isn't in the SEM-I
- (member pred-symbol *semi-fragment-relations* :test #'eq)
- (member
- pred-symbol
- *semi-punctuation-relations* :test #'eq)
- (member pred-symbol *semi-token-relations* :test #'eq)
- (lookup-predicate pred-symbol semi))
- pred-symbol
- (if (lookup-predicate pred semi)
- pred
- nil))))
+(defun semi-compatible-predicates (predicate &key (semi (first *semis*)))
+ ;;
+ ;; determine ‘compatible’ predicates for use in generation: all predicates
+ ;; that can unify with .predicate. (i.e. subsume it, are subsumbed by it, or
+ ;; have at least one descendant in common with it) need to be considered for
+ ;; initialization of the generator chart.
+ ;;
+ (let ((sps (lookup-predicate predicate semi)))
+ (when sps
+ (or (sps-compatible sps)
+ (setf (sps-compatible sps)
+ (let ((result (list sps)))
+ (loop
+ for descendant in (sps-descendants sps)
+ do
+ (pushnew descendant result :test #'eq)
+ (loop
+ for ancestor in (sps-ancestors descendant)
+ do (pushnew ancestor result :test #'eq)))
+ (loop
+ for ancestor in (sps-ancestors sps)
+ do (pushnew ancestor result :test #'eq))
+ (loop
+ for sps in result collect (sps-predicate sps))))))))
Index: src/mt/vpm.lisp
===================================================================
--- src/mt/vpm.lisp (revision 24124)
+++ src/mt/vpm.lisp (working copy)
@@ -186,6 +186,9 @@
(setf (mrs:psoa-liszt copy)
(loop
for ep in (mrs:psoa-liszt mrs)
+ for pred = (if mrs::*normalize-predicates-p*
+ (mrs::normalize-predicate (mrs:rel-pred ep))
+ (mrs:rel-pred ep))
collect
(let ((handel (map-variable (mrs:rel-handel ep)))
(flist (loop
@@ -195,7 +198,7 @@
:feature (mrs:fvpair-feature role)
:value (map-variable value)))))
(mrs::make-rel
- :handel handel :pred (mrs:rel-pred ep) :flist flist
+ :handel handel :pred pred :flist flist
:lnk (mrs::rel-lnk ep)
:cfrom (mrs::rel-cfrom ep) :cto (mrs::rel-cto ep)))))
(setf (mrs:psoa-h-cons copy)
@@ -213,8 +216,7 @@
(mrs::make-icons
:relation (mrs::icons-relation icons)
:iarg1 (map-variable (mrs::icons-iarg1 icons))
- :iarg2 (map-variable (mrs::icons-iarg2 icons)))))
- )
+ :iarg2 (map-variable (mrs::icons-iarg2 icons))))))
copy))
;;;
Index: src/mt-package.lsp
===================================================================
--- src/mt-package.lsp (revision 24124)
+++ src/mt-package.lsp (working copy)
@@ -10,9 +10,11 @@
"READ-TRANSFER-RULES" "READ-TRANSFER-TYPES" "READ-VPM"
"TRANSFER-MRS" "MAP-MRS" "PARSE-INTERACTIVELY"
"FRAGMENTP" "GENERATE-FROM-FRAGMENTED-MRS"
- "*SEMIS*" "SEMI-P"
+ "*SEMIS*" "*SEMI-TEST*" "SEMI-P"
"READ-SEMI" "CONSTRUCT-SEMI" "PRINT-SEMI"
- "SEMI-LOOKUP" "TEST-SEMI-COMPLIANCE"
+ "SEMI-LOOKUP"
+ "SEMI-COMPARE-PREDICATES" "SEMI-COMPATIBLE-PREDICATES"
+ "TEST-SEMI-COMPLIANCE"
"TEST-INTEGRITY"
"UTOOL-PROCESS" "UTOOL-NET-P"))
Index: src/rmrs/rmrs-convert.lisp
===================================================================
--- src/rmrs/rmrs-convert.lisp (revision 24124)
+++ src/rmrs/rmrs-convert.lisp (working copy)
@@ -571,7 +571,8 @@
(let* ((problems nil)
(rmrs-pred (rel-pred ep))
(mrs-pred (convert-rmrs-pred-to-mrs rmrs-pred))
- (semi-pred (mt::find-semi-entries mrs-pred)))
+ (semi-pred (or (mt:semi-lookup :predicate mrs-pred)
+ (mt:semi-lookup :predicate (vsym mrs-pred)))))
(if semi-pred
(let ((new-ep
(make-rel
Index: src/systems/lkb.system
===================================================================
--- src/systems/lkb.system (revision 24124)
+++ src/systems/lkb.system (working copy)
@@ -559,6 +559,7 @@
(:file "semi")
(:file "transfer")
(:file "comparison")
+ (:file "aac")
#+:multiprocessing
(:file "translate")
#+:clim
Index: src/tsdb/lisp/derivations.lisp
===================================================================
--- src/tsdb/lisp/derivations.lisp (revision 24124)
+++ src/tsdb/lisp/derivations.lisp (working copy)
@@ -34,6 +34,8 @@
(defparameter *derivations-print-head-p* t)
+(defparameter *derivations-print-rule-type-p* nil)
+
(defparameter *derivations-print-lexical-type-p* nil)
(defparameter *derivations-print-tokens-p* t)
@@ -243,10 +245,10 @@
;;; of the structure, in which case our naive assumptions about where to find
;;; the values (made in derivation-from() and derivation-to()) will break.
;;; (2-jul-11; oe)
-(defun derivation-from (derivation &optional start)
+(defun derivation-from (derivation &optional start token)
(with-derivation (derivation derivation)
- (if (or (null start) (= (derivation-start derivation) start))
- (let* ((token (first (derivation-tokens derivation)))
+ (if (or token (null start) (= (derivation-start derivation) start))
+ (let* ((token (or token (first (derivation-tokens derivation))))
(start (and (stringp token) (search "+FROM " token)))
(from (and start (subseq token (+ start 6)))))
(when (and from (char= (char from 0) #\#))
@@ -257,12 +259,15 @@
thereis (and (derivation-id daughter)
(derivation-from daughter start))))))
-(defun derivation-to (derivation &optional end)
+(defun derivation-to (derivation &optional end token)
(with-derivation (derivation derivation)
- (if (or (null end) (= (derivation-end derivation) end))
- (let* ((token (first (last (derivation-tokens derivation))))
- (start (and (stringp token) (search "+TO \"" token))))
- (and start (parse-integer token :start (+ start 5) :junk-allowed t)))
+ (if (or token (null end) (= (derivation-end derivation) end))
+ (let* ((token (or token (first (last (derivation-tokens derivation)))))
+ (start (and (stringp token) (search "+TO \"" token)))
+ (to (and start (subseq token (+ start 4)))))
+ (when (and to (char= (char to 0) #\#))
+ (setf to (subseq to (+ (position #\= to) 1))))
+ (and to (parse-integer to :start 1 :junk-allowed t)))
(loop
for daughter in (derivation-daughters derivation)
thereis (and (derivation-id daughter)
@@ -425,25 +430,65 @@
for daughter2 in bdaughters
always (derivation-equal daughter1 daughter2 level))))))))
-(defun pprint-derivation (derivation &key (stream t) head)
- (let ((sponsor (derivation-sponsor derivation))
- (daughters (derivation-daughters derivation)))
+(defun pprint-derivation (derivation
+ &key (format :udf) (stream t) head
+ labels
+ (rulep *derivations-print-rule-type-p*)
+ (lexicalp *derivations-print-lexical-type-p*))
+ (when (null stream)
+ (return-from pprint-derivation
+ (with-output-to-string (stream)
+ (pprint-derivation
+ derivation :format format :stream stream :head head
+ :labels labels :rulep rulep lexicalp lexicalp))))
+ (when (and labels (not (hash-table-p labels)))
+ #+:lkb
+ (labels ((recurse (edge)
+ (let ((label (lkb::edge-label edge))
+ (derivation (lkb::edge-foo edge)))
+ (when (and label derivation)
+ (setf (gethash derivation labels) label))
+ (loop
+ for edge in (lkb::edge-children edge)
+ do (recurse edge)))))
+ (setf labels (make-hash-table :test #'eq))
+ (let ((edge (reconstruct derivation :word)))
+ (label-edge edge)
+ (when edge (recurse edge))))
+ #-:lkb
+ (setf labels nil))
+ (let ((*derivations-print-rule-type-p* rulep)
+ (*derivations-print-lexical-type-p* lexicalp)
+ (sponsor (derivation-sponsor derivation))
+ (daughters (derivation-daughters derivation))
+ (prefix (case format (:udf "(") (:json "{")))
+ (suffix (case format (:udf ")") (:json "}")))
+ (*package* (find-package :tsdb))
+ (*print-length* nil)
+ (*print-level* nil))
(cond
- (sponsor
- (pprint-logical-block (stream derivation :prefix "(" :suffix ")")
+ ((and sponsor (not (eq format :json)))
+ (case format
+ (:udf
+ (pprint-logical-block (stream derivation :prefix prefix :suffix suffix)
(write sponsor :stream stream)
(write-char #\space stream)
(pprint-newline :fill stream)
- (pprint-derivation (first (rest derivation)) :stream stream)))
+ (pprint-derivation
+ (first (rest derivation))
+ :format format :stream stream :labels labels)))))
(daughters
- (pprint-logical-block (stream derivation :prefix "(" :suffix ")")
+ (pprint-logical-block (stream derivation :prefix prefix :suffix suffix)
(let ((id (derivation-id derivation))
(root (derivation-root derivation))
(score (derivation-score derivation))
(start (derivation-start derivation))
- (end (derivation-end derivation)))
+ (end (derivation-end derivation))
+ (label (and labels (gethash derivation labels))))
(when id
+ (when (eq format :json) (write-string "\"id\": " stream))
(write id :stream stream)
+ (when (eq format :json) (write-char #\, stream))
(write-char #\space stream))
(cond
((null (derivation-daughters (first daughters)))
@@ -450,38 +495,122 @@
(let ((*print-case* :downcase)
(type (when *derivations-print-lexical-type-p*
(type-of-lexical-entry root :tsdb))))
- (write root :stream stream)
+ (case format
+ (:udf
+ (write root :stream stream))
+ (:json
+ (write-string "\"entity\": " stream)
+ (write (string-downcase root) :stream stream)))
(when type
+ (case format
+ (:udf
(write-char #\@ stream)
- (write type :stream stream))))
+ (write type :stream stream))
+ (:json
+ (write-string ", \"type\": " stream)
+ (write (string-downcase type) :stream stream))))
+ (when label
+ (write-string ", \"label\": " stream)
+ (write label :stream stream))))
(t
+ (case format
+ (:udf
(when head (write-char #\^ stream))
- (write root :stream stream)))
+ (write root :stream stream))
+ (:json
+ (write-string "\"entity\": " stream)
+ (write (string-downcase root) :stream stream)
+ (let ((type (and rulep (type-of-rule root))))
+ (when type
+ (write-string ", \"type\": " stream)
+ (write (string-downcase type) :stream stream)))
+ (when label
+ (write-string ", \"label\": " stream)
+ (write label :stream stream))))))
+ (when (eq format :json) (write-char #\, stream))
(write-char #\space stream)
+ (case format
+ (:udf
(loop
for foo in (list score start end)
when foo do
(write foo :stream stream)
- (write-char #\space stream))
+ (write-char #\space stream)))
+ (:json
+ (when score
+ (write-string "\"score\": " stream)
+ (write score :stream stream)
+ (write-char #\, stream)
+ (write-char #\space stream))))
+ (when (and (eq format :json)
+ (not (null (derivation-daughters (first daughters)))))
+ (write-string "\"daughters\": [" stream))
(loop
with head = (when (and *derivations-print-head-p*
- (rest (derivation-daughters derivation)))
+ (rest daughters))
(let ((root (intern root :tsdb)))
(get-field
:head (rest (assoc root *derivation-heads*)))))
+ with last = (first (last daughters))
for i from 0
- for daughter in (derivation-daughters derivation)
+ for daughter in daughters
do
(pprint-newline :fill stream)
(pprint-derivation
- daughter :stream stream :head (eql i head))))))
+ daughter :format format
+ :stream stream :head (eql i head) :labels labels)
+ (when (and (eq format :json) (not (eq daughter last)))
+ (write-char #\, stream)))
+ (when (and (eq format :json)
+ (not (null (derivation-daughters (first daughters)))))
+ (write-char #\] stream)))))
(t
(if *derivations-print-tokens-p*
- (write derivation :stream stream)
+ (case format
+ (:udf
+ (write derivation :stream stream))
+ (:json
+ (write-string "\"form\": " stream)
+ (write (first derivation) :stream stream)
+ (let ((from (derivation-from derivation))
+ (to (derivation-to derivation)))
+ (when (and from to)
+ (write-string ", \"from\": " stream)
+ (write from :stream stream)
+ (write-string ", \"to\": " stream)
+ (write to :stream stream)))
+ (write-string ", \"tokens\": [" stream)
+ (pprint-newline :fill stream)
+ (loop
+ with tokens = (rest derivation)
+ with last = (first (last tokens))
+ for id = (pop tokens)
+ for tfs = (pop tokens)
+ for from = (derivation-from nil nil tfs)
+ for to = (derivation-to nil nil tfs)
+ while (and id (stringp tfs))
+ do
+ (pprint-logical-block (stream derivation
+ :prefix prefix :suffix suffix)
+ (write-string "\"id\": " stream)
+ (write id :stream stream)
+ (when (and from to)
+ (write-string ", \"from\": " stream)
+ (write from :stream stream)
+ (write-string ", \"to\": " stream)
+ (write to :stream stream))
+ (write-string ", \"tfs\": " stream)
+ (write tfs :stream stream))
+ (unless (eq tfs last)
+ (write-string ", ")
+ (pprint-newline :fill stream)))
+ (write-char #\] stream)))
+ (case format
+ (:udf
(let ((form (first derivation)))
(write-char #\( stream)
(write form :stream stream)
- (write-char #\) stream)))))))
+ (write-char #\) stream)))))))))
(defun parseval (derivation gderivation &key log)
(declare (ignore log))
@@ -773,9 +902,12 @@
(throw :fail
(values
nil (list derivation result failure))))))))))))
- (when (and *reconstruct-cache* edge)
+ (when edge
+ (when *reconstruct-cache*
(push edge (gethash id *reconstruct-cache*)))
#+:lkb
+ (setf (lkb::edge-foo edge) derivation)
+ #+:lkb
(when topp
(let* ((sponsor (derivation-sponsor derivation))
(sponsor (and sponsor (intern sponsor lkb::*lkb-package*))))
@@ -787,7 +919,7 @@
(format nil "`~a'" sponsor))))))
(when (null (lkb::edge-string edge))
(setf (lkb::edge-string edge)
- (format nil "~{~(~a~)~^ ~}" (lkb::edge-leaves edge)))))
+ (format nil "~{~(~a~)~^ ~}" (lkb::edge-leaves edge))))))
edge))
(defstruct node
Index: src/tsdb/lisp/features.lisp
===================================================================
--- src/tsdb/lisp/features.lisp (revision 24124)
+++ src/tsdb/lisp/features.lisp (working copy)
@@ -963,28 +963,42 @@
finally (return features)))
(defun mrs-to-dependencies (mrs)
- (let* ((eds (mrs::ed-convert-psoa mrs))
+ (let* ((eds (mrs:eds-convert-psoa mrs))
(relations (and eds (mrs::eds-relations eds))))
(loop for rel in relations
for pred = (intern (mrs::ed-predicate rel) 'lkb)
for args = (mrs::ed-arguments rel)
- for arg-list = (loop for arg in args
+ for arg-list
+ = (loop for arg in args
collect (list (intern (car arg) 'lkb)
(intern (if (stringp (cdr arg))
(cdr arg)
(mrs::ed-predicate (cdr arg))) 'lkb)))
- collect (make-feature :tid 20 :parameters (list 0)
+ collect
+ (make-feature
+ :tid 20 :parameters (list 0)
:symbol `(0 ,pred
- ,@(loop for arg in arg-list
+ ,@(loop
+ for arg in arg-list
append (list (first arg) (second arg)))))
- append (loop for arg in arg-list
- collect (make-feature :tid 21 :parameters (list 0)
+ append
+ (loop
+ for arg in arg-list
+ collect
+ (make-feature
+ :tid 21 :parameters (list 0)
:symbol `(0 ,pred ,(first arg) ,(second arg))))
- collect (make-feature :tid 22 :parameters (list 0)
- :symbol `(0 ,pred ,@(loop for arg in arg-list
+ collect
+ (make-feature
+ :tid 22 :parameters (list 0)
+ :symbol `(0 ,pred ,@(loop
+ for arg in arg-list
collect (second arg))))
- append (loop for arg in arg-list
- collect (make-feature :tid 23 :parameters (list 0)
+ append
+ (loop
+ for arg in arg-list
+ collect (make-feature
+ :tid 23 :parameters (list 0)
:symbol `(0 ,pred ,(second arg)))))))
(defun result-to-flags (result)
Index: src/tsdb/lisp/filter.lisp
===================================================================
--- src/tsdb/lisp/filter.lisp (revision 24124)
+++ src/tsdb/lisp/filter.lisp (working copy)
@@ -82,11 +82,11 @@
when (and (null mrs) edge)
do
(setf mrs (mrs::extract-mrs edge))
- (when (mrs::psoa-p mrs) (nconc result (acons :mrs mrs nil)))
+ (when (mrs:psoa-p mrs) (nconc result (acons :mrs mrs nil)))
when (and (stringp mrs) (string= mrs "") edge)
do
(setf mrs (mrs::extract-mrs edge))
- (when (mrs::psoa-p mrs) (setf (get-field :mrs result) mrs))
+ (when (mrs:psoa-p mrs) (setf (get-field :mrs result) mrs))
when (stringp mrs)
do
(setf (get-field :mrs result) (mrs::read-mrs-from-string mrs)))
@@ -119,10 +119,10 @@
for role in (mrs:rel-flist ep)
for value = (mrs:fvpair-value role)
when (or (null value)
- (and (mrs::var-p value)
+ (and (mrs:var-p value)
(null (mrs:var-type value))))
do (pushnew ep nulls)
- else when (mrs::var-p value) do
+ else when (mrs:var-p value) do
(loop
for extra in (mrs:var-extra value)
when (null (mrs::extrapair-value extra))
@@ -135,7 +135,7 @@
"dubious ~{`~(~a~)'~^, ~}"
(loop
for null in nulls
- when (mrs::var-p null)
+ when (mrs:var-p null)
collect (mrs::var-string null)
else when (mrs::rel-p null)
collect (mrs:rel-pred null)))
@@ -166,7 +166,7 @@
(push
(list :cscope output)
(gethash id flags)))))
- (unless (mrs::psoa-p result)
+ (unless (mrs:psoa-p result)
(push
(list :cscope "no cheap scope")
(gethash id flags)))
@@ -286,8 +286,8 @@
for result in (get-field :results item)
for id = (get-field :result-id result)
for mrs = (get-field :mrs result)
- for eds = (mrs::ed-convert-psoa mrs)
- when (mrs::ed-fragmented-p eds)
+ for eds = (mrs:eds-convert-psoa mrs)
+ when (mrs:eds-fragmented-p eds)
do
(let* ((fragments
(loop
@@ -302,8 +302,8 @@
for result in (get-field :results item)
for id = (get-field :result-id result)
for mrs = (get-field :mrs result)
- for eds = (mrs::ed-convert-psoa mrs)
- when (mrs::ed-cyclic-p eds)
+ for eds = (mrs:eds-convert-psoa mrs)
+ when (mrs:eds-cyclic-p eds)
do
(push (list :cycle "circular EDS") (gethash id flags))))
#+:mrs
@@ -346,10 +346,15 @@
(unknown
(loop for foo in invalid collect (mrs::rel-pred foo)))
(output
+ (if mrs:*normalize-predicates-p*
(format
nil
+ "~@[invalid SEM-I predicates: ~{|~(~a~)|~^, ~}~]"
+ unknown)
+ (format
+ nil
"~@[invalid SEM-I predicates: ~{|~(~s~)|~^, ~}~]"
- unknown)))
+ unknown))))
(push (list :semi output) (gethash id flags)))))
(when (or (and verbose (not (zerop (hash-table-count flags))))
Index: src/tsdb/lisp/import.lisp
===================================================================
--- src/tsdb/lisp/import.lisp (revision 24124)
+++ src/tsdb/lisp/import.lisp (working copy)
@@ -258,6 +258,15 @@
:comment comment :shift shift
:separator separator :pseparator pseparator
:encoding encoding :meter rmeter))
+ (:lisp
+ (loop
+ with items = (with-open-file (stream file) (read stream))
+ with appendix
+ = (pairlis '(:i-origin :i-register :i-difficulty :i-comment)
+ (list origin register difficulty comment))
+ for item in items
+ do (nconc item appendix)
+ finally (return items)))
(:ptb
(read-items-from-ptb-directory file :base base))
(:conll
Index: src/tsdb/lisp/lkb-interface.lisp
===================================================================
--- src/tsdb/lisp/lkb-interface.lisp (revision 24124)
+++ src/tsdb/lisp/lkb-interface.lisp (working copy)
@@ -1243,6 +1243,22 @@
nil)
(values status %failure%))))
+(defun tsdb::type-of-rule (name &optional (package *lkb-package*))
+ (let* ((rule (tsdb::find-rule name))
+ (type (and rule (indef-type-of-tdfs (rule-full-fs rule)))))
+ (when type
+ (intern type package))))
+
+(defun tsdb::label-edge (edge)
+ (labels ((recurse (edge node)
+ (when (and edge node)
+ (setf (edge-label edge) (get-string-for-edge node))
+ (loop
+ for edge in (edge-children edge)
+ for node in (get node 'daughters)
+ do (recurse edge node)))))
+ (recurse edge (make-new-parse-tree edge 1 t))))
+
;;;
;;; RMRS comparison
;;;
Index: src/tsdb/lisp/pvm.lisp
===================================================================
--- src/tsdb/lisp/pvm.lisp (revision 24124)
+++ src/tsdb/lisp/pvm.lisp (working copy)
@@ -375,6 +375,10 @@
result-id
(wait 5))
+ (when (or (null item) (and (stringp item) (string= item "")))
+ (return-from pvm-process
+ (pairlis '(:i-id :parse-id :i-input :readings)
+ (list i-id parse-id "" -1))))
;;
;; zero out :edge or :tree fields, if any, since they are not remote readable
;;
@@ -384,7 +388,11 @@
for edge = (assoc :edge result)
for tree = (assoc :tree result)
when edge do (setf (rest edge) nil)
- when (and nil tree) do (setf (rest tree) nil)))
+ when (and nil tree) do (setf (rest tree) nil))
+ (let ((input (get-field :i-input item)))
+ (when (or (null input) (and (stringp input) (string= input "")))
+ (return-from pvm-process
+ (acons :readings -1 item)))))
(let* ((item (if (stringp item)
(pairlis '(:i-id :parse-id :i-input)
Index: src/tsdb/lisp/redwoods.lisp
===================================================================
--- src/tsdb/lisp/redwoods.lisp (revision 24124)
+++ src/tsdb/lisp/redwoods.lisp (working copy)
@@ -85,9 +85,7 @@
(stream *tsdb-io*)
(runp t) interrupt meter)
- (declare
- #-:logon (ignore external)
- (optimize (speed 3) (safety 0) (space 0)))
+ (declare (optimize (speed 3) (safety 0) (space 0)))
(initialize-tsdb)
@@ -153,7 +151,6 @@
(status :text message)
(meter :value 0))
- #+:logon
(when (and (eq lkb::*tree-discriminants-mode* :external) external)
(let* ((file (format
nil "~a/.redwoods.~a.~a.log"
@@ -1798,39 +1795,38 @@
(when (or (eq *redwoods-export-values* :all)
(smember :eds *redwoods-export-values*)
(smember :dependencies *redwoods-export-values*))
- (ignore-errors (mrs::ed-output-psoa mrs :stream out)))
- (when (or (eq *redwoods-export-values* :all)
- (smember :triples *redwoods-export-values*))
+ (ignore-errors (mrs::eds-output-psoa mrs :stream out)))
+ (when (smember :amr *redwoods-export-values*)
(ignore-errors
- (mrs::ed-output-psoa
- mrs :format :triples :cargp nil :markp nil :lnkp nil
+ (mrs::eds-output-psoa mrs :format :amr :stream out)))
+ (when (smember :triples *redwoods-export-values*)
+ (ignore-errors
+ (mrs::eds-output-psoa
+ mrs :format :triples :cargp nil :sentinelp nil :lnkp nil
:collocationp t :abstractp t :stream out)))
- (when (or (eq *redwoods-export-values* :all)
- (smember :mtriples *redwoods-export-values*))
+ (when (smember :mtriples *redwoods-export-values*)
(ignore-errors
- (mrs::ed-output-psoa
- mrs :format :triples :cargp nil :markp t :lnkp nil
+ (mrs::eds-output-psoa
+ mrs :format :triples :cargp nil :sentinelp t :lnkp nil
:collocationp t :abstractp t :stream out)))
- (when (or (eq *redwoods-export-values* :all)
- (smember :ltriples *redwoods-export-values*))
+ (when (smember :ltriples *redwoods-export-values*)
(ignore-errors
- (mrs::ed-output-psoa
- mrs :format :triples :cargp t :markp nil :lnkp t
+ (mrs::eds-output-psoa
+ mrs :format :triples :cargp t :sentinelp nil :lnkp t
:collocationp nil :abstractp nil :stream out)))
- (when (or (eq *redwoods-export-values* :all)
- (smember :striples *redwoods-export-values*))
+ (when (smember :striples *redwoods-export-values*)
(ignore-errors
- (mrs::ed-output-psoa
- mrs :format :triples :cargp t :markp nil :lnkp t :propertyp nil
+ (mrs::eds-output-psoa
+ mrs :format :triples :cargp t
+ :sentinelp nil :lnkp t :propertiesp nil
:collocationp nil :abstractp nil :sortp t :stream out)))
- (when (or (eq *redwoods-export-values* :all)
- (smember :dtriples *redwoods-export-values*))
+ (when (smember :dtriples *redwoods-export-values*)
(ignore-errors
- (mrs::ed-output-psoa
- mrs :format :triples :cargp t :markp nil :lnkp t :propertyp nil
+ (mrs::eds-output-psoa
+ mrs :format :triples :cargp t
+ :sentinelp nil :lnkp t :propertiesp nil
:collocationp nil :abstractp nil :sortp t :dmrsp t :stream out)))
- (when (or (eq *redwoods-export-values* :all)
- (smember :dmrx *redwoods-export-values*))
+ (when (smember :dmrx *redwoods-export-values*)
(ignore-errors
(mrs::output-dmrs1
(mrs::rmrs-to-dmrs (mrs::mrs-to-rmrs mrs))
@@ -4173,7 +4169,7 @@
with *phenomena* = nil
with *statistics-aggregate-dimension* = :phenomena
with *statistics-all-rejections-p* = t
- with *tsdb-home* = (logon-directory "lingo/terg/tsdb/gold" :string)
+ with *tsdb-home* = (logon-directory "lingo/erg/tsdb/gold" :string)
initially
(purge-profile-cache :all)
(when (probe-file "/tmp/redwoods.csv") (delete-file "/tmp/redwoods.csv"))
@@ -4183,8 +4179,8 @@
#|
for i in 00 01 02 03 04 05 06 07 08 09 10 11 12 13 14 15 16 17 18 19 20 21; do
- mkdir wsj${i}.1;
- for j in wsj${i}?.1; do echo '"'$j'"'; done > wsj${i}.1/virtual;
+ mkdir wsj${i};
+ for j in wsj${i}?; do echo '"'$j'"'; done > wsj${i}/virtual;
done
|#
@@ -4193,11 +4189,11 @@
with *phenomena* = nil
with *statistics-aggregate-dimension* = :phenomena
with *statistics-all-rejections-p* = t
- with *tsdb-home* = (logon-directory "coli/deepbank/tsdb/home" :string)
+ with *tsdb-home* = (logon-directory "lingo/erg/tsdb/gold" :string)
initially
(purge-profile-cache :all)
(when (probe-file "/tmp/deepbank.csv") (delete-file "/tmp/deepbank.csv"))
for name in (loop
for i from 0 to 21
- collect (format nil "wsj~2,'0d.1" i))
+ collect (format nil "wsj~2,'0d" i))
do (analyze-trees name :append "/tmp/deepbank.csv" :format :csv))
Index: src/tsdb/lisp/statistics.lisp
===================================================================
--- src/tsdb/lisp/statistics.lisp (revision 24124)
+++ src/tsdb/lisp/statistics.lisp (working copy)
@@ -572,10 +572,12 @@
(loop
for tuple in result
for comment = (get-field :comment tuple)
- for stream = (and comment (make-string-input-stream comment))
+ for stream = (when (and (stringp comment) (> (length comment) 0)
+ (char= (char comment 0) #\())
+ (make-string-input-stream comment))
for extra = (when stream
(loop
- for field = (read stream nil nil)
+ for field = (ignore-errors (read stream nil nil))
while field
collect field
finally (close stream)))
Index: src/tsdb/lisp/tsdb.lisp
===================================================================
--- src/tsdb/lisp/tsdb.lisp (revision 24124)
+++ src/tsdb/lisp/tsdb.lisp (working copy)
@@ -204,7 +204,7 @@
(setf (gethash :flags *statistics-readers*) "read-from-string")
(when (find-package :lkb)
(when (null *tsdb-trees-hook*)
- (setf *tsdb-trees-hook* "lkb::parse-tree-structure")))
+ (setf *tsdb-trees-hook* "lkb::extract-syntax-tree")))
(when (find-package :mrs)
(when (null *tsdb-semantix-hook*)
(setf *tsdb-semantix-hook* "mrs::get-mrs-string"))
Index: src/tsdb/lisp/utilities.lisp
===================================================================
--- src/tsdb/lisp/utilities.lisp (revision 24124)
+++ src/tsdb/lisp/utilities.lisp (working copy)
@@ -178,6 +178,35 @@
(subseq string (length prefix))
string))
+(defun prefix-string (string prefix &key (firstp t) escapep)
+ (loop
+ with padding = 128
+ with n = (length prefix)
+ with length = (+ (length string) padding)
+ with result = (make-array
+ (+ length n)
+ :element-type 'character :adjustable nil :fill-pointer 0)
+ initially (when firstp
+ (loop for c across prefix do (vector-push c result)))
+ for c across string
+ when (char= c #\Newline)
+ do
+ (cond
+ (escapep
+ (vector-push #\\ result)
+ (vector-push #\n result)
+ (decf padding))
+ (t
+ (vector-push c result)))
+ (when (< padding n)
+ (setf padding 128)
+ (incf length padding)
+ (setf result (adjust-array result length)))
+ (loop for c across prefix do (vector-push c result))
+ (decf padding n)
+ else do (vector-push c result)
+ finally (return result)))
+
(defun shell-escape-quotes (string)
(if (and (stringp string) (>= (length string) 1))
(let ((prefix (elt string 0)))
Index: src/tsdb/lisp/yy.lisp
===================================================================
--- src/tsdb/lisp/yy.lisp (revision 24124)
+++ src/tsdb/lisp/yy.lisp (working copy)
@@ -192,18 +192,62 @@
(or (not (smember :tags *yy-token-compare*))
(equal (get-field :tags foo) (get-field :tags bar)))))
-(defun yy-print-token (token &key (prefix "") (stream *tsdb-io*))
+(defun yy-print-token (token
+ &key (prefix "") (stream *tsdb-io*) (format :ascii))
(let* ((from (get-field :from token))
(to (get-field :to token))
(characterization
(and (numberp from) (numberp to) (<= 0 from to)
- (format nil "<~a:~a>" from to))))
+ (case format
+ (:ascii (format nil "<~a:~a>" from to))
+ (:json (format nil "\"from\": ~a, \"to\": ~a" from to))))))
+ (case format
+ (:ascii
(format
stream "~a(~a, ~a, ~a~@[, ~a~], 1, ~s~@[ ~s~], 0, ~s~@[,~{ ~s~}~])"
prefix (get-field :id token)
(get-field :start token) (get-field :end token)
characterization (get-field :form token) (get-field :surface token)
- (get-field :inflection token) (get-field :tags token))))
+ (get-field :inflection token) (get-field :tags token)))
+ (:json
+ (write-string prefix stream)
+ (pprint-logical-block (stream token :prefix "{" :suffix "}")
+ (write-string "\"id\": " stream)
+ (write (get-field :id token) :stream stream)
+ (write-string ", \"form\": " stream)
+ (write (get-field :form token) :stream stream)
+ (write-string ", \"start\": " stream)
+ (write (get-field :start token) :stream stream)
+ (write-string ", \"end\": " stream)
+ (write (get-field :end token) :stream stream)
+ (write-string ", " stream)
+ (write-string characterization stream)
+ (let (tags probabilities)
+ (loop
+ for i from 0
+ for field in (get-field :tags token)
+ when (evenp i) do (push field tags)
+ when (oddp i) do (push field probabilities))
+ (when (and tags probabilities)
+ (write-string ", " stream)
+ (pprint-newline :fill stream)
+ (write-string "\"tags\": [" stream)
+ (loop
+ with last = (first (last tags))
+ for tag in tags
+ do
+ (write tag :stream stream)
+ (unless (eq tag last) (write-string ", " stream)))
+ (write-string "], " stream)
+ (pprint-newline :fill stream)
+ (write-string "\"probabilities\": [" stream)
+ (loop
+ with last = (first (last probabilities))
+ for probability in probabilities
+ do
+ (write probability :stream stream)
+ (unless (eq probability last) (write-string ", " stream)))
+ (write-string "]" stream))))))))
(labels ((|[|-reader (stream char)
(declare (ignore char))
Index: tex/mrs.sty
===================================================================
--- tex/mrs.sty (revision 24124)
+++ tex/mrs.sty (working copy)
@@ -22,9 +22,13 @@
% two global switches, to control whether role labels and variable properties
% are included in the output or not.
%
-\newif\ifroles\rolesfalse
+\newif\ifroles\rolestrue
\newif\ifproperties\propertiestrue
+\newif\iflnk\lnktrue
+\newcommand{\rolenewline}{%
+ \ifroles\\\fi}
+
%
% used to foreground select MRS elements, e.g. predicates or variables
%
@@ -40,18 +44,16 @@
%
% a variable, e.g. \svar{e}{2}{\svp{TENSE}{past}} or \svar{h}{0}{}
%
-% \newcommand{\svar}[3]{%
-% \def\testa{}\def\testb{#3}%
-% \ensuremath{%
-% \mbox{\textsf{\textit{#1}}}_{#2}\,%
-% \ifproperties\ifx \testa\testb\else\left\lbrace#3\right\rbrace\fi\fi}}
\newcommand{\svar}[3]{%
{\fboxsep 0pt
- \def\testa{}\def\testb{#2}\def\testc{#3}%
+ \def\testa{}\def\testb{\_}\def\testc{#1}\def\testd{#2}\def\teste{#3}%
\ensuremath{%
- \mbox{\textsf{\textit{\ifmetacontext\uppercase{#1}\else #1\fi}}}%
- \ifx\testa\testb\else_{#2}\fi%
- \ifproperties\ifx\testa\testc\else\svps{#3}\fi\fi}}}
+ \mbox{\textsf{\textit{%
+ \ifmetacontext\uppercase{#1}\else%
+ \ifx\testb\testc\raisebox{-0.15ex}{\rule{1ex}{0.05ex}}%
+ \else#1\fi\fi}}}%
+ \ifx\testa\testd\else_{#2}\fi%
+ \ifproperties\ifx\testa\teste\else\svps{#3}\fi\fi}}}
\newcommand{\svps}[1]{%
\ensuremath{\lbrace\hspace{0.00ex}#1\hspace{0.00ex}\rbrace}}
@@ -139,6 +141,17 @@
\mbox{\textsf{#1}}}
%
+% various forms of surface LNKs, anchoring a predicate in the parser input
+%
+\newcommand{\slnkc}[2]{%
+ \iflnk%
+ {\def\testa{}\def\testb{#1}\def\testc{#2}%
+ \ensuremath{%
+ \left\langle%
+ \ifx\testa\testb\else#1\fi\!:\!\ifx\testa\testc\else#2\fi
+ \right\rangle}}\fi}
+
+%
% one elementary predication, see above for examples
%
\newcommand{\sep}[3]{%
@@ -193,8 +206,9 @@
\fboxsep 0pt
\ensuremath{%
\vcenter{%
+ \def\testa{}\def\testb{#1}%
\hbox{\vbox{%
- \hbox{$\langle\,$#1,}%
+ \hbox{$\langle\,$#1\ifx\testa\testb\else,\fi}%
\hbox{\phantom{$\langle\,$}%
\hskip -0.0ex%
\ensuremath{%
@@ -203,18 +217,37 @@
\end{array}}}%
\hbox{\phantom{$\langle\,$}\hskip -0.1ex\shcons{#3}$\,\rangle$}}}}}}
-\iffalse
-\newcommand{\sblock}[3]{%
+%
+% a minor variant of the above, also including the top-level INDEX, approved
+% by ann in mid-2016.
+%
+\newcommand{\siblock}[4]{%
\fboxsep 0pt
+ \ensuremath{%
+ \vcenter{%
+ \def\testa{}\def\testb{#1}\def\testc{#2}%
\hbox{\vbox{%
- \hbox{$\langle\,$#1,}%
+ \hbox{$\langle\,$#1\ifx\testa\testb\else,\fi%
+ \ifx\testa\testc\else$\,$\fi#2\ifx\testa\testc\else,\fi}%
\hbox{\phantom{$\langle\,$}%
+ \hskip -0.0ex%
\ensuremath{%
- \left|\,%
+ \begin{array}{@{}|l|@{}}%
+ #3\\
+ \end{array}}}%
+ \hbox{\phantom{$\langle\,$}\hskip -0.1ex\shcons{#4}$\,\rangle$}}}}}}
+
+\newcommand{\eds}[2]{%
+ \fboxsep 0pt
+ \ensuremath{%
+ \vcenter{%
+ \hbox{\vbox{%
+ \hbox{$\lbrace\,$#1}%
+ \hbox{\phantom{$\lbrace\,$}%
+ \hskip -0.0ex%
+ \ensuremath{%
\begin{array}{@{}l@{}}%
#2\\
- \end{array}%
- \,\right|}}%
- \hbox{\phantom{$\langle\,$}\shcons{#3}$\,\rangle$}}}}
-\fi
+ \end{array}}}%
+ \hbox{$\rbrace$}}}}}}
More information about the logon
mailing list