;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: LKB -*- ;;; Copyright (c) 2003--2020 ;;; John Carroll, Ann Copestake, Robert Malouf, Stephan Oepen; ;;; see `LICENSE' for conditions. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; file: lui.lsp ;;; module: Linguistic User Interface protocol ;;; version: 0.0 (1-jun-03) ;;; written by: oe, csli stanford ;;; last update: ;;; updated by: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; author | date | modification ;;; ------------------|-------------|------------------------------------------ ;;; | | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :lkb) (defparameter *lui-application* nil) (defparameter *lui-autonomy-p* t) (defparameter *lui-debug-p* nil) (defparameter %lui-stream% nil) (defparameter %lui-socket% nil) (defparameter %lui-pid% nil) (defparameter %lui-process% nil) (defparameter %lui-pending-events% nil) (defparameter %lui-eoc% (format nil " ~a" #\page)) (defun lui-initialize (&key runtimep port lui) (declare (ignore runtimep)) (lui-shutdown) #-:mswindows (let ((display (getenv "DISPLAY"))) (when (and (null port) (or (null display) (equal display ""))) (return-from lui-initialize))) (unless *lui-application* (setf *lui-application* (let* ((directory #-:lkb-fos (pathname-directory (pathname make::bin-dir)) #+:lkb-fos ;; assume PATH contains yzlui, as in installation instructions '(:relative)) (lui (and (stringp lui) (> (length lui) 0) (make-pathname :directory directory :name lui))) (binary (namestring (if (and lui (probe-file lui)) lui (make-pathname :directory directory :name "yzlui"))))) (format nil "exec ~a -p" binary)))) (if port (let* ((socket (socket:make-socket :connect :passive :local-port port)) (stream (socket:accept-connection socket :wait t)) (address (socket:remote-host stream)) (host (and address (socket:ipaddr-to-hostname address))) (port (socket:remote-port stream))) (format t "~&lui-initialize(): remote connection from `~a:~a'~%" host port) (setf %lui-socket% socket) (setf %lui-stream% stream) (setf %lui-pid% nil)) (multiple-value-bind (stdout stderr pid) #-:clisp (run-process *lui-application* :wait nil :input :stream :output :stream :error-output "/dev/null" :if-error-output-exists :supersede) #+:clisp (ext:make-pipe-io-stream *lui-application* :buffered nil) (declare (ignore stderr)) (setq %lui-stream% stdout %lui-pid% pid))) #+:allegro (setf (stream-external-format %lui-stream%) (excl:find-external-format :utf-8)) (lui-parameters :all) #-:clisp (setf %lui-process% (mp:run-function '(:name "LUI") #'lsp-loop nil %lui-stream%)) #+:clisp (progn (lsp-loop nil %lui-stream%) (lui-shutdown))) (defun lui-shutdown () (when %lui-stream% ;; tell LUI to close any open windows and then give it a chance to do so before ;; shutting it down (ignore-errors (format %lui-stream% "~%~%quit~a" %lui-eoc%) (finish-output %lui-stream%)) (sleep 2) (ignore-errors (close %lui-stream%)) (setf %lui-stream% nil)) (when %lui-socket% #-:acl-compat (ignore-errors (socket:shutdown %lui-socket% :output)) #-:acl-compat (ignore-errors (socket:shutdown %lui-socket% :input)) (ignore-errors (close %lui-socket%)) (setf %lui-socket% nil)) #-:clisp (when %lui-pid% (ignore-errors (loop for signal in '("HUP" "TERM" "QUIT") do (run-process (format nil "kill -~a ~d" signal %lui-pid%) :wait t :output "/dev/null" :if-output-exists :supersede :error-output "/dev/null" :if-error-output-exists :supersede))) #+:allegro (sys:os-wait nil %lui-pid%) (setf %lui-pid% nil)) #-:clisp (when %lui-process% (ignore-errors (mp:process-kill %lui-process%)) (setf %lui-process% nil))) (defun lui-parameters (&optional style) (when (or (null style) (eq style :all)) (format %lui-stream% "parameter list-type ~a~a~%~ parameter non-empty-list-type ~a~a~%~ parameter empty-list-type ~a~a~%~ parameter list-head ~a~a~%~ parameter list-tail ~a~a~%~ status ready~a~%" *list-type* %lui-eoc% *non-empty-list-type* %lui-eoc% *empty-list-type* %lui-eoc% (first *list-head*) %lui-eoc% (first *list-tail*) %lui-eoc% %lui-eoc%)) (unless *lui-autonomy-p* (when (member style '(:avm :all)) (format %lui-stream% "parameter avm-bar-font #F[Helvetica ~a roman blue]~a~%~ parameter avm-type-font #F[Helvetica ~a roman blue]~a~%~ parameter avm-feature-font #F[Helvetica ~a roman black]~a~%~ parameter avm-tag-font #F[Helvetica ~a roman red]~a~%" *fs-type-font-size* %lui-eoc% *fs-type-font-size* %lui-eoc% *fs-type-font-size* %lui-eoc% *fs-type-font-size* %lui-eoc%)) (when (member style '(:tree :all)) (format %lui-stream% "parameter tree-summary-bar-font #F[Helvetica ~a roman black]~a~%~ parameter tree-summary-node-font #F[Helvetica ~a roman black]~a~%~ parameter tree-summary-surface-font #F[Helvetica ~a roman black]~a~%~ parameter tree-detail-bar-font #F[Helvetica ~a roman black]~a~%~ parameter tree-detail-node-font #F[Helvetica ~a roman black]~a~%~ parameter tree-detail-surface-font #F[Helvetica ~a roman black]~a~%" *summary-tree-font-size* %lui-eoc% *summary-tree-font-size* %lui-eoc% *summary-tree-font-size* %lui-eoc% *parse-tree-font-size* %lui-eoc% *parse-tree-font-size* %lui-eoc% *parse-tree-font-size* %lui-eoc%)) (when (member style '(:chart :all)) (format %lui-stream% "parameter chart-bar-font #F[Helvetica ~a roman blue]~a~%~ parameter chart-word-font #F[Helvetica ~a roman black]~a~%~ parameter chart-word-font #F[Helvetica ~a roman black]~a~%" *parse-tree-font-size* %lui-eoc% *parse-tree-font-size* %lui-eoc% *parse-tree-font-size* %lui-eoc%))) (force-output %lui-stream%)) (defun send-to-lui (string &key (wait nil) recursive) (unless recursive (when *lui-debug-p* (format t "~&send-to-lui(): [send] `~a'.~%" string)) (format %lui-stream% "~@[wait ~*~]~a~a" wait string %lui-eoc%) (force-output %lui-stream%)) (unwind-protect (when (or wait recursive) (let ((*package* (find-package :lkb)) (form (when (streamp %lui-stream%) (lsp-parse-command nil (lsp-read nil %lui-stream%))))) (when *lui-debug-p* (format t "~&send-to-lui(): [return] `~s'.~%" form)) (cond ((eq (first form) 'event) (when *lui-debug-p* (format t "~&send-to-lui(): queueing intervening event `~s'.~%" form)) (setf %lui-pending-events% (append %lui-pending-events% (list form))) (send-to-lui nil :recursive t)) (t form)))))) (defun process-pending-events () #+(and :debug (not :acl-compat)) (when (and %lui-process% (not (eq mp:*current-process* %lui-process%))) (mp:process-add-arrest-reason %lui-process% :pending-events)) (loop while (and (streamp %lui-stream%) %lui-pending-events%) do (lsp-process-event nil (pop %lui-pending-events%) %lui-stream%)) #+(and :debug (not :acl-compat)) (when (and %lui-process% (not (eq mp:*current-process* %lui-process%))) (mp:process-revoke-arrest-reason %lui-process% :pending-events))) (defun lui-status (string) (format %lui-stream% "message ~s~a~%" string %lui-eoc%)) (defun lui-show-parses (edges &optional (input *sentence*) (tchart (copy-array *tchart*)) (chart (copy-array *chart*))) (loop with stream = (make-string-output-stream) initially (lui-parameters :tree) (format stream "group ~d ~s~a~%" (length edges) (if input (format nil "`~a' (~a Tree~p)" input (length edges) (length edges)) "Analysis Result(s)") %lui-eoc%) for i from 1 for title = (format nil "`~a' Parse Tree # ~d" input i) for edge in edges for top = (make-new-parse-tree edge 1) for tdfs = (get top 'full-fs) for lspb = (make-lspb :input input :tchart tchart :chart chart :edge edge :dag tdfs) for id = (lsp-store-object nil lspb) do (setf (lspb-id lspb) id) (format stream "tree ~d " id) (lui-show-tree top input :lspb lspb :tchart tchart :chart chart :stream stream) (format stream " ~s~a~%" title %lui-eoc%) finally (format %lui-stream% "~a" (get-output-stream-string stream))) (force-output %lui-stream%)) (defun lui-show-tree (top &optional (input *sentence*) &key tchart chart lspb (stream %lui-stream%)) (let* ((edge (get top 'edge-record)) (tdfs (get top 'full-fs)) (lspb (make-lspb :context lspb :input input :tchart tchart :chart chart :edge edge :dag tdfs)) (daughters (get top 'daughters)) (form (when (and daughters (null (rest daughters)) (null (get (first daughters) 'edge-record))) (get-string-for-edge (first daughters)))) (id (or (lspb-id lspb) (let ((id (lsp-store-object nil lspb))) (setf (lspb-id lspb) id) id))) (label (get-string-for-edge top)) (n (edge-id edge)) (rule (if (rule-p (edge-rule edge)) (rule-id (edge-rule edge)) (string-downcase (string (first (edge-lex-ids edge))))))) (format stream "#T[~a ~s ~s ~a ~a " id label form n rule) (loop for daughter in (if form (get (first daughters) 'daughters) daughters) do (lui-show-tree daughter input :tchart tchart :chart chart :lspb lspb :stream stream)) (format stream "]"))) (defun lui-display-fs (tdfs title id &optional failures) (declare (ignore id)) (let* ((tdfs (if (tdfs-p tdfs) tdfs (make-tdfs :indef tdfs))) (id (lsp-store-object nil (make-lspb :dag tdfs))) (dag (tdfs-indef tdfs)) (*package* (find-package :lkb))) (lui-parameters :avm) (let* ((string (with-output-to-string (stream) (display-dag1 dag 'linear stream))) ;; ;; work around a LUI idiosyncrasy: LUI rejects atomic dags - so ;; dress them up with a (kind of) spurious outermost decoration ;; (string (if (char= (char string 0) #\#) string (concatenate 'string "#D[" string "]"))) ;; ;; work around a LUI bug: LUI rejects dags containing non-string types ;; with numeric names - sneak them in by double-quoting them so they look ;; like string types (LUI doesn't distinguish between the two anyway) ;; (string (cl-ppcre:regex-replace-all "([\\[ ])([-+]?[0-9]+)([ \\]])" string "\\1\"\\2\"\\3")) ;; ;; work around another LUI bug: LUI rejects dags with list types or ;; features at the top level - in such cases temporarily unset the LUI ;; parameters pertaining to lists ;; (list-top-level-p (or (member (dag-type dag) (list *list-type* *non-empty-list-type* *empty-list-type*)) (get-dag-value dag (first *list-head*)) (get-dag-value dag (first *list-tail*))))) (unwind-protect (progn (when list-top-level-p (let* ((u (gensym "U")) (*list-type* u) (*non-empty-list-type* u) (*empty-list-type* u) (*list-head* (list u)) (*list-tail* (list u))) (lui-parameters nil))) (format %lui-stream% "avm ~d ~a" id string) #+:null (format %lui-stream% " ~s~%" path) (format %lui-stream% " ~s~%" title) (format %lui-stream% "~@[[~{~s~^ ~}]~]" failures) (format %lui-stream% "~a" %lui-eoc%) (force-output %lui-stream%)) (when list-top-level-p (lui-parameters nil)))))) (defun lui-show-chart (&optional (input *sentence*) (tchart (copy-array *tchart*)) (chart (copy-array *chart*))) (let* ((stream (make-string-output-stream)) (root (make-lspb :input input :tchart tchart :chart chart)) (id (lsp-store-object nil root)) (nvertices (max *tchart-max* *chart-max*))) (lui-parameters :chart) (format stream "chart ~d ~d ~s~%" id nvertices (if input (format nil "`~a' (Chart)" input) "Chart View")) (loop for key downfrom -1 for start from 0 to (1- nvertices) for token = (loop for edge in (aref *tchart* start 1) when (token-edge-p edge) return edge) when token do (format stream " #E[~a ~a ~a ~a ~(~s~) \"\" []]~%" key key start #+:null (+ start 1) -1 (token-edge-word token))) (loop for end from 1 to (min nvertices (1- *chart-limit*)) for edges = (loop for start from 0 below end nconc (sort (copy-list (aref chart start end)) #'< :key #'edge-id)) do (loop for edge in edges for start = (edge-from edge) for lspb = (make-lspb :input input :tchart tchart :chart chart :edge edge) for key = (lsp-store-object nil lspb) for id = (edge-id edge) for name = (lui-chart-edge-name edge) for label = (lui-chart-edge-label edge) do (push key (lspb-children root)) when (and (numberp start) (numberp end)) do (format stream " #E[~a ~:[-1~;~a~] ~a ~a ~s \"~(~a~)\" []" key id id start end name label) (loop for child in (edge-children edge) do (format stream " ~a" (edge-id child))) ;; ;; for lexemes, generate pseudo daughters list again ;; (when (stringp (edge-rule edge)) (loop for i from (- (+ start 1)) downto (- end) do (format stream " ~a" i))) (format stream "]~%"))) (format stream "~a" %lui-eoc%) (format %lui-stream% "~a" (get-output-stream-string stream)) (force-output %lui-stream%) id)) (defun lui-chart-event (id format object) (when (and (lspb-p object) (edge-p (lspb-edge object)) (numberp (edge-id (lspb-edge object)))) (format %lui-stream% "chart ~d event ~(~a~) ~d~a~%" id (if (eq format :edges) :highlight :restrict) (edge-id (lspb-edge object)) %lui-eoc%) (force-output %lui-stream%))) (defun lui-show-gen-result (&optional edges chart) (declare (special *gen-record* *gen-chart* *generator-input* %generator-condition%)) (loop with edges = (or edges *gen-record*) with chart = (or chart (copy-tree *gen-chart*)) with stream = (make-string-output-stream) with context = (make-lspb) with last = (first (last edges)) for edge in edges for string = (if (consp (g-edge-string edge)) (format nil "~{~a~^ ~}" (g-edge-string edge)) (g-edge-string edge)) for lspb = (make-lspb :chart chart :mrs *generator-input* :edge edge :input string) initially (lsp-store-object nil context) (format stream "text ~a #X[" (lspb-id context)) (unless edges (if (typep %generator-condition% 'error) (let ((condition (format nil "~a" %generator-condition%))) (format stream "\"~a\" ]" (normalize-string condition))) (format stream "\"no realizations found\"]"))) do (push (lsp-store-object nil lspb) (lspb-children context)) (format stream " #X[~d \"~a\"] ~:[newline~;]~]~%" (lspb-id lspb) string (eq edge last)) collect lspb into lspbs finally (loop for lspb in lspbs for id = (lspb-id lspb) do (format stream " #M[\"Tree\" \"browse ~d ~d tree\"~% ~ \"AVM\" \"browse ~d ~d avm\"~% ~ \"Simple MRS\" \"browse ~d ~d mrs simple\" ~d~% ~ \"Indexed MRS\" \"browse ~d ~d mrs indexed\" ~d~% ~ \"Dependencies\" \"browse ~d ~d dependencies\" ~d]~%" id id id id id id id id id id id id id)) (format stream " ~s~a~%" "Realization Result(s)" %lui-eoc%) (format %lui-stream% "~a" (get-output-stream-string stream))) (force-output %lui-stream%)) (defun lui-display-mrs (mrs &optional title (format :simple)) (let* ((id (lsp-store-object nil (make-lspb :mrs mrs))) (title (case format (:simple (format nil "~@[~a ~]Simple MRS Display" title)) (:indexed (format nil "~@[~a ~]Indexed MRS Display" title)) (:dependencies (format nil "~@[~a ~]Dependencies Display" title)))) (string (with-output-to-string (stream) (case format (:simple (format stream "parameter avm-collapsed-types [u h i e x]~a~%" %lui-eoc%) (format stream "avm ~d " id) (mrs::lui-dagify-mrs mrs :stream stream)) (:indexed (format stream "text 42 ") (mrs::lui-indexed-mrs mrs :stream stream)) (:dependencies (format stream "text 42 ") (mrs:eds-output-psoa mrs :stream stream :format :lui)))))) (format %lui-stream% string) (format %lui-stream% " ~s~a~%" title %lui-eoc%)) (force-output %lui-stream%)) (defun lui-display-eds (eds &optional title) (let* ((id (lsp-store-object nil (make-lspb :eds eds))) (title (format nil "~@[~a ~]Elementary Dependencies Display" title)) (string (with-output-to-string (stream) (format stream "text ~a " id) (mrs:eds-output-psoa eds :stream stream :format :lui)))) (format %lui-stream% string) (format %lui-stream% " ~s~a~%" title %lui-eoc%)) (force-output %lui-stream%)) (defun lui-status-p (&optional key format) (when (and (streamp %lui-stream%) (open-stream-p %lui-stream%)) (if (null key) (streamp %lui-stream%) (case key #-:null (:tree (streamp %lui-stream%)) #-:null (:avm (streamp %lui-stream%)) #-:null (:chart (streamp %lui-stream%)) #-:null (:realization (streamp %lui-stream%)) #-:null (:mrs (and (streamp %lui-stream%) (or (null format) (member format '(:simple :indexed :dependencies))))))))) (defun lui-display-tree (tree &optional input &key title (stream %lui-stream%) size (n 0)) (unless %lui-stream% (return-from lui-display-tree)) (when (numberp size) (format stream "parameter tree-detail-bar-font #F[Helvetica ~a roman black]~a~%~ parameter tree-detail-node-font #F[Helvetica ~a roman black]~a~%~ parameter tree-detail-surface-font #F[Helvetica ~a roman black]~a~%" size %lui-eoc% size %lui-eoc% size %lui-eoc%)) (labels ((label (tree) (and (null (rest (rest tree))) (not (consp (first (rest tree)))) (first (rest tree)))) (traverse (tree) (if (and (consp (first tree)) (null (rest tree))) ;; ;; accomodate extra level of embedding at the root of PTB trees ;; (traverse (first tree)) (loop initially (format stream " #T[~a ~s ~s ~a ? " n (first tree) (label tree) n (first tree)) ; !!! superfluous argument - JAC 16-Feb-2022 (incf n) for daughter in (and (consp (first (rest tree))) (rest tree)) do (traverse daughter) finally (format stream "]"))))) (let* ((title (or title (format nil "~@[`~a' ~]Parse Tree" input))) (lspb (make-lspb :input input)) (id (lsp-store-object nil lspb))) (setf (lspb-id lspb) id) (format stream "tree ~d " id) (traverse tree) (format stream " ~s~a~%" title %lui-eoc%) (force-output stream)))) (defun copy-array (array) (let ((dimensions (array-dimensions array)) (element-type (array-element-type array)) (adjustable (adjustable-array-p array)) (fill-pointer (when (array-has-fill-pointer-p array) (fill-pointer array)))) (let ((new-array (apply #'make-array (list dimensions :element-type element-type :adjustable adjustable :fill-pointer fill-pointer)))) (dotimes (i (array-total-size array)) (setf (row-major-aref new-array i) (row-major-aref array i))) new-array)))