;;;; feature-display.el --- macros for checking f-structure ;;;; descriptions and displaying f-structures. For use with GNU Emacs. ;; Author: Mary Dalrymple ;; Keywords: lfg xle ;; This file is not a part of GNU Emacs, but is made available under ;; the same conditions. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;###autoload (defun feature-display-mode () "Mode for displaying feature structures." (interactive) (kill-all-local-variables) (setq major-mode 'feature-display-mode) (setq mode-name "F-description") (fdisp-mode-variables) (use-local-map fdisp-mode-map)) ;;; Set these variables to nil to turn off debugging. (defvar fdisp-debug-mode t "*If true, causes debugging display for possibly ill-formed feature structures.") (defvar fdisp-type-check-mode nil "*If true, causes debugging display for feature coocurrence checks.") (defvar fdisp-debug-reentrancies-mode nil "*If true, causes debugging display for possible incorrect reentrancies.") ;;; Automatically loaded for files ending in ".fdsc". (setq auto-mode-alist (append '(("\\.fdsc" . feature-display-mode)) auto-mode-alist)) ;;; Variables for the mode (defun fdisp-mode-variables () ;; Turn on fonts in different colors. (add-hook 'fdisp-mode-hook 'turn-on-font-lock) (make-local-variable 'font-lock-defaults) (setq font-lock-defaults '(fdisp-font-lock-keywords nil nil ((?_ . "w")))) ;; Blink matching parentheses. (make-local-variable 'blink-matching-paren) (setq blink-matching-paren t) ;; Turn off auto-fill. (make-local-variable 'auto-fill-function) (setq auto-fill-function nil) ;; Raise the eval depth. (make-local-variable 'max-lisp-eval-depth) (setq max-lisp-eval-depth 1000) (run-hooks 'fdisp-mode-hook)) ;;; Key mappings (defvar fdisp-mode-map (make-sparse-keymap) "Keymap used in feature display mode.") ;;; Menu items (define-key fdisp-mode-map [menu-bar fstr] (cons "FDesc" (make-sparse-keymap "FDesc"))) ;; Produces an abbreviated version of an f-description, or writes ;; abbreviated versions of all f-descriptions in current file. (define-key fdisp-mode-map [menu-bar fstr fdisp-pred-arg-file] '("Write pred-arg descriptions from current file" . fdisp-pred-arg-file)) (define-key fdisp-mode-map "\e\C-p" 'fdisp-pred-arg-file) (define-key fdisp-mode-map [menu-bar fstr fdisp-pred-arg] '("Produce pred-arg description of current f-description" . fdisp-pred-arg)) (define-key fdisp-mode-map "\e\C-t" 'fdisp-pred-arg) ;; Display a feature structure (define-key fdisp-mode-map [menu-bar fstr fdisp-expression-numbers] '("Display current f-description with indices" . fdisp-expression-numbers)) (define-key fdisp-mode-map "\e\C-f" 'fdisp-expression-numbers) (define-key fdisp-mode-map [menu-bar fstr fdisp-expression] '("Display current f-description" . fdisp-expression)) (define-key fdisp-mode-map "\e\C-d" 'fdisp-expression) ;; Check a description (if fdisp-debug-mode (define-key fdisp-mode-map [menu-bar fstr fstr-desc-check-all] '("Check current and following f-descriptions" . fstr-desc-check-all))) (define-key fdisp-mode-map "\e\C-a" 'fstr-desc-check-all) (if fdisp-debug-mode (define-key fdisp-mode-map [menu-bar fstr fstr-desc] '("Check current f-description" . fstr-desc-check))) (define-key fdisp-mode-map "\e\C-c" 'fstr-desc-check) (defvar fdisp-font-lock-keywords '(("^[ \t]*sentence_form" . 'font-lock-string-face) ("^[ \t]*sentence" . 'font-lock-string-face) ("^[ \t]*structure" . 'font-lock-function-name-face) ("^[ \t]*id([-_.,/a-z0-9 ]+)" . 'font-lock-string-face) ("^[ \t]*date(200[0-9].1?[0-9].[123]?[0-9])" . 'font-lock-string-face) ("^[ \t]*validators([-',.A-Za-z0-9 ]+)" . 'font-lock-string-face) ("~[0-9]+" . 'font-lock-string-face)) "Expressions to highlight in f-description display mode.") ;;;;;;;;;Definitions for well-formedness checks. ; Exhaustive list of attributes with their permitted values. Use ; "FSTR" for f-structure values, "ANY" if you do not want the value ; checked. (defvar fdesc-function-names '(("pred" ("ANY")) ("subj" ("FSTR")) ("obj" ("FSTR")) ("obj_theta" ("FSTR")) ("comp" ("FSTR")) ("xcomp" ("FSTR")) ("obl" ("FSTR")) ("obl_compar" ("FSTR")) ("obl_ag" ("FSTR")) ("adjunct" ("FSTR")) ("name_mod" ("FSTR")) ("mod" ("FSTR")) ("topic" ("FSTR")) ("topic_rel" ("FSTR")) ("pron_rel" ("FSTR")) ("pron_int" ("FSTR")) ("focus" ("FSTR")) ("focus_int" ("FSTR")) ("poss" ("FSTR")) ("conj" ("FSTR")) ("aquant" ("FSTR")) ("quant" ("FSTR")) ("number" ("FSTR")) ("adegree" ("comparative" "positive" "superlative")) ("adeg_dim" ("positive" "negative" "equative")) ("adjunct_type" ("cleft" "conditional" "degree" "extent" "manner" "negative" "nominal" "parenthetical" "purpose" "quant" "quote-paren" "relative" "temporal" "unspecified")) ("adv_type" ("advmod" "affix" "amod" "amod-int" "conjmod" "delimiter" "focus" "initadv" "npadv" "nummod" "pmod" "sadv" "timeadv" "unspecified" "vpadv")) ("atype" ("attributive" "predicative")) ("base" ("+")) ("case" ("acc" "gen" "nom")) ("comp_form" ("for" "if" "null" "that" "whether")) ("compar_form" ("than" "as")) ("coord_form" ("and" "and/or" "but" "nor" "null" "or" "plus" "then" "vs" "/" "," ";" ":")) ("coord_level" ("ANY")) ("deixis" ("distal" "proximal")) ("det_form" ("a" "another" "that" "the" "these" "this" "those")) ("det_type" ("def" "demon" "indef")) ("emphasis" ("+")) ("gend_sem" ("female" "male" "nonhuman")) ("gerund" ("+")) ("inf_form" ("to")) ("mood" ("imperative" "indicative" "subjunctive")) ("num" ("pl" "sg")) ("number_type" ("cardinal" "ordinal")) ("partitive" ("+")) ("passive" ("+")) ("pcase" ("a" "about" "above" "absent" "across" "adjacent" "after" "ahead" "against" "along" "amid" "among" "around" "apart" "as" "aside" "as early as" "as late as" "at" "atop" "away" "back" "because" "before" "behind" "below" "beneath" "beside" "besides" "between" "beyond" "by" "close" "concerning" "down" "despite" "due" "during" "except" "exclusive" "for" "from" "in" "inside" "instead" "into" "irrespective of" "like" "near" "next" "of" "off" "on" "onto" "opposite" "other than" "out" "outside" "over" "past" "per" "prior" "pursuant" "rather than" "round" "sans" "since" "such as" "than" "till" "through" "throughout" "to" "toward" "towards" "under" "underneath" "unlike" "until" "unspecified" "up" "upon" "via" "with" "within" "without" "x")) ("perf" ("+")) ("pers" ("1" "2" "3")) ("polarity" ("-")) ("precoord_form" ("both" "either" "neither")) ("prog" ("+")) ("pron_form" ("another" "anyone" "anybody" "anything" "anywhere" "each other" "everybody" "everything" "everyone" "everywhere" "he" "here" "hers" "his" "how" "how come" "how many" "how much" "however" "I" "it" "mine" "most" "my" "nobody" "no one" "nothing" "nowhere" "null" "ours" "she" "somebody" "someone" "something" "sometime" "somewhere" "that" "theirs" "there" "these" "they" "this" "those" "we" "what" "what if" "whatever" "whatsoever" "when" "whenever" "where" "wherever" "which" "whichever" "who" "whom" "whoever" "whose" "whosever" "whosoever" "why" "you" "yours")) ("pron_type" ("demon" "expletive" "free" "interrogative" "locative" "null" "pers" "quant" "poss" "recip" "refl" "relative")) ("proper" ("location" "name" "title" "misc" "date")) ("prt_form" ("back" "down" "in" "off" "on" "out" "over" "up" "aside" "away" "about" "around" "open" "round" "together" "through" "along")) ("ptype" ("nonsemantic" "semantic")) ("quant_type" ("comparative")) ("stmt_type" ("conditional" "declarative" "header" "imperative" "interrogative" "purpose")) ("subord_form" ("that" "null" "whether" "for")) ("tense" ("fut" "past" "pres")) ("topic_type" ("left-dislocated" "simple")) ("vconstr" ("cleft" "extraposition")) ("vtype" ("copular" "main" "modal"))) "Features and their values") ; Checks f-structures that are values of particular grammatical ; functions. You can also specify particular attributes and possibly ; their values that the f-structure must have in order for checking to ; occur, or "ANY" if all instances should be checked. ; Format: ; (grammatical_function constraining_attrs forbidden_attrs required_attrs) ; Each "attrs" list should be a list consisting of attributes or ; attribute-value pairs to be checked. Examples: ; ; ("gf" ("ANY") () ("attr")) ; Check all values of attribute "gf"; the attribute "attr" must be ; present. ; ; ("gf" ("attr") () ("attr2")) ; Check values of attribute "gf" which contain the attribute ; "attr"; the attribute "attr2" must also be present. ; ; ("gf" (("attr" "val") "attr2") () (("attr3" "val3") "attr4") ; Check values of attribute "gf" which contain the attribute ; "attr" with value "val" as well as attribute "attr2"; the attribute ; "attr3" with value "val3" as well as the attribute "attr4" must also ; be present. ; ; More than one instance of a grammatical function may be present with ; different constraints. (defvar fdesc-gf-restrs '(("adjunct" ("atype") () ("adjunct_type")) ("conj" ("ANY") ("pcase") ()) ("mod" ("ANY") ("adjunct_type") ("pers" "num")) ("obl" ("ANY") (("pron_type" "null")) ()) ("xcomp" ("ANY") () ("subj"))) "Lists of 4-tuples: first is gf of the f-structure; second is additional features of the f-structure that the check is conditioned on, or ANY if we want to check on all instances; third is attributes or attribute-value pairs that the f-structure may not have; fourth is attributes or attribute-value pairs that the f-structure must have.") ; Checks f-structures with particular attributes and values for ; additional required or forbidden attributes. Use "ANY" if the ; f-structure should be checked regardless of the value of the ; conditioning attribute. Format: ; constraining_attr its_value forbidden_attrs required_attrs ; Examples are as above. (defvar fdesc-attr-restrs '(("adegree" ("comparative") () ("adjunct")) ("atype" ("ANY") () ("adegree")) ("coord_level" ("ANY") () ("coord_form")) ("conj" ("ANY") () ("coord_form")) ("conj" ("ANY") () ("coord_level")) ("conj" ("ANY") ("subj") ()) ("focus_int" ("ANY") ("pron_rel") ()) ("pron_rel" ("ANY") ("focus_int") ("topic_rel")) ("pron_type" ("expletive") (("pred" "pro")) ()) ("tense" ("ANY") () ("mood" "vtype")) ("topic_rel" ("ANY") () ("pron_rel")) ("vtype" ("ANY") ("pron_type") ())) "Lists of 4-tuples: first is attribute we are interested in; second is its value, or ANY if we want to check all instances of the attribute; third is sister attributes which may not appear in the same f-structure, or lists of attribute-value pairs; fourth is sister attributes or attribute-value pairs that must appear in the same f-structure.") ;;;;;;; Check f-descriptions for well-formedness. ;;; Regular expressions for f-description sections (defvar fstr-desc-id "id([-_.,/a-z0-9 ]+)") (defvar fstr-desc-date "date(200[0-9].1?[0-9].[123]?[0-9])") (defvar fstr-desc-validators "validators([-',.A-Za-z0-9 ]+)") (defvar fstr-desc-sentence_form "sentence_form(.+)") (defvar fstr-desc-structure "[A-Za-z_]+([-A-Za-z0-9$.,+'/\\&%:; ]+~[0-9]+, [-A-Za-z0-9$.,+'/\\&%:; ]+\\(~[0-9]+\\)?)") (defun fstr-desc-check () "Checks the current f-description for well-formedness. Narrows buffer to current expression. Either returns t or exits with an error at the point where the description is not well-formed." (interactive) (let ((start-point (point))) (or (re-search-backward "^\\(sentence\\)\(" nil t) (re-search-forward "^\\(sentence\\)\(" nil t) (error "No f-description found")) (goto-char (match-end 1)) (forward-sexp 1) (save-restriction (narrow-to-region (match-end 1) (point)) (goto-char (point-min)) (fstr-desc-check-parts)) (goto-char start-point))) (defun fstr-desc-check-all () "Checks all the descriptions in the file for well-formedness. Either returns t or exits with an error at the point where the description is not well-formed." (interactive) (let ((start-point (point))) ; First check current structure (or (re-search-backward "^\\(sentence\\)\(" nil t) (re-search-forward "^\\(sentence\\)\(" nil t) (error "No f-description found")) (goto-char (- (match-end 0) 1)) (forward-sexp 1) (save-restriction (narrow-to-region (match-end 1) (point)) (goto-char (point-min)) (fstr-desc-check-parts)) ; Then check all the rest of the structures (while (looking-at "[ \t\n]*\\(sentence\\)(") (forward-word 1) (forward-sexp 1) (save-restriction (narrow-to-region (match-end 1) (point)) (goto-char (point-min)) (fstr-desc-check-parts))) (skip-chars-forward " \n\t") (if (eq (point) (point-max)) (progn (message "This and the following f-descriptions appear well-formed") (goto-char start-point)) (error "Ill-formed structure near here")))) (defun fstr-desc-check-parts () "Check the individual parts of the f-structure description." (fstr-check-line "id" (concat "([ \t\n]*" fstr-desc-id "[ \t\n]*")) (fstr-check-line "date" (concat fstr-desc-date "[ \t\n]*")) (fstr-check-line "validators" (concat fstr-desc-validators "[ \t\n]*")) (fstr-check-line "sentence_form" (concat fstr-desc-sentence_form "[ \t\n]*")) (fstr-check-structure)) (defun fstr-check-line (type expected) "See if what we expect to find is here. If it is not, let the user know." (if (looking-at expected) (goto-char (match-end 0)) (error "Field `%s' is missing or appears ill-formed" type))) (defun fstr-check-structure () "See if the elements of the structure field look well-formed." (if (looking-at "structure([ \t\n]*") (goto-char (match-end 0)) (error "No `structure' field")) ; All the members of the structure field should follow the ; definition of structure given by the regular expression above. We ; should see the close parens at the end. If we don't, we have found an ; ill-formed structure expression. (while (not (eq (point) (point-max))) (cond ((looking-at fstr-desc-structure) (progn (goto-char (match-end 0)) (skip-chars-forward " \t\n"))) ((looking-at ")") (skip-chars-forward " )\n\t")) (t (error "This or the previous line appears ill-formed")))) (if (eq (point) (point-max)) (message "This f-description appears well-formed") (error "This line appears ill-formed"))) ;;;;;;;;; Display a feature structure. (defun inferior-fdisp-mode () "Mode for displaying an f-structure corresponding to an f-description." (setq major-mode 'inferior-fdisp-mode) (setq mode-name "F-display") ;; Turn on fonts in different colors. (add-hook 'inferior-fdisp-mode-hook 'turn-on-font-lock) (make-local-variable 'font-lock-defaults) (setq font-lock-defaults '(inferior-fdisp-font-lock-keywords nil nil ((?_ . "w")))) ;; Turn off auto-fill. (make-local-variable 'auto-fill-function) (setq auto-fill-function nil) (run-hooks 'inferior-fdisp-mode-hook)) (defvar inferior-fdisp-font-lock-keywords '(("\\(INCORRECT PRED VALUE IN PREVIOUS LINE OR PREVIOUS F-STRUCTURE\\|UNCONNECTED PREDICATES:\\|POSSIBLE DUPLICATE REENTRANCY\\|ILL-FORMED FEATURE:\\|ILL-FORMED VALUE\\|OF FEATURE\\|FEATURE\\|ILLEGAL WITH\\|SHOULD BE PRESENT WITH\\)" . 'font-lock-warning-face)) "Expressions to highlight in feature display mode.") (defun fdisp-expression-numbers () (interactive) (fdisp-expression t)) (defun fdisp-expression (&optional numbers) (interactive) "Display a feature structure." (save-excursion (let ((home (current-buffer)) (point (point)) (fdisp-buffer (get-buffer-create "*Feature Expression Display*")) fdesc sentence reentr toppred) (fdisp-find-exp-beg) (setq sentence (fdisp-find-sentence)) (setq fdesc (fdisp-gather-f-features)) (setq toppred (nth 2 (assoc 0 fdesc))) (setq reentr (fdisp-compute-reentrancies fdesc toppred)) (switch-to-buffer-other-frame fdisp-buffer) (inferior-fdisp-mode) (erase-buffer) (insert (format "%s\n\n" sentence)) (fdisp-unconnected (fdisp-display-fstr (sort fdesc 'fdesc-sort) 0 toppred 0 reentr '() numbers '() nil)) (goto-char (point-min)) (switch-to-buffer-other-frame home) (goto-char point)))) ;;; Locate and gather information in the f-description. (defun fdisp-find-exp-beg () "Find the beginning of the expression that point is in, or go to the next expression." (end-of-line) (or (re-search-backward "^\\(sentence\\)\(" nil t) (re-search-forward "^\\(sentence\\)\(" nil t) (error "No f-description found"))) (defun fdisp-find-sentence () "Return the sentence form." (let (beg-exp) (re-search-forward "^sentence_form(" nil t) (forward-char -1) (setq beg-exp (point)) (forward-sexp 1) (substring (buffer-substring beg-exp (point)) 1 -1))) (defun fdisp-gather-f-features () "Gather up and return the f-features." (let (beg-exp fstrs) (re-search-forward "^structure(") (forward-char -1) (setq beg-exp (point)) (forward-sexp 1) (save-restriction (narrow-to-region beg-exp (point)) (goto-char (point-min)) (skip-chars-forward "( \n\t") (while (looking-at "\\([^(\n]+\\)(\\([^~\n]+\\)~\\([0-9]+\\), \\(.+~\\)?\\([^\n\t]+\\))[ \t]*[)]?[ \t]*$") (setq fstrs (cons (fdisp-f-feature) fstrs)) (goto-char (match-end 0)) (skip-chars-forward " \n\t"))) ; Return the list of f-structure features fstrs)) (defun fdisp-f-feature () "Assemble an f-description from the predicate we are looking at. The predicate has the following form: match1(match2~match3, (match4~)match5)" (if (match-beginning 4) (list (string-to-int (buffer-substring (match-beginning 3) (match-end 3))) "gf" (buffer-substring (match-beginning 2) (match-end 2)) (buffer-substring (match-beginning 1) (match-end 1)) (string-to-int (buffer-substring (match-beginning 5) (match-end 5))) (substring (buffer-substring (match-beginning 4) (match-end 4)) 0 -1)) (list (string-to-int (buffer-substring (match-beginning 3) (match-end 3))) "feat" (buffer-substring (match-beginning 2) (match-end 2)) (buffer-substring (match-beginning 1) (match-end 1)) (buffer-substring (match-beginning 5) (match-end 5))))) (defun fdisp-compute-reentrancies (fdesc toppred) "Return a list of reentrancies in an f-structure. First check for reentrancy for the outermost f-structure; then check for each gf id in the structure. The result is a list of pairs, where the first member is the f-structure id and the second is the pred of the f-structure. We keep the pred to do spelling checks if needed later. " (let (reentr) (if (fdesc-reentrant 0 fdesc) (setq reentr (cons (list 0 toppred) reentr))) (while fdesc (if (string-equal (nth 1 (car fdesc)) "gf") (if (fdesc-reentrant (nth 4 (car fdesc)) (cdr fdesc)) (setq reentr (cons (list (nth 4 (car fdesc)) (nth 5 (car fdesc))) reentr)))) (setq fdesc (cdr fdesc))) reentr)) (defun fdesc-reentrant (id fdesc) "Succeeds if id is the value of some gf in fdesc." (if fdesc (if (eq id (nth 4 (car fdesc))) t (fdesc-reentrant id (cdr fdesc))))) ;;; Sort the f-description. (defun fdesc-sort (a b) "Sort an f-description so it displays nicely." (or (< (car a) (car b)) (and (= (car a) (car b)) (or (string-lessp (nth 1 a) (nth 1 b)) (and (string-equal (nth 1 a) (nth 1 b)) (fdesc-gf-order (nth 3 a) (nth 3 b))))))) (defun fdesc-gf-order (gf1 gf2) "Sort the grammatical functions in a reasonable order." (cond ((string-equal gf1 "subj") t) ((string-equal gf2 "subj") nil) ((string-equal gf1 "obj") t) ((string-equal gf2 "obj") nil) ((string-equal gf1 "obl") t) ((string-equal gf2 "obl") nil) ((string-equal gf1 "xcomp") t) ((string-equal gf2 "xcomp") nil) ((string-equal gf1 "comp") t) ((string-equal gf2 "comp") nil) ((string-equal gf1 "mod") t) ((string-equal gf2 "mod") nil) ((string-equal gf1 "name_mod") t) ((string-equal gf2 "name_mod") nil) ((string-equal gf1 "adjunct") nil) (t (string-lessp gf1 gf2)))) ;;; Display the f-structure. (defun fdisp-display-fstr (fd id pred indent reentr printed numbers dup-preds is-dup) "Display f-structure `id' with indentation `indent' according to fd. Keep track of reentrancies. Also keep track of the duplicate preds inside a coordinate structure, and mark the preds that are spelled the same, since they might be incorrectly duplicated instead of just marked as reentrant." (indent-to indent) ; If needed, check f-structures for well-formedness. (if fdisp-type-check-mode (fdisp-check-gfs (fdisp-gf-id (copy-alist fd) id) indent)) (cond ((and (assoc id reentr) (or (member id printed) (not (assoc id fd)))) ; Non-initial member of a reentrancy -- nothing to print ; but the f-str id and the pred name. (insert (format "[%s: %s]\n" id pred)) (or (string-equal pred (nth 1 (assoc id reentr))) (and fdisp-debug-mode (indent-to indent) (insert (format "| INCORRECT PRED VALUE IN PREVIOUS LINE OR PREVIOUS F-STRUCTURE\n"))))) ((or numbers (assoc id reentr)) ; F-str id needed: first member of a reentrancy, or we want ; all ids (insert (format "[%s]" id)) (setq indent (current-column)) (insert (format "| pred `%s'%s\n" pred (fdisp-dup-message is-dup (member id reentr)))) (or numbers (string-equal pred (nth 1 (assoc id reentr))) (and fdisp-debug-mode (indent-to indent) (insert (format "| INCORRECT PRED VALUE IN PREVIOUS LINE OR PREVIOUS F-STRUCTURE\n")))) (fdisp-display-fstr-rest fd id pred indent reentr printed numbers dup-preds)) (t ; Not a reentrancy, we don't want numbers (insert (format "| pred `%s'%s\n" pred (fdisp-dup-message is-dup nil))) (fdisp-display-fstr-rest fd id pred indent reentr printed numbers dup-preds)))) (defun fdisp-display-fstr-rest (fd id pred indent reentr printed numbers dup-preds) "Display the features and values of `id' other than the pred." (let (feat) (if (string-equal pred "coord") (setq dup-preds (append dup-preds (fdisp-get-pred-duplicates fd id)))) (while (setq feat (assoc id fd)) (fdisp-display-line feat fd pred indent reentr printed numbers dup-preds) (setq fd (delete feat fd)))) fd) (defun fdisp-get-pred-duplicates (fd id) "Get all of the pred names that appear more than once in the coordinate f-structure with id `id'. These might be duplicate preds from a reentrancy in a coordinate structure." (let (dup-preds (allpreds (fdisp-gather-all-preds (copy-alist fd) id))) (while allpreds (if (member (car allpreds) (cdr allpreds)) (setq dup-preds (cons (car allpreds) dup-preds))) (setq allpreds (cdr allpreds))) dup-preds)) (defun fdisp-gather-all-preds (fd id) "Gather all the pred names that appear in the f-structure `id'." (let (prednames feat) (while (setq feat (assoc id fd)) (setq fd (delete feat fd)) (if (string-equal (nth 1 feat) "gf") (setq prednames (append (list (nth 5 feat)) (fdisp-gather-all-preds fd (nth 4 feat)) prednames)))) prednames)) (defun fdisp-dup-message (is-dup is-reentr) "Give the correct message depending on whether or not this pred is a duplicate inside a coordinate structure." (if (and fdisp-debug-reentrancies-mode is-dup (not is-reentr)) " POSSIBLE DUPLICATE REENTRANCY" "")) (defun fdisp-display-line (feat fd pred indent reentr printed numbers dup-preds) "Display a line of f-structure. Format of feat is one of: (id gf pred feat val gf-pred) (id feat pred feat val) val is an atomic value (string) or id (int)." (indent-to indent) (cond ((string-equal (nth 1 feat) "feat") (insert (format "| %s %s\n" (nth 3 feat) (nth 4 feat)))) ((string-equal (nth 1 feat) "gf") (insert (format "| %s" (nth 3 feat))) (fdisp-display-fstr fd (nth 4 feat) (nth 5 feat) (+ 4 (+ indent (length (nth 3 feat)))) reentr (cons (nth 0 feat) printed) numbers dup-preds (member (nth 5 feat) dup-preds)))) (or (string-equal pred (nth 2 feat)) (and fdisp-debug-mode (indent-to indent) (insert (format "| INCORRECT PRED VALUE IN PREVIOUS LINE OR PREVIOUS F-STRUCTURE\n"))))) ;;; Well-formedness checking. (defun fdisp-gf-id (fd id) "Return the grammatical functions of the f-structure `id' as car of result, and its features and their values as cdr." (let (feat gfs (attr-vals (list (list "pred" (nth 2 (assoc id fd)))))) (while (setq feat (car fd)) (setq fd (cdr fd)) (cond ; id is value of feature feat ((and (integerp (nth 4 feat)) (= (nth 4 feat) id)) (setq gfs (cons (nth 3 feat) gfs))) ; id has feature feat with value val ((= (nth 0 feat) id) (if (string-equal (nth 1 feat) "gf") (setq attr-vals (cons (list (nth 3 feat) "FSTR") attr-vals)) (setq attr-vals (cons (list (nth 3 feat) (nth 4 feat)) attr-vals)))))) (if gfs (cons gfs attr-vals) (cons '("root") attr-vals)))) (defun fdisp-check-gfs (gfs-attr-vals indent) "Check to see that an f-structure description is well-formed. There are several cases. First, there may be restrictions on the values of certain grammatical functions. Second, there may be restrictions on which attributes can or must cooccur in the same f-structure. Third, each attribute-value pair must be a legal and correctly spelled pair. The car of gfs-attr-vals is the list of grammatical functions of id, and the cdr is its attribute value pairs." (let (avpair (avs (cdr gfs-attr-vals)) (gf-restrs (copy-alist fdesc-gf-restrs)) (attr-restrs (copy-alist fdesc-attr-restrs))) ; First check for coocurrence restrictions on grammatical ; functions. (while gf-restrs (if (member (caar gf-restrs) (car gfs-attr-vals)) (if (fdisp-has-attrs (nth 1 (car gf-restrs)) avs) (fdisp-check-neg-pos-constraint avs (nth 2 (car gf-restrs)) (nth 3 (car gf-restrs)) (caar gf-restrs) indent))) (setq gf-restrs (cdr gf-restrs))) ; Next check for any attribute/attribute coocurrence restrictions. (while attr-restrs (if (setq avpair (assoc (caar attr-restrs) avs)) (if (or (member (nth 1 avpair) (nth 1 (car attr-restrs))) (member "ANY" (nth 1 (car attr-restrs)))) (fdisp-check-neg-pos-constraint avs (nth 2 (car attr-restrs)) (nth 3 (car attr-restrs)) (caar attr-restrs) indent))) (setq attr-restrs (cdr attr-restrs))) ; Finally, check for illegal attribute or value names. (while avs (if (setq avpair (assoc (caar avs) fdesc-function-names)) (unless (or (member (nth 1 (car avs)) (nth 1 avpair)) (member "ANY" (nth 1 avpair))) (progn (insert (format "ILL-FORMED VALUE %s OF FEATURE %s\n" (nth 1 (car avs)) (caar avs))) (indent-to indent))) (progn (insert (format "ILL-FORMED FEATURE: %s\n" (caar avs))) (indent-to indent))) (setq avs (cdr avs))))) (defun fdisp-has-attrs (attrs avs) "Check whether the attribute-value pairs avs has the specified attrs." (or (string-equal "ANY" (car attrs)) ; any avs is ok (null attrs) ; there is no constraint (and (or (assoc (car attrs) avs) ; the attr is present (member (car attrs) avs)) ; the attr/val is present (fdisp-has-attrs (cdr attrs) avs)))) ; and the rest is ok too (defun fdisp-check-neg-pos-constraint (avs neg pos reason indent) "Check to see if the negative and positive constraints are compatible with avs." (while neg (cond ((stringp (car neg)) (or (not (assoc (car neg) avs)) (progn (insert (format "FEATURE %s ILLEGAL WITH %s\n" (car neg) reason)) (indent-to indent)))) ((listp (car neg)) (or (not (member (car neg) avs)) (progn (insert (format "FEATURE %s ILLEGAL WITH %s\n" (car neg) reason)) (indent-to indent))))) (setq neg (cdr neg))) (while pos (cond ((stringp (car pos)) (or (assoc (car pos) avs) (progn (insert (format "FEATURE %s SHOULD BE PRESENT WITH %s\n" (car pos) reason)) (indent-to indent)))) ((listp (car pos)) (or (member (car pos) avs) (progn (insert (format "FEATURE %s SHOULD BE PRESENT WITH %s\n" (car pos) reason)) (indent-to indent))))) (setq pos (cdr pos)))) ;;; Display unconnected predicates. (defun fdisp-unconnected (fd) "Display any remaining unconnected predicates." (goto-char (point-min)) (if (and fdisp-debug-mode fd) (progn (goto-char (point-min)) (insert "UNCONNECTED PREDICATES:\n\n") (while fd (if (string-equal (nth 1 (car fd)) "feat") (insert (format "%s(%s~%s, %s)\n" (nth 3 (car fd)) (nth 2 (car fd)) (nth 0 (car fd)) (nth 4 (car fd)))) (insert (format "%s(%s~%s, %s~%s)\n" (nth 3 (car fd)) (nth 2 (car fd)) (nth 0 (car fd)) (nth 5 (car fd)) (nth 4 (car fd))))) (setq fd (cdr fd))) (insert "\n\n") (goto-char (point-min))))) ;;;;;;;;;;;; Produce an abbreviated "pred-arg" version of an ;;;;;;;;;;;; f-description according to configuration file ;;;;;;;;;;;; (by default called pred-arg.el), which needs to be ;;;;;;;;;;;; readable by emacs, or write abbreviated versions of all ;;;;;;;;;;;; f-descriptions in current file. (defun fdisp-pred-arg () "Produce abbreviated `pred-arg' version of current f-description according to config file." (interactive) ; Get the config information (fdisp-get-config-info) ; Go to the beginning of the current expression and save the ; preamble material (save-excursion (let ((home (current-buffer)) (point (point)) (fdisp-buffer (get-buffer-create "*Pred-Arg Structure*")) pred-arg-desc) (fdisp-find-exp-beg) (setq pred-arg-desc (fdesc-produce-pred-arg)) (switch-to-buffer-other-frame fdisp-buffer) (erase-buffer) (feature-display-mode) (insert pred-arg-desc) (goto-char (point-min)) (switch-to-buffer-other-frame home) (goto-char point)))) (defun fdisp-pred-arg-file () "Produce abbreviated `pred-arg' version of each f-description in current file, according to config file, and write to a new file." (interactive) ; Get the config information (fdisp-get-config-info) ; Go to the beginning of the file and start reading f-descriptions (let ((home (current-buffer)) (point (point)) (fdisp-buffer (get-buffer-create "*Pred-Arg Structures from File*")) pred-arg-desc) (set-buffer fdisp-buffer) (erase-buffer) (set-buffer home) (goto-char (point-min)) (while (re-search-forward "\\(sentence([ \t\n]*id.*[ \t\n]*date.*\\)" nil t) (goto-char (match-beginning 0)) (fdisp-pred-arg) (setq pred-arg-desc (fdesc-produce-pred-arg)) (set-buffer fdisp-buffer) (insert pred-arg-desc) (set-buffer home)) (goto-char point) (switch-to-buffer-other-window fdisp-buffer) (goto-char (point-min)))) (defun fdisp-get-config-info () "Get the information about what attributes should be kept in the abbreviated description. By default it is kept in a file called `pred-arg'." (or (boundp 'fdesc-features) (let ((file (read-file-name "Config file for pred-arg structure (default: pred-arg): " default-directory "pred-arg"))) (load-file file) (or (boundp 'fdesc-features) (error "Config information not found in file %s" file))))) (defun fdesc-produce-pred-arg () "Produce and return abbreviated description corresponding to current f-description." (let (desc) (if (looking-at "\\(sentence([ \t\n]*id.*[ \t\n]*date.*[ \t\n]*validators.*[ \t\n]*sentence_form.*[ \t\n]*structure\\)") (progn (setq desc (buffer-substring (match-beginning 0) (match-end 0))) (goto-char (match-end 0)) (forward-sexp) (save-restriction (narrow-to-region (match-end 0) (point)) (goto-char (point-min)) (skip-chars-forward "\n\t (") (setq desc (concat desc "(" (substring (fdisp-gather-relevant-preds) 1) ")\n)\n\n")))) (error "F-description appears ill-formed")))) (defun fdisp-gather-relevant-preds () "We are sitting at the beginning of the list of f-features. Keep only the ones mentioned in fdesc-features." (let (feats) (while (looking-at "\\([^(\n]+\\)(\\([^ \t\n]+\\)~\\([0-9]+\\), \\(.+~\\)?\\([^ \t\n]+\\))[ \t]*[)]?[ \t]*$") (if (or (match-beginning 4) ; second argument is f-str (member (buffer-substring (match-beginning 1) (match-end 1)) fdesc-features) ; we want this feature (member (buffer-substring (match-beginning 5) (match-end 5)) (cdr (assoc (buffer-substring (match-beginning 1)(match-end 1)) fdesc-features)))) ;we want this ;value of this feature (setq feats (concat feats ",\n " (buffer-substring (match-beginning 0) (match-end 5)) ")"))) (goto-char (match-end 0)) (skip-chars-forward " \n\t")) (if feats feats " "))) (setq fdesc-features '( "passive", "det_form", "pron_form", "tense", "perf", "prog", "coord_form", "precoord_form", "prt_form", ("stmt_type", "declarative", "interrogative", "imperative", "conditional", "header"), ("subord_form", "that", "whether", "for") )) ;; not sure about subord_form since is often null