;; Copyright (c) 2003--2018 ;;; John Carroll, Ann Copestake, Robert Malouf, Stephan Oepen; ;;; see `LICENSE' for conditions. (in-package :lkb) ;;; RMRS windows ;;; Frames (define-lkb-frame rmrs-ordinary ((rmrs :initform nil :accessor rmrs-ordinary-rmrs)) :display-function 'show-rmrs-ordinary :text-style (lkb-parse-tree-font) :width :compute :height :compute) (define-lkb-frame mrs-rmrs ((mrsstruct :initform nil :accessor mrs-rmrs-mrsstruct) (rmrs :initform nil :accessor mrs-rmrs-rmrs)) :display-function 'show-mrs-rmrs :text-style (lkb-parse-tree-font) :width *parse-window-width* :height *parse-window-height*) ; not :compute since not compact vertically ;;; compare functionality (define-lkb-frame mrs-rmrs-compare ((rmrs1 :initform nil :accessor mrs-rmrs-compare-rmrs1) (rmrs2 :initform nil :accessor mrs-rmrs-compare-rmrs2) (comparison-record :initform nil :accessor mrs-rmrs-compare-comparison-record)) :display-function 'show-mrs-rmrs-compare :text-style (lkb-parse-tree-font) :width (* 2 *parse-window-width*) :height *parse-window-height*) ;;; DMRS (define-lkb-frame dmrs-ordinary ((dmrs :initform nil :accessor dmrs-ordinary-dmrs)) :display-function 'show-dmrs-ordinary :text-style (lkb-parse-tree-font) :width :compute :height :compute) (define-lkb-frame mrs-dmrs ((mrsstruct :initform nil :accessor mrs-dmrs-mrsstruct) (rmrs :initform nil :accessor mrs-dmrs-dmrs)) :display-function 'show-mrs-dmrs :text-style (lkb-parse-tree-font) :width :compute :height :compute) ;;; end frames (define-rmrs-ordinary-command (com-select-rmrs :menu "Select") () (set-selected-rmrs-from-menu (rmrs-ordinary-rmrs clim:*application-frame*))) (define-mrs-rmrs-command (com-select-mrs-rmrs :menu "Select") () (set-selected-rmrs-from-menu (mrs-rmrs-rmrs clim:*application-frame*))) ;;; As MRS - XML output (define-rmrs-ordinary-command (com-output-rmrs-xml :menu "Save as XML") () (save-rmrs-as-xml (rmrs-ordinary-rmrs clim:*application-frame*))) (define-mrs-rmrs-command (com-output-mrs-rmrs-xml :menu "Save as XML") () (save-rmrs-as-xml (mrs-rmrs-rmrs clim:*application-frame*))) (define-mrs-dmrs-command (com-output-dmrs-xml :menu "Save as XML") () (save-dmrs-as-xml (mrs-dmrs-dmrs clim:*application-frame*))) (define-mrs-dmrs-command (com-output-dmrs-rmrs :menu "Convert to RMRS") () (show-rmrs-ordinary-window (mrs::dmrs-to-rmrs (mrs-dmrs-dmrs clim:*application-frame*)) "Converted from DMRS")) (define-mrs-dmrs-command (com-output-dmrs-latex :menu "Save as LaTeX") () (save-dmrs-as-latex (mrs-dmrs-dmrs clim:*application-frame*))) (define-mrs-dmrs-command (com-output-dmrs-svg :menu "Save as SVG") () (save-dmrs-as-svg (mrs-dmrs-dmrs clim:*application-frame*))) (define-mrs-dmrs-command (com-output-dmrs-simplify :menu "Simplify") () (show-dmrs-ordinary-window (mrs::dmrs-simplify-complex-names (mrs-dmrs-dmrs clim:*application-frame*)) "Simplified DMRS")) (defparameter *rmrs-xml-output-file* nil) (defun save-rmrs-as-xml (rmrsstruct) (let ((file-name (if *rmrs-xml-output-file* (let ((use-existing-p (lkb-y-or-n-p (format nil "Append to ~A?" *rmrs-xml-output-file*)))) (if use-existing-p *rmrs-xml-output-file* (ask-user-for-new-pathname "New file for RMRS XML dumps"))) (ask-user-for-new-pathname "File for RMRS XML dumps")))) (setf *rmrs-xml-output-file* file-name) (when file-name (mrs::output-rmrs rmrsstruct 'mrs::xml file-name)))) (defparameter *dmrs-xml-output-file* nil) (defun save-dmrs-as-xml (dmrsstruct) (let ((file-name (if *dmrs-xml-output-file* (let ((use-existing-p (lkb-y-or-n-p (format nil "Append to ~A?" *dmrs-xml-output-file*)))) (if use-existing-p *dmrs-xml-output-file* (ask-user-for-new-pathname "New file for DMRS XML dumps"))) (ask-user-for-new-pathname "File for DMRS XML dumps")))) (setf *dmrs-xml-output-file* file-name) (when file-name (mrs::output-dmrs dmrsstruct 'mrs::dxml file-name)))) (defparameter *dmrs-latex-output-file* nil) (defun save-dmrs-as-latex (dmrsstruct) (let ((file-name (if *dmrs-latex-output-file* (let ((use-existing-p (lkb-y-or-n-p (format nil "Overwrite ~A?" *dmrs-latex-output-file*)))) (if use-existing-p *dmrs-latex-output-file* (ask-user-for-new-pathname "New file for DMRS LaTeX"))) (ask-user-for-new-pathname "File for DMRS LaTeX")))) (setf *dmrs-latex-output-file* file-name) (when file-name (with-open-file (ostream file-name :direction :output :if-exists :supersede :if-does-not-exist :create) (mrs::layout-dmrs dmrsstruct :latex ostream))))) (defparameter *dmrs-svg-output-file* nil) (defun save-dmrs-as-svg (dmrsstruct) (let ((file-name (if *dmrs-svg-output-file* (let ((use-existing-p (lkb-y-or-n-p (format nil "Overwrite ~A?" *dmrs-svg-output-file*)))) (if use-existing-p *dmrs-svg-output-file* (ask-user-for-new-pathname "New file for DMRS svg"))) (ask-user-for-new-pathname "File for DMRS svg")))) (setf *dmrs-svg-output-file* file-name) (when file-name (with-open-file (ostream file-name :direction :output :if-exists :supersede :if-does-not-exist :create) (mrs::layout-dmrs dmrsstruct :svg ostream))))) ;;; ordinary window for one RMRS ;;; calling function (called from emacs) (defun display-rmrs-from-string (str) (with-package (:mrs) (let ((rmrs (mrs::read-single-rmrs-from-string str))) (when (and rmrs (mrs::rmrs-p rmrs)) (show-rmrs-ordinary-window rmrs "RMRS"))))) ;;; windows functions (defun show-rmrs-ordinary-window (rmrs title) (mp:run-function "RMRS ORDINARY" #'show-rmrs-ordinary-window-really :rmrs rmrs :title title)) (defun show-rmrs-ordinary-window-really (&key rmrs title) (let ((mframe (clim:make-application-frame 'rmrs-ordinary :pretty-name (or title "Robust MRS")))) (setf (rmrs-ordinary-rmrs mframe) rmrs) (clim:run-frame-top-level mframe))) (defun show-rmrs-ordinary (mframe stream &key max-width max-height) (declare (ignore max-width max-height)) (let ((rmrs (rmrs-ordinary-rmrs mframe))) (mrs::output-rmrs1 rmrs 'mrs::compact stream t))) ;;; Window from parser (defun show-mrs-rmrs-window (edge &key mrs rmrs title) (mp:run-function "RMRS" #'show-mrs-rmrs-window-really edge :mrs mrs :rmrs rmrs :title title)) (defun show-mrs-rmrs-window-really (edge &key mrs rmrs title) (let ((mframe (clim:make-application-frame 'mrs-rmrs :pretty-name (or title "Robust MRS"))) (mrsstruct (or mrs (when edge (mrs::extract-mrs edge))))) (setf (mrs-rmrs-mrsstruct mframe) mrsstruct) (setf (mrs-rmrs-rmrs mframe) (or rmrs (mrs::mrs-to-rmrs mrsstruct))) (clim:run-frame-top-level mframe))) (defun show-mrs-rmrs (mframe stream &key max-width max-height) (declare (ignore max-width max-height)) (let ((rmrs (mrs-rmrs-rmrs mframe))) (if rmrs (mrs::output-rmrs1 rmrs 'mrs::compact stream t) (format stream "~%::: RMRS structure could not be extracted~%")))) ;;; RMRS comparison (defun show-mrs-rmrs-compare-window (rmrs1 rmrs2 comparison-record title) (mp:run-function "RMRS comparison" #'show-mrs-rmrs-compare-window-really rmrs1 rmrs2 comparison-record title)) (defun show-mrs-rmrs-compare-window-really (rmrs1 rmrs2 comparison-record title) (let ((mframe (clim:make-application-frame 'mrs-rmrs-compare :pretty-name (or title "RMRS comparison")))) (setf (mrs-rmrs-compare-rmrs1 mframe) rmrs1) (setf (mrs-rmrs-compare-rmrs2 mframe) rmrs2) (setf (mrs-rmrs-compare-comparison-record mframe) comparison-record) (clim:run-frame-top-level mframe))) (defun show-mrs-rmrs-compare (mframe stream &key max-width max-height) (declare (ignore max-width max-height)) (let ((rmrs1 (mrs-rmrs-compare-rmrs1 mframe)) (rmrs2 (mrs-rmrs-compare-rmrs2 mframe)) (comparison-record (mrs-rmrs-compare-comparison-record mframe))) (if (and rmrs1 rmrs2 comparison-record) (clim:with-output-recording-options (stream :draw nil :record t) (let ((pts1 (mrs::output-rmrs1 rmrs1 'mrs::compact-g stream t t))) (move-to-x-y stream 0 0) (let ((pts2 (mrs::output-rmrs1 rmrs2 'mrs::compact-two stream t t))) (add-comparison-pointers stream pts1 pts2 comparison-record)))) (format stream "~%::: RMRS structures could not be extracted~%")))) (defun add-comparison-pointers (stream pts1 pts2 comparison-record) (when (and pts1 pts2 comparison-record (mrs::rmrs-comparison-record-matched-rels comparison-record)) ;;; assume nothing to add if no matched-rels (let ((top-pt1 (mrs::rmrs-position-record-top pts1)) (top-pt2 (mrs::rmrs-position-record-top pts2)) (ep-pts1 (mrs::rmrs-position-record-eps pts1)) (ep-pts2 (mrs::rmrs-position-record-eps pts2)) (arg-pts1 (mrs::rmrs-position-record-args pts1)) (arg-pts2 (mrs::rmrs-position-record-args pts2)) (ing-pts1 (mrs::rmrs-position-record-ings pts1)) (ing-pts2 (mrs::rmrs-position-record-ings pts2)) (hcons-pts1 (mrs::rmrs-position-record-hcons pts1)) (hcons-pts2 (mrs::rmrs-position-record-hcons pts2))) (let ((match (mrs::rmrs-comparison-record-matched-top comparison-record))) (when match (let* ((l1 (mrs::match-top-record-label1 match)) (l2 (mrs::match-top-record-label2 match)) (ink (determine-comparison-line-colour match))) (draw-rmrs-matching-line l1 (list top-pt1) l2 (list top-pt2) ink stream)))) (loop for match in (mrs::rmrs-comparison-record-matched-rels comparison-record) do (let ((ep1 (mrs::match-rel-record-rel1 match)) (ep2 (mrs::match-rel-record-rel2 match)) (ink (determine-comparison-line-colour match))) (draw-rmrs-matching-line ep1 ep-pts1 ep2 ep-pts2 ink stream))) (loop for match in (mrs::rmrs-comparison-record-matched-args comparison-record) do (let ((arg1 (mrs::match-arg-record-arg1 match)) (arg2 (mrs::match-arg-record-arg2 match)) (ink (determine-comparison-line-colour match))) (draw-rmrs-matching-line arg1 arg-pts1 arg2 arg-pts2 ink stream))) (loop for match in (mrs::rmrs-comparison-record-matched-ings comparison-record) do (let ((ing1 (mrs::match-ing-record-ing1 match)) (ing2 (mrs::match-ing-record-ing2 match)) (ink (determine-comparison-line-colour match))) (draw-rmrs-matching-line ing1 ing-pts1 ing2 ing-pts2 ink stream))) (loop for match in (mrs::rmrs-comparison-record-matched-hcons comparison-record) do (let ((hcons1 (mrs::match-hcons-record-hcons1 match)) (hcons2 (mrs::match-hcons-record-hcons2 match)) (ink (determine-comparison-line-colour match))) (draw-rmrs-matching-line hcons1 hcons-pts1 hcons2 hcons-pts2 ink stream)))))) (defun draw-rmrs-matching-line (object1 pts1 object2 pts2 ink stream) (let ((found-object1 (find object1 pts1 :key #'mrs::rmrs-object-position-object)) (found-object2 (find object2 pts2 :key #'mrs::rmrs-object-position-object))) (when (and found-object1 found-object2) (let ((object1-pos (mrs::rmrs-object-position-position found-object1)) (object2-pos (mrs::rmrs-object-position-position found-object2))) (clim:draw-line* stream (+ (position-x object1-pos) 10) (+ (position-y object1-pos) 10) (- (position-x object2-pos) 10) (+ (position-y object2-pos) 10) :ink ink))))) (defun determine-comparison-line-colour (match) ;;; if we assume that the deep-grammar derived RMRS is ;;; in position 1, then the :sub2 and :comp cases are ;;; generally unexpected - hence use red/magenta for these (cond ((mrs::match-top-record-p match) +green-flipping-ink+) ((mrs::match-rel-record-p match) (let ((pred-comp-type (mrs::match-rel-record-pred-comp-status match)) (var-comp-type (mrs::match-rel-record-var-comp-status match))) (declare (ignore var-comp-type)) (ecase pred-comp-type (:equal +green-flipping-ink+) (:sub1 +blue-flipping-ink+) (:sub2 +red-flipping-ink+) (:comp +magenta-flipping-ink+)))) ((mrs::match-arg-record-p match) (let ((comp-type (mrs::match-arg-record-comp-status match))) (ecase comp-type (:equal +green-flipping-ink+) (:sub1 +blue-flipping-ink+) (:sub2 +red-flipping-ink+) (:comp +magenta-flipping-ink+)))) ((mrs::match-ing-record-p match) +green-flipping-ink+) ((mrs::match-hcons-record-p match) +green-flipping-ink+) (t (error "Unexpected record type ~A" match)))) ;;; New top level function for comparison calling ;;; (defvar *selected-rmrs* nil "can be set from menu or via emacs") (defvar *compared-rmrs* nil "can be set from menu or via emacs") (defvar *rmrs-input-str* nil "just for display purposes, set by parser") (defun select-rmrs-from-emacs (str) (with-package (:mrs) (let ((rmrs (mrs::read-single-rmrs-from-string str))) (when (and rmrs (mrs::rmrs-p rmrs)) (set-selected-rmrs-from-menu rmrs))))) (defun set-selected-rmrs-from-menu (rmrs) (when (and rmrs (mrs::rmrs-p rmrs)) (cond ((or (null *selected-rmrs*) (and *selected-rmrs* *compared-rmrs*)) (setf *compared-rmrs* nil) (setf *selected-rmrs* rmrs) (with-output-to-top () (format t "~%Selected RMRS 1"))) (t (setf *compared-rmrs* rmrs) (with-output-to-top () (format t "~%Selected RMRS 2")))))) (defun compare-rmrs-interactive nil (let ((rmrs1 *selected-rmrs*) (rmrs2 *compared-rmrs*)) (unless (and (mrs::rmrs-p rmrs1) (mrs::rmrs-p rmrs2)) (error "No RMRSs to compare")) (let ((comparison-records (mrs::compare-rmrs rmrs1 rmrs2 *pos-sensitive-rmrs-p*))) (when (> (length comparison-records) 10) (if (y-or-n-p-general (format nil "There are ~A distinct correspondences. Do you want to view a sample of 10 of them?" (length comparison-records))) (setq comparison-records (subseq comparison-records 0 10)) (return-from compare-rmrs-interactive nil))) (dolist (comp comparison-records) (show-mrs-rmrs-compare-window rmrs1 rmrs2 comp (or *rmrs-input-str* "RMRS Comparison")) ;; slow down rate of window opening to try to avoid these operations ;; overlapping, which in McCLIM can corrupt internal data structures (sleep 0.2))))) ;;; ****** Comparison of RMRSs based on data stored in the fine system ;; code moved to rmrs/compare.lisp since it isn't actually ACL specific ;;; DMRS code ;;; (defun display-dmrs-from-string (str) (with-package (:mrs) (let ((dmrs (mrs::read-single-dmrs-from-string str))) (when (and dmrs (mrs::dmrs-p dmrs)) (show-dmrs-ordinary-window dmrs "DMRS"))))) (defun show-dmrs-ordinary-window (dmrs title) (mp:run-function "DMRS ORDINARY" #'show-dmrs-ordinary-window-really :dmrs dmrs :title title)) (defun show-dmrs-ordinary-window-really (&key dmrs title) (let ((mframe (clim:make-application-frame 'dmrs-ordinary :pretty-name (or title "Dependency MRS")))) (setf (dmrs-ordinary-dmrs mframe) dmrs) (clim:run-frame-top-level mframe))) (defun show-dmrs-ordinary (mframe stream &key max-width max-height) (declare (ignore max-width max-height)) (let ((dmrs (dmrs-ordinary-dmrs mframe))) (mrs::layout-dmrs dmrs :clim stream))) ;;; DMRS display from parser (defun show-mrs-dmrs-window (edge &key mrs dmrs title) (mp:run-function "DMRS" #'show-mrs-dmrs-window-really edge :mrs mrs :dmrs dmrs :title title)) (defparameter *dmrs-grammar-p* nil) (defun show-mrs-dmrs-window-really (edge &key mrs dmrs title) (let ((mframe (clim:make-application-frame 'mrs-dmrs :pretty-name (or title "Dependency MRS")))) (if *dmrs-grammar-p* (or dmrs (setf dmrs (when edge (mrs::extract-dmrs edge)))) (let ((mrsstruct (or mrs (when edge (mrs::extract-mrs edge))))) (setf (mrs-dmrs-mrsstruct mframe) mrsstruct))) (setf (mrs-dmrs-dmrs mframe) (or dmrs (let ((rmrs (mrs::mrs-to-rmrs (mrs-dmrs-mrsstruct mframe)))) (if rmrs (mrs::rmrs-to-dmrs rmrs))))) (clim:run-frame-top-level mframe))) (defun show-mrs-dmrs (mframe stream &key max-width max-height) (declare (ignore max-width max-height)) (let ((dmrs (mrs-dmrs-dmrs mframe))) (if dmrs (mrs::layout-dmrs dmrs :clim stream) (format stream "~%::: DMRS structure could not be extracted~%")))) ;;; Layout-dmrs has produced an abstract layout of the nodes and links in terms ;;; of unit-width characters, with nodes being 10 units apart horizontally. ;;; For CLIM purposes: ;;; a) y coordinates start with 0 at the top ;;; b) positions are scaled horizontally by 3/4*(mean width of characters in nodes) ;;; c) the first arc line is at y coord 4/3*font-height, with subsequent arcs at ;;; intervals of 2*font-height ;;; d) arc labels are 1/3*font-height below arc lines ;;; These seemingly arbitrary fractions replace the pre-2021 arbitrary constants ;;; and preserve the previous appearance at font size 12 - while looking much better ;;; at other sizes. (defun construct-dmrs-clim-diagram (nodes links stream) (let ((hs (loop for node in nodes sum (clim:stream-string-width stream (mrs::dmrs-layout-node-label node)) into width sum (length (mrs::dmrs-layout-node-label node)) into nchars finally (return (* 3/4 (/ width nchars))))) (fh (clim:stream-line-height stream))) (clim:with-output-recording-options (stream :draw nil :record t) (dolist (node nodes) (move-to-x-y stream (* hs (mrs::dmrs-layout-node-start-x node)) 0) (format stream "~A~A" (mrs::dmrs-layout-node-label node) (if (mrs::dmrs-layout-node-ltop node) "*" ""))) (dolist (link links) (let* ((y-pos (+ (* fh 4/3) (* fh 2 (mrs::dmrs-layout-link-y link)))) (arrow-direction (mrs::dmrs-layout-link-direction link)) (left-x (+ (* hs (mrs::dmrs-layout-link-left-x link)) hs)) (right-x (- (* hs (mrs::dmrs-layout-link-right-x link)) hs)) (mid-point (+ left-x (/ (- right-x left-x) 2))) (label (mrs::dmrs-layout-link-label link))) ;; draw the label (move-to-x-y stream (- mid-point (/ (clim:stream-string-width stream label) 2)) (+ y-pos (/ fh 3))) (format stream "~A" label) ;; draw the arrow or line (if arrow-direction (clim:draw-arrow* stream ;; draw-arrow* x1 y1 x2 y2 - :from-head is x1 y1 left-x y-pos right-x y-pos :from-head (eq arrow-direction :l) :to-head (eq arrow-direction :r)) (clim:draw-line* stream left-x y-pos right-x y-pos)))))))