;(eval-when (compile) ; (unless (find-package :lkb) (make-package :lkb)) ; (unless (find-package :mrs) (make-package :mrs))) (eval-when (compile load eval) (unless (find-package :utool) (make-package :utool))) (in-package :utool) (defvar *equivalences* "<equivalences style="GG"> <equivalencegroup> <quantifier label="def_q" hole="1"/> <quantifier label="udef_q" hole="1"/> <quantifier label="_def_q" hole="1"/> <quantifier label="_dergleiche_q" hole="1"/> <quantifier label="_derjenige_q" hole="1"/> <quantifier label="_derselbe_q" hole="1"/> <quantifier label="_dies_q" hole="1"/> <quantifier label="_jen_q" hole="1"/> <quantifier label="_ein_q" hole="0"/> <quantifier label="_ein_q" hole="1"/> <quantifier label="_indef_q" hole="0"/> <quantifier label="_indef_q" hole="1"/> <quantifier label="_einig_q_qua" hole="0"/> <quantifier label="_einig_q_qua" hole="1"/> <quantifier label="_etlich_q" hole="0"/> <quantifier label="_etlich_q" hole="1"/> <quantifier label="_solch+ein_q" hole="0"/> <quantifier label="_solch+ein_q" hole="1"/> <quantifier label="_so+ein_q" hole="0"/> <quantifier label="_so+ein_q" hole="1"/> <quantifier label="_sowas_q" hole="0"/> <quantifier label="_sowas_q" hole="1"/> <quantifier label="_etwas_q" hole="0"/> <quantifier label="_etwas_q" hole="1"/> <quantifier label="_manch+ein_q" hole="0"/> <quantifier label="_manch+ein_q" hole="1"/> <quantifier label="_manche_q" hole="0"/> <quantifier label="_manche_q" hole="1"/> <quantifier label="_ein-paar_q" hole="0"/> <quantifier label="_ein-paar_q" hole="1"/> <quantifier label="_ein-wenig_q" hole="0"/> <quantifier label="_ein-wenig_q" hole="1"/> <quantifier label="_ein-bisschen_q" hole="0"/> <quantifier label="_ein-bisschen_q" hole="1"/> <quantifier label="_mehr_q_qua" hole="0"/> <quantifier label="_mehr_q_qua" hole="1"/> <quantifier label="_mehrere_q" hole="0"/> <quantifier label="_mehrere_q" hole="1"/> <quantifier label="_irgendein_q" hole="0"/> <quantifier label="_irgendein_q" hole="1"/> <quantifier label="_irgendwelch_q" hole="0"/> <quantifier label="_irgendwelch_q" hole="1"/> </equivalencegroup> <equivalencegroup> <quantifier label="_all_q" hole="1" /> <quantifier label="_jed_q" hole="1" /> <quantifier label="_jeglich_q" hole="1" /> </equivalencegroup> <permutesWithEverything label="pronoun_q" hole="1"/></equivalences>") (defvar *utool-port* 2802) (defvar *utool-host* "localhost") (defun collect-solutions (acc elt) (cond ((consp elt) (case (car elt) (|solution| (apply #'collect-solution acc elt)) (t (reduce #'collect-solutions elt :initial-value acc)))) (t acc))) (defun collect-solution (acc _ _ solution) (cons (read-from-string solution) acc)) (defun parse-xml (istream) (let ((*package* (find-package :utool))) (xml:parse-xml istream :content-only istream))) (defun send-to-utool (writer) (let ((utool (socket:make-socket :remote-host *utool-host* :remote-port *utool-port*))) (funcall writer utool) (socket:shutdown utool :direction :output) (parse-xml utool))) (defun make-scoped-mrs (mrs) (flet ((writer (os) (format os "") (format os "") (format os "" *equivalences*) (format os ""))) (collect-solutions nil (send-to-utool #'writer)))) (defun display-mrs (edge) (let ((tree (lkb::deriv-tree-compute-derivation-tree edge)) (mrs (mrs::extract-mrs edge))) (flet ((writer (os) (format os "") (format os "") (format os ""))) (send-to-utool #'writer)))) (defun sdrow (acc tree) (cond ((stringp (car tree)) (cons (car tree) acc)) (t (reduce #'sdrow (cdddr tree) :initial-value acc)))) (defun prefix (tree) (let ((words (reverse (sdrow nil tree)))) (case (length words) (0 "") (1 (format nil "~A" (nth 0 words))) (t (format nil "~A ~A ..." (nth 0 words) (nth 1 words)))))) (in-package :mrs) (defvar *solver-internal* #'mrs::make-scoped-mrs) (defvar *solver-utool* #'utool::make-scoped-mrs) (defvar *solver* *solver-internal*) (defun make-scoped-mrs (mrs) (funcall *solver* mrs)) (in-package :lkb) (define-parse-tree-frame-command (com-multiple-tree-menu) ((tree 'prtree :gesture :select)) (let ((command (clim:menu-choose `(("Show enlarged tree" :value show) ("Highlight chart nodes" :value chart) ("Partial chart" :value partial-chart) ("Generate" :value generate :active ,*mrs-loaded*) ("MRS" :value mrs :active ,*mrs-loaded*) ("Prolog MRS" :value prolog :active ,*mrs-loaded*) ("RMRS" :value rmrs :active ,*mrs-loaded*) ("Indexed MRS" :value indexed :active ,*mrs-loaded*) ;;; {{{ ("[*] Display MRS [utool display]" :value display-utool :active ,*mrs-loaded*) ("[*] Scoped MRS [utool solve]" :value scoped-utool :active ,*mrs-loaded*) ("[*] Scoped MRS [use internal solver]" :value scoped :active ,*mrs-loaded*) ;;; }}} ("Dependencies" :value dependencies :active ,*mrs-loaded*) ("Rephrase" :value rephrase :active ,*mrs-loaded*) )))) (when command (handler-case (ecase command (show (draw-new-parse-tree (prtree-top tree) "Parse tree" nil (parse-tree-frame-current-chart clim:*application-frame*))) (chart (if (or (not (parse-tree-frame-current-chart clim:*application-frame*)) (eql (parse-tree-frame-current-chart clim:*application-frame*) *chart-generation-counter*)) (progn (cond ((and *main-chart-frame* (eql (clim:frame-state *main-chart-frame*) :enabled)) nil) ((and *main-chart-frame* (eql (clim:frame-state *main-chart-frame*) :shrunk)) (clim:raise-frame *main-chart-frame*)) (t (show-chart) (mp:process-wait-with-timeout "Waiting" 5 #'chart-ready))) (display-edge-in-chart (prtree-edge tree))) (lkb-beep))) (partial-chart (if (or (not (parse-tree-frame-current-chart clim:*application-frame*)) (eql (parse-tree-frame-current-chart clim:*application-frame*) *chart-generation-counter*)) (multiple-value-bind (root subframe-p) (cond ((and *main-chart-frame* (eql (clim:frame-state *main-chart-frame*) :enabled)) (values (chart-window-root *main-chart-frame*) t)) ((and *main-chart-frame* (eql (clim:frame-state *main-chart-frame*) :shrunk)) (values (chart-window-root *main-chart-frame*) t)) (t (values (construct-chart-no-display) nil))) (display-partial-chart root (prtree-edge tree) subframe-p)) (lkb-beep))) ;; funcall avoids undefined function warnings (generate (funcall 'really-generate-from-edge (prtree-edge tree))) (mrs (funcall 'show-mrs-window (prtree-edge tree))) (indexed (funcall 'show-mrs-indexed-window (prtree-edge tree))) (prolog (funcall 'show-mrs-prolog-window (prtree-edge tree))) ;;; {{{ (scoped (setf mrs::*solver* mrs::*solver-internal*) (funcall 'show-mrs-scoped-window (prtree-edge tree))) (scoped-utool (setf mrs::*solver* mrs::*solver-utool*) (funcall 'show-mrs-scoped-window (prtree-edge tree))) (display-utool (funcall 'utool::display-mrs (prtree-edge tree))) ;;; }}} (rmrs (funcall 'show-mrs-rmrs-window (prtree-edge tree))) (dependencies (funcall 'show-mrs-dependencies-window (prtree-edge tree))) (rephrase (let ((symbol (when (find-package :mt) (find-symbol "REPHRASE" :mt)))) (when (and symbol (fboundp symbol)) (funcall symbol (prtree-edge tree)))))) (storage-condition (condition) (with-output-to-top () (format t "~%Memory allocation problem: ~A~%" condition))) (error (condition) (with-output-to-top () (format t "~%Error: ~A~%" condition))) (serious-condition (condition) (with-output-to-top () (format t "~%Something nasty: ~A~%" condition))))))) (define-compare-frame-command (com-tree-popup) ((tree 'ctree :gesture :select)) (let* ((mrsp *mrs-loaded*) (command (clim:menu-choose (list '("Yes" :value yes :active t) #+:null '("No" :value no :active t) '("Enlarged Tree" :value show) (list "MRS" :value 'mrs :active mrsp) (list "RMRS" :value 'rmrs :active mrsp) (list "Indexed MRS" :value 'indexed :active mrsp) ;;; {{{ (list "[*] Display MRS [utool display]" :value 'display-utool :active mrsp) (list "[*] Scoped MRS [utool solve]" :value 'scoped-utool :active mrsp) (list "[*] Scoped MRS [use internal solver]" :value 'scoped :active mrsp) ;;; }}} (list "Dependencies" :value 'dependencies :active mrsp) (list "Rephrase" :value 'rephrase :active mrsp)))) (edge (ctree-edge tree))) (when command (handler-case (ecase command (yes (record-decision (make-decision :type :select :value edge)) (clim:with-application-frame (frame) (update-discriminants (compare-frame-discriminants frame) edge t) (recompute-in-and-out frame) (if (smember (compare-frame-display frame) '(:concise :ordered :inspect)) (update-trees frame) (update-tree-colours frame)))) (no ;; ;; _fix_me_ ;; not sure what to do here: there may be no discriminant(s) to ;; exclusively rule out this single tree; we would presumably have ;; to create one and add it to the global list of discriminants; ;; not clear this is so desirable. (12-oct-02; oe) ;; (record-decision (make-decision :type :drop :value edge)) (clim:with-application-frame (frame) (update-discriminants (compare-frame-discriminants frame) edge nil) (if (smember (compare-frame-display frame) '(:concise :ordered :inspect)) (update-trees frame) (update-tree-colours frame)))) (show (clim:with-application-frame (frame) (draw-new-parse-tree (or (ctree-symbol tree) (setf (ctree-symbol tree) (make-new-parse-tree (ctree-edge tree) 1))) "Parse tree" nil (compare-frame-chart frame)))) (mrs (when edge (ignore-errors (funcall 'show-mrs-window edge)))) (rmrs (when edge (ignore-errors (funcall 'show-mrs-rmrs-window edge)))) (indexed (when edge (ignore-errors (funcall 'show-mrs-indexed-window edge)))) ;;; {{{ (scoped (when edge (ignore-errors (setf mrs::*solver* mrs::*solver-internal*) (funcall 'show-mrs-scoped-window edge)))) (scoped-utool (when edge (ignore-errors (setf mrs::*solver* mrs::*solver-utool*) (funcall 'show-mrs-scoped-window edge)))) (display-utool (when edge (ignore-errors (funcall 'utool::display-mrs edge)))) ;;; }}} ; (scoped ; (when edge ; (ignore-errors (funcall 'show-mrs-scoped-window edge)))) (dependencies (when edge (ignore-errors (funcall 'show-mrs-dependencies-window edge)))) (rephrase (let ((symbol (when (find-package :mt) (find-symbol "REPHRASE" :mt)))) (when (and symbol (fboundp symbol)) (funcall symbol edge))))) (storage-condition (condition) (with-output-to-top () (format t "~%Memory allocation problem: ~A~%" condition))) (error (condition) (with-output-to-top () (format t "~%Error: ~A~%" condition))) (serious-condition (condition) (with-output-to-top () (format t "~%Something nasty: ~A~%" condition)))))))