;;; Hey, emacs, this file is -*- Mode: common-lisp; -*- ... got that?

;;;
;;; a set of functions that facilitate user-level customization of the 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)))
             (daughter (existing-dag-at-end-of mother '(ARGS FIRST)))
             (dorth (existing-dag-at-end-of daughter '(ORTH))))
        (not (eq morth dorth))))))


(defun make-orth-tdfs (orthography)
  ;;
  ;; create feature structure representation of orthography value for insertion
  ;; into the output structure of inflectional rules.
  ;;
  (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")
	   ((ppcre:scan "noun-3sing-irule" string) "N-WD")
	   ((ppcre:scan "noun-non-3sing-irule" string) "N-ND")
	   ((ppcre:scan "verb-3sing-irule" string) "V-WD")
	   ((ppcre:scan "verb-past-irule" string) "V-WD")
	   ((ppcre:scan "verb-non-3sing-irule" string) "V-WD")
	   ((ppcre:scan "null-irule" string) "WORD"))))
    (format 
     nil 
     "~a[~a]"
     (cond 
      ((not (edge-children edge)) 
       (let* ((le (get-lex-entry-from-id (first (edge-lex-ids edge))))
	      (id (dag-type (tdfs-indef (lex-entry-full-fs le))))
	      (string (and id (string-downcase id))))
	 (cond
	  ((ppcre:scan "noun-lxm" string) "N-LXM")
	  ((ppcre:scan "verb-lxm" string) "V-LXM")
	  ((ppcre:scan "prep" string) "P-LXM")
	  (t (string-upcase string)))))
      (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))))