;;; Copyright (c) 1998-2001 John Carroll, Ann Copestake, Robert Malouf, Stephan Oepen
;;; see LICENSE for conditions


(in-package :lkb)
;;;; *****************************************************

;;; (defparameter *ordered-mrs-rule-list* nil)
;;; in mrsglobals

(defun clear-mrs-rules nil
  (setf *ordered-mrs-rule-list* nil))

(defparameter *gen-rule-list* nil)

(defun clear-gen-rules nil
  (setf mrs::*gen-rule-ids* nil)
  (setf *gen-rule-list* nil))

;;; Reading in rules expressed in tdl format
;;; 
(defstruct (funny-unification)
  lhs
  rhs)

(defstruct (mrs-rule-sexp)
  value)

(defstruct (mrs-rule-predicate)
  value)

(defstruct (mrs-rule-constant)
  value)

;;; Conversion rules

(defun read-gen-rule-file nil  
   (let* ((file-name 
            (ask-user-for-existing-pathname "Heuristics file?")))
      (when file-name
         (read-mrs-rule-file-aux file-name t))))

(defun read-mrs-rule-file nil  
   (let* ((file-name 
            (ask-user-for-existing-pathname "Rule file?")))
      (when file-name
         (read-mrs-rule-file-aux file-name))))


(defparameter *mrs-rule-fs-list* nil 
  "list of rules expressed as fs for debugging")

(defun read-mrs-rule-file-aux (file-names &optional generator-p)
  (unless (listp file-names)
    (setf file-names (list file-names)))
  (let ((mrs::*variable-generator*
          (if generator-p
              mrs::*variable-generator*
              (mrs::create-variable-generator 10000))))
    (when (every #'(lambda (file-name)
                     (and file-name (probe-file file-name)))
                 file-names)
      (if generator-p
          (clear-gen-rules)
          (clear-mrs-rules))
      (let ((*tdl-expanded-syntax-function* #'read-mrs-rule-expanded-syntax))
        (setf *mrs-rule-fs-list* nil)
        (loop for file in file-names
             do
             (with-open-file
                 (istream file :direction :input)
               (format t "~%Reading in rule file ~A" file)
               (read-mrs-rule-stream istream generator-p)))))))

(defun read-mrs-rule-stream (istream generator-p)
   (loop
      (let ((next-char (peek-with-comments istream)))
         (if (eql next-char 'eof)
            (return)
            (catch 'syntax-error
               (read-mrs-rule-entry istream generator-p))))))

(defun read-mrs-rule-entry (istream generator-p)
   (let ((id (lkb-read istream nil)))
     #+(or :allegro :mcclim) (record-source id istream nil)
     (check-for-string ":=" istream id)
     (let ((non-def (read-expanded-avm-def istream id))
           (funny-unifs nil)
           (normal-unifs nil))
        (check-for #\. istream id)
        (loop for unif in non-def
             do
             (if (funny-unification-p unif)
                 (push unif funny-unifs)
                 (push unif normal-unifs)))
        (let* ((temp-fs (process-unifications normal-unifs))
               (entry (if temp-fs
                          (if generator-p
                              (mrs::construct-gen-rule-from-fs
                                id temp-fs funny-unifs)
                              (mrs::construct-munge-rule-from-fs
                                id temp-fs funny-unifs
                                mrs::*variable-generator*)))))
          #+:debug (push temp-fs *mrs-rule-fs-list*)
          (when entry
            (if generator-p
                (push entry *gen-rule-list*)
                (push entry *ordered-mrs-rule-list*)))))))


(defun read-expanded-avm-def (istream name)
  (clrhash *tdl-coreference-table*) ; parameter defined in tdltypeinput
  (let ((constraint nil))
      ;;; read-tdl-conjunction in tdltypeinput
      ;;; returns a list of path constraints
      ;;; plus funny-unifications
    (setf constraint (read-tdl-conjunction istream name nil nil))
    (loop for coref in (make-mrs-rule-coref-conditions *tdl-coreference-table*)
         do
      (push coref constraint))
    constraint))

(defun make-mrs-rule-coref-conditions (coref-table)
  ;;; the coref table is a list of paths, indexed by
  ;;; a coreference atom.  
  (let ((unifs nil))
    (maphash #'(lambda (index value)
                 (declare (ignore index))
                 (let ((path1 (car value))
                       (rest (cdr value)))
                   (if rest
                     (loop for path2 in rest
                          do
                          (push (make-tdl-path-path-unif path1 path2 nil) unifs))
                     (push (make-tdl-path-value-unif path1 *toptype* nil)
                           unifs))))
             coref-table)
    unifs))


(defun read-mrs-rule-expanded-syntax (istream name path-so-far in-default-p)
  ;;; stuff starting with ^
  ;;; intended to be value of *tdl-expanded-syntax-function*
  ;;; and thus to be called in tdltypeinput
  (when in-default-p
    (error "~%read-mrs-rule-expanded-syntax called inside default in ~A" 
           name))
  (unless (eql (read-char istream) #\^)
    (error "~%read-mrs-rule-expanded-syntax called without initial ^ in ~A" 
           name))
  (let* ((next-char (peek-char t istream nil 'eof))
         (value (read istream)))
    (list (make-funny-unification 
           :lhs (reverse path-so-far)
           :rhs (case next-char
                  (#\u :unique)
                  (#\c (make-mrs-rule-constant :value value))
                  (#\( (make-mrs-rule-sexp :value value))
                  (t (make-mrs-rule-predicate :value value))))
          (make-tdl-path-value-unif 
           (reverse path-so-far) *toptype* nil))))

           

  
;;; *************************************************