(in-package :lkb)

(defparameter *generic-lexical-entries* nil)

(defparameter *generics-carg* 'CARG)

(defparameter %generics-index% nil)

(defstruct gle
  id flags test le pred mrs)

(defun index-generics ()
  (setf %generics-index%
    (cons
     nil
     (loop
         for (id . flags) in *generic-lexical-entries*
         for test = (let ((predicate (second flags))
                          (*package* (find-package :lkb)))
                      (typecase predicate
                        (string (symbol-function
                                 (read-from-string predicate)))
                        (null nil)
                        (symbol (symbol-function predicate))
                        (function predicate)
                        (cons predicate)))
         for entry = (when (member :generate flags)
                       (get-lex-entry-from-id id))
         for mrs = (and entry (lex-entry-full-fs entry)
                        (mrs::extract-mrs-from-fs 
                         (tdfs-indef (lex-entry-full-fs entry))))
         when (and entry (null mrs)) do
           (format 
            t 
            "index-generic(): ~
             ignoring entry `~(~a~)' for null semantics.~%"
            id)
         when (and mrs (rest (mrs:psoa-liszt mrs))) do
           (format 
            t 
            "index-generic(): ~
             ignoring entry `~(~a~)' for decomposed semantics.~%"
            id)
         else when mrs
         collect
           (make-gle
            :id id :flags flags :test test :le entry
            :pred (mrs::rel-pred (first (mrs:psoa-liszt mrs)))
            :mrs mrs)))))
            
(defun gen-instantiate-generics (ep)
  (loop
      with ids
      with pred = (mrs::rel-pred ep)
      with carg = (loop
                      for role in (mrs:rel-flist ep)
                      when (eq (mrs:fvpair-feature role) *generics-carg*)
                      return (mrs:fvpair-value role))
      with surface = (substitute #\space #\_ carg :test #'char=)
      with *package* = (find-package :lkb)
      for gle in (rest %generics-index%)
      for test
      = (when (gle-test gle) (ignore-errors (funcall (gle-test gle) ep)))
      when (or test (and carg (equal pred (gle-pred gle))))
      do
        (let* ((id (format nil "~@:(~a[~a]~)" (gle-id gle) (or test surface)))
               (id (intern id :lkb)))
          (if (get-lex-entry-from-id id)
            (push id ids)
            (multiple-value-bind (tdfs orth)
                (instantiate-generic-lexical-entry
                 gle (or test surface) pred carg)
              (when tdfs
                (let ((new
                       (make-lex-entry
                        :orth (list orth) :id id :full-fs tdfs)))
                  ;;
                  ;; _fix_me_
                  ;; we should encapsulate the write access on the lexicon as a
                  ;; method cache-psort() or the like.           (7-jun-09; oe)
                  ;;
                  (with-slots (psorts) *lexicon*
                    (setf (gethash id psorts) new))
                  (mrs::extract-lexical-relations new)
                  (push id ids))))))
      finally (return ids)))


(defun glep (le)
  (typecase le
    (lex-entry
     (let* ((id (string (lex-entry-id le)))
            (bracket (position #\[ id))
            (id (intern (subseq id 0 bracket) *lkb-package*)))
       (assoc id *generic-lexical-entries* :test #'eq)))))