(in-package :mt) ;;; ;;; Copyright (c) 2006 -- 2008 Stephan Oepen (oe@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 ;;; the Free Software Foundation; either version 2.1 of the License, or (at ;;; your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, but WITHOUT ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public ;;; License for more details. ;;; (defconstant *vpm-wildcard* (mrs:vsym "*")) (defconstant *vpm-blade* (mrs:vsym "!")) (defstruct vpm id tms pms flags) (defstruct pm lhs rhs mrs) (defstruct mr left right (test :subsumption) (direction (cons t t))) (defparameter *vpms* nil) (defun read-vpm (file &optional (id :default)) (unless (probe-file file) (error "read-vpm(): unable to open `~a'" (namestring file))) (format t "~&read-vpm(): reading file `~a~@[.~a~]'.~%" (pathname-name file) (pathname-type file)) (with-open-file (stream file :direction :input) (loop with vpm = (make-vpm :id id) with pm for line = (read-line stream nil nil) while line when (or (ppcre::scan "^[ \\t]*;+" line) (ppcre:scan "^[ \\t]*$" line)) do (setf line nil) when line do (multiple-value-bind (foo bar starts ends) (ppcre::scan "^[ \\t]*([^:]+)[ \\t]*:[ \\t]*([^:]+)[ \\t]*$" line) (declare (ignore foo bar)) (when (and starts ends) (when pm (setf (pm-mrs pm) (nreverse (pm-mrs pm)))) (setf pm (make-pm)) (let ((lhs (subseq line (aref starts 0) (aref ends 0))) (rhs (subseq line (aref starts 1) (aref ends 1)))) (ppcre:do-scans (foo bar starts ends "([^ ]+)(?: |$)" lhs) (declare (ignore foo bar)) (push (mrs:vsym (subseq lhs (aref starts 0) (aref ends 0))) (pm-lhs pm))) (ppcre:do-scans (foo bar starts ends "([^ ]+)(?: |$)" rhs) (declare (ignore foo bar)) (push (mrs:vsym (subseq rhs (aref starts 0) (aref ends 0))) (pm-rhs pm)))) (setf (pm-lhs pm) (nreverse (pm-lhs pm))) (setf (pm-rhs pm) (nreverse (pm-rhs pm))) (push pm (vpm-pms vpm)) (setf line nil))) when line do (multiple-value-bind (foo bar starts ends) (ppcre::scan "^\\s*(.+)\\s*([<>=]{2,3})\\s*(.+)\\s*$" line) (declare (ignore foo bar)) (when (and starts ends) (let ((mr (make-mr)) (left (subseq line (aref starts 0) (aref ends 0))) (test (subseq line (aref starts 1) (aref ends 1))) (right (subseq line (aref starts 2) (aref ends 2)))) (setf (mr-direction mr) (if (string= test "==") (cons t t) (cons (position #\> test) (position #\< test)))) (when (position #\= test) (setf (mr-test mr) :equality)) (ppcre:do-scans (foo bar starts ends "([^ ]+)(?: |$)" left) (declare (ignore foo bar)) (let* ((match (subseq left (aref starts 0) (aref ends 0))) (n (length match))) (push (cond ((null pm) match) ((and (char= (char match 0) #\[) (char= (char match (- n 1)) #\])) (cons :type (subseq match 1 (- n 1)))) (t (mrs:vsym match))) (mr-left mr)))) (ppcre:do-scans (foo bar starts ends "([^ ]+)(?: |$)" right) (declare (ignore foo bar)) (let* ((match (subseq right (aref starts 0) (aref ends 0))) (n (length match))) (push (cond ((null pm) match) ((and (char= (char match 0) #\[) (char= (char match (- n 1)) #\])) (cons :type (subseq match 1 (- n 1)))) (t (mrs:vsym match))) (mr-right mr)))) (setf (mr-left mr) (nreverse (mr-left mr))) (setf (mr-right mr) (nreverse (mr-right mr))) (unless pm (setf (mr-left mr) (first (mr-left mr))) (setf (mr-right mr) (first (mr-right mr)))) (if pm (push mr (pm-mrs pm)) (push mr (vpm-tms vpm)))))) finally (when pm (setf (pm-mrs pm) (nreverse (pm-mrs pm)))) (setf (vpm-tms vpm) (nreverse (vpm-tms vpm))) (setf (vpm-pms vpm) (nreverse (vpm-pms vpm))) (push vpm *vpms*) (return vpm)))) (defun map-mrs (mrs vpm &optional (direction :forward) &key skolemizep preserve (copyp t)) (declare (ignore copyp)) ;; ;; _fix_me_ ;; given the various contexts to call this function, we would be better off ;; providing a destructive version too, i.e. add a :copyp &key parameter to ;; turn the initial copy on or off. (23-jun-06; oe) ;; (when (consp vpm) (setf direction (second vpm)) (setf vpm (find (first vpm) *vpms* :key #'vpm-id))) (when (symbolp vpm) (setf vpm (find vpm *vpms* :key #'vpm-id))) (when (null vpm) (return-from map-mrs mrs)) (let ((%variables%) (copy (mrs::make-psoa))) (labels ((map-variable (variable) (if (mrs::var-p variable) (or (rest (assoc variable %variables%)) (let ((copy (mrs::make-var :type (map-type (mrs:var-type variable) vpm direction) :id (mrs:var-id variable)))) (setf (mrs:var-extra copy) (map-properties (mrs:var-type variable) (mrs:var-extra variable) vpm direction)) (when preserve (loop for extra in (mrs:var-extra variable) for name = (mrs::extrapair-feature extra) when (member name preserve :test #'eq) do (push (mrs::make-extrapair :feature name :value (mrs::extrapair-value extra)) (mrs:var-extra copy)))) (when skolemizep (push (mrs::make-extrapair :feature *mtr-skolem-property* :value (mrs::var-string variable)) (mrs:var-extra copy))) (push (cons variable copy) %variables%) copy)) variable))) (setf (mrs:psoa-top-h copy) (map-variable (mrs:psoa-top-h mrs))) (setf (mrs:psoa-index copy) (map-variable (mrs:psoa-index mrs))) (setf (mrs:psoa-liszt copy) (loop for ep in (mrs:psoa-liszt mrs) collect (let ((handel (map-variable (mrs:rel-handel ep))) (flist (loop for role in (mrs:rel-flist ep) for value = (mrs:fvpair-value role) collect (mrs::make-fvpair :feature (mrs:fvpair-feature role) :value (map-variable value))))) (mrs::make-rel :handel handel :pred (mrs:rel-pred ep) :flist flist :lnk (mrs::rel-lnk ep) :cfrom (mrs::rel-cfrom ep) :cto (mrs::rel-cto ep))))) (setf (mrs:psoa-h-cons copy) (loop for hcons in (mrs:psoa-h-cons mrs) collect (mrs::make-hcons :relation (mrs:hcons-relation hcons) :scarg (map-variable (mrs:hcons-scarg hcons)) :outscpd (map-variable (mrs:hcons-outscpd hcons)))))) copy)) ;;; ;;; _fix_me_ ;;; make sure properties end up in an order compatible with the VPM itself, ;;; i.e. the order in which they were mapped. ;;; (defun map-properties (type properties vpm &optional (direction :forward)) (when (null properties) (return-from map-properties)) ;; ;; _fix_me_ ;; a special case: when there are no property mappings, in principle we might ;; opt to delete all properties, as the VPM definition states that only those ;; matched explicitly will be preserved. however, in our `dual' universe of ;; grammar-internal and SEM-I namespaces and our current half-assed approach ;; to using grammar-internal names for MTR matching, convert-dag-to-mtr() may ;; manufacture a VPM with variable type but no property mappings for creation ;; of MTRs. to make that work, treat nil property mappings as the identity ;; mapping. (23-jan-09; oe) ;; (when (null (vpm-pms vpm)) (return-from map-properties properties)) (loop with result with mapped for pm in (vpm-pms vpm) for lhs = (if (eq direction :forward) (pm-lhs pm) (pm-rhs pm)) for rhs = (if (eq direction :forward) (pm-rhs pm) (pm-lhs pm)) for values = (loop for property in lhs for match = (loop for foo in properties when (eq (mrs::extrapair-feature foo) property) return (mrs::extrapair-value foo)) collect match) do (loop for mr in (pm-mrs pm) when (test-pmr type values mr direction) do (loop for property in lhs do (pushnew property mapped :test #'eq)) (loop with right = (if (eq direction :forward) (mr-right mr) (mr-left mr)) for property in rhs for new in right do (cond ((eq new *vpm-blade*)) ((eq new *vpm-wildcard*) (let ((old (pop values))) (when old (push (mrs::make-extrapair :feature property :value old) result)))) (t (push (mrs::make-extrapair :feature property :value new) result)))) (loop-finish)) finally (return (nreverse result)))) (defun test-pmr (type values mr &optional (direction :forward)) (unless (if (eq direction :forward) (first (mr-direction mr)) (rest (mr-direction mr))) (return-from test-pmr)) (let ((left (if (eq direction :forward) (mr-left mr) (mr-right mr)))) (loop for value in values for match in left always (cond ((and (consp match) (eq (first match) :type)) (compare-types type (rest match) :type :subsumption :internp t)) ((eq match *vpm-wildcard*) value) ((eq match *vpm-blade*) (null value)) (t (case (mr-test mr) (:equality (eq value match)) (:subsumption (or (eq value match) (and (mrs::is-valid-type value) (mrs::is-valid-type match) (mrs::equal-or-subtype value match)))))))))) (defun map-type (type vpm &optional (direction :forward)) (when (consp vpm) (setf direction (second vpm)) (setf vpm (find (first vpm) *vpms* :key #'vpm-id))) (when (symbolp vpm) (setf vpm (find vpm *vpms* :key #'vpm-id))) (when (null vpm) (return-from map-type type)) ;; ;; for a transition period, until we can import the full SEM-I hierarchy and ;; use it for MRS comparison, only map variable types in :forward direction. ;; this is backwards-compatible with what the LKB used to do, in the sense ;; that comparsing MRSs post-generation will end up using MRS variable types ;; (`e', `x', et al.) but SEM-I variable properties. (22-jan-09; oe) ;; (loop for mr in (and (eq direction :forward) (vpm-tms vpm)) for left = (if (eq direction :forward) (mr-left mr) (mr-right mr)) when (and (if (eq direction :forward) (first (mr-direction mr)) (rest (mr-direction mr))) (or (eq (mrs:vsym left) *vpm-wildcard*) (compare-types type left :type (mr-test mr) :internp t))) return (let ((right (if (eq direction :forward) (mr-right mr) (mr-left mr)))) (if (eq (mrs:vsym right) *vpm-wildcard*) type right)) finally (return type)))