;;; Common user-fns file for all ESSLLI grammars

(in-package :lkb)

(defun establish-linear-precedence (rule)
  ;;
  ;; 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.
  ;;
  (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))))

#|
(defun spelling-change-rule-p (rule)
  ;;
  ;; detect rules that have orthographemic variation associated to them; those 
  ;; who do should only be applied within the morphology system; this version
  ;; is a little complicated because we change from a full-form set-up to one
  ;; with on-line morphology during the course.
  ;;
  (let ((rule-type (type-of-fs (tdfs-indef (rule-full-fs rule)))))
    (when (or (eql rule-type 'word)
              (subtype-p rule-type 'word)
              (eql rule-type 'lexeme)
              (subtype-p rule-type 'lexeme))
      (let* ((mother (tdfs-indef (rule-full-fs rule)))
             (morth (existing-dag-at-end-of mother *orth-path*))
             (daughter (existing-dag-at-end-of mother '(ARGS FIRST)))
             (dorth (existing-dag-at-end-of daughter *orth-path*)))
        (not (eq morth dorth))))))
|#

(defun spelling-change-rule-p (rule)
  ;;
  ;; detect rules that have orthographemic variation associated to them; just
  ;; see whether there is a %prefix() or %suffix() constraint associated with
  ;; the rule.
  ;;
  (rule-orthographemicp rule))



(defun make-orth-tdfs (orthography)
  ;;
  ;; create feature structure representation of orthography value for insertion
  ;; into the output structure of inflectional rules.
  ;;
  (loop 
      with unifications
      for string in (split-into-words orthography)
      for path = *orth-path* then (append path *list-tail*)
      for opath = (create-path-from-feature-list (append path *list-head*))
      for unification 
      = (make-unification :lhs opath :rhs (make-u-value :type string))
      do (push unification unifications)
      finally
        (let* ((path (append path *list-tail*))
               (opath (create-path-from-feature-list path))
               (value (make-u-value :type *empty-list-type*))
               (unification (make-unification :lhs opath :rhs value))
               (indef (process-unifications (cons unification unifications)))
               (indef (and indef (create-wffs indef))))
          (return (when indef (make-tdfs :indef indef))))))

;                (opath
;                 (create-path-from-feature-list (append path *list-head*)))


(defun redundancy-rule-p (rule)
;;; a function which is used to prevent the parser 
;;; trying to apply a rule which is only used
;;; as a redundancy rule 
  (declare (ignore rule))
  nil)
             

;;; return true for types that shouldn't be displayed in type hierarchy
;;; window. None of their descendents (if any) will be displayed either

(defun hide-in-type-hierarchy-p (type-name)
  (declare (ignore type-name))
  nil)