;;; LinGO big grammar specific functions

#+(or :lkb-v5.3 :lkb-v5.4)
(in-package :lkb)
#-(or :lkb-v5.3 :lkb-v5.4)
(in-package :cl-user)

(defun establish-linear-precedence (rule-fs)
   ;;;    A function which will order the features of a rule
   ;;;    to give (mother daughter1 ... daughtern)
   ;;;    
   ;;;  Modification - this must always give a feature
   ;;;  position for the mother - it can be NIL if
   ;;; necessary
  (let* ((mother NIL)
         (daughter1 (get-value-at-end-of rule-fs '(ARGS FIRST)))
         (daughter2 (get-value-at-end-of rule-fs '(ARGS REST FIRST)))
         (daughter3 (get-value-at-end-of rule-fs '(ARGS REST REST FIRST))))
    (declare (ignore mother))
    (unless (and daughter1 (not (eql daughter1 'no-way-through)))
      (cerror "Ignore it" "Rule without daughter"))
    (append (list nil '(ARGS FIRST))
            (if (and daughter2 (not (eql daughter2 'no-way-through)))
                (list '(ARGS REST FIRST)))
            (if (and daughter3 (not (eql daughter3 'no-way-through)))
                (if (and daughter2 (not (eql daughter2 'no-way-through)))
                    (list '(ARGS REST REST FIRST)))))))

(defun spelling-change-rule-p (rule)
;;; a function which is used to prevent the parser 
;;; trying to apply a rule which affects spelling and
;;; which should therefore only be applied by the morphology
;;; system.  
;;; Old test was for something which was a subtype of
;;; *morph-rule-type* - LinGO ERG tests for 
;;; < NEEDS-AFFIX > = +
;;; in the rule
;;; this version tests for a subtype of infl_lrule (subtype-p is strict
;;; subtype)
  (let ((rule-type (type-of-fs (tdfs-indef 
                                (rule-full-fs rule)))))
    (or (eql rule-type 'infl_lrule)
        (subtype-p rule-type 'infl_lrule))))

(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. Descendents (if any) will be displayed, i.e. non-displayed
;;; types are effectively spliced out

(defun hide-in-type-hierarchy-p (type-name)
   ;; starts with _, or ends with _[0-9][M]LE[0-9]
   (and (symbolp type-name)
      (or
         ;; graphs are pretty unreadable without glbtypes in there as well
         (search "GLBTYPE" (symbol-name type-name))
         (eql (char (symbol-name type-name) 0) #\_)
         (let* ((name (symbol-name type-name))
                (end (length name))
                (cur (position #\_ name :from-end t)))
            ;; wish I had a regexp package available...
            (and cur
               (< (incf cur) end)
               (if (digit-char-p (char name cur)) (< (incf cur) end) t)
               (if (eql (char name cur) #\M) (< (incf cur) end) t)
               (if (eql (char name cur) #\L) (< (incf cur) end))
               (if (eql (char name cur) #\E) (<= (incf cur) end))
               (or (= cur end)
                   (and (digit-char-p (char name cur)) (= (incf cur) end))))))))

(defparameter *new-orth-path* '(MORPH LIST FIRST FORM))

(defun make-orth-tdfs (orth)
  ;;; WARNING - temporary hack - won't work for multi words
  (let ((orth-value (car (split-into-words orth)))
        (tmp-orth-path *new-orth-path*))
    (let ((opath (create-path-from-feature-list 
                       tmp-orth-path)))
      (let ((indef (process-unifications 
                    (list
                    (make-unification :lhs opath                    
                                      :rhs
                                      (make-u-value
                                       #+:lkb-v5.4 :type #+:lkb-v5.4 orth-value
                                       #+:lkb-v5.3 :types #+:lkb-v5.3 (list orth-value)
                                       ))))))
      (when indef
        (setf indef (create-wffs indef))
        (make-tdfs :indef indef))))))

;; removed #\/ because of s/w
;; removed #\_ in order to be able to test unknowns: pn_type_percentage
(defun alphanumeric-or-extended-p (char)
  (and (graphic-char-p char)
       (not (member char '(#\space #\! #\" #\# #\$ #\% #\& #\' #\(
                           #\) #\* #\+ #\, #\. #\: #\;
                           #\< #\= #\> #\? #\@ #\[ #\\ #\] #\^
                           #\` #\{ #\| #\} #\~)))))

(defparameter *infl-pos-record* nil)

(defun find-infl-pos (unifs orth-string sense-id)
  (declare (ignore orth-string))
  (let ((types
         (loop for unif in unifs
               when (null (path-typed-feature-list (unification-lhs unif)))
               collect
               (u-value-type (unification-rhs unif)))))
    (cond
     ((null types) 
      (format t 
              "~%Warning ~A doesn't specify any types, no affix position found"
              sense-id)
      nil)
     ((cdr types)
      (format t 
              "~%Warning ~A specifies multiple types, no affix position found"
              sense-id))
     (t
      (let* ((type (car types))
             (res (assoc type *infl-pos-record*)))
        (if res (cdr res)
          (progn
            (eval-possible-leaf-type *leaf-types* type)
            (let ((type-entry (get-type-entry type)))
              (cond (type-entry 
                     (let ((pos
                            (extract-infl-pos-from-fs 
                             (tdfs-indef (type-tdfs type-entry)))))
                       (unless (or pos (subtype-p type 'non_affix_bearing))
                         (format t "~%No position identified for ~A" sense-id))
                       (push (cons type pos) *infl-pos-record*)
                       pos))
                    (t
                     (format t "~%Warning ~A specifies invalid type, no affix position found"
                             sense-id)
                     nil))))))))))

;;; Remember to put in preferences sometime

(defun extract-infl-pos-from-fs (fs)  
  (let ((current-path '(ARGS))
         (coindexed-position 
          (existing-dag-at-end-of fs '(--FINAL-ARG)))
        (position 1))
    (if coindexed-position
        (loop (let* ((next-path 
                      (append current-path '(FIRST)))
                     (new-pos 
                      (existing-dag-at-end-of 
                       fs next-path)))
                (unless new-pos
                       (return nil))
                (when (eq new-pos coindexed-position)
                  (return position))
                (incf position)
                (setf current-path 
                  (append current-path '(REST))))))))


(defun set-temporary-lexicon-filenames nil
  (let* ((version (or (find-symbol "*GRAMMAR-VERSION*" :common-lisp-user)
                      (and (find-package :lkb)
                           (find-symbol "*GRAMMAR-VERSION*" :lkb))))
         (prefix
          (if version
            (remove-if-not #'alphanumericp (symbol-value version))
            "biglex")))
    (setf *psorts-temp-file* 
      (make-pathname :name prefix 
                     :directory (pathname-directory (lkb-tmp-dir))))
    (setf *psorts-temp-index-file* 
      (make-pathname :name (concatenate 'string prefix "-index") 
                     :directory (pathname-directory (lkb-tmp-dir))))
    (setf *leaf-temp-file* 
      (make-pathname :name (concatenate 'string prefix "-rels")
                     :directory (pathname-directory (lkb-tmp-dir))))))