(in-package :lkb)

(defun expand-and-inherit-constraints nil
   (let ((ok t)
         (*unify-debug-cycles* t)) ; turn on cyclic dag warning messages
      ;; a. determine which types are atomic
      ;;    can't do unification really without this info
      ;; 
      ;; b. expand constraints by first forming fstructure from
      ;; any constraint spec and then unifying with
      ;; the parents' constraints, expanding these if necessary
      ;; marking types when the constraint has been expanded
      ;;
      ;; JAC 24-Aug-2021: changed b to work in two separate phases, since
      ;; all local constraints must be available when expanding
      ;;
      (determine-atomic-types)
      (loop for node in *type-names*
          for type-entry = (get-type-entry node)
          unless (leaf-type-p type-entry)
          do
            (setq ok
              (and (compute-local-constraint node type-entry) ok)))
      (unmark-type-table)
      (loop for node in *type-names*
          for type-entry = (get-type-entry node)
          unless (leaf-type-p type-entry)
          do
            (setq ok 
              (and (expand-constraint node type-entry) ok)))
      (when ok 
         (check-feature-table))))


(defun compute-local-constraint (node type-entry)
   (let* ((constraint-spec (ltype-constraint-spec type-entry))
          (local-constraint 
             (if constraint-spec (process-unifications constraint-spec))))
      (cond ((and constraint-spec (null local-constraint))
               (format t "~%Type ~A has an invalid constraint specification" node)
               nil)
            (t    
               (when local-constraint
                  (unless 
                     (or (eq (type-of-fs local-constraint) *toptype*)
                         (eq (type-of-fs local-constraint) node))
                     (format t 
                        "~%Warning: setting constraint of ~A to have ~A as type"
                        node node))
                  (setq local-constraint 
                     (destructively-retype-dag local-constraint node))
                  (setf (ltype-local-constraint type-entry) 
                     local-constraint)
                  ;; NB no need to do inheritance when checking
                  ;; for maximal introduction
                  (let ((local-appfeats 
                           (top-level-features-of local-constraint)))
                     (loop for feature in local-appfeats
                        do 
                        (add-maximal-type feature node))))
               t))))


(defun expand-constraint (node type-entry)
   (cond
      ((seen-node-p type-entry) (ltype-inherited-constraint type-entry))
      (t
         (mark-node-seen type-entry)
         (let ((full-constraint 
                  (inherit-constraints
                     node type-entry (ltype-local-constraint type-entry))))
               (cond 
                  (full-constraint
                     (setf (ltype-inherited-constraint type-entry) full-constraint)
                     (setf (ltype-appfeats type-entry)
                        (top-level-features-of full-constraint))
                     full-constraint)
                  (t (format t "~%Type ~A's constraint ~
                        specification clashes with its parents'" node) 
                     nil))))))