;;; -*- Mode: LISP; Package: CGP; BASE: 10; Syntax: ANSI-Common-Lisp; -*- ;; ;; Copyright (C) Paul Meurer 1999, 2000. All rights reserved. ;; paul.meurer@hit.uib.no ;; HIT-centre, University of Bergen ;; ;; Version 0.9 ;; ;; Constraint Grammar Parser ;; (See Fred Karlsson et.al.: Constraint Grammar, Mouton de Gruyter 1995) ;; ;;------------------------------------------------------------------------------------- ;; TO DO: ;; ;;------------------------------------------------------------------------------------- (in-package "CGP") (pushnew :rule-tree *features*) ;(setf *features* (delete :rule-tree *features*)) #+test (progn (load "projects:cgp;rules;nbo.lisp") (load "projects:cgp;rules;norsk-map.lisp") (load "projects:cgp;rules;norsk-syn.lisp")) #+old (defclass constraint-node () ((constraint :initform nil :initarg :constraint :reader constraint) (parent-constraint :initform nil :initarg :parent :reader parent-constraint) (child-constraints :initform () :accessor child-constraints))) #+old (defclass partial-constraint-node (constraint-node) ((rules :initform nil :initarg :rules :accessor constraint-rules) (constraint-node :initform nil :initarg :constraint-node :reader constraint-node))) (defclass constraint-node () ((constraint :initform nil :initarg :constraint :reader constraint) (parent-constraint :initform nil :initarg :parent :reader parent-constraint) (child-constraints :initform () :accessor child-constraints) (rules :initform nil :initarg :rules :accessor constraint-rules))) (defmethod add-rule-to-tree ((cg constraint-grammar) feature+rule tree) (let* ((rule (if (consp feature+rule) (cdr feature+rule) feature+rule)) (constraints (rule-constraints rule))) (labels ((add (constraints tree) (let ((constraint (car constraints))) (if (null constraint) (pushnew feature+rule (constraint-rules tree)) (let ((sub-tree (find constraint (child-constraints tree) :test #'equal :key #'constraint))) (when (null sub-tree) (setf sub-tree (make-instance 'constraint-node :constraint constraint :parent tree ;:constraint-node sub-tree :rules (when (null (cdr constraints)) (list feature+rule)))) (push sub-tree (child-constraints tree))) (add (cdr constraints) sub-tree)))))) (add constraints tree)))) #+old (defmethod add-rule-to-tree ((cg constraint-grammar) feature+rule partial-tree) (with-slots (constraint-tree) cg (let* ((rule (if (consp feature+rule) (cdr feature+rule) feature+rule)) (constraints (rule-constraints rule))) (labels ((add (constraints tree partial-tree) (let ((constraint (car constraints))) (if (null constraint) (pushnew feature+rule (constraint-rules partial-tree)) (let ((sub-tree (find constraint (child-constraints tree) :test #'equal :key #'constraint))) (unless sub-tree (setf sub-tree (make-instance 'constraint-node :constraint constraint :parent tree)) (push sub-tree (child-constraints tree))) (let ((sub-partial-tree (find constraint (child-constraints partial-tree) :test #'equal :key #'constraint))) (when (null sub-partial-tree) (setf sub-partial-tree (make-instance 'partial-constraint-node :constraint constraint :parent partial-tree :constraint-node sub-tree :rules (when (null (cdr constraints)) (list feature+rule)))) (push sub-partial-tree (child-constraints partial-tree))) (add (cdr constraints) sub-tree sub-partial-tree))))))) (add constraints constraint-tree partial-tree))))) #+test (defun memo-check-constraint (constraint-node cg sentence position constraint boundary-mode link-pos link-code check-all-p readings) (if constraint (let* ((table (if check-all-p *constraints-memo-table/check-all* *constraints-memo-table*)) (memo (gethash constraint-node table))) (if (and memo (= (car memo) *memo-counter*)) (values-list (cdr memo)) (multiple-value-bind (satisfied-p/readings link-pos link-code) (check-constraint cg sentence position constraint boundary-mode link-pos link-code check-all-p readings) (if memo (setf (car memo) *memo-counter* (cadr memo) satisfied-p/readings (caddr memo) link-pos (cadddr memo) link-code) (setf (gethash constraint-node table) (list *memo-counter* satisfied-p/readings link-pos link-code))) (values satisfied-p/readings link-pos link-code)))) t)) (defun memo-check-constraint (constraint-node cg sentence position constraint boundary-mode link-pos link-code check-all-p readings) (declare (ignore constraint-node)) (check-constraint cg sentence position constraint boundary-mode link-pos link-code check-all-p readings)) (defmacro do-tree-rules ((rule cg rule-tree sentence position &optional boundary-mode) &body body) (let (;(constraint-node (gensym)) (constraint (gensym)) (next-constraint (gensym)) (check-all-p (gensym)) (satisfied-p/readings (gensym)) (link-pos (gensym)) (link-code (gensym)) (rules (gensym)) #+rule-tree-xx(%rule (gensym)) (c/a-p (gensym)) (not-c/a-p (gensym)) (c/a-satisfied-p/readings (gensym)) (c/a-link-pos (gensym)) (c/a-link-code (gensym))) `(labels ((walk (tree link-position link readings) (let* ((,constraint (constraint tree)) (,rules (constraint-rules tree)) (,c/a-p nil) ; T if constraint has been tested (,not-c/a-p nil) ,c/a-satisfied-p/readings ,c/a-link-pos ,c/a-link-code ,satisfied-p/readings ,link-pos ,link-code) (when ,rules (multiple-value-setq (,satisfied-p/readings ,link-pos ,link-code) (check-constraint ,cg ,sentence ,position ,constraint ,boundary-mode link-position link)) (setf ,not-c/a-p t) (when ,satisfied-p/readings (dolist (,rule ,rules) ; simpler for syntactic disambiguation (progn ,@body)) #+rule-tree-xx (dolist (,%rule ,rules) (let ((,rule (cond ((atom ,%rule) ,%rule) ((feature-subset-p ,cg (car ,%rule) ,reading) (cdr ,%rule)) (t nil)))) (when ,rule (progn ,@body)))))) (dolist (sub-tree (child-constraints tree)) ;; check if this and the next constraint apply to the same position ;; and are simple constraints (let* (;(,next-constraint (constraint (constraint-node sub-tree))) (,next-constraint (constraint sub-tree)) (,check-all-p (and (integerp (car ,constraint)) (eql (car ,constraint) (car ,next-constraint))))) (cond (,check-all-p (unless ,c/a-p ; compute those only in case we need them (multiple-value-setq (,c/a-satisfied-p/readings ,c/a-link-pos ,c/a-link-code) (check-constraint ,cg ,sentence ,position ,constraint ,boundary-mode link-position link t readings)) (setf ,c/a-p t)) (when ,c/a-satisfied-p/readings (walk sub-tree ,c/a-link-pos ,c/a-link-code ,c/a-satisfied-p/readings))) (t (unless ,not-c/a-p (multiple-value-setq (,satisfied-p/readings ,link-pos ,link-code) (check-constraint ,cg ,sentence ,position ,constraint ,boundary-mode link-position link)) (setf ,not-c/a-p t)) (when ,satisfied-p/readings (walk sub-tree ,link-pos ,link-code nil))))))))) (walk ,rule-tree nil nil nil)))) ;; *nbo-cg* #+rule-tree-xx (defmacro do-disambiguation-rules ((rule sentence position reading word-form cg heuristic-rules-p rule-type) &body body) "Loops over the RULEs applicable for the given reading executing BODY." (let ((constraints-table (gensym)) (rules-table (gensym)) (rule-tree (gensym)) (downcase-form (gensym))) `(let ((,constraints-table (if ,heuristic-rules-p (heuristic-disambiguation-constraints ,cg) (disambiguation-constraints ,cg)))) ,(ecase rule-type (:domains `(let* ((,downcase-form (string-downcase ,word-form)) (,rules-table (gethash ,downcase-form ,constraints-table))) (declare (dynamic-extent ,downcase-form)) (when ,rules-table (loop for code in (disambiguation-domain-feature-codes ,cg ,downcase-form ,heuristic-rules-p) when (has-feature-code-p (cdr ,reading) code) do (let ((,rule-tree (gethash (code-feature code) ,rules-table))) (do-tree-rules (,rule ,cg ,rule-tree ,sentence ,position ,reading nil) ,@body)))))) (:select `(let ((,rules-table (gethash '=! ,constraints-table))) (when ,rules-table (loop for code in (disambiguation-select-feature-codes ,cg ,heuristic-rules-p) when (has-feature-code-p (cdr ,reading) code) do (let ((,rule-tree (gethash (code-feature code) ,rules-table))) (do-tree-rules (,rule ,cg ,rule-tree ,sentence ,position ,reading nil) ,@body)))))) (:discard `(let ((,rules-table (gethash '=0 ,constraints-table))) (when ,rules-table (loop for code in (disambiguation-discard-feature-codes ,cg ,heuristic-rules-p) when (has-feature-code-p (cdr ,reading) code) do (let ((,rule-tree (gethash (code-feature code) ,rules-table))) (do-tree-rules (,rule ,cg ,rule-tree ,sentence ,position ,reading nil) ,@body)))))))))) ; *nbo-cg* #+rule-tree-xx (defmacro do-mapping-rules ((rule sentence position reading cg) &body body) "Loops over the RULEs applicable for the given READING executing BODY." (let ((rule-tree (gensym))) `(with-slots (morphosyntactic-mappings) ,cg (loop for code in (mapping-feature-codes ,cg) when (has-feature-code-p (cdr ,reading) code) do (let ((,rule-tree (gethash (code-feature code) morphosyntactic-mappings))) (do-tree-rules (,rule ,cg ,rule-tree ,sentence ,position ,reading nil) ,@body)) #+old (dolist (,%rule (gethash (code-feature code) morphosyntactic-mappings)) (let ((,rule (when (feature-subset-p ,cg (car ,%rule) ,reading) (cdr ,%rule)))) (when ,rule ,@body))))))) #+rule-tree (defmacro do-syntactic-rules ((rule word-form sentence position features cg heuristic-level rule-type) &body body) "Loops over the rules applicable for the given READING executing BODY." (let ((constraints-table (gensym)) (rules-table (gensym)) (rule-tree (gensym)) (code (gensym)) (downcase-form (gensym))) `(let ((,constraints-table (if ,heuristic-level (aref (heuristic-syntactic-constraints ,cg) ,heuristic-level) (syntactic-constraints ,cg)))) ,(ecase rule-type (:domains `(let* ((,downcase-form (string-downcase ,word-form)) (,rules-table (gethash ,downcase-form ,constraints-table))) (declare (dynamic-extent ,downcase-form)) (when ,rules-table (loop for ,code in (syntactic-function-codes ,cg) when (has-feature-code-p ,features ,code) do (block feature-rules (when-let (,rule-tree (gethash (code-feature ,code) ,rules-table)) (do-tree-rules (,rule ,cg ,rule-tree ,sentence ,position) ,@body))))))) (:select `(let ((,rules-table (gethash '=s! ,constraints-table))) (when ,rules-table (loop for ,code in (syntactic-function-codes ,cg) when (has-feature-code-p ,features ,code) do (when-let (,rule-tree (gethash (code-feature ,code) ,rules-table)) (do-tree-rules (,rule ,cg ,rule-tree ,sentence ,position) ,@body)))))) (:discard `(let ((,rules-table (gethash '=s0 ,constraints-table))) (when ,rules-table (loop for ,code in (syntactic-function-codes ,cg) when (has-feature-code-p ,features ,code) do (block feature-rules (when-let (,rule-tree (gethash (code-feature ,code) ,rules-table)) (do-tree-rules (,rule ,cg ,rule-tree ,sentence ,position) ,@body)))))))))))