(in-package :mt) ;;; ;;; Copyright (c) 2004 -- 2006 Stephan Oepen (oe@csli.stanford.edu) ;;; ;;; 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. ;;; (eval-when (:compile-toplevel :load-toplevel :execute) (shadow '(variable))) ; since 'variable' is a symbol in the CL package (defstruct (mrs) top index eps hcons variables) (defstruct (ep) label pred roles) (defstruct (role) name value optionality) (defstruct (variable) type id properties external optionality) (defstruct constant value) (defstruct (property) name value) (defstruct (hcons) relation harg larg) (defstruct (icons) relation left right) ;;; ;;; make debugging with MRSs a little easier: print very compact representation ;;; of object by default; set *mrs-raw-output-p* to see things in full glory. ;;; (defparameter *mrs-raw-output-p* nil) (defmethod print-object ((object mrs) stream) (cond (*mrs-raw-output-p* (call-next-method)) (t (format stream "~a:~@[~a:~]{" (mrs-top object) (mrs-index object)) (loop for ep in (mrs-eps object) do (format stream " ~a" ep)) (format stream " }")))) (defmethod print-object ((object ep) stream) (if *mrs-raw-output-p* (call-next-method) (let ((pred (ep-pred object)) (roles (ep-roles object))) (format stream "~@[~a:~]~(~a~)(" (ep-label object) (if (stringp pred) (format nil "~s" pred) (or pred "_"))) (loop for role in roles for value = (role-value role) do (format stream "~:[ ~;~]~a" (eq role (first roles)) value)) (format stream ")")))) (defmethod print-object ((object variable) stream) (if *mrs-raw-output-p* (call-next-method) (format stream "~@[~*[~]~(~a~)~@[~d~]~@[~*]~]" (variable-optionality object) (variable-type object) (variable-id object) (variable-optionality object)))) (defmethod print-object ((object constant) stream) (if *mrs-raw-output-p* (call-next-method) (format stream "`~a'" (constant-value object)))) (defun pred= (pred1 pred2) ;; ;; the symbol vs. string distinction is, at best, technically motivated. in ;; comparing two predicates, symbol comparison will be faster, but otherwise ;; we want to consider _foo_rel and "_foo_rel" equal, nevertheless. also, ;; pred names are _not_ case sensitive, thus string-equal(). ;; (or (eq pred1 pred2) (string-equal (string pred1) (string pred2)))) (defun type= (type1 type2) (string-equal type1 type2)) (defun constant= (value1 value2) ;; ;; see comments on pred=(), only constants _are_ case-sensitive ;; (when (and (constant-p value1) (constant-p value2)) (let ((value1 (constant-value value1)) (value2 (constant-value value2))) (or (eq value1 value2) (string= (string value1) (string value2)))))) (defun copy-value (value) (cond ((variable-p value) (copy-variable value)) ((constant-p value) (copy-constant value)) (t value))) (defun clone-mrs (mrs &key skolemizep) (let ((copy (mrs::make-psoa))) (setf (mrs:psoa-top-h copy) (clone-variable (mrs:psoa-top-h mrs) :skolemizep skolemizep)) (setf (mrs:psoa-index copy) (clone-variable (mrs:psoa-index mrs) :skolemizep skolemizep)) (setf (mrs:psoa-liszt copy) (loop for ep in (mrs:psoa-liszt mrs) collect (clone-ep ep :skolemizep skolemizep))) (setf (mrs:psoa-h-cons copy) (loop for hcons in (mrs:psoa-h-cons mrs) collect (clone-hcons hcons :skolemizep skolemizep))) (setf (mrs::psoa-icons copy) (loop for icons in (mrs::psoa-icons mrs) collect (clone-icons icons :skolemizep skolemizep))) copy)) (defun clone-variable (variable &key skolemizep (cachep t)) (when variable (or (and cachep (rest (assoc variable %mrs-copy-cache%))) (let ((copy (mrs::make-var :type (mrs:var-type variable) :id (mrs:var-id variable)))) (setf (mrs:var-extra copy) (loop for extra in (mrs:var-extra variable) collect (mrs::make-extrapair :feature (mrs::extrapair-feature extra) :value (mrs::extrapair-value extra)))) (when skolemizep (push (mrs::make-extrapair :feature *mtr-skolem-property* :value (mrs::var-id variable)) (mrs:var-extra copy))) (when cachep (push (cons variable copy) %mrs-copy-cache%)) copy)))) (defun clone-ep (ep &key skolemizep) (let ((copy (mrs::make-rel :handel (clone-variable (mrs:rel-handel ep) :skolemizep skolemizep) :pred (mrs:rel-pred ep) :lnk (mrs::rel-lnk ep)))) (setf (mrs:rel-flist copy) (loop for role in (mrs:rel-flist ep) for value = (mrs:fvpair-value role) when (mrs::var-p value) collect (mrs::make-fvpair :feature (mrs:fvpair-feature role) :value (clone-variable value :skolemizep skolemizep)) else collect (mrs::make-fvpair :feature (mrs:fvpair-feature role) :value value))) copy)) (defun clone-hcons (hcons &key skolemizep) (mrs::make-hcons :relation (mrs:hcons-relation hcons) :scarg (clone-variable (mrs:hcons-scarg hcons) :skolemizep skolemizep) :outscpd (clone-variable (mrs:hcons-outscpd hcons) :skolemizep skolemizep))) (defun clone-icons (icons &key skolemizep) (mrs::make-icons :relation (mrs::icons-relation icons) :iarg1 (clone-variable (mrs::icons-iarg1 icons) :skolemizep skolemizep) :iarg2 (clone-variable (mrs::icons-iarg2 icons) :skolemizep skolemizep))) (defun import-mrs (psoa &key externals) (let* ((%mrs-construction-cache% nil) (new (make-mrs :top (import-variable (mrs:psoa-top-h psoa)) :index (import-variable (mrs:psoa-index psoa))))) (setf (mrs-eps new) (loop for ep in (mrs:psoa-liszt psoa) collect (import-ep ep))) (setf (mrs-hcons new) (loop for hcons in (mrs:psoa-h-cons psoa) collect (import-hcons hcons))) (if externals (loop for (foo . internal) in %mrs-construction-cache% for external = (first (rassoc foo externals)) do (setf (variable-external internal) external) (push internal (mrs-variables new))) (loop for (external . internal) in %mrs-construction-cache% do (setf (variable-external internal) external) (push internal (mrs-variables new)))) new)) (defun import-ep (rel) (let ((new (make-ep :label (import-variable (mrs:rel-handel rel)) :pred (import-pred (mrs:rel-pred rel))))) (setf (ep-roles new) (loop for role in (mrs:rel-flist rel) for value = (mrs:fvpair-value role) collect (make-role :name (mrs:fvpair-feature role) :value (if (mrs::var-p value) (import-variable value) (import-constant value))))) new)) (defun import-hcons (hcons) (make-hcons :relation (mrs:hcons-relation hcons) :harg (import-variable (mrs:hcons-scarg hcons)) :larg (import-variable (mrs:hcons-outscpd hcons)))) (defun import-pred (pred) pred) (defun import-variable (var) (when var (or (rest (assoc var %mrs-construction-cache%)) (let ((new (make-variable :type (mrs:var-type var) :id (mrs:var-id var)))) (setf (variable-properties new) (loop for extra in (mrs:var-extra var) collect (make-property :name (mrs::extrapair-feature extra) :value (mrs::extrapair-value extra)))) (push (cons var new) %mrs-construction-cache%) new)))) (defun import-constant (atom) (make-constant :value atom)) (defun export-mrs (mrs &key ids) (let* ((%mrs-construction-cache% nil) (new (mrs::make-psoa :top-h (export-variable (mrs-top mrs) :ids ids) :index (export-variable (mrs-index mrs) :ids ids)))) (setf (mrs:psoa-liszt new) (loop for ep in (mrs-eps mrs) collect (export-ep ep :ids ids))) (setf (mrs:psoa-h-cons new) (loop for hcons in (mrs-hcons mrs) collect (export-hcons hcons :ids ids))) new)) (defun export-ep (ep &key ids) (let ((new (mrs::make-rel :handel (export-variable (ep-label ep) :ids ids) :pred (export-pred (ep-pred ep))))) (setf (mrs:rel-flist new) (loop for role in (ep-roles ep) for value = (role-value role) collect (mrs::make-fvpair :feature (role-name role) :value (if (variable-p value) (export-variable value :ids ids) (export-constant value))))) new)) (defun export-hcons (hcons &key ids) (mrs::make-hcons :relation (hcons-relation hcons) :scarg (export-variable (hcons-harg hcons) :ids ids) :outscpd (export-variable (hcons-larg hcons) :ids ids))) (defun export-pred (pred) pred) (defun export-variable (variable &key ids) (when variable (or (rest (assoc variable %mrs-construction-cache%)) (let ((new (mrs::make-var :type (variable-type variable) :id (or (and ids (funcall ids)) (variable-id variable))))) (setf (mrs:var-extra new) (loop for property in (variable-properties variable) collect (mrs::make-extrapair :feature (property-name property) :value (property-value property)))) (push (cons variable new) %mrs-construction-cache%) new)))) (defun export-constant (constant) (constant-value constant)) (defun test-integrity (mrs) (labels ((test-variable (variable) (or (not (mrs:var-p variable)) (not (stringp (mrs:var-type variable))) (not (numberp (mrs:var-id variable))) (not (loop for extra in (mrs:var-extra variable) always (and (symbolp (mrs::extrapair-feature extra)) (mrs::extrapair-value extra) (symbolp (mrs::extrapair-value extra)))))))) (when (mrs:psoa-p mrs) (loop with invalid for ep in (mrs:psoa-liszt mrs) for pred = (mrs:rel-pred ep) unless (and (or (symbolp pred) (stringp pred)) (mrs:var-p (mrs:rel-handel ep))) do (pushnew ep invalid) else when (test-variable (mrs:rel-handel ep)) do (pushnew (mrs:rel-handel ep) invalid) else do (loop for role in (mrs:rel-flist ep) for value = (mrs:fvpair-value role) unless (symbolp (mrs:fvpair-feature role)) do (pushnew ep invalid) when (mrs:var-p value) do (when (test-variable value) (pushnew value invalid)) else do (unless (stringp value) (pushnew ep invalid))) finally (return (nreverse invalid))))))