;;analyze lexical entry and dig out te list of subcategorizations as needed ;; returns the list of entry subcategorizations (defun get-entry-subcat(entry) ;; analyze only verbs (let ((descr (second entry))) (when (equal (first descr) 'V)) ;; entry is in the form (word description) (let ((subcat (assoc 'subcat (cdr descr)))) ;; subcat is now (subcat _xp) iff it exists (when subcat (cond ((atom (second subcat)) (list (second subcat))) ((eql (car (second subcat)) '?) (cddr (second subcat))) ))))) ;; given a lexicon, figure out all possible subcategorization frames ;; return a list of subcat values without duplicates (defun get-subcats (lexicon) (let ((slist (mapcar #'get-entry-subcat lexicon))) ;; remove duplicate entries and nils from slist, ;; previously having glued its sublists together (remove-duplicates (remove-if #'null (apply #'append slist))))) ;; given a subcat, generate a vp rule for it ;; we need a unique rule identifier. ;; I use -vp-auto_subcat> (defun generate-vp-rule (subcat) (let ((complements nil)) (when (not (eql subcat '_none)) (setq complements (parse-subcat subcat))) (append ;; (vp (main +) (passgap -)) -vp-auto_subcat> (head (v (subcat _subcat))) (list '(vp (main +) (passgap -)) (right-var subcat '-vp-auto '>) (list 'head (list 'v (list 'subcat subcat))) ) ;; the complements complements))) (defun parse-subcat (subcat) (let ((slist (break-string #\_ (symbol-name subcat)))) ;; break the subcat name into the list of subcat specs (mapcar #'make-complement slist)) ) ;; takes a string and breaks it into a list of substrings at char (defun break-string (char str) (let ((cpos (position char str))) (cond ((null str) ;; do not do anything if the string is empty nil) ((null cpos) ;; no such chars in string - nothing to break (list str)) ((> cpos 0) ;; non-null substring before the symbol ;; cons the substring before the char with the result of processing the rest of it (cons (subseq str 0 cpos) (break-string char (subseq str (+ cpos 1))))) (t ;; the string starts with char, we ignore it and analyze the rest (break-string char (subseq str 1))) ))) ;;takes the string of the sort _cp-cp-type and makes it into ;; (cp (ptype cp-type)) (defun make-complement (compl) (let ((cl (break-string #\- compl))) (cond ((null cl) nil) ;; do not do anything with an empty constit ((eql (length cl) 1) ;; a phrase and nothing else ;; "xp" -> xp (list (read-from-string (first cl)))) (t ;; oterwise deal with parameters (make-complement-with-features cl)) ))) ;; takes the phrase name and the list of features and checks that it can handle them ;; if it cannot, ignores them and prints a warning (defun make-complement-with-features (clist) (let ( (cat (read-from-string (first clist))) ;; complement category, e.g np (feats (mapcar #'read-from-string (cdr clist))) ;; feature values ) (cond ((eql cat 'pp) (cons 'pp (make-pp-feat-spec feats))) ((eql cat 'vp) (cons 'vp (make-vp-feat-spec feats))) (t ;; unknown phrase type - ignore features (list cat))) )) ;; given the PP feature values values, makes up the specification (defun make-pp-feat-spec (vals) (cond ((eql (length vals) 1) ;; just 1 value. ;; Will have to add (pred -) for correct handling of semantics (list (list 'ptype (first vals)) ) ) ((eql (second vals) 'pred) ;; will have to add (pred +) and sme feature for correct handling of semantics (list (list 'ptype (first vals)) ) ))) ;; given the VP feature values, makes up the specification (defun make-vp-feat-spec (vals) (cond ((eql (length vals) 1) ;; just 1 value. ;; Will have to add the expression of subject control in sem feature for correct handling of semantics (list (list 'vform (first vals)) ) ) ((eql (second vals) 'subj) ;; will have to add expression of subject control in sem feature for correct handling of semantics (list (list 'vform (first vals)) ) ) ((eql (second vals) 'obj) ;; will have to add expression of object control in sem feature for correct handling of semantics (list (list 'vform (first vals)) ) ) (t ;;error! nil) )) (defun generate-subcat-rules (lexicon) (cons '(headfeatures (vp vform agr)) (mapcar #'generate-vp-rule (get-subcats lexicon)))) ;; ;; Given the name and the suffix, makes a variable name out of it ;; (defun right-var (name pref suf) (cond ((and pref suf) (read-from-string (format nil "~S~S~S" pref name suf))) (suf (read-from-string (format nil "~S~S" name suf))) (pref (read-from-string (format nil "~S~S" pref name))) (t name)))