;;;
;;; Common set of user functions for all ESSLLI grammars (and derivatives)
;;;

;;;
;;; 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; this version is
;;; a little complicated because we change from a full-form set-up to one with
;;; on-line morphology during the course.
;;;
(defun spelling-change-rule-p (rule)
  (let ((rule-type (type-of-fs (tdfs-indef (rule-full-fs rule)))))
    (when (or (eql rule-type 'word)
              (subtype-p rule-type 'word))
      (let* ((mother (tdfs-indef (rule-full-fs rule)))
             (morth (existing-dag-at-end-of mother '(ORTH)))
             (daughter (existing-dag-at-end-of mother '(ARGS FIRST)))
             (dorth (existing-dag-at-end-of daughter '(ORTH))))
        (not (eq morth dorth))))))

;;;
;;; create feature structure representation of orthography value for insertion
;;; into the output structure of inflectional rules.
;;;
(defun make-orth-tdfs (orthography)
  (let* ((unification
          (make-unification :lhs (create-path-from-feature-list *orth-path*)
                            :rhs (make-u-value :type orthography)))
         (indef (process-unifications (list unification))))
    (when indef
      (make-tdfs :indef (create-wffs indef)))))

;;;
;;; the following two functions allow customization of how edges are displayed
;;; in the LUI chart browser (not the traditional LKB chart window).  for each
;;; edge, two properties are relevant: (a) its `name' and (b) its `label'; both
;;; should be strings, where name should be a relatively short, yet contentful
;;; identifier used as the primary representation of edges in chart cell, and
;;; label can be a longer string shown in the pop-up area on mouse-over.
;;;
(defun lui-chart-edge-name (edge)
  (let* ((rule (edge-rule edge))
         (id (and (rule-p rule) (rule-id rule)))
         (string (and id (string-downcase id)))
         (name
          (cond
           ((ppcre:scan "head-specifier" string) "SH")
           ((ppcre:scan "head-complement" string) "HC")
           ((ppcre:scan "head-adjunct" string) "HA")
           ((ppcre:scan "adjunct-head" string) "AH"))))
    (format 
     nil 
     "~a[~a]"
     (cond 
      ((not (edge-children edge)) 
       (let ((le (get-lex-entry-from-id (first (edge-lex-ids edge)))))
         (dag-type (tdfs-indef (lex-entry-full-fs le)))))
      (id name) (t (tree-node-text-string (find-category-abb (edge-dag edge)))))
     (edge-id edge))))

(defun lui-chart-edge-label (edge)
  (format
   nil
   "~a"
   (typecase (edge-rule edge)
     (string (first (edge-lex-ids edge)))
     (symbol (edge-rule edge))
     (rule (rule-id (edge-rule edge)))
     (t :unknown))))