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

;;; FIX - checked in although ICONS generation is not finished
;;; because I don't think anything should actually be broken by the 
;;; changes so far!

(in-package :lkb)


;;; Control parameters

(defparameter *gen-packing-p* t)
(defparameter *gen-filtering-p* t)
(defparameter *bypass-equality-check* nil)
(defparameter *gen-equate-qeqs-p* nil)
; (defparameter *gen-maximal-number-of-realizations* nil) ; JAC 1-May-2020 - use *gen-first-only-p*

(defparameter *gen-scoring-hook* nil)
(defparameter *gen-extract-surface-hook* nil)
(defparameter *gen-filtering-debug* nil)
(defparameter *gen-adjunction-debug* nil)
(defparameter *gen-equality-debug* nil)


(defvar *gen-chart* nil)
(defvar *gen-pchart* nil)
(defvar *gen-record* nil)
(defvar *gen-rel-indexes* nil)
(defvar *lexemes-allowed-orderings* nil)

;;;
;;; we distinguish three versions of the input MRS, viz. (a) the original 
;;; semantics as passed into generate-from-mrs() (b) the effect of equating 
;;; QEQs (when enabled by *gen-equate-qeqs-p*), and (c) the generator-internal 
;;; MRS, i.e. the result of applying a grammar-specific VPM or (un-)filling.
;;; the post-generation MRS compatibility test actually uses the internal MRS,
;;; so as to take advantage of the type hierarchy in comparing values; yet, for
;;; `default' values and such to come in, MRSs read off candidate realizations
;;; go through the SEM-I VPM twice, once by default in extract-mrs(), and once
;;; again, backwards, in gen-chart-check-compatible().  for similar reasons,
;;; trigger rules for semantically vacuous lexical entries are tried against
;;; the internal MRS. 
;;;
(defvar *generator-input* nil)
(defvar *generator-equated-mrs* nil)
(defvar *generator-internal-mrs* nil)

(defvar *non-intersective-rules* nil)

(defparameter %generator-lexical-items% nil)
(defparameter %generator-unknown-eps% nil)
(defparameter %generator-statistics% nil)
(defparameter %generator-condition% nil)
#+:debug
(defvar %rel-indexes)
#+:debug
(defvar %input-rels)

;;;
;;; given all the new parameters we have just introduced, attempt to make sure
;;; things are set up coherently.
;;;
(defun check-generator-environment ()
  (when mrs::*instloc-path*
    (let* ((feature (first (last mrs::*instloc-path*)))
           (type (minimal-type-for feature)))
      (unless (or (equal type *string-type*)
                  (subtype-p *string-type* type))
        (format
         t
         "~%Error: the constraint of feature `~a' must be equal to, ~
          or be a supertype of, ~
          type `~(~a~)' (the *string-type* parameter)."
         feature *string-type*)
        (force-output t)
        (return-from check-generator-environment :error))))
  (when (and *intersective-rule-names* *gen-filtering-p*)
    (format 
     t
     "~%Warning: intersective rules and variable accessibility filtering ~
      are incompatible - the generator will ignore intersective rules.")
    (setf *intersective-rule-names* nil))
  (when (and (null *intersective-rule-names*) (null *gen-filtering-p*))
    (format t "~%Warning: filtering off and no intersective rules specified."))
  (force-output t))


;;; Utility functions for initialising and building daughters and leaves
;;; fields in active chart edges, and for computing the index of a
;;; rule daughter path

(defun gen-make-list-and-insert (len item index)
  ;; make list of length len and insert item at index (1-based)
  (let ((lst (make-list len)))
     (setf (nth (1- index) lst) item)
     lst))

(defun gen-copy-list-and-insert (lst item index)
  ;; non-destructively replace index-th element of lst by item
  (if (zerop index)
     (cons item (cdr lst))
     (cons (car lst) (gen-copy-list-and-insert (cdr lst) item (1- index)))))

(defun gen-chart-path-index (p paths)
   (loop
      for x in paths
      for i of-type fixnum from 0
      when (eq x p) return i))


;;; Functions on sets (of MRS relations) represented as integers

(defmacro gen-chart-set-disjoint-p (r1 r2)
   `(not (logtest ,r1 ,r2)))

(defmacro gen-chart-set-equal-p (r1 r2)
   `(= ,r1 ,r2))

(defun gen-chart-set-ctz (r) ; count trailing zeros
   (integer-length (1- (logand r (- r)))))

(defun gen-chart-subset-p (r1 r2)
   ;; is r1 a strict subset or equal to r2
   (= (logior r1 r2) r2))

(defun gen-chart-set-difference (r1 r2)
   (logandc2 r1 r2))

(defun gen-chart-set-union (r1 r2)
   (if r1 (logior r1 r2) r2))

(defun gen-chart-set-non-empty-p (r)
   (not (zerop r)))


(defun gen-chart-ordering-allowed-p (left right)
  ;; ordering will already have been checked within both left and right
  (or (null *lexemes-allowed-orderings*)
    (flet ((lexeme-set-intersection-p (lst1 lst2)
             (dolist (x1 lst1 nil) 
               (when (member x1 lst2 :test #'eq) (return t)))))
       (dolist (ordering *lexemes-allowed-orderings* t)
          (do ((rtail (cdr ordering) (cdr rtail)))
             ((null rtail))
             (when (lexeme-set-intersection-p left (car rtail))
                (do ((ltail ordering (cdr ltail)))
                   ((eq ltail rtail))
                   (when (lexeme-set-intersection-p right (car ltail))
                      ;; (print (list (mapcar #'mrs::found-lex-lex-id left) 
                      ;;              (mapcar #'mrs::found-lex-lex-id right)))
                      (return-from gen-chart-ordering-allowed-p nil)))
                ;; this ordering constraint can't contain another set of
                ;; lexemes matching left, so go on and try next constraint
                (return-from nil)))))))


;;; Find semantic variables in a dag that are externally visible. For
;;; reentrant dags this does unnecessary work, but this doesn't show
;;; in profiling, so there's no need to complicate things.
;;; No point in collecting variables if *gen-filtering-p* is false.

(defun collect-semantic-variables-in-fs (tdfs)
   ;; look at the end of every instloc for an instantiated string and extract
   ;; its number as an integer
   (labels
      ((sem-vars-in-dag (dag vars)
          (let ((d (existing-dag-at-end-of dag mrs::*instloc-path*)))
             (if (and d (stringp (dag-type d)))
                (let* ((type-name (dag-type d))
                       (s (position-if #'digit-char-p type-name))
                       (e (and s (position-if-not #'digit-char-p type-name :start s))))
                      (when s
                         (pushnew
                            (parse-integer type-name
                               :start s :end (or e (length type-name)))
                            vars)))
               (dolist (arc (dag-arcs dag))
                 ;;
                 ;; when we are not packing, all variables would seem to remain
                 ;; accessible in the FS reconstruction of the MRS, i.e. below
                 ;; RELS and HCONS; thus, simulate FS restriction here.
                 ;;                                              (9-jan-05; oe)
                 ;; _fix_me_
                 ;; think more about this: an erroneously set restrictor could
                 ;; cause people surprising results; if they were not packing
                 ;; anyway, why should they care about the restrictor?
                 ;;                                             (20-mar-05; oe)
                 (when (or *gen-packing-p*
                           (not (smember 
                                (dag-arc-attribute arc) *packing-restrictor*)))
                   (setq vars (sem-vars-in-dag (dag-arc-value arc) vars)))))
             vars)))
      (if *gen-filtering-p*
         (sem-vars-in-dag (tdfs-indef tdfs) nil)
         nil)))

#|
(defun collect-semantic-variables-in-fs (tdfs)
   ;; only look for variables in expected places - this puts constraints on
   ;; the grammar which if not satisfied can lead to strings not being
   ;; generated
   (flet
      ((sem-vars-at-end-of (dag path vars)
          (when path
             (let ((d (existing-dag-at-end-of dag (append path '(instloc))))) ; ***
                (when (and d (stringp (dag-type d)))
                   (let* ((type-name (dag-type d))
                          (s (position-if #'digit-char-p type-name))
                          (e (and s (position-if-not #'digit-char-p type-name :start s))))
                      (when s
                         (pushnew
                            (parse-integer type-name
                               :start s :end (or e (length type-name)))
                            vars))))))
          vars))
      (if *gen-filtering-p*
         (let ((vars nil))
            (when mrs::*initial-semantics-path*
               (let ((d (existing-dag-at-end-of
                            (tdfs-indef tdfs) mrs::*initial-semantics-path*)))
                  (when d
                     (setq vars
                        (sem-vars-at-end-of d mrs::*psoa-top-h-path*
                           (sem-vars-at-end-of d mrs::*psoa-index-path*
                              (sem-vars-at-end-of d mrs::*psoa-xarg-path* vars)))))))
            (when mrs::*slash-semantics-path*
               (let ((d (existing-dag-at-end-of
                            (tdfs-indef tdfs) mrs::*slash-semantics-path*)))
                  (when d
                     (setq vars
                        (sem-vars-at-end-of d mrs::*psoa-top-h-path*
                           (sem-vars-at-end-of d mrs::*psoa-index-path*
                              (sem-vars-at-end-of d mrs::*psoa-xarg-path* vars)))))))
            vars)
         nil)))
|#


(defun accessible-list-subset-p (l1 l2)
   ;; is l1 a subset of l2, or equal? -- using eql element comparison
   (loop for x1 in l1 always (member x1 l2)))


;;;
;;; see whether we can put the condition facility to use.  it has the advantage
;;; of centralizing information about the various types of (expected) errors,
;;; their internal structure (if we were to pass any of that to an application
;;; system), printing regime, et al.                           (25-apr-04; oe)
;;;
(define-condition generator-uninitialized (error) 
  () 
  (:report (lambda (condition stream) 
             (declare (ignore condition))
             (format stream "the generator indices are uninitialized"))))

(define-condition unknown-predicates (error) 
  ((eps :initarg :eps :initform nil)) 
  (:report (lambda (condition stream) 
             (with-slots (eps) condition
               (format
                stream
                "invalid predicates: ~{|~a|~^, ~}"
                (loop
                    with result
                    for ep in eps
                    do (pushnew (mrs::ep-shorthand ep) result :test #'equal)
                    finally (when result
                              (return (sort result #'string-lessp)))))))))

(define-condition generation/fixup-ambiguity (error) 
  ((mrss :initarg :mrss :initform nil))
  (:report (lambda (condition stream) 
             (with-slots (mrss) condition
               (format
                stream
                "input fix-up ambiguity: ~a outputs"
                (length mrss))))))


;;; Interface to generator - take an input MRS, ask for instantiated lexical
;;; items, instantiated and uninstantiated rules that might be applicable,
;;; and partial ordering on lexical items, and then call generator
;;; proper

(defun generate-from-mrs (mrs 
                          &key signal 
                               (nanalyses *gen-first-only-p*))
  ;; JAC 1-May-2020 - previously, nanalyses defaulted to *gen-maximal-number-of-realizations*

  (setf %generator-condition% nil)
  (setf *generator-input* mrs)

  (when *gen-equate-qeqs-p* (setf mrs (mrs::equate-all-qeqs mrs)))
  (setf *generator-equated-mrs* mrs)
  
  (if (mt:fragmentp mrs)
    (mt:generate-from-fragmented-mrs mrs :signal signal)
    #+:debug
    (generate-from-mrs-internal mrs :nanalyses nanalyses)
    #-:debug
    (handler-case (generate-from-mrs-internal mrs :nanalyses nanalyses)
      (condition (condition)
        (setf %generator-condition% condition)
        (if signal
          (error condition)
          (warn (format nil "~a" condition)))))))


;;; current rather hacky control - FIX
(defparameter *mrs-icons-strict-check-p* nil)

(defun generate-from-mrs-internal (input-sem &key nanalyses)

  ;; don't even try generating if there is no relation index
  ;;
  (unless (and (hash-table-p mrs::*relation-index*)
               (> (hash-table-count mrs::*relation-index*) 0))
    (error 'generator-uninitialized))
      
  ;; (ERB 2003-10-08) For aligned generation -- if we're in first only
  ;; mode, break up the tree in *parse-record* for reference by
  ;; ag-gen-lex-priority and ag-gen-rule-priority.  Store in *found-configs*.
  ;;
  #+:arboretum
  (populate-found-configs)

  ;;
  ;; inside the generator, apply the VPM in reverse mode to map to grammar-
  ;; internal variable types, properties, and values.  the internal MRS, beyond
  ;; doubt, is what we should use for lexical instantiations and Skolemization.
  ;; regarding trigger rules and the post-generation MRS compatibility test, on
  ;; the other hand, we have a choice.  in principle, these should operate in
  ;; the external (SEM-I) MRS namespace (the real MRS layer); however, trigger
  ;; rules are created from FSs (using grammar-internal nomenclature) and, more
  ;; importantly, the post-generation test uses the grammar-internal hierarchy
  ;; to test for predicate, variable type, and property subsumption.  hence, it
  ;; is currently convenient to apply these MRS-level operations with grammar-
  ;; internal names, i.e. at an ill-defined intermediate layer.
  ;;
  ;; _fix_me_
  ;; the proper solution to all this misery will be to create separate SEM-I
  ;; hierarchies, i.e. enrich the SEM-I files with whatever underspecifications
  ;; the grammar wants to provide at the MRS level, and then import that file
  ;; into its own, grammar-specific namespace.  one day soon, i hope, i might
  ;; actually get to implementing this design ...               (22-jan-09; oe)
  ;;
  (setf input-sem (mt:map-mrs input-sem :semi :backward))

  ;;
  ;; per request by dan, manufacture a top handle, if missing and enable the
  ;; generator `input compliance' mechanism.                     (8-mar-10; oe)
  ;;
  (when (and mrs::*rel-handel-path* (null (mrs:psoa-top-h input-sem)))
    (setf (mrs:psoa-top-h input-sem)
      (mrs::make-var :id (funcall mrs::*variable-generator*) :type "h")))
  (unless *mrs-icons-strict-check-p* 
    ;; this fixup isn't currently ICONS compatible, so bypass it for the
    ;; strict condition
    (let ((fixup (mt::transfer-mrs input-sem :filter nil :task :fixup)))
      (when (rest fixup)
	(error 'generation/fixup-ambiguity :mrss fixup))
      (when fixup
	(setf input-sem (mt::edge-mrs (first fixup))))))  
  (setf *generator-internal-mrs* input-sem)

  (with-parser-lock ()
    (with-package (:lkb)

      (clear-gen-chart)
      (setf *cached-category-abbs* nil)
      (flush-agenda *agenda*)
  
      (let (lex-results lex-items grules lex-orderings 
            tgc tcpu conses symbols others)
        (time-a-funcall
          #'(lambda () 
              (multiple-value-setq (lex-results grules lex-orderings)
                (mrs::collect-lex-entries-from-mrs input-sem))
              (multiple-value-setq (lex-items grules lex-orderings)
                (filter-generator-lexical-items 
                  (apply #'append lex-results) grules lex-orderings)))
          #'(lambda (tgcu tgcs tu ts tr scons ssym sother &rest ignore)
              (declare (ignore tr ignore))
              (setf tgc (+ tgcu tgcs) tcpu (+ tu ts)
                    conses (* scons 8) symbols (* ssym 24) others sother)))

        (setq %generator-statistics%
          (pairlis '(:ltgc :ltcpu :lconses :lsymbols :lothers)
                   (list tgc tcpu conses symbols others)))
        (when *debugging* (print-generator-lookup-summary lex-items grules))
        
        (let ((rel-indexes nil) (rel-indexes-n -1) (input-rels 0))
          (dolist (lex lex-items)
            (loop
                with eps = (mrs::found-lex-main-rels lex)
                initially (setf (mrs::found-lex-main-rels lex) 0)
                for ep in eps
                for index = (ash 1 (or (getf rel-indexes ep)
                                       (setf (getf rel-indexes ep)
                                             (incf rel-indexes-n))))
                do 
                  (setf (mrs::found-lex-main-rels lex)
                    (logior (mrs::found-lex-main-rels lex) index))))
          (dolist (grule grules)
            (when (mrs::found-rule-p grule)
              (loop
                  with eps = (mrs::found-rule-main-rels grule)
                  initially (setf (mrs::found-rule-main-rels grule) 0)
                  for ep in eps
                  for index = (ash 1 (or (getf rel-indexes ep)
                                         (setf (getf rel-indexes ep)
                                               (incf rel-indexes-n))))
                  do
                    (setf (mrs::found-rule-main-rels grule)
                      (logior (mrs::found-rule-main-rels grule) index)))))
          (setf %generator-unknown-eps% nil)
          (loop
              for ep in (mrs::psoa-liszt input-sem)
              do
                (if (getf rel-indexes ep)
                  (setq input-rels
                     (logior input-rels (ash 1 (getf rel-indexes ep))))
                  (push ep %generator-unknown-eps%)))
          (when %generator-unknown-eps%
             (error 'unknown-predicates :eps %generator-unknown-eps%))
  
          #+:debug
          (setf %rel-indexes rel-indexes %input-rels input-rels)
          
          (chart-generate
            input-sem input-rels lex-items grules lex-orderings rel-indexes
            :nanalyses nanalyses))))))


(defun filter-generator-lexical-items (lex-items grules lex-orderings)
  (values
   (remove-if
    #'(lambda (x) (member x *duplicate-lex-ids* :test #'eq))
    lex-items :key #'mrs::found-lex-lex-id)
   grules lex-orderings))


;;; run chart generation given an input MRS and a set of lexical entry FSs, each
;;; of which covers zero or more of the relations in the MRS
;;;
;;; constraints on generation:
;;;
;;; when completing an active edge ensure that all relations containing
;;; indices internal to the rule have been realised (ensures only maximal
;;; alternative phrase containing modifiers is available for incorporation
;;; into larger phrases)
;;;
;;; extending an active edge with an inactive must not result in the
;;; duplication of any relation (prevents e.g. same modifier being added
;;; repeatedly)
;;;
;;; final analysis must not have any semantics missing (e.g. makes sure all
;;; relevant modifiers have been realised)
;;;
;;; returns values: realisations, number of argument instantiations filtered
;;; out, number of argument instantiation attempts, number of argument
;;; instantiations succeeding, number of unifications, number of copies, number
;;; of active and inactive edges

(defun chart-generate (input-sem input-rels found-lex-items possible-grules
                       *lexemes-allowed-orderings* *gen-rel-indexes*
                       &key nanalyses)

  (setq %generator-lexical-items% found-lex-items)

  (when (> (integer-length input-rels) *chart-limit*)
     (error "MRS contains more than the maximum of ~a relations ~
             (see documentation for *chart-limit*)" 
            *chart-limit*))

  (reset-statistics)
  (let ((*gen-first-only-p* (first-only-p-normalise nanalyses))
        (*intersective-rule-names* 
         ;; disable two-phase set-up when index accessibility filtering is on or
         ;; we're in non-exhaustive mode
         (if (or *gen-filtering-p*
                 (and *gen-first-only-p* (null *unpacking-scoring-hook*)))
             nil
             *intersective-rule-names*))
        (*safe-not-to-copy-p* t)
        (*non-intersective-rules*
          (remove-if
            #'(lambda (r)
                (or (some
                      #'(lambda (p)
                          (cond ((atom p) (eq p (rule-id r)))
                                (t (eq (car p) (rule-id r)))))
                      *intersective-rule-names*)
                    (spelling-change-rule-p r)))
            possible-grules))
        tgc tcpu conses symbols others consistent partial yield)
    
    (time-a-funcall
     #'(lambda () 
         (catch 'first
           ;; Add lexical edges
           (loop
               for fl in found-lex-items
               for edge = (unfold-found-lex fl)
               when *gen-packing-p* do
                 (setf (edge-odag edge) (edge-dag edge))
                 (setf (edge-dag edge)
                   (copy-tdfs-partially (edge-odag edge)))
               do
                 (setf (g-edge-accessible edge)
                   (collect-semantic-variables-in-fs (g-edge-dag edge)))
                 ;; each lex entry will be a copy
                 (incf (statistics-copies *statistics*))
                 ;; with-agenda() closes over lexical variables, so we need to
                 ;; establish new bindings here for any of these that get
                 ;; re-assigned in the loop - in this case .edge.
                 (let ((edge edge)
                       (priority
                        (when (and *gen-first-only-p* (null *unpacking-scoring-hook*))
                          (if *gen-scoring-hook*
                            (funcall *gen-scoring-hook* (list :lexicon edge))
                            (gen-lex-priority (g-edge-odag edge))))))
                   (with-agenda priority
                     (gen-chart-add-inactive edge input-sem input-rels)))
                 (push edge yield))
           ;; Process tasks
           (loop 
               until (agenda-empty-p *agenda*)
               do (funcall (agenda-extract-max *agenda*)))
           ;; Look for sentential edges covering all input rels
           (unless (and *gen-first-only-p* (null *unpacking-scoring-hook*))
             (multiple-value-setq (consistent partial)
               (gen-chart-find-covering-edges
                 (gen-filter-root-edges
                   (apply #'append (gen-chart-retrieve-with-index *toptype* 'inactive))
                   :full-check-p nil)
                 input-rels)))))
     #'(lambda (tgcu tgcs tu ts tr scons ssym sother &rest ignore)
         (declare (ignore tr ignore))
         (setq tgc (+ tgcu tgcs) tcpu (+ tu ts)
               conses (* scons 8) symbols (* ssym 24) others sother)))
    ;;
    ;; edges corresponding to lexical rule applications are not in the chart
    ;; initially, as lexical rules have been applied prior to invocation of
    ;; chart-generate().  for better post-generation debugging, add the extra
    ;; edges into the chart now.  it would seem tempting to delegate this to
    ;; unfold-found-lex(), but because we do not have correct dags for those
    ;; edges, it would be tricky avoiding unwanted combinatorics; for similar
    ;; reasons, suppress packing of these edges.               (1-jul-08; oe)
    ;;
    (loop
        with *gen-packing-p* = nil
        for edge in yield
        do
          (loop
              with queue = (copy-list (edge-children edge))
              for edge = (pop queue)
              while edge do
                (gen-chart-add-with-index edge)
                (loop
                    for edge in (edge-children edge)
                    do (push edge queue))))
                
    (setq %generator-statistics%
      (nconc %generator-statistics%
             (pairlis '(:gtgc :gtcpu :gconses :gsymbols :gothers)
                      (list tgc tcpu conses symbols others))))

    (time-a-funcall
     #'(lambda () 
         ;; compute complete realisations from consistent and partial edges
         ;; - unless we're in non-exhaustive mode, in which case we will have
         ;; tried already
         (unless (and *gen-first-only-p* (null *unpacking-scoring-hook*))
           (setq *gen-record*
             (realisations-from-covering-edges
               consistent partial *gen-first-only-p* input-rels possible-grules))))
     #'(lambda (tgcu tgcs tu ts tr scons ssym sother &rest ignore)
         (declare (ignore tr ignore))
         (setq tgc (+ tgcu tgcs) tcpu (+ tu ts)
               conses (* scons 8) symbols (* ssym 24) others sother)))
    (setq %generator-statistics%
      (nconc %generator-statistics%
             (pairlis '(:atgc :atcpu :aconses :asymbols :aothers)
                      (list tgc tcpu conses symbols others))))
    ;;
    ;; _fix_me_
    ;; the edge accounting fails to include packed edges and those created
    ;; during unpacking.                                      (1-jan-05; oe)
    ;;
    (values
     (extract-strings-from-gen-record) ; also fixes spelling e.g. "a" -> "an"
     (statistics-ftasks *statistics*) (statistics-etasks *statistics*)
     (statistics-stasks *statistics*) 
     (statistics-unifications *statistics*) (statistics-copies *statistics*)
     (statistics-aedges *statistics*)
     (statistics-pedges *statistics*))))

(defun realisations-from-covering-edges (consistent partial n input-rels
                                         possible-grules)
  (let* ((covering
           (nconc consistent
             (when (and *intersective-rule-names* partial)
               (gen-chart-adjoin-modifiers partial input-rels possible-grules))))
         (complete ; = covering and compatible
           (let ((lnkp mrs:*lnkp*)
                 (mrs:*lnkp* :id))
             (unpack-and-select-edges
               covering
               n
               :test #'(lambda (edge)
                         (and
                           (gen-filter-root-edges (list edge) :full-check-p t)
                           (let ((mrs:*lnkp* lnkp))
                             (gen-chart-check-compatible edge))))
               :robust 42
               :limit (and (numberp n) (* 2 n))))))
    (gen-compute-root-edges complete)))


;;; the lexical lookup returns results in its own idiosyncratic form; to make
;;; generator edges look more like corresponding parser edges, `unfold' the
;;; chain of lexical rules that have been applied already.

(defun unfold-found-lex (fl
                         &optional (rules (mrs::found-lex-rule-list fl) rulesp)
                                   (tdfs (mrs::found-lex-inst-fs fl))
                                   (eps (mrs::found-lex-main-rels fl))
                                   (id (mrs::found-lex-lex-id fl)))
  ;;
  ;; _fix_me_
  ;; to give these daughter edges a correct TDFS, we would have to re-create
  ;; the unifications at each level; at the top, however, we always must keep
  ;; the Skolemized TDFS given to us by lexical lookup.  all a bit messy ...
  ;;                                                             (9-feb-08; oe)
  (if (null rules)
    (let* ((word (extract-orth-from-fs tdfs))
           (entry (get-lex-entry-from-id id))
           (tdfs
            (if rulesp (copy-tdfs-completely (lex-entry-full-fs entry)) tdfs)))
      (make-g-edge
       :id (next-edge) :category (indef-type-of-tdfs tdfs) :rule word :dag tdfs
       :needed nil :rels-covered eps :children nil :leaves (list word)
       :lex-ids (list id) :lexemes (if rulesp nil (list fl))))
    (let* ((child (unfold-found-lex fl (rest rules) tdfs eps id))
           (rid (first rules))
           (rule (get-lex-rule-entry rid))
           (tdfs (if rulesp (rule-full-fs rule) tdfs)))
      (make-g-edge
       :id (next-edge) :category (indef-type-of-tdfs tdfs) :rule rule :dag tdfs
       :needed nil :rels-covered eps :children (list child)
       :leaves (edge-leaves child) :lex-ids (list id)
       :lexemes (unless rulesp (list fl))))))
  

(defun extract-strings-from-gen-record nil
  (loop 
      for edge in *gen-record*
      collect (extract-string-from-g-edge edge)))

(defun extract-string-from-g-edge (edge)
  (or (edge-string edge)
      (let ((string
             (cond
              ((fboundp *gen-extract-surface-hook*)
               (funcall *gen-extract-surface-hook* edge))
              ((fboundp mrs::*fix-spelling-fn*)
               (funcall mrs::*fix-spelling-fn* (g-edge-leaves edge)))
              (t (g-edge-leaves edge)))))
        ;;
        ;; setting LNK values on MRSs associated with generation results is a
        ;; tad involved: while creating the generator forest, surface positions
        ;; are not yet determined, and in fact the same edge may appear in more
        ;; than one tree, quite possibly at distinct surface positions.  hence
        ;; (in LOGON at least, right now) during the post-generation MRS test, 
        ;; LNK values on EPs are set as edge identifiers.  furthermore, the ERG
        ;; gen-extract-surface() puts character position information into the
        ;; `lnk' slot of edges.  at this point, right after complete extraction
        ;; of the surface representation of one edge, we can adjust LNK values
        ;; in the MRS of that edge appropriately.
        ;;
        (when (and mrs:*lnkp* (mrs::psoa-p (edge-mrs edge))
                   (eq mrs:*lnkp* (first (edge-lnk edge))))
          (loop
              for ep in (mrs:psoa-liszt (edge-mrs edge))
              for id = (when (eq (first (mrs::rel-lnk ep)) :id)
                         (second (mrs::rel-lnk ep)))
              for edge = (and (numberp id) (retrieve-edge :id id))
              for lnk = (and edge (edge-lnk edge))
              do (setf (mrs::rel-lnk ep) lnk)))
        (setf (edge-string edge) string))))


(defun clear-gen-chart nil
  (purge-edge-registry)
  (setq *edge-id* 0)
  (setq *active-edge-id* 0)
  (setq %generator-lexical-items% nil)
  (setq %edge-allowance% 0)
  (setq *gen-chart* nil)
  (let ((clen (1+ *chart-limit*)))
    (unless (and (arrayp *gen-pchart*)
                 (= (array-dimension *gen-pchart* 0) clen))
      (setq *gen-pchart* (make-array (list clen clen)))))
  (dotimes (i (array-total-size *gen-pchart*))
    (setf (row-major-aref *gen-pchart* i) nil))
  (setq *gen-record* nil)
  (setq mrs::%gen-triggers% nil))


;;; Partition generation candidate edges based on whether they cover all or subset of
;;; input relations

(defun gen-chart-find-covering-edges (candidate-edges input-rels)
  (let ((covering nil)
        (partial nil))
    (dolist (e candidate-edges)
      ;; process has so far ensured that we have not generated any edge
      ;; containing a relation name that is not in input semantics, and that
      ;; no edge contains duplicates of exactly the same relation - now check
      ;; whether we have generated all relations
      (if (gen-chart-check-covering e input-rels)
         (push e covering)
         (push e partial)))
    (when *gen-adjunction-debug*
       (format t "~&Covering edges: ~:A~%Partial edges: ~:A"
          (mapcar #'g-edge-id covering) (mapcar #'g-edge-id partial)))
    (values covering partial)))


(defun gen-chart-check-covering (edge input-rels)
   ;; check that we've got all the relations that we wanted
   (gen-chart-subset-p
      input-rels
      (g-edge-rels-covered edge)))


(defun gen-chart-check-compatible (edge)
  ;; construct the MRS for edge
  ;; We test for 'compatibility' rather than equality - in
  ;; particular, semantics of generated string might be more specific than
  ;; input MRS wrt things like scope.
  (or (and *bypass-equality-check* (not (eq *bypass-equality-check* :filter)))
      ;;
      ;; at this point, we will try to confirm that the candidate realization
      ;; has a semantics compatible to our input.  in order for the comparison
      ;; to take advantage of the grammar-internal type hierarchy, we actually
      ;; compare internal MRSs.  still, to get default values (and `purity' and
      ;; such), go through the SEM-I VPM twice: extract-mrs() does the forward
      ;; mapping by default, so to return to internal values, run backwards one
      ;; more time.                                              (4-jul-06; oe)
      ;;
      (let* ((input *generator-internal-mrs*)
             (mrs (let ((mrs:*lnkp* :id)) (mrs::extract-mrs edge))))
        (setf (edge-mrs edge) mrs)
        ;;
        ;; see the comment on extract-string-from-g-edge() for our rationale in
        ;; determining the surface string for this .edge. just here.  the side
        ;; effect on the `lnk' value in EPs is destructive.  unfortunately, EPs
        ;; get copied in equate-all-qeqs(), and those copies will end up in the
        ;; solution returned by compare-mrss().  hence, we need to make sure to
        ;; destructively set LNK values early enough.           (16-jul-08; oe)
        ;;
        (extract-string-from-g-edge edge)
        (let* ((imrs (mt:map-mrs mrs :semi :backward))
               (imrs (if *gen-equate-qeqs-p* (mrs::equate-all-qeqs imrs) imrs))
               #+:logon
               (roles (list (mrs::vsym "TPC") (mrs::vsym "PSV")))
               ;;
               ;; in a few cases, the input is over-specified, e.g. using an
               ;; `i' variable for an unbound subject in infinitivals.
               ;;
               #+:logon
               (types '(("i" "u")))
               (solution (mt::compare-mrss imrs input :type :subsumption))
	       
	       (solution (if solution
			     (if *mrs-icons-strict-check-p*
				 (if
				     (mrs::mrs-equalp imrs input nil nil t t)
				     solution)
			       solution)))
	       
               (distance
                ;;
                ;; _fix_me_
                ;; the following is, say, incredibly naive: rather than trying
                ;; ten or so times, the comparison should be able to carry on 
                ;; when detecting a problem (that can be remedied according to
                ;; one of the known ways of relaxation) and return a suitable
                ;; code indicating which exception(s) had to be made.
                ;;                                             (30-may-06; oe)
                (or (when solution 0)
                    #+:logon
                    (when (eq *bypass-equality-check* :filter)
                      (or
                       (when (setf solution
                               (mt::compare-mrss
                                imrs input :type :subsumption
                                :roles roles))
                         1)
                       (when (setf solution
                               (mt::compare-mrss
                                imrs input :type :subsumption
                                :types types))
                         2)
                       (when (setf solution
                               (mt::compare-mrss
                                imrs input :type :subsumption
                                :properties t))
                         3)
                       (when (setf solution
                               (mt::compare-mrss
                                imrs input :type :subsumption
                                :roles roles :types types))
                         4)
                       (when (setf solution
                               (mt::compare-mrss
                                imrs input :type :subsumption
                                :roles roles :properties t))
                         5)
                       (when (setf solution
                               (mt::compare-mrss
                                imrs input :type :subsumption
                                :roles roles :properties t :types types))
                         6)
                       (when (setf solution
                               (mt::compare-mrss
                                imrs input :type :subsumption
                                :hcons t))
                         7)
                       (when (setf solution
                               (mt::compare-mrss
                                imrs input :type :subsumption
                                :roles roles :hcons t))
                         8)
                       (when (setf solution
                               (mt::compare-mrss
                                imrs input :type :subsumption
                                :roles roles :properties t :hcons t))
                         9)
                       42)))))
          (when solution
            (let* ((eps (mt::solution-eps solution))
                   (distortion
                    (ignore-errors (mrs::compute-lnk-distortion eps))))
              (push (cons :distortion distortion) (edge-flags edge))))
          (values (and (numberp distance) (= distance 0)) distance)))))

(defun gen-compute-root-edges (edges
                               &optional (start-symbols (or *gen-start-symbol* *start-symbol*)))
  ;; c.f. compute-root-edges in parse.lsp
  (if (and start-symbols *substantive-roots-p*)
      (loop for edge in edges
          nconc
          (loop
              for start-symbol
                  in (if (listp start-symbols) start-symbols (list start-symbols))
              for rtdfs = (get-tdfs-given-id start-symbol)
              when rtdfs
              do
                (let ((unif (yadu rtdfs (g-edge-dag edge))))
                  (when unif
                    (let*
                       ((accessible (collect-semantic-variables-in-fs unif))
                        (new-edge
                          (make-g-edge :id (next-edge)
                                       :category (indef-type-of-tdfs unif)
                                       :rule start-symbol
                                       :dag (copy-tdfs-elements unif)
                                       :dag-restricted
                                       (restrict-fs (tdfs-indef unif))
                                       :rels-covered (g-edge-rels-covered edge)
                                       :children (list edge)
                                       :leaves (g-edge-leaves edge)
                                       :lex-ids (g-edge-lex-ids edge)
                                       :lexemes (g-edge-lexemes edge)
                                       :accessible accessible)))
                      (gen-chart-add-with-index new-edge)
                      (return (list new-edge)))))))
      edges))

(defun gen-filter-root-edges (edges &key
                                    (start-symbols (or *gen-start-symbol* *start-symbol*))
                                    (full-check-p t))
  ;; as well as checking edges against start symbols, we also check the edges' top
  ;; type constraints, since some relevant features may have been restricted out
  ;; 
  (unless (listp start-symbols) (setq start-symbols (list start-symbols)))
  (loop
      with roots = (loop
                       for start-symbol in start-symbols
                       when (get-tdfs-given-id start-symbol)
                       collect it)
      for edge in edges
      for match = (loop
                      for root in roots
                      thereis
                      (and
                        (unifiable-wffs-p
                          (tdfs-indef root)
                          (tdfs-indef (g-edge-dag edge)))
                        (unifiable-wffs-p
                          (tdfs-indef root)
                          (ltype-constraint
                            (get-type-entry (dag-type (tdfs-indef (g-edge-dag edge))))))))
      when
      (and match
           (if (and full-check-p *additional-root-condition*)
               (funcall *additional-root-condition* (edge-dag edge))
               t))
      collect edge))


;;; Chart indexing - on *semantics-index-path* values. May be full types or
;;; instance types. Seem to be mostly disjoint if not eq, so don't bother using
;;; a tree-like representation
;;;
;;; The generator chart *gen-chart* is a list, with each element being of the form
;;; (index actives . passives). In addition, an auxiliary array *gen-pchart*
;;; stores passive edges (only), for more efficient retrieval of packing candidates
;;; based on the index of the first relation covered and the total number covered
;;;
;;; Apart from the functions below, the only others that need to know the internal
;;; representation of the chart are: print-gen-chart, find-gen-edge-given-id
;;; and create-gen-chart-pointers

(defun gen-chart-dag-index (index-dag edge-id)
   (declare (ignore edge-id))
   (if index-dag
      (unify-get-type index-dag) ; may be called inside unif context
      (progn
         ;; (cerror (format nil "use type ~A" *toptype*)
         ;;    "unexpectedly missing index for edge ~A: ~S" edge-id dag)
         ;; (warn "unexpectedly missing index for edge ~A - using ~A" edge-id *toptype*)
         *toptype*)))


(defun gen-chart-add-with-index (edge &optional chart-index)
  (let ((index
           (or chart-index
              (gen-chart-dag-index
                 (or (existing-dag-at-end-of
                        (tdfs-indef (g-edge-dag edge)) *semantics-index-path*)
                     (if *alt-semantics-index-path*
                         (existing-dag-at-end-of
                            (tdfs-indef (g-edge-dag edge)) *alt-semantics-index-path*)))
                 (g-edge-id edge)))))
      (setf (g-edge-index edge) index)
      (let ((entry (assoc index *gen-chart* :test #'equal))) ; index may be a cons
         (unless entry
            (push (setq entry (list* index nil nil)) *gen-chart*))
         ;; is edge is active or passive?
         (if (g-edge-needed edge)
            (progn
               (push edge (cadr entry))
               index)
            (if *gen-packing-p*
                (loop
                    with first = (gen-chart-set-ctz (g-edge-rels-covered edge))
                    with covered = (logcount (g-edge-rels-covered edge))
                    for inact in (aref *gen-pchart* first covered)
                    when 
                      (and
                        (gen-chart-set-equal-p
                           (g-edge-rels-covered edge) (g-edge-rels-covered inact))
                        (not (g-edge-foo inact)) ; avoid previously unpacked part of forest
                        ;; can only pack this edge into existing inact if latter has equal
                        ;; or subset of accessible indices, i.e. is equally or less liable
                        ;; to be filtered
                        (accessible-list-subset-p
                           (g-edge-accessible inact) (g-edge-accessible edge))
                        (restrictors-subsuming-p
                           (g-edge-dag-restricted inact) (g-edge-dag-restricted edge)))
                    do
                      (multiple-value-bind (forwardp backwardp)
                            (dag-subsumes-p
                               (tdfs-indef (g-edge-dag inact)) (tdfs-indef (g-edge-dag edge)))
                         (when *debugging*
                            (format t "~&Trying subsumption between edges ~A and ~A"
                                    (g-edge-id inact) (g-edge-id edge)))
                         (when forwardp
                            (if backwardp
                               (progn
                                  (incf (statistics-equivalent *statistics*))
                                  (push edge (g-edge-equivalent inact)))
                               (progn
                                  (incf (statistics-proactive *statistics*))
                                  (push edge (g-edge-packed inact))))
                            (return nil))) ; packed successfully
                    finally
                      (push edge (cddr entry))
                      (push edge (aref *gen-pchart* first covered))
                      (return index))
                (progn
                   (push edge (cddr entry))
                   index))))))


(defun gen-chart-retrieve-with-index (index mode)
  ;; return all active/inactive edges in chart keyed by a type compatible with index
  (let ((res nil))
    (dolist (entry *gen-chart* res)
      (when (greatest-common-subtype (car entry) index)
         (let ((edges (if (eq mode 'active) (cadr entry) (cddr entry))))
            (when edges (push edges res)))))))


;;; Daughter paths in a rule, in the order that they should be instantiated. Second
;;; value is the zero-based index of the head/key daughter

(defun gen-chart-rule-ordered-daughters (rule)
   (values
      (rule-daughters-apply-order rule)
      (gen-chart-path-index
         (car (rule-daughters-apply-order rule)) (cdr (rule-order rule)))))


;;; Core control functions. Processing inactive and active edges

(defun gen-chart-add-inactive (edge input-sem input-rels)
  ;; assume that all relations supplied in lexical entries and rules
  ;; are relevant to input-sem, i.e. that if we've generated an edge
  ;; it won't contain any relations that aren't in input-sem
  (unless edge (return-from gen-chart-add-inactive nil))
  (let ((index (gen-chart-add-with-index edge)))
    ;; no index, so not entered into the chart as a first class citizen
    (unless index (return-from gen-chart-add-inactive nil))
    ;; if we are in non-exhaustive mode, check to see whether we just found a result
    (when (and *gen-first-only-p* (null *unpacking-scoring-hook*)
               (gen-filter-root-edges (list edge) :full-check-p nil)
               (gen-chart-find-covering-edges (list edge) input-rels))
      (let ((results
              (realisations-from-covering-edges
                (list edge) nil *gen-first-only-p* input-sem nil)))
        (when results
          (setq *gen-record* (append *gen-record* results))
          (decf *gen-first-only-p* (length results))
          (when (< *gen-first-only-p* 1)
            (throw 'first t)))))
    ;; see if this new inactive edge can extend any existing active edges
    (dolist (actlist (gen-chart-retrieve-with-index index 'active))
      (dolist (act actlist)
        (let ((act act)) ; ensure we have a new binding for .act.
          (with-agenda (when (and *gen-first-only-p* (null *unpacking-scoring-hook*))
                         (if *gen-scoring-hook*
                             (funcall *gen-scoring-hook* (list :active act edge))
                             (gen-rule-priority (g-edge-rule act))))
            (gen-chart-test-active edge act input-sem input-rels)))))
    ;; see if we can create new active edges by instantiating the head
    ;; daughter of a rule
    (dolist (rule *non-intersective-rules*) 
      (when *debugging*
        (format t "~&Trying to create new active edge from rule ~A ~
                   and inactive edge ~A"
          (rule-id rule) (g-edge-id edge)))
      (let ((rule rule)) ; ensure we have a new binding for .rule.
         (with-agenda (when (and *gen-first-only-p* (null *unpacking-scoring-hook*))
                        (if *gen-scoring-hook*
                            (funcall *gen-scoring-hook* (list :rule rule edge))
                            (gen-rule-priority rule)))
           (multiple-value-bind (gen-daughter-order head-index) ; zero-based on daughters
               (gen-chart-rule-ordered-daughters rule)
             (multiple-value-bind (act chart-index)
                 (gen-chart-create-active
                   rule edge gen-daughter-order head-index)
               (when act
                 ;; and try and fill in next needed daughter of active edge
                 (gen-chart-extend-active act input-sem input-rels chart-index)))))))))


(defun gen-chart-create-active (rule edge gen-daughter-order head-index)
   (multiple-value-bind (unified-dag restricted chart-index)
          (gen-chart-try-unification rule
             (if *gen-packing-p* (rule-rtdfs rule) (rule-full-fs rule))
             (first gen-daughter-order) ; head daughter path
             (nth head-index (rule-daughters-restricted rule)) ; head restrictor
             head-index edge
             (rest gen-daughter-order)
             (first (rule-order rule)))
      (when unified-dag
         (let* ((needed (rest gen-daughter-order))
                (ndaughters (length gen-daughter-order)))
            (values
               (make-g-edge
                  :id (if needed (next-active-edge) (next-edge))
                  :rule rule
                  ;; category slot not filled in since not a complete constituent
                  :dag unified-dag
                  :res rule
                  :needed needed
                  :dag-restricted restricted
                  :rels-covered
                  (gen-chart-set-union
                     (if (mrs::found-rule-p rule)
                        (mrs::found-rule-main-rels rule)) 
                     (g-edge-rels-covered edge))
                  :children
                  (gen-make-list-and-insert ndaughters edge (1+ head-index))
                  :lex-ids
                  (gen-make-list-and-insert
                     ndaughters (g-edge-lex-ids edge) (1+ head-index))
                  :leaves
                  (gen-make-list-and-insert
                     ndaughters (g-edge-leaves edge) (1+ head-index))
                  :lexemes (g-edge-lexemes edge)
                  :accessible (g-edge-accessible edge))
               chart-index)))))


(defun gen-chart-test-active (inact act input-sem input-rels &optional one-off-p)
  ;; can extend active edge with inactive? First check to make sure new edge
  ;; would not use any relation from initial lexical items more than once.
  (when (and
           (or one-off-p ; intersection guaranteed to be OK if one-off-p
               (gen-chart-set-disjoint-p
                  (g-edge-rels-covered act) (g-edge-rels-covered inact)))
           (if (car (g-edge-children act)) ; looking for inact on right or left?
              (gen-chart-ordering-allowed-p
                 (g-edge-lexemes act) (g-edge-lexemes inact))
              (gen-chart-ordering-allowed-p
                 (g-edge-lexemes inact) (g-edge-lexemes act))))
       (when *debugging*
         (format t "~&Trying to extend active edge ~A with inactive edge ~A"
                 (g-edge-id act) (g-edge-id inact)))
       (let ((next-index
               (gen-chart-path-index
                  (first (g-edge-needed act)) (rest (rule-order (g-edge-res act))))))
         (multiple-value-bind (unified-dag restricted index-dag)
              (gen-chart-try-unification (g-edge-rule act)
                (g-edge-dag act)
                (first (g-edge-needed act))
                (g-edge-dag-restricted act)
                next-index inact
                (rest (g-edge-needed act))
                (first (rule-order (g-edge-res act)))
                act)
           (when unified-dag
             ;; remaining non-head daughters in active edge are filled in
             ;; left-to-right order
             (let* ((needed (rest (g-edge-needed act)))
                    (new-act
                     (make-g-edge
                      :id (if needed (next-active-edge) (next-edge))
                      ;; category slot not filled in since not (yet) a complete constituent
                      :rule (g-edge-rule act)
                      :dag unified-dag
                      :res (g-edge-res act)
                      :needed needed
                      :dag-restricted restricted
                      :rels-covered
                      (gen-chart-set-union
                         (g-edge-rels-covered act) (g-edge-rels-covered inact))
                      :children
                      (gen-copy-list-and-insert
                        (g-edge-children act) inact next-index)
                      :lex-ids 
                      (gen-copy-list-and-insert
                        (g-edge-lex-ids act) (g-edge-lex-ids inact) next-index)
                      :leaves
                      (gen-copy-list-and-insert
                        (g-edge-leaves act) (g-edge-leaves inact) next-index)
                      :lexemes
                      (append (g-edge-lexemes act) (g-edge-lexemes inact))
                      :mod-index (g-edge-mod-index act)
                      :accessible (union (g-edge-accessible act) (g-edge-accessible inact)))))
               (if one-off-p new-act
                 ;; (ERB 2003-10-22) There originally wasn't any reference to
                 ;; the agenda here, but I'm not getting my hands on all of the
                 ;; edges.
                 (with-agenda (when (and *gen-first-only-p* (null *unpacking-scoring-hook*))
                                (if *gen-scoring-hook*
                                    (funcall *gen-scoring-hook* (list :active act inact))
                                    (gen-rule-priority inact)))
                   (gen-chart-extend-active 
                     new-act input-sem input-rels index-dag)))))))))


(defun gen-chart-extend-active (act input-sem input-rels act-chart-index)
   (if (g-edge-needed act)
      ;; add newly extended active edge to chart, then look for any existing
      ;; inactive edges which can extend it
      (let ((index (gen-chart-add-with-index act act-chart-index)))
         (dolist (elist (gen-chart-retrieve-with-index index 'inactive))
            (dolist (e elist)
               (gen-chart-test-active e act input-sem input-rels))))
      ;; have ended up completing an active edge - forming a complete constituent
      (gen-chart-add-inactive
         (gen-chart-finish-active act input-sem) input-sem input-rels)))


(defun gen-chart-finish-active (e input-sem)
   ;; turn active into an inactive edge
   (setf (g-edge-category e) (indef-type-of-tdfs (g-edge-dag e)))
   (setf (g-edge-res e) nil)
   (setf (g-edge-lex-ids e)
      (apply #'append (g-edge-lex-ids e)))
   (setf (g-edge-leaves e)
      (apply #'append (g-edge-leaves e)))
   (let ((old-accessible (g-edge-accessible e))
         newly-inaccessible)
      (setf (g-edge-accessible e)
         (collect-semantic-variables-in-fs (g-edge-dag e)))
      (setq newly-inaccessible
         (set-difference old-accessible (g-edge-accessible e)))
      (when (and *gen-filtering-p* newly-inaccessible)
         (dolist (rel (mrs::psoa-liszt input-sem))
            (unless (logbitp (getf *gen-rel-indexes* rel) (g-edge-rels-covered e))
               ;; rel in input semantics not covered by this edge - now check the
               ;; rel's handle and its other non-ignorable variables against the set
               ;; of vars that have just become inaccessible
               (when (and mrs::*rel-handel-path*
                          (member (mrs::var-id (mrs::rel-handel rel)) newly-inaccessible))
                  (when *gen-filtering-debug*
                     (format t
"~&Filtering edge ~A on non-covered rel ~A needing inaccessible variable ~A~%"
                        (g-edge-id e) (mrs::rel-pred rel) (mrs::var-id (mrs::rel-handel rel)))
                     (print-gen-chart-edge e t nil))
                  (return-from gen-chart-finish-active nil))
               (dolist (fp (mrs::rel-flist rel))
                  (when (and (mrs::var-p (mrs::fvpair-value fp))
                             (not (member (mrs::fvpair-feature fp) mrs::*scoping-ignored-roles*))
                             (member (mrs::var-id (mrs::fvpair-value fp)) newly-inaccessible))
                     (when *gen-filtering-debug*
                        (format t
"~&Filtering edge ~A on non-covered rel ~A needing inaccessible variable ~A~%"
                           (g-edge-id e) (mrs::rel-pred rel) (mrs::var-id (mrs::fvpair-value fp)))
                        (print-gen-chart-edge e t nil))
                     (return-from gen-chart-finish-active nil)))))))
   e)


;;; Unification routines, entered only through gen-chart-try-unification

(defun gen-chart-try-unification (rule rule-tdfs daughter-path
                                  daughter-restricted daughter-index edge 
                                  needed mother-path &optional act)
   ;; try unification corresponding to applying a grammar rule or incorporating
   ;; inactive into an active edge
   (if (and (check-rule-filter rule (g-edge-rule edge) daughter-index)
            (restrictors-compatible-p daughter-restricted 
                                      (g-edge-dag-restricted edge)))
      (gen-chart-evaluate-unification
         rule-tdfs daughter-path (g-edge-dag edge) needed mother-path act)
      (progn (incf (statistics-ftasks *statistics*)) nil)))


(defun gen-chart-evaluate-unification (rule-tdfs daughter-path fs needed
                                       mother-path &optional act)
   ;; c.f. evaluate-unifications in parse.lsp
   ;; 
   ;; No orthography done here - it was done during the production of the
   ;; initial set of candidate lexical entries
   ;;
   ;; unify path <daughter-path> of rule-tdfs with fs, then if needed is
   ;; false return mother portion of rule-tdfs. Return as second value
   ;; the quick-check restrictor for the result, and if needed is true
   ;; return as third value the semantic index for next needed daughter
   (unless rule-tdfs
      ;; a previous delayed copy stuffed back into edge failed
      (return-from gen-chart-evaluate-unification nil))
   (when (functionp rule-tdfs)
      ;; redo the unification and delayed copy, stuffing result back into the
      ;; active edge. Copy might fail due to circularity
      (setf (g-edge-dag act) (setq rule-tdfs (funcall rule-tdfs)))
      (unless rule-tdfs
         (decf (statistics-stasks *statistics*))
         (return-from gen-chart-evaluate-unification nil)))
   (with-unification-context (ignore)
     (incf (statistics-etasks *statistics*))
     (unless
        (setq rule-tdfs
           (yadu rule-tdfs
              (create-temp-parsing-tdfs fs daughter-path)))
        (return-from gen-chart-evaluate-unification nil))
     (incf (statistics-stasks *statistics*))
     (if needed
        #+:gen-immediate-copy
        (let ((dag (copy-tdfs-elements rule-tdfs))) ; immediately copy active edge
           (when dag
              (values
                 dag
                 (restrict-fs
                    (existing-dag-at-end-of (tdfs-indef dag) (first needed)))
                 (gen-chart-dag-index
                    (existing-dag-at-end-of (tdfs-indef dag)
                      (append (first needed) *semantics-index-path*))
                    nil))))
        #-:gen-immediate-copy ; the default
        (values
           ;; return a closure which when funcalled will replay the unification and
           ;; perform copy - don't do copy yet since no guarantee we'll ever use it
           #'(lambda ()
               (with-unification-context (ignore)
                  (copy-tdfs-elements
                     (yadu rule-tdfs
                        (create-temp-parsing-tdfs fs daughter-path)))))
           (x-restrict-fs
              (x-existing-dag-at-end-of (tdfs-indef rule-tdfs) (first needed)))
           (gen-chart-dag-index
              (x-existing-dag-at-end-of (tdfs-indef rule-tdfs)
                 (append (first needed) *semantics-index-path*))
              nil))
        (let ((dag (restrict-and-copy-tdfs
                      (tdfs-at-end-of mother-path rule-tdfs))))
           (when dag
             (values dag (restrict-fs (tdfs-indef dag))))))))


;;; Second phase, where intersective modifiers are introduced

(defun gen-chart-adjoin-modifiers (partial-edges input-rels possible-grules)
   (let
      ((intersective-edges (gen-chart-intersective-inactive-edges))
       (intersective-rules-and-daughters
         (mapcar
            #'(lambda (p)
               (if (consp p) p
                  (let ((rule (get-grammar-rule-entry p)))
                     (cons p
                        (if rule
                           (loop for i from 1 to (1- (length (rule-order rule)))
                                 collect i))))))
            *intersective-rule-names*))
       (partial-extendable nil))
      (when *gen-adjunction-debug*
         (format t "~%Intersective inactive edges: ~:A" 
            (mapcar #'g-edge-id intersective-edges)))
      (let*
         ((mod-candidate-edges
            (gen-chart-active-mod-candidate-edges
               intersective-edges possible-grules intersective-rules-and-daughters)))
         ;; perform all possible adjunctions of modifiers into others e.g. to get nested PPs
         ;; -- NB after doing this some of the modifiers may have supersets of rels-covered
         ;; unpackable from them
         (when *gen-adjunction-debug* (format t "~&Adjoining into adjuncts"))
         (dolist (int mod-candidate-edges)
            (gen-chart-insert-adjunction int
               (remove-if-not
                  #'(lambda (mod) (gen-chart-set-disjoint-p mod (g-edge-rels-covered int)))
                  mod-candidate-edges :key #'g-edge-rels-covered)
               nil))
         ;; adjoin into partial analyses, considering only modifiers that do not have
         ;; any overlap, and rejecting any partial analysis that couldn't be completed
         ;; by any subset of modifiers available
         (dolist (partial partial-edges)
            (when *gen-adjunction-debug*
               (format t "~&---~%Partial edge [~A] spanning ~:A" (g-edge-id partial)
                  (g-edge-leaves partial)))
            (let
               ((missing-rels
                   (gen-chart-set-difference input-rels (g-edge-rels-covered partial)))
                (non-overlapping
                   (remove-if-not
                      #'(lambda (mod)
                           (gen-chart-set-disjoint-p mod (g-edge-rels-covered partial)))
                      mod-candidate-edges :key #'g-edge-rels-covered)))
               (when (and non-overlapping
                        (gen-chart-set-equal-p missing-rels
                           (reduce #'gen-chart-set-union
                              non-overlapping :key #'g-edge-rels-covered)))
                  (when *gen-adjunction-debug*
                     (format t "~&Checking adjunction into partial edge"))
                  (let ((adjoined
                          (gen-chart-insert-adjunction partial non-overlapping nil)))
                     (when adjoined
                        (when *gen-adjunction-debug*
                           (format t "~&Successful modifiers ~A" (mapcar #'g-edge-id adjoined)))
                        (push partial partial-extendable))))))
         partial-extendable)))


(defun gen-chart-set-rel-preds (rels)
   (flet ((rgetf (plist val)
            (do ((tail plist (cddr tail)))
                ((null tail) nil)
                (when (eql (cadr tail) val) (return (car tail))))))
      (loop for n from 0 to (1- (integer-length rels))
         for rel = (and (logbitp n rels) (rgetf *gen-rel-indexes* n))
         when rel collect (mrs::rel-pred rel))))


(defun gen-chart-intersective-inactive-edges nil
  ;; return a list of all inactive edges in chart which are able to function
  ;; as intersective modifiers
  (let ((res nil))
     (dolist (elist (gen-chart-retrieve-with-index *toptype* 'inactive) res)
        (dolist (e elist)
           (when
             (and
                ;; words like 'had' on their own with no semantics cannot be
                ;; intersective modifiers
                (gen-chart-set-non-empty-p (g-edge-rels-covered e))
                (intersective-modifier-dag-p (tdfs-indef (g-edge-dag e))))
             (push e res))))))


;;; Make active edges from inactive intersective modifier edges

(defun gen-chart-active-mod-candidate-edges (intersective-edges possible-grules
      intersective-rules-and-daughters)
   (mapcan
      #'(lambda (inact)
         (mapcan
            #'(lambda (rule)
               (let ((entry
                       (assoc (rule-id rule) intersective-rules-and-daughters :test #'eq)))
                  (when entry
                     (mapcan
                        #'(lambda (index) ; index is 1 for 1st daughter, etc
                           (let ((path (nth index (rule-order rule))))
                              (unless path
                                 (error "No daughter ~A in rule ~A" index (rule-id rule)))
                              (multiple-value-bind (act index-dag)
                                    (gen-chart-create-active 
                                       rule inact
                                       (cons path
                                          (remove path (cdr (rule-order rule)) :test #'eq))
                                       (gen-chart-path-index path (cdr (rule-order rule))))
                                 (when act
                                    (unless (eql (length (g-edge-needed act)) 1)
                                       (error "Intersective modification rule ~A is not ~
                                          binary branching" (rule-id rule)))
                                    (setf (g-edge-mod-index act)
                                       (gen-chart-path-index
                                          (first (g-edge-needed act)) (cdr (rule-order rule))))
                                    (when (functionp (g-edge-dag act))
                                       (setf (g-edge-dag act) (funcall (g-edge-dag act))))
                                    (gen-chart-add-with-index act index-dag)
                                    (when *gen-adjunction-debug*
                                       (format t "~&Inactive [~A] -> active [~A]"
                                          (g-edge-id inact) (g-edge-id act)))
                                    (list act)))))
                         (cdr entry)))))
            possible-grules))
       ;; (mapcan #'(lambda (e) (unpack-edge! e)) intersective-edges)
       intersective-edges))


;;; Attempt to adjoin all possible of acts into forest with top node edge, recording
;;; in list adjoined which of acts succeeded in adjoining at some point.

(defun gen-chart-insert-adjunction (edge acts adjoined)
   (unless (member nil (g-edge-children edge))
      ;; don't try to adjoin into the top of an active edge
      (dolist (act acts)
         (when (gen-chart-try-adjunction act edge)
            (pushnew act adjoined)
            (pushnew act (g-edge-adjuncts edge)))))
   (dolist (c (g-edge-children edge))
      (when c
         ;; don't try to adjoin into the needed daughter of an active edge
         (setq adjoined (gen-chart-insert-adjunction c acts adjoined))))
   (dolist (p (g-edge-equivalent edge))
      (setq adjoined (gen-chart-insert-adjunction p acts adjoined)))
   (dolist (p (g-edge-packed edge))
      (setq adjoined (gen-chart-insert-adjunction p acts adjoined)))
   adjoined)
         
         
(defun gen-chart-try-adjunction (act edge)
   (let ((rule (g-edge-rule act))
         (rule-tdfs (g-edge-dag act))
         (daughter-path (first (g-edge-needed act)))
         (daughter-restricted (g-edge-dag-restricted act))
         (daughter-index (g-edge-mod-index act))
         (fs (g-edge-dag edge)))
      (if (and (check-rule-filter
                  rule (g-edge-rule edge) daughter-index)
               (restrictors-compatible-p
                  daughter-restricted (g-edge-dag-restricted edge)))
         (with-unification-context (ignore)
            (incf (statistics-etasks *statistics*))
            (if
               (yadu rule-tdfs
                  (create-temp-parsing-tdfs fs daughter-path))
               (progn
                  (incf (statistics-stasks *statistics*))
                  (when *gen-adjunction-debug*
                     (format t
"~&Adjoining active edge ~A covering ~A~%   into inactive edge ~A covering ~A" 
                        (g-edge-id act) (g-edge-leaves act) (g-edge-id edge)
                        (g-edge-leaves edge)))
                  t)
               nil))
         (progn (incf (statistics-ftasks *statistics*)) nil))))


;;; Print out summary of strings in generator chart - (print-gen-summary)

(defun print-gen-summary (&key (stream t))
   (format stream "~%> generator chart summary:~%")
   (let ((leaves nil))
      (dolist (entry *gen-chart*)
         (dolist (e (cddr entry))
            (pushnew (g-edge-leaves e) leaves :test #'equal)
            (dolist (p (g-edge-equivalent e))
               (pushnew (g-edge-leaves p) leaves :test #'equal)
            (dolist (p (g-edge-packed e))
               (pushnew (g-edge-leaves p) leaves :test #'equal)))))
      (dolist (s
                (sort leaves
                   ;; on length, and then lexicographically case-insensitive
                   #'(lambda (x y)
                       (if (eql (length x) (length y))
                          (loop for a in x for b in y do
                             (unless (string-equal a b) (return (string-lessp a b))))
                          (< (length x) (length y))))))
         (format stream "~A~%" s))
      (format stream "~%")))


;;; Print out contents of generator chart (tty output) - (print-gen-chart)

(defun print-gen-chart (&key concise (stream t) activep)
   (format stream "~%> generator chart dump:~%")
   (dolist (entry (reverse *gen-chart*)) ; order in which originally created
      (format stream "~%Vertex ~(~A~):~%" (car entry))
      (dolist (e (sort (append (cadr entry) (copy-list (cddr entry))) #'<
                       :key #'edge-id))
        (when (or activep (> (edge-id e) 0))
          (print-gen-chart-edge e stream concise)
          (dolist (p (g-edge-equivalent e))
            (format stream " = packed ")
            (print-gen-chart-edge p stream concise)
            (dolist (p (g-edge-packed e))
              (format stream " > packed ")
              (print-gen-chart-edge p stream concise))))))
   (format stream "~%"))

(defun print-gen-chart-edge (e stream concise)
  (format 
   stream "[~A] ~A~A ~35,5T=> (~{~:A~^ ~}) ~A [~{~A~^ ~}]~%"
   (g-edge-id e)
   (if (rule-p (g-edge-rule e))
     (rule-id (g-edge-rule e))
     (if concise (first (g-edge-lex-ids e)) (g-edge-rule e)))
   (if (g-edge-needed e)
     (format nil " / ~{~A~^ ~}" (g-edge-needed e))
     "")
   (g-edge-leaves e)
   (if (and *gen-filtering-p* *gen-filtering-debug*)
     (format nil " a~:A " (sort (copy-list (g-edge-accessible e)) #'<))
     "")
   (mapcan #'(lambda (x) (if x (list (g-edge-id x)))) (g-edge-children e))))


(defun print-generator-lookup-summary (lex-items grules)
  ;;
  ;; code formerly commented out in body of generate-from-mrs(); move here for
  ;; better readability of the main function.                  (19-apr-04; oe)
  ;;
  (dolist (lex lex-items)
    (format t "~%Id ~A, Index ~A, Lexical rules ~:A, Main rel sorts ~:A"
            (mrs::found-lex-lex-id lex)
            (gen-chart-dag-index
             (existing-dag-at-end-of
              (tdfs-indef (mrs::found-lex-inst-fs lex)) *semantics-index-path*)
             nil)
            (mrs::found-lex-rule-list lex)
            (mapcar #'mrs::rel-pred (mrs::found-lex-main-rels lex))))
  (print
   (sort (remove-duplicates (mapcar #'mrs::found-lex-lex-id lex-items))
         #'string-lessp))
  (finish-output)
  (dolist (grule grules)
    (when (mrs::found-rule-p grule)
      (format t "~%Id ~A, Index ~A, Main rel sorts ~:A"
              (mrs::found-rule-id grule)
              (gen-chart-dag-index
               (existing-dag-at-end-of
                (tdfs-indef (mrs::found-rule-full-fs grule)) 
                *semantics-index-path*)
               nil)
               (mapcar #'mrs::rel-pred (mrs::found-rule-main-rels grule))))))


;;; End of file