;;; Copyright (c) 1991-2001 John Carroll, Ann Copestake, Robert Malouf, Stephan Oepen
;;; see LICENSE for conditions
(in-package :lkb)
;;; Displaying FSs in a variety of ways
;;; Window functions are in activefs.lsp which is not
;;; Lisp-independent
;;; Jan 1997 - made lisp-independent again
;;; - make compatible with YADU
;;; Display-dag etc are defined to keep the actual printing
;;; operations seperate from the process of walking over the dag
;;; structure. This is done by setting *display-structure*
;;; to be a structure containing the functions which are appropriate
;;; for the particular output device.
(defvar *reentrancy-pointer* 0)
(defvar *display-structure* nil)
(defun def-print-operations (class indentation stream box)
(setf *display-structure* (make-instance class
:indentation indentation
:stream stream :box box)))
;;;
;;; Generic output-type class
;;;
(defclass fs-output-type ()
((indentation :initform 0 :initarg :indentation)
(stream :initarg :stream)
(box :initform nil :initarg :box)
(max-width :initform 0)))
(defmethod fs-output-error-fn ((fsout fs-output-type) dag-instance)
(with-slots (stream) fsout
(format stream
"~%::: ~A is not a dag...~%"
dag-instance)))
(defmethod fs-output-max-width-fn ((fsout fs-output-type))
(with-slots (max-width) fsout
max-width))
(defmethod fs-output-reentrant-value-endfn ((fsout fs-output-type))
nil)
(defmethod fs-output-shrinks ((fsout fs-output-type))
nil)
(defmethod fs-output-no-need-to-display ((fsout fs-output-type) rpath)
(declare (ignore rpath))
(values nil nil nil nil))
(defmethod fs-output-record-start
((fsout fs-output-type) rpath flag pointer)
(declare (ignore flag pointer rpath))
nil)
(defmethod fs-output-record-end ((fsout fs-output-type) rpath)
(declare (ignore rpath))
nil)
;;; ********** linear operations ***********
;;; - for cheap readable display of dags during tracing etc
(defclass linear (fs-output-type) ())
(defmethod fs-output-start-fn ((fsout linear))
nil)
(defmethod fs-output-end-fn ((fsout linear))
nil)
(defmethod fs-output-reentrant-value-fn ((fsout linear) reentrant-pointer)
(with-slots (stream) fsout
(format stream
"<~A>= "
reentrant-pointer)))
(defmethod fs-output-reentrant-fn ((fsout linear) reentrant-pointer)
(with-slots (stream) fsout
(format stream "<~A>" reentrant-pointer)))
(defmethod fs-output-atomic-fn ((fsout linear) atomic-value)
(with-slots (stream) fsout
(format stream "~s" atomic-value)))
(defmethod fs-output-start-fs ((fsout linear) type depth labels)
(declare (ignore depth labels))
(with-slots (stream) fsout
(format stream "#D[~(~a~)" type)))
(defmethod fs-output-label-fn ((fsout linear) label depth old-x old-y path)
(declare (ignore depth old-x old-y path))
(with-slots (stream) fsout
(format stream " ~a: " label)))
(defmethod fs-output-end-fs ((fsout linear) terminal)
(declare (ignore terminal))
(with-slots (stream) fsout
(format stream "]")))
;;; linear print is used by the following
(defparameter *pprint-abbreviate-dags-p* t)
(defmethod print-object ((object dag) (stream t))
;; default dag structure output during lisp code tracing etc
;; effectively ignores *print-level* etc since control never passes out
;; to lisp printer again
(cond
(*print-readably*
;; print so object can be read back into lisp
(call-next-method))
(*pprint-abbreviate-dags-p*
(format stream "#D[~(~a~) ...]" (dag-type object)))
(t
;; usual case
(display-dag1 object 'linear stream))))
;;; ****** TDL printing operations **********
(defclass tdl (fs-output-type)
((new-fs-p :accessor tdl-new-fs-p
:initform t)
(indentation-vector :accessor edit-indentation-vector
:initform (make-array '(3000)))))
(defmethod fs-output-start-fn ((fsout tdl))
(with-slots (stream) fsout
(format stream "~V%" 1)))
(defmethod fs-output-end-fn ((fsout tdl))
nil)
(defmethod fs-output-reentrant-value-fn ((fsout tdl) reentrant-pointer)
(with-slots (stream indentation) fsout
(format stream
"~VT#~A & "
indentation
reentrant-pointer)
(setf indentation
(cond ((> indentation 53) (terpri stream) 3)
(t (+ 12 indentation))))))
(defmethod fs-output-reentrant-fn ((fsout tdl) reentrant-pointer)
(with-slots (stream indentation) fsout
(format stream "~VT#~A" indentation reentrant-pointer)))
(defmethod fs-output-atomic-fn ((fsout tdl) atomic-value)
(with-slots (stream indentation) fsout
(if (stringp atomic-value)
(format stream "~VT~S" indentation atomic-value)
(format stream "~VT~A" indentation
(string-downcase atomic-value)))))
(defmethod fs-output-start-fs ((fsout tdl) type depth labels)
(declare (ignore labels))
(with-slots (stream indentation indentation-vector new-fs-p) fsout
(if (eql type *toptype*)
(format stream "~VT[ " indentation)
(if (stringp type)
(format stream "~VT ~S & [ " indentation type)
(format stream "~VT ~A & [ " indentation (string-downcase type))))
(setf new-fs-p t)
(setf (aref indentation-vector depth) (+ indentation 2))))
(defmethod fs-output-label-fn ((fsout tdl) label depth stored-x stored-y
rpath)
(declare (ignore stored-x stored-y rpath))
(with-slots (stream indentation indentation-vector new-fs-p) fsout
(setf indentation (aref indentation-vector depth))
(unless new-fs-p
(format stream ",~%~VT" indentation))
(setf new-fs-p nil)
(format stream "~A " label)
(setf indentation (+ indentation 7))
(when (> indentation 65) (terpri stream) (setf indentation 1))))
(defmethod fs-output-end-fs ((fsout tdl) terminal)
(declare (ignore terminal))
(with-slots (stream indentation) fsout
(format stream " ]")
(incf indentation)))
;;; ****** compact TDL format (inspired by Chris Manning :-) ******
(defclass compact (fs-output-type)
((initialp :accessor initialp :initform t)))
(defmethod fs-output-start-fn ((fsout compact))
nil)
(defmethod fs-output-end-fn ((fsout compact))
nil)
(defmethod fs-output-reentrant-value-fn ((fsout compact) value)
(with-slots (stream) fsout
(format stream "#~a & " value)))
(defmethod fs-output-reentrant-fn ((fsout compact) value)
(with-slots (stream) fsout
(format stream "#~a" value)))
(defmethod fs-output-atomic-fn ((fsout compact) value)
(with-slots (stream) fsout
(if (stringp value)
(format stream "~s" value)
(format stream "~(~a~)" value))))
(defmethod fs-output-start-fs ((fsout compact) type foo bar)
(declare (ignore foo bar))
(with-slots (stream indentation initialp) fsout
(if (eq type *toptype*)
(format stream "[ " indentation)
(if (stringp type)
(format stream "~s & [~%" type)
(format stream "~(~a~) & [~%" type)))
(incf indentation 2)
(setf initialp t)))
(defmethod fs-output-label-fn ((fsout compact)
label depth foo bar baz)
(declare (ignore depth foo bar baz))
(with-slots (stream indentation initialp) fsout
(unless initialp (format stream ",~%"))
(setf initialp nil)
(format stream "~vt~a " indentation label)))
(defmethod fs-output-end-fs ((fsout compact) terminal)
(declare (ignore terminal))
(with-slots (stream indentation) fsout
(format stream " ]")
(setf indentation (max (- indentation 2) 0))))
;;; ******* LiLFeS printing operations ***********
(defclass lilfes (fs-output-type)
((new-fs-p :accessor lilfes-new-fs-p
:initform t)))
(defmethod fs-output-start-fn ((fsout lilfes))
nil)
(defmethod fs-output-end-fn ((fsout lilfes))
nil)
(defmethod fs-output-reentrant-value-fn ((fsout lilfes) reentrant-pointer)
(with-slots (stream) fsout
(format stream
"($~A & "
reentrant-pointer)))
;; no terpris
(defmethod fs-output-reentrant-value-endfn ((fsout lilfes))
(with-slots (stream) fsout
(format stream ")")))
(defmethod fs-output-reentrant-fn ((fsout lilfes) reentrant-pointer)
(with-slots (stream) fsout
(format stream "$~A" reentrant-pointer)))
(defmethod fs-output-atomic-fn ((fsout lilfes) atomic-value)
(with-slots (stream) fsout
(if (stringp atomic-value)
(format stream "~S" atomic-value)
(format stream "'~A'"
(string-downcase
(convert-lilfes-type atomic-value))))))
(defmethod fs-output-start-fs ((fsout lilfes) type depth labels)
(declare (ignore labels depth))
(with-slots (stream new-fs-p) fsout
(if (eql type *toptype*)
(format stream "(")
(if (stringp type)
(format stream "(~S & " type)
(format stream "('~A' & "
(string-downcase (convert-lilfes-type type)))))
(setf new-fs-p t)))
(defmethod fs-output-label-fn ((fsout lilfes) label depth stored-x stored-y
rpath)
(declare (ignore depth stored-x stored-y rpath))
(with-slots (stream new-fs-p) fsout
(unless new-fs-p
(format stream " & "))
(setf new-fs-p nil)
(format stream "~A\\" (convert-lilfes-feature label))))
(defmethod fs-output-end-fs ((fsout lilfes) terminal)
(declare (ignore terminal))
(with-slots (stream) fsout
(format stream ")")))
;;; ***** simple print operations ************
;;; used by tty display
(defclass simple (fs-output-type)
((indentation-vector :accessor edit-indentation-vector
:initform (make-array '(3000)))))
(defmethod fs-output-start-fn ((fsout simple))
(with-slots (stream) fsout
(format stream "~V%" 1)))
(defmethod fs-output-end-fn ((fsout simple))
(with-slots (stream) fsout
(format stream "~V%" 1)))
(defmethod fs-output-reentrant-value-fn ((fsout simple) reentrant-pointer)
(with-slots (stream indentation) fsout
(format stream
"~VT<~A> = "
indentation
reentrant-pointer)
(setf indentation
(cond ((> indentation 53) (terpri stream) 3)
(t (+ 12 indentation))))))
(defmethod fs-output-reentrant-fn ((fsout simple) reentrant-pointer)
(with-slots (stream indentation) fsout
(format stream "~VT<~A>" indentation reentrant-pointer)))
(defmethod fs-output-atomic-fn ((fsout simple) atomic-value)
(with-slots (stream indentation) fsout
(format stream "~VT~A" indentation atomic-value)))
(defmethod fs-output-start-fs ((fsout simple) type depth labels)
(declare (ignore labels))
(with-slots (stream indentation indentation-vector) fsout
(format stream "~VT[~A" indentation type)
(setf (aref indentation-vector depth) (+ indentation 2))))
(defmethod fs-output-label-fn ((fsout simple) label depth stored-x stored-y
rpath)
(declare (ignore stored-x stored-y rpath))
(with-slots (stream indentation indentation-vector) fsout
(setf indentation (aref indentation-vector depth))
(format stream "~%~VT~A: " indentation label)
(setf indentation (+ indentation 7))
(when (> indentation 65) (terpri stream) (setf indentation 1))))
(defmethod fs-output-end-fs ((fsout simple) terminal)
(declare (ignore terminal))
(with-slots (stream indentation) fsout
(format stream "]")
(incf indentation)))
;;; ***** `edit' print operations ************
;;; are used by graphical display
(defclass edit (fs-output-type)
((type-label-list :accessor edit-type-label-list
:initform nil)
(indentation-vector :accessor edit-indentation-vector
:initform (make-array '(3000)))))
(defmethod fs-output-error-fn ((fsout edit) dag-instance)
(declare (ignore dag-instance))
(with-slots (stream) fsout
(format stream
"~%No feature structure~%")))
(defmethod fs-output-start-fn ((fsout edit))
(with-slots (stream) fsout
(format stream "~V%" 1)))
(defmethod fs-output-end-fn ((fsout edit))
(with-slots (stream) fsout
(format stream "~V%" 1)))
(defmethod fs-output-reentrant-value-fn ((fsout edit) reentrant-pointer)
(with-slots (stream indentation max-width type-label-list) fsout
(move-to-x-y stream indentation (current-position-y stream))
(with-bold-output stream
(let ((start-pos (current-position stream)))
(add-active-pointer stream start-pos reentrant-pointer
type-label-list t)))
(setf indentation (current-position-x stream))
(setf max-width (max indentation max-width))))
(defmethod fs-output-reentrant-fn ((fsout edit) reentrant-pointer)
(with-slots (stream indentation type-label-list max-width) fsout
(move-to-x-y stream indentation (current-position-y stream))
(with-bold-output stream
(let ((start-pos (current-position stream)))
(add-active-pointer stream start-pos reentrant-pointer
type-label-list nil)))
(setf max-width (max (current-position-x stream) max-width))
(pop type-label-list)))
(defmethod fs-output-atomic-fn ((fsout edit) atomic-value)
(with-slots (stream indentation type-label-list max-width) fsout
(let ((y-pos (current-position-y stream)))
(move-to-x-y stream indentation y-pos)
; make start-pos the actual place where the type label starts!!
(let ((start-pos (current-position stream)))
(add-type-and-active-fs-region stream start-pos type-label-list
atomic-value nil t)
(setf max-width (max (current-position-x stream) max-width))
(pop type-label-list)))))
(defmethod fs-output-start-fs ((fsout edit) type depth labels)
(declare (ignore labels))
(with-slots (stream indentation indentation-vector type-label-list
max-width) fsout
(let ((y-pos (current-position-y stream)))
(move-to-x-y stream indentation y-pos)
(write-char #\[ stream)
(let ((start-pos (current-position stream)))
(add-type-and-active-fs-region stream start-pos type-label-list
type nil nil)
(setf max-width (max (current-position-x stream) max-width))
(setf (aref indentation-vector depth)
(+ indentation (stream-string-width stream "[")))))))
(defmethod fs-output-shrunk-fn ((fsout edit) type)
(with-slots (stream indentation type-label-list max-width) fsout
(let ((y-pos (current-position-y stream))
(start-pos (current-position stream)))
(move-to-x-y stream indentation y-pos)
(add-type-and-active-fs-region stream start-pos
type-label-list type t nil)
(frame-text-box stream start-pos (current-position stream))
(setf max-width (max (current-position-x stream) max-width))
(pop type-label-list))))
(defmethod fs-output-shrinks ((fsout edit))
t)
(defmethod fs-output-label-fn ((fsout edit) label depth stored-x stored-y
rpath)
(with-slots (stream indentation indentation-vector
type-label-list max-width) fsout
(push label type-label-list)
(setf indentation (aref indentation-vector depth))
(terpri stream)
;; write-char #\newline goes wrong on PC
(if (and stored-x stored-y)
(move-to-x-y stream stored-x stored-y)
(move-to-x-y stream indentation (current-position-y stream)))
(store-fs-record-data-label stream rpath)
(let ((output-label (concatenate 'string (symbol-name label)
": ")))
(write-string output-label stream))
(setf indentation (current-position-x stream))
(setf max-width (max indentation max-width))))
(defun make-output-label (real-name)
;;; removed feature abbreviation facility - probably never used
(write-to-string real-name :case :upcase))
(defmethod fs-output-end-fs ((fsout edit) terminal)
(declare (ignore terminal))
(with-slots (stream type-label-list indentation max-width) fsout
(setq type-label-list (cdr type-label-list))
(write-char #\] stream)
(setf indentation
(+ indentation (stream-string-width stream "]")))
(setf max-width (max (current-position-x stream) max-width))))
;; following are to speed up redisplay e.g. when scrolling
(defmethod fs-output-no-need-to-display ((fsout edit) rpath)
(with-slots (stream box) fsout
(store-fs-redisplay stream rpath box)))
(defmethod fs-output-record-start
((fsout edit) rpath flag pointer)
(with-slots (stream) fsout
(store-fs-record-data stream rpath flag pointer)))
(defmethod fs-output-record-end ((fsout edit) rpath)
(with-slots (stream) fsout
(store-fs-record-data-end stream rpath)))
;;; ********* outputting Antonio's TeX macros ***********
#|
macro definitions
\newcommand{\avmplus}[1]{{\setlength{\arraycolsep}{0.8mm}
\renewcommand{\arraystretch}{1.2}
\left[
\begin{array}{l}
\\[-2mm] #1 \\[-2mm] \\
\end{array}
\right]
}}
%
\newcommand{\att}[1]{{\mbox{\small {\bf #1}}}}
\newcommand{\attval}[2]{{\mbox{\small {\sc #1}}\ =\ {{#2}}}}
\newcommand{\attvaltyp}[2]{{\mbox{\small{\sc #1}}\ =\ {\myvaluebold{#2}}}}
\newcommand{\attvalshrunktyp}[2]{{\mbox{\small{\sc #1}}\ =\ {\boxvaluebold{#2}}}}
\newcommand{\myvaluebold}[1]{{\mbox{\small {\bf #1}}}}
\newcommand{\boxvaluebold}[1]{{\fbox{\small {\bf #1}}}}
\newcommand{\ind}[1]{{\setlength{\fboxsep}{0.5mm} \: \fbox{{\small #1}} \:}}
|#
;;; \ has to be inserted into the format as a character ~C
(defclass tex (fs-output-type)
((indentation-vector :accessor edit-indentation-vector
:initform (make-array '(3000)))
(bracket-stack :accessor tex-bracket-stack :initform nil)
(unoutput-label :accessor tex-unoutput-label :initform nil)))
(defmethod fs-output-start-fn ((fsout tex))
;; $
(with-slots (stream) fsout
(format stream "$")))
(defmethod fs-output-end-fn ((fsout tex))
;; $
;;
(with-slots (stream) fsout
(format stream "$")
(format stream "~V%" 1)))
(defmethod fs-output-reentrant-value-fn ((fsout tex) reentrant-pointer)
;; \attval{label}{\ind{number}}\\
(with-slots (stream indentation unoutput-label) fsout
(format stream "\\\\~%~VT\\attval{~A}{\\ind{~A}}"
indentation (convert-values-for-tex unoutput-label)
reentrant-pointer)
(setf unoutput-label nil)
(setf indentation
(cond ((> indentation 53) (terpri stream) 3)
(t (+ 12 indentation))))))
(defmethod fs-output-reentrant-fn ((fsout tex) reentrant-pointer)
(with-slots (stream indentation unoutput-label) fsout
(format stream "\\\\~%~VT\\attval{~A}{\\ind{~A}}"
indentation (convert-values-for-tex unoutput-label)
reentrant-pointer)
(setf unoutput-label nil)))
(defmethod fs-output-atomic-fn ((fsout tex) atomic-value)
;; \attvaltyp{label}{value}\\
(with-slots (stream indentation unoutput-label) fsout
(if unoutput-label
(format stream "\\\\~%~VT\\attvaltyp{~A}{~A}"
indentation (convert-values-for-tex unoutput-label)
(convert-values-for-tex atomic-value))
(format stream "\\ \\ \\myvaluebold{~A}"
(convert-values-for-tex atomic-value)))
(setf unoutput-label nil)))
(defmethod fs-output-shrunk-fn ((fsout tex) type)
(with-slots (stream indentation unoutput-label) fsout
(if unoutput-label
(format stream "\\\\~%~VT\\attvalshrunktyp{~A}{~(~A~)}"
indentation (convert-values-for-tex unoutput-label)
(convert-values-for-tex type))
(format stream "\\ \\ \\boxvaluebold{~(~A~)}"
(convert-values-for-tex type)))
(setf unoutput-label nil)))
(defmethod fs-output-shrinks ((fsout tex))
t)
(defmethod fs-output-start-fs ((fsout tex) type depth labels)
(with-slots (stream indentation indentation-vector bracket-stack
unoutput-label) fsout
(cond
((and unoutput-label labels)
(format stream
"\\\\~%~VT\\attval{~A}{\\avmplus{\\att{~(~A~)}"
indentation (convert-values-for-tex unoutput-label)
(convert-values-for-tex type))
;; \attval{label}{\avmplus{\att{type}\\
(push 2 bracket-stack)
(setf unoutput-label nil))
(labels
(format stream "~VT\\avmplus{\\att{~(~A~)}"
indentation (convert-values-for-tex type))
;; \avmplus{\att{label}\\
(push 1 bracket-stack))
(unoutput-label
(format stream
"\\\\~%~VT\\attvaltyp{~A}{~(~A~)}"
indentation (convert-values-for-tex unoutput-label)
(convert-values-for-tex type))
(setf unoutput-label nil)
(push 0 bracket-stack))
(t (format stream "~VT\\ \\ \\myvaluebold{~(~A~)}"
indentation (convert-values-for-tex type))
(push 0 bracket-stack)))
(setf (aref indentation-vector depth) (+ indentation 2))))
(defmethod fs-output-label-fn ((fsout tex) label depth stored-x stored-y
rpath)
(declare (ignore stored-x stored-y rpath))
(with-slots (stream indentation indentation-vector unoutput-label) fsout
(setf indentation (aref indentation-vector depth))
(setf indentation (+ indentation 7))
(setf unoutput-label label)))
(defmethod fs-output-end-fs ((fsout tex) terminal)
(declare (ignore terminal))
(with-slots (stream bracket-stack) fsout
(dotimes (x (pop bracket-stack))
(format stream "}"))))
;;; TeX support functions
(defun convert-values-for-tex (at-val)
(let ((value (format nil "~A" at-val))
(char-bag nil))
(loop for char in (coerce value 'list)
do
(when (char= char #\_)
(push #\\ char-bag))
(push char char-bag))
(coerce (nreverse char-bag) 'string)))
;;; ********** Paths *************
;;; Output paths in notation defined for types etc
;;; this is the original LKB version, with the type feature
;;; notation in the paths
(defclass pathout (fs-output-type)
((reentrant-vector :accessor pathout-reentrant-vector
:initform (make-array '(3000)))
(type-label-list :accessor pathout-type-label-list
:initform nil)))
(defmethod fs-output-start-fn ((fsout pathout))
(with-slots (stream) fsout
(format stream "~V%" 1)))
(defmethod fs-output-end-fn ((fsout pathout))
(with-slots (stream) fsout
(format stream ".~V%" 1)))
(defmethod fs-output-reentrant-value-fn ((fsout pathout) reentrant-pointer)
(with-slots (reentrant-vector type-label-list) fsout
(setf (aref reentrant-vector reentrant-pointer)
type-label-list)))
(defmethod fs-output-reentrant-fn ((fsout pathout) reentrant-pointer)
(with-slots (stream type-label-list reentrant-vector) fsout
(output-typed-list stream type-label-list)
(format stream " = ")
(output-typed-list stream
(aref reentrant-vector reentrant-pointer))
(pop type-label-list)
(format stream "~%")))
(defmethod fs-output-atomic-fn ((fsout pathout) atomic-value)
(with-slots (stream type-label-list) fsout
(output-typed-list stream type-label-list)
(format stream " = ~A~%" atomic-value)
(pop type-label-list)))
(defmethod fs-output-start-fs ((fsout pathout) type depth labels)
(declare (ignore labels depth))
(with-slots (type-label-list) fsout
(push type type-label-list)))
(defmethod fs-output-label-fn ((fsout pathout) label depth stored-x stored-y
rpath)
(declare (ignore depth stored-x stored-y rpath))
(with-slots (type-label-list) fsout
(push label type-label-list)))
(defmethod fs-output-end-fs ((fsout pathout) terminal)
(with-slots (stream type-label-list) fsout
(when terminal
(output-typed-list stream (cdr type-label-list))
(format stream " = ~A~%" (car type-label-list)))
(pop type-label-list)
(pop type-label-list)))
;;; support function
(defun output-typed-list (stream type-label-list)
(let ((ordered-list (reverse type-label-list)))
(format stream "< ~A ~A " (car ordered-list)
(cadr ordered-list))
(when (cddr ordered-list)
(format stream "~{: ~A ~A ~}"
(cddr ordered-list)))
(format stream ">")))
;;; **** another version of paths ******
;;; this is a simpler version, with no types on
;;; paths
(defclass pathout2 (fs-output-type)
((reentrant-vector :accessor pathout2-reentrant-vector
:initform (make-array '(3000)))
(type-label-list :accessor pathout2-type-label-list
:initform nil)))
(defmethod fs-output-start-fn ((fsout pathout2))
nil)
(defmethod fs-output-end-fn ((fsout pathout2))
(with-slots (stream) fsout
(format stream ".~V%" 1)))
(defmethod fs-output-reentrant-value-fn ((fsout pathout2) reentrant-pointer)
(with-slots (reentrant-vector type-label-list) fsout
(setf (aref reentrant-vector reentrant-pointer)
type-label-list)))
(defmethod fs-output-reentrant-fn ((fsout pathout2) reentrant-pointer)
(with-slots (stream type-label-list reentrant-vector) fsout
(format stream "~%")
(output-typed-list2 stream type-label-list)
(format stream " = ")
(output-typed-list2 stream
(aref reentrant-vector reentrant-pointer))
(pop type-label-list)))
(defmethod fs-output-atomic-fn ((fsout pathout2) atomic-value)
(with-slots (stream type-label-list) fsout
(format stream "~%")
(output-typed-list2 stream type-label-list)
(format stream " = ~A" atomic-value)
(pop type-label-list)))
(defmethod fs-output-start-fs ((fsout pathout2) type depth labels)
(declare (ignore labels depth))
(with-slots (type-label-list) fsout
(push type type-label-list)))
(defmethod fs-output-label-fn ((fsout pathout2) label depth stored-x stored-y
rpath)
(declare (ignore depth stored-x stored-y rpath))
(with-slots (type-label-list) fsout
(push label type-label-list)))
(defmethod fs-output-end-fs ((fsout pathout2) terminal)
(with-slots (stream type-label-list) fsout
(when terminal
(format stream "~%")
(output-typed-list2 stream (cdr type-label-list))
(format stream " = ~(~A~)" (car type-label-list)))
(pop type-label-list)
(pop type-label-list)))
;;; support fn
(defun output-typed-list2 (stream type-label-list)
(let ((ordered-list (reverse type-label-list)))
(format stream "< ~A "
(cadr ordered-list))
(when (cddr ordered-list)
(do* ((feat (cadddr ordered-list) (cadr rest))
(rest (cddddr ordered-list) (cddr rest)))
((null feat) nil)
(format stream ": ~A " feat)))
(format stream ">")))
;;; ******** Output shrunkenness *********
;;; eg the way a feature structure is displayed is defined by
;;; specifying a series of paths
(defclass shrunk (fs-output-type)
((label-list :accessor shrunk-label-list
:initform nil)
(shrunk-list :accessor shrunk-shrunk-list
:initform nil)))
(defmethod fs-output-start-fn ((fsout shrunk))
nil)
(defmethod fs-output-end-fn ((fsout shrunk))
nil)
(defmethod fs-output-reentrant-value-fn ((fsout shrunk) reentrant-pointer)
(declare (ignore reentrant-pointer))
nil)
(defmethod fs-output-reentrant-fn ((fsout shrunk) reentrant-pointer)
(declare (ignore reentrant-pointer))
(with-slots (label-list) fsout
(pop label-list)))
(defmethod fs-output-atomic-fn ((fsout shrunk) atomic-value)
(declare (ignore atomic-value))
(with-slots (label-list) fsout
(pop label-list)))
(defmethod fs-output-shrinks ((fsout shrunk))
t)
(defmethod fs-output-shrunk-fn ((fsout shrunk) type)
(declare (ignore type))
(with-slots (label-list shrunk-list) fsout
(let ((ordered-list (reverse label-list)))
(push ordered-list shrunk-list)
(pop label-list))))
(defmethod fs-output-start-fs ((fsout shrunk) type depth labels)
(declare (ignore type depth labels))
nil)
(defmethod fs-output-label-fn ((fsout shrunk)
label depth stored-x stored-y
rpath)
(declare (ignore depth stored-x stored-y rpath))
(with-slots (label-list) fsout
(push label label-list)))
(defmethod fs-output-max-width-fn ((fsout shrunk))
;;; need to return a value (nothing to do with max-width ...)
(with-slots (shrunk-list) fsout
shrunk-list))
(defmethod fs-output-end-fs ((fsout shrunk) terminal)
(declare (ignore terminal))
(with-slots (label-list) fsout
(pop label-list)))
;;;
;;; ************* Shrinking paths in types **********
;;;
(def-lkb-parameter *shrunk-types* nil)
(defvar *shrunk-local-dags* nil)
(defvar *not-shrunk-local-dags* nil)
#|
(defun set-up-display-settings (file-name)
(with-open-file
(istream file-name :direction :input)
(loop for setting in-stream istream
do
(unless (get-type-entry (car setting))
(error "Type ~A not found" (car setting)))
(loop for path in (cdr setting)
do
(unless (listp path)
(error "~A is not a valid path" path))
(pushnew (nconc (reverse path) (list (car setting))) *shrunk-types*
:test #'equal)))))
|#
(defun set-up-display-settings (filename)
(when (and filename
(probe-file filename))
(with-open-file (stream filename
:direction :input)
(setf *shrunk-types* (read stream nil nil)))))
(defun set-dag-display-value (fs f-list action type-fs-display)
(let* ((sub-dag
(if (tdfs-p fs) (existing-dag-at-end-of (tdfs-indef fs) f-list) nil))
(type
(type-of-fs (if (tdfs-p fs) (tdfs-indef fs) fs)))
(spec
(nconc (reverse f-list) (list type))))
(if (eql action :shrink)
(progn
;; shrink a currently expanded node - remove any block on this particular
;; node being shrunk, add it to the local list of shrunk nodes, and
;; if this is a type definition record the path to the root of the fs
;; as a shrunk path
(when sub-dag
(setf (tdfs-not-shrunk fs) ; override any globally-set shrunk path
(remove sub-dag (tdfs-not-shrunk fs) :test #'eq))
(pushnew sub-dag (tdfs-shrunk fs) ; in addition to any globally-set shrunk paths
:test #'eq))
(when type-fs-display (pushnew spec *shrunk-types* :test #'equal)))
(progn
;; expand a node which is currently shrunk - remove it from the local list
;; of shrunk nodes, block any path saying that this node should be shrunk,
;; and if this is a type definition remove any record of the path to root
;; being a shrunk path
(when sub-dag
(setf (tdfs-shrunk fs)
(remove sub-dag (tdfs-shrunk fs) :test #'eq))
;; we maybe don't quite get the expected behaviour if a user has unshrunk
;; a local node, shrunk a matching path in a type definition, and comes
;; back and redisplays this dag: the local node won't be shrunk because
;; it's on the local not-shrunk list
(pushnew sub-dag (tdfs-not-shrunk fs) :test #'eq))
(when type-fs-display
(setq *shrunk-types* (remove spec *shrunk-types* :test #'equal)))))))
;;;
;;; *********** Display functions ************
;;;
(defun display-dag (dag-instance device &optional file-name)
(flet ((display (dag-instance device stream)
(cond
((dag-p dag-instance)
(display-dag1 dag-instance device stream))
((tdfs-p dag-instance)
(display-dag2 dag-instance device stream))
(t (error "Not a feature structure")))))
(if file-name
(with-open-file (stream file-name :direction :output :if-exists :supersede
:if-does-not-exist :create)
(display dag-instance device stream))
(display dag-instance device t))))
(defparameter *no-type* nil
"if this is set via optional argument to display-dag1 instead
of using the real first type in a feature structure, the code in print-dag-aux is
called on *toptype*. This is for conversion of type constraints
for PAGE and LiLFeS")
(defun display-dag1 (dag-instance device stream &optional x-pos
no-first-type box)
(def-print-operations device (or x-pos 0) stream box)
(let ((*no-type* no-first-type))
(cond ((dag-p dag-instance)
(invalidate-visit-marks)
(mark-dag-for-output dag-instance)
(setf *reentrancy-pointer* 0)
(fs-output-start-fn *display-structure*)
(print-dag dag-instance 0 nil)
(fs-output-end-fn *display-structure*)
(fs-output-max-width-fn *display-structure*))
(t (fs-output-error-fn *display-structure*
dag-instance)))))
(defun mark-dag-for-output (dag-instance)
(let ((real-dag (follow-pointers dag-instance)))
(cond
((dag-visit real-dag)
(setf (dag-visit real-dag) 'double))
(t
(setf (dag-visit real-dag) 'single)
(dolist (arc (dag-arcs real-dag))
(let ((label (dag-arc-attribute arc)))
(mark-dag-for-output (get-dag-value real-dag label))))))))
(defun print-dag (dag-instance depth rpath)
(let* ((real-dag (deref-dag dag-instance)))
(multiple-value-bind (dont-display-p stored-flag stored-pointer
stored-label-pos)
(fs-output-no-need-to-display *display-structure* rpath)
(unless dont-display-p
(let ((new-rpath (cons (type-of-fs real-dag) rpath))
(flag-value (or stored-flag (dag-visit real-dag))))
(declare (dynamic-extent new-rpath))
(fs-output-record-start *display-structure* rpath
flag-value *reentrancy-pointer*)
(cond
((eq flag-value 'double)
(setf (dag-visit real-dag)
(or stored-pointer *reentrancy-pointer*))
(incf *reentrancy-pointer*)
(fs-output-reentrant-value-fn *display-structure*
(dag-visit real-dag))
(print-dag-aux real-dag depth new-rpath stored-label-pos)
(fs-output-reentrant-value-endfn *display-structure*))
((eq flag-value 'single)
(print-dag-aux real-dag depth new-rpath stored-label-pos))
(t (fs-output-reentrant-fn *display-structure*
flag-value)))
(fs-output-record-end *display-structure* rpath))))))
(defun print-dag-aux (real-dag depth rpath stored-label-pos)
(cond
((not (has-features real-dag))
(fs-output-atomic-fn *display-structure* (type-of-fs real-dag)))
((and (fs-output-shrinks *display-structure*)
;; shrink it if it is locally specified as shrunk, or it's
;; globally specified and not overriden locally (really
;; should test for shrunk-fn method being defined first)
(or (member real-dag *shrunk-local-dags* :test #'eq)
(and (find rpath *shrunk-types* :test #'print-dag-shrunk-match-p)
(not (member real-dag *not-shrunk-local-dags* :test #'eq)))))
(fs-output-shrunk-fn *display-structure* (dag-type real-dag)))
(t
(let* ((type (if *no-type*
*toptype*
(type-of-fs real-dag)))
(labels (top-level-features-of real-dag))
(start-x nil)
(start-y nil))
(setf *no-type* nil)
(if labels
(progn
(fs-output-start-fs *display-structure* type depth labels)
(loop for label in (canonical-order type labels)
do
(when stored-label-pos
(setf start-x (caar stored-label-pos))
(setf start-y (cdar stored-label-pos))
(setf stored-label-pos
(cdr stored-label-pos)))
(fs-output-label-fn *display-structure*
label depth start-x start-y (cdr rpath))
(let ((new-rpath (cons label rpath)))
(declare (dynamic-extent new-rpath))
(print-dag (get-dag-value real-dag label)
(+ 1 depth) new-rpath)))
(fs-output-end-fs *display-structure*
(null labels)))
(fs-output-atomic-fn *display-structure*
(list type))))))
(setf *no-type* nil))
(defun print-dag-shrunk-match-p (x y)
;; x is an alternating list of types and features representing the current place
;; in the fs, y is a shrunk path spec consisting of a list of features followed by
;; a type. Both are in 'reverse' order (i.e. deeper features first). Return true
;; if y an initial segment of x, modulo type subsumption at the end of x
;; e.g. true for x = (VERB HEAD CAT CAT LOCAL LOCAL PHR_SYNSEM SYNSEM ROOT_CLAUSE),
;; y = (HEAD CAT LOCAL CANONICAL_SYNSEM) if PHR_SYNSEM < CANONICAL_SYNSEM
;; and for x = (ROOT_CLAUSE), y = (CANONICAL_SYNSEM), and for
;; x = (*DIFF-LIST* H-STORE BASICMRS C-CONT HCOMP_RULE), y = (*DIFF-LIST*)
(cond
((null (cdr y))
(or (eq (car x) (car y)) (subtype-p (car x) (car y))))
((eq (cadr x) (car y))
(print-dag-shrunk-match-p (cddr x) (cdr y)))))
;;; We want a standard order on the features - otherwise the output becomes
;;; very difficult to read.
(defun canonical-order (type dag-attributes)
(let* ((type (get-type-entry type))
(ordered-attributes (when type (ltype-appfeats type))))
(stable-sort (copy-list dag-attributes)
#'(lambda (x y)
(member y (member x ordered-attributes))))))