;(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>")
;;; Equivalences for GG
(setf *equivalences* "<equivalences style="GG"> <equivalencegroup> <quantifier label="def_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="udef_q" hole="1"/> <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)))
(net.xml.parser: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)))
(defvar mrs::*orig-ignored-sem-features* ())
(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)))))))