[developers] How to unify a type constraint onto a dag extracted from chart (LKB)
Berthold Crysmann
berthold.crysmann at gmail.com
Wed Jun 26 14:34:00 CEST 2013
On 26/06/13 14:18, Ann Copestake wrote:
> could you give more of the function you're using, please?
>
>
>
Sure. I attach my user-fns.lsp.
It;'s the function gen-extract-surface that's at stake.
Thanks for looking into this.
Berthold
--
Berthold Crysmann <crysmann at linguist.jussieu.fr>
CNRS, Laboratoire de linguistique formelle (UMR 7110), U Paris Diderot
Case 7031, 5 rue Thomas Mann, 75205 Paris cedex 13
Bureau 545, bâtiment Olympe de Gouges, rue Albert Einstein, 75013 Paris
-------------- next part --------------
;;; -*- Mode: Lisp; Coding: utf-8 -*-
;;; HaG (Hausa Grammar)
;;; Based on Matrix user-fns.lsp
;;; Post-generation remapping of tones (BC)
(in-package :lkb)
;;;
;;; identify characters that can form words; all other characters will create
;;; word boundaries and later be suppressed in tokenization.
;;;
(defun alphanumeric-or-extended-p (c)
(and (graphic-char-p c) (not (member c *punctuation-characters*))))
;;;
;;; determine surface order of constituents in rule: returns list of paths into
;;; feature structure of rule, i.e. (nil (args first) (args rest first)) for a
;;; binary rule, where the first list element is the path to the mother node of
;;; the rule.
;;;
(defun establish-linear-precedence (rule)
(let ((daughters
(loop
for args = (existing-dag-at-end-of rule '(args))
then (existing-dag-at-end-of args *list-tail*)
for daughter = (when args
(get-value-at-end-of args *list-head*))
for path = (list 'args) then (append path *list-tail*)
while (and daughter (not (eq daughter 'no-way-through)))
collect (append path *list-head*))))
(if (null daughters)
(cerror "Ignore it" "Rule without daughters")
(cons nil daughters))))
;;;
;;; detect rules that have orthographemic variation associated to them; those
;;; who do should only be applied within the morphology system; for the time
;;; being use value of NEEDS-AFFIX feature, though it would be nicer to rely
;;; on a type distinction of lexical rules or re-entrancy of ORTH.
;;;
(defun spelling-change-rule-p (rule)
(let ((affix (get-dag-value (tdfs-indef
(rule-full-fs rule)) 'needs-affix)))
(and affix (bool-value-true affix))))
;;;
;;; create feature structure representation of orthography value for insertion
;;; into the output structure of inflectional rules; somewhat more complicated
;;; than one might expect because of treatment for multi-word elements.
;;;
(defun make-orth-tdfs (orth)
(let ((unifs nil)
(tmp-orth-path *orth-path*))
(loop for orth-value in (split-into-words orth)
do
(let ((opath (create-path-from-feature-list
(append tmp-orth-path *list-head*))))
(push (make-unification :lhs opath
:rhs
(make-u-value
:type orth-value))
unifs)
(setq tmp-orth-path (append tmp-orth-path *list-tail*))))
(let ((indef (process-unifications unifs)))
(when indef
(setf indef (create-wffs indef))
(make-tdfs :indef indef)))))
;;;
;;; assign priorities to parser tasks and lexical entries
;;;
;;; ERB 2008-03-12 rule-priory has to return a value for every
;;; rule or the mmt system fails.
(defun rule-priority (rule)
(case (rule-id rule)
(subj 1000)
(t 0)))
(defun gen-rule-priority (rule)
(rule-priority rule))
(defun lex-priority (mrec)
(declare (ignore mrec))
800)
(defun gen-lex-priority (fs)
(declare (ignore fs))
800)
;;;
;;; determine path and file names for lexicon and leaf type cache files.
;;;
(defun set-temporary-lexicon-filenames nil
(let* ((version (or (find-symbol "*GRAMMAR-VERSION*" :common-lisp-user)
(and (find-package :lkb)
(find-symbol "*GRAMMAR-VERSION*" :lkb))))
(prefix
(if (and version (boundp version))
(remove-if-not #'alphanumericp (symbol-value version))
"lexicon")))
(setf *psorts-temp-file*
(make-pathname :name prefix
:directory (pathname-directory (lkb-tmp-dir))))
(setf *psorts-temp-index-file*
(make-pathname :name (concatenate 'string prefix ".idx")
:directory (pathname-directory (lkb-tmp-dir))))
(setf *leaf-temp-file*
(make-pathname :name (concatenate 'string prefix ".lfs")
:directory (pathname-directory (lkb-tmp-dir))))))
(defun bool-value-true (fs)
(and fs
(let ((fs-type (type-of-fs fs)))
(eql fs-type '+))))
(defun bool-value-false (fs)
(and fs
(let ((fs-type (type-of-fs fs)))
(eql fs-type '-))))
(defun gen-extract-surface (edge &optional (initialp t) &key cliticp stream)
(if stream
(let ((daughters (edge-children edge)))
(if daughters
(loop
for daughter in daughters
for foo = initialp then nil
do
(and (not (get-dag-value
(get-dag-value
(get-dag-value
(get-dag-value (tdfs-indef (edge-dag edge))
'SUPRA)
'LEN)
'LIST)
'FIRST)
)
(progn
(setf supra
(unify-dags
(tdfs-indef (ltype-tdfs (get-type-entry 'supra_reent))) (get-dag-value (tdfs-indef (edge-dag daughter))
'SUPRA)
) )
(setf tones (get-dag-value
(get-dag-value
supra
'TONE)
'LIST)
)
(setf lengths (get-dag-value
(get-dag-value supra
'LEN)
'LIST)
)
(setf rulename (unify-get-type (tdfs-indef (edge-dag daughter))))
)
)
(setf cliticp
(gen-extract-surface
daughter foo :cliticp cliticp :stream stream))
#+:logon finally
#+:logon
(setf (edge-lnk edge)
(mrs::combine-lnks
(edge-lnk (first daughters))
(edge-lnk (first (last daughters))))))
(let* ((entry (get-lex-entry-from-id (first (edge-lex-ids edge))))
(orth (format nil "~{~a~^ ~}" (lex-entry-orth entry)))
;;
;;
;; (orth (if (ppcre::scan "man$" orth)
;; (subseq orth 0 (- (length orth) 3))
;; orth))
(tdfs (and entry (lex-entry-full-fs entry)))
(type (and tdfs (type-of-fs (tdfs-indef tdfs))))
(string (string-downcase (copy-seq (first (edge-leaves edge)))))
;;; Map Tonal annotation to diacritics
(string (loop
do
(setf string (praf string rulename))
(setf string (tonelen string lengths tones))
(setf tones nil)
(setf lengths nil)
(if (and (boundp '*hag-demo*) *hag-demo*)
(return (composite-tone string))
(return string) ;;(tidy-tone string))
)
))
;;
;; _fix_me_
;; maybe we could be more courageous and just search for .orth.
;; as a sub-sequence of .string., starting at position .prefix.
;; (22-dec-06; oe)
(prefix (loop
for c across string
while (member c '(#\( #\" #\') :test #'char=)
count 1))
(suffix (min (length string) (+ prefix (length orth))))
(suffix (when (string-equal
orth string :start2 prefix :end2 suffix)
suffix))
(rawp (and suffix
(loop for c across orth thereis (upper-case-p c))))
(capitalizep
(ignore-errors
(loop
for match in '(proper-noun-lex
)
thereis (or (eq type match)
(subtype-p type match)))))
(cliticp (or cliticp
(and (> (length string) 0)
(char= (char string 0) #\')))))
(if rawp
(setf string
(concatenate 'string
(subseq string 0 prefix) orth (subseq string suffix)))
(when capitalizep
(loop
with spacep = t
for i from 0 to (- (length string) 1)
for c = (schar string i)
when (char= c #\Space) do (setf spacep t)
else when (char= c #\_)
do
(setf spacep t)
(setf (schar string i) #\Space)
else do
(when (and spacep (alphanumericp c))
(setf (schar string i) (char-upcase c)))
(setf spacep nil))))
(when (and (> (length string) 1)
(char= (char string 0) #\_)
(upper-case-p (char string 1)))
(setf string (subseq string 1)))
(when (and initialp (alphanumericp (schar string 0)))
(setf (schar string 0) (char-upcase (schar string 0))))
(unless (or initialp cliticp)
(format stream " "))
(let (#+:logon
(start (file-position stream)))
(loop
with hyphenp
for c across string
unless (and hyphenp (char= c #\space))
do (write-char c stream)
when (char= c #\-) do (setf hyphenp t)
else do (setf hyphenp nil))
#+:logon
(setf (edge-lnk edge)
(list :characters start (file-position stream))))
;;
;; finally, inform the caller as to whether we output something that
;; inhibits intervening space (e.g. `mid-July').
;;
(unless (string= orth "")
(member (schar orth (- (length orth) 1)) '(#\-) :test #'char=)))))
(let ((stream (make-string-output-stream)))
(gen-extract-surface edge initialp :stream stream)
(get-output-stream-string stream))))
(eval-when #+:ansi-eval-when (:load-toplevel :compile-toplevel :execute)
#-:ansi-eval-when (load eval compile)
(setf *gen-extract-surface-hook* 'gen-extract-surface))
(defun praf (string rulename)
(if (eql rulename lkb::'DO-PRON-IRULE)
(setf string (ppcre::regex-replace "^(.*)(ka|ki|shi|ta|mu|ku|su)$" string "\\1 \\2"))
)
string
)
(defun tonelen (string lengths tones)
(if (setf len (get-dag-value lengths 'FIRST))
(progn
(or (setf tone (get-dag-value tones 'FIRST))
(setf tone (get-dag-value (possibly-new-constraint-of (unify-get-type (unify-dags (create-typed-dag 'CONS) tones ))) 'FIRST ) ))
(setf string (map-tone-tfs string (type-of-fs tone) (type-of-fs len)))
(if (get-dag-value lengths 'REST)
(if (get-dag-value tones 'REST)
(setf string (tonelen string (get-dag-value lengths 'REST) (get-dag-value tones 'REST)))
(setf string (tonelen string (get-dag-value lengths 'REST)
(get-dag-value
(possibly-new-constraint-of
(unify-get-type (unify-dags (create-typed-dag 'CONS) tones )))
'REST )
)
)
)
)
)
)
string
)
(defun map-tone-tfs (string tone len)
;;; FIXME: tone pretty printing currently presupposes chart packing
;;; Does not really hurt, mais quand-même...
(setf vow (ppcre::regex-replace "^.*?(ai|au|[aeiou])[^aeiou]*$" string "\\1"))
(if (eql len lkb::'LONG)
(cond
((eql tone lkb::'HIGH)
(case (intern vow)
(|a| (setf string (ppcre::regex-replace "^(.*)([a])([^aeiou]*)$" string "\\1áá\\3")))
(|e| (setf string (ppcre::regex-replace "^(.*)([e])([^aeiou]*)$" string "\\1éé\\3")))
(|i| (setf string (ppcre::regex-replace "^(.*)([i])([^aeiou]*)$" string "\\1íí\\3")))
(|o| (setf string (ppcre::regex-replace "^(.*)([o])([^aeiou]*)$" string "\\1óó\\3")))
(|u| (setf string (ppcre::regex-replace "^(.*)([u])([^aeiou]*)$" string "\\1úú\\3")))
)
)
((eql tone lkb::'LOW)
(case (intern vow)
(|a| (setf string (ppcre::regex-replace "^(.*)([a])([^aeiou]*)$" string "\\1àà\\3")))
(|e| (setf string (ppcre::regex-replace "^(.*)([e])([^aeiou]*)$" string "\\1èè\\3")))
(|i| (setf string (ppcre::regex-replace "^(.*)([i])([^aeiou]*)$" string "\\1ìì\\3")))
(|o| (setf string (ppcre::regex-replace "^(.*)([o])([^aeiou]*)$" string "\\1òò\\3")))
(|u| (setf string (ppcre::regex-replace "^(.*)([u])([^aeiou]*)$" string "\\1ùù\\3")))
)
)
((eql tone lkb::'FALL)
(case (intern vow)
(|a| (setf string (ppcre::regex-replace "^(.*)([a])([^aeiou]*)$" string "\\1áà\\3")))
(|e| (setf string (ppcre::regex-replace "^(.*)([e])([^aeiou]*)$" string "\\1éè\\3")))
(|i| (setf string (ppcre::regex-replace "^(.*)([i])([^aeiou]*)$" string "\\1íì\\3")))
(|o| (setf string (ppcre::regex-replace "^(.*)([o])([^aeiou]*)$" string "\\1óò\\3")))
(|u| (setf string (ppcre::regex-replace "^(.*)([u])([^aeiou]*)$" string "\\1úù\\3")))
)
)
)
(cond
((eql tone lkb::'HIGH)
(case (intern vow)
(|ai| (setf string (ppcre::regex-replace "^(.*)(ai)([^aeiou]*)$" string "\\1áí\\3")))
(|au| (setf string (ppcre::regex-replace "^(.*)(au)([^aeiou]*)$" string "\\1áú\\3")))
(|a| (setf string (ppcre::regex-replace "^(.*)([a])([^aeiou]*)$" string "\\1á\\3")))
(|e| (setf string (ppcre::regex-replace "^(.*)([e])([^aeiou]*)$" string "\\1é\\3")))
(|i| (setf string (ppcre::regex-replace "^(.*)([i])([^aeiou]*)$" string "\\1í\\3")))
(|o| (setf string (ppcre::regex-replace "^(.*)([o])([^aeiou]*)$" string "\\1ó\\3")))
(|u| (setf string (ppcre::regex-replace "^(.*)([u])([^aeiou]*)$" string "\\1ú\\3")))
)
)
((eql tone lkb::'LOW)
(case (intern vow)
(|ai| (setf string (ppcre::regex-replace "^(.*)(ai)([^aeiou]*)$" string "\\1àì\\3")))
(|au| (setf string (ppcre::regex-replace "^(.*)(au)([^aeiou]*)$" string "\\1àù\\3")))
(|a| (setf string (ppcre::regex-replace "^(.*)([a])([^aeiou]*)$" string "\\1à\\3")))
(|e| (setf string (ppcre::regex-replace "^(.*)([e])([^aeiou]*)$" string "\\1è\\3")))
(|i| (setf string (ppcre::regex-replace "^(.*)([i])([^aeiou]*)$" string "\\1ì\\3")))
(|o| (setf string (ppcre::regex-replace "^(.*)([o])([^aeiou]*)$" string "\\1ò\\3")))
(|u| (setf string (ppcre::regex-replace "^(.*)([u])([^aeiou]*)$" string "\\1ù\\3")))
)
)
((eql tone lkb::'FALL)
(case (intern vow)
(|ai| (setf string (ppcre::regex-replace "^(.*)(ai)([^aeiou]*)$" string "\\1áì\\3")))
(|au| (setf string (ppcre::regex-replace "^(.*)(au)([^aeiou]*)$" string "\\1áù\\3")))
(|a| (setf string (ppcre::regex-replace "^(.*)([a])([^aeiou]*)$" string "\\1â\\3")))
(|e| (setf string (ppcre::regex-replace "^(.*)([e])([^aeiou]*)$" string "\\1ê\\3")))
(|i| (setf string (ppcre::regex-replace "^(.*)([i])([^aeiou]*)$" string "\\1î\\3")))
(|o| (setf string (ppcre::regex-replace "^(.*)([o])([^aeiou]*)$" string "\\1ô\\3")))
(|u| (setf string (ppcre::regex-replace "^(.*)([u])([^aeiou]*)$" string "\\1û\\3")))
)
)
)
)
string
)
(defun map-tone (string)
(setf string (ppcre::regex-replace "^([^aeiou]*)(a)(.*)_h:$" string "\\1áá\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(e)(.*)_h:$" string "\\1éé\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(i)(.*)_h:$" string "\\1íí\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(o)(.*)_h:$" string "\\1óó\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(u)(.*)_h:$" string "\\1úú\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(a)(.*)_l:$" string "\\1àà\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(e)(.*)_l:$" string "\\1èè\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(i)(.*)_l:$" string "\\1ìì\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(o)(.*)_l:$" string "\\1òò\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(u)(.*)_l:$" string "\\1ùù\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(au)(.*)_h$" string "\\1áú\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(ai)(.*)_h$" string "\\1áí\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(a)(.*)_h$" string "\\1á\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(e)(.*)_h$" string "\\1é\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(i)(.*)_h$" string "\\1í\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(o)(.*)_h$" string "\\1ó\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(u)(.*)_h$" string "\\1ú\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(a)(.*)_l$" string "\\1à\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(e)(.*)_l$" string "\\1è\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(i)(.*)_l$" string "\\1ì\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(o)(.*)_l$" string "\\1ò\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(u)(.*)_l$" string "\\1ù\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(a)(.*)_hl:$" string "\\1áà\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(e)(.*)_hl:$" string "\\1éè\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(i)(.*)_hl:$" string "\\1íì\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(o)(.*)_hl:$" string "\\1óò\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(u)(.*)_hl:$" string "\\1úù\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(au)(.*)_hl$" string "\\1áù\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(ai)(.*)_hl$" string "\\1áì\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(a)(.*)_hl$" string "\\1â\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(e)(.*)_hl$" string "\\1ê\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(i)(.*)_hl$" string "\\1î\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(o)(.*)_hl$" string "\\1ô\\3"))
(setf string (ppcre::regex-replace "^([^aeiou]*)(u)(.*)_hl$" string "\\1û\\3"))
)
(defun tidy-tone (string)
(setf string (ppcre::regex-replace-all "(áà)" string "âa"))
(setf string (ppcre::regex-replace-all "(áù)" string "âu"))
(setf string (ppcre::regex-replace-all "(áì)" string "âi"))
(setf string (ppcre::regex-replace-all "(éè)" string "êe"))
(setf string (ppcre::regex-replace-all "(íì)" string "îi"))
(setf string (ppcre::regex-replace-all "(óò)" string "ôo"))
(setf string (ppcre::regex-replace-all "(úù)" string "ûu"))
(setf string (ppcre::regex-replace-all "(áá)" string "aa"))
(setf string (ppcre::regex-replace-all "(éé)" string "ee"))
(setf string (ppcre::regex-replace-all "(íí)" string "ii"))
(setf string (ppcre::regex-replace-all "(óó)" string "oo"))
(setf string (ppcre::regex-replace-all "(úú)" string "uu"))
(setf string (ppcre::regex-replace-all "(àà)" string "àa"))
(setf string (ppcre::regex-replace-all "(àì)" string "ài"))
(setf string (ppcre::regex-replace-all "(àù)" string "àu"))
(setf string (ppcre::regex-replace-all "(èè)" string "èe"))
(setf string (ppcre::regex-replace-all "(ìì)" string "ìi"))
(setf string (ppcre::regex-replace-all "(òò)" string "òo"))
(setf string (ppcre::regex-replace-all "(ùù)" string "ùu"))
(setf string (ppcre::regex-replace-all "(á)" string "a"))
(setf string (ppcre::regex-replace-all "(é)" string "e"))
(setf string (ppcre::regex-replace-all "(í)" string "i"))
(setf string (ppcre::regex-replace-all "(ó)" string "o"))
(setf string (ppcre::regex-replace-all "(ú)" string "u"))
)
(defun composite-tone (string)
(setf string (ppcre::regex-replace-all "(áà)" string "ā̂"))
(setf string (ppcre::regex-replace-all "(áù)" string "âu"))
(setf string (ppcre::regex-replace-all "(áì)" string "âi"))
(setf string (ppcre::regex-replace-all "(éè)" string "ē̂"))
(setf string (ppcre::regex-replace-all "(íì)" string "ī̂"))
(setf string (ppcre::regex-replace-all "(óò)" string "ō̂"))
(setf string (ppcre::regex-replace-all "(úù)" string "ū̂"))
(setf string (ppcre::regex-replace-all "(áá)" string "ā"))
(setf string (ppcre::regex-replace-all "(éé)" string "ē"))
(setf string (ppcre::regex-replace-all "(íí)" string "ī"))
(setf string (ppcre::regex-replace-all "(óó)" string "ō"))
(setf string (ppcre::regex-replace-all "(úú)" string "ū"))
(setf string (ppcre::regex-replace-all "(àà)" string "ā̀"))
(setf string (ppcre::regex-replace-all "(àì)" string "ài"))
(setf string (ppcre::regex-replace-all "(àù)" string "àu"))
(setf string (ppcre::regex-replace-all "(èè)" string "ḕ"))
(setf string (ppcre::regex-replace-all "(ìì)" string "ī̀"))
(setf string (ppcre::regex-replace-all "(òò)" string "ṑ"))
(setf string (ppcre::regex-replace-all "(ùù)" string "ū̀"))
(setf string (ppcre::regex-replace-all "(à)" string "à"))
(setf string (ppcre::regex-replace-all "(è)" string "è"))
(setf string (ppcre::regex-replace-all "(ì)" string "ì"))
(setf string (ppcre::regex-replace-all "(ò)" string "ò"))
(setf string (ppcre::regex-replace-all "(ù)" string "ù"))
(setf string (ppcre::regex-replace-all "(â)" string "â"))
(setf string (ppcre::regex-replace-all "(ê)" string "ê"))
(setf string (ppcre::regex-replace-all "(î)" string "î"))
(setf string (ppcre::regex-replace-all "(ô)" string "ô"))
(setf string (ppcre::regex-replace-all "(û)" string "û"))
(setf string (ppcre::regex-replace-all "(á)" string "a"))
(setf string (ppcre::regex-replace-all "(é)" string "e"))
(setf string (ppcre::regex-replace-all "(í)" string "i"))
(setf string (ppcre::regex-replace-all "(ó)" string "o"))
(setf string (ppcre::regex-replace-all "(ú)" string "u"))
)
(defun instantiate-generic-lexical-entry (gle surface pred &optional carg)
(let ((tdfs (copy-tdfs-elements
(lex-entry-full-fs (if (gle-p gle) (gle-le gle) gle))))
(spath
(if carg '(SYNSEM LKEYS KEYREL CARG) '(SYNSEM LKEYS KEYREL PRED))))
(loop
with dag = (tdfs-indef tdfs)
for path in (list '(ORTH FIRST) spath)
for foo = (existing-dag-at-end-of dag path)
when foo do (setf (dag-type foo) *string-type*))
(let* ((surface (or
#+:logon
(case (gle-id gle)
(guess_n_gle
(format nil "/~a/" surface))
(decade_gle
(format nil "~as" surface)))
surface))
(unifications
(list
(make-unification
:lhs (create-path-from-feature-list
(append *orth-path* *list-head*))
:rhs (make-u-value :type surface))
(make-unification
:lhs (create-path-from-feature-list
(append *orth-path* *list-tail*))
:rhs (make-u-value :type *empty-list-type*))
(make-unification
:lhs (create-path-from-feature-list spath)
:rhs (make-u-value :type (or carg pred)))))
(indef (process-unifications unifications))
(indef (and indef (create-wffs indef)))
(overlay (and indef (make-tdfs :indef indef))))
(values
(when overlay
(with-unification-context (ignore)
(let ((foo (yadu tdfs overlay)))
(when foo (copy-tdfs-elements foo)))))
surface))))
(defun extract-strings-from-parse-record nil
(loop
for edge in *parse-record*
collect (extract-string-from-p-edge edge)))
(defun extract-string-from-p-edge (edge)
(or (edge-string edge)
(let ((string
(cond
((fboundp *gen-extract-surface-hook*)
(funcall *gen-extract-surface-hook* edge))
(t (g-edge-leaves edge)))))
(setf (edge-string edge) string))))
;;;(defun find-infl-pos (unifs orths sense-id)
;;; (declare (ignore unifs orths sense-id))
;;; nil)
More information about the developers
mailing list