;;; 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 *debugging* nil)

(defvar *gen-chart* nil)
(defvar *gen-record* nil)
(defvar *gen-rel-indexes* nil)
(defvar *lexemes-allowed-orderings* nil)
(defvar *additional-root-condition-warning-p* t)

;;;
;;; 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))

(defmacro gen-chart-set-cardinality (r)
   `(logcount ,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.
;;; No point in collecting variables if *gen-filtering-p* is false.

(defconstant +variables-mark+ 31)

(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
  (let ((vars nil))
    (labels
      ((find-sem-vars (dag)
         (when (and (dag-arcs dag) (not (dag-copy dag)))
           (setf (dag-copy dag) +variables-mark+)
           (let ((type-name (get-value-at-end-of dag mrs::*instloc-path*)))
             (if type-name
                 (let ((s (and (stringp type-name)
                            (position-if #'digit-char-p type-name))))
                   (when s
                     (pushnew (parse-integer type-name :start s :junk-allowed t) 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 (member (dag-arc-attribute arc) *packing-restrictor*
                                    :test #'eq)))
                     (find-sem-vars (dag-arc-value arc)))))))))
      (when *gen-filtering-p*
        (with-unification-context (nil) (find-sem-vars (tdfs-indef tdfs))))
      vars)))

#|
(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 (find x1 (the list 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*
  ;; now replaced with *gen-first-only-p* to match analogous mechanism in parser
  ;;
  ;; value of keyword argument signal effects what happens when a condition occurs:
  ;;   t: signal the condition - for use when we've established a suitable handler (e.g. with
  ;;   handler-case), or for when we want the condition to cause us to enter the debugger
  ;;   nil: if we only want a warning about the condition and a normal return with result nil
  (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)
      (handler-bind
          ((condition
             #'(lambda (condition)
                 (setf %generator-condition% condition)
                 (if signal
                     (error condition)
                     (progn
                       (warn (princ-to-string condition))
                       (return-from generate-from-mrs nil))))))
         (generate-from-mrs-internal mrs :nanalyses nanalyses))))


;;; 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)
      (unwind-protect
        (progn
          (flush-agenda *agenda*)
          (clear-gen-chart)
          (setq %generator-statistics% nil)
  
          (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))))
        ;; there may be incomplete realisations if a best-first search was halted, but
        ;; unfortunately we haven't got the freedom to finish them off
        (setq *gen-record* (delete-if-not #'edge-string *gen-record*))
        (flush-agenda *agenda*)))))


(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 ((*additional-root-condition-warning-p* *additional-root-condition-warning-p*)
        (*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 ; lex items with empty semantics not 'safe' since can be used >once
                   = (let* ((*safe-not-to-copy-p*
                              (gen-chart-set-non-empty-p (mrs::found-lex-main-rels fl)))
                            (e (unfold-found-lex fl)))
                       (when *gen-packing-p*
                         (setf (edge-odag e) (edge-dag e)
                               (edge-dag e) (copy-tdfs-partially (edge-odag e))))
                       e)
               do
                 (setf (g-edge-accessible edge)
                   (collect-semantic-variables-in-fs (g-edge-dag edge)))
                 ;; one copy operation per lexical item
                 (incf (statistics-copies *statistics*))
                 ;; with-agenda() closes over lexical variables, so we need to
                 ;; establish new bindings here for any of these that can get
                 ;; re-assigned after they were bound - 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)
  (when (eql n 0)
    (return-from realisations-from-covering-edges nil))
  (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 :dag-restricted (restrict-fs (tdfs-indef tdfs))
       :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))
           (rule (get-lex-rule-entry (first rules)))
           (otdfs
             ;; if rule has orthographemic effects, stash orth part of fs (ensuring
             ;; substring list is properly terminated, since make-orth-tdfs might not
             ;; do so) - we need orth later to be able to construct full tree FS and
             ;; post-generation mapping edge lattice
             (and (rule-orthographemicp rule)
               (let ((odag (create-dag))
                     (orth (existing-dag-at-end-of (tdfs-indef tdfs) *orth-path*)))
                 (with-unification-context (odag)
                   (loop
                       for d = (get-dag-value orth (car *list-tail*))
                             then (get-dag-value d (car *list-tail*))
                       while d
                       do (unless (dag-arcs d) (setf (dag-new-type d) *empty-list-type*)))
                   (unify-list-path *orth-path* odag orth)
                   (make-nondefault-tdfs (copy-dag odag))))))
           (tdfs (if rulesp (rule-full-fs rule) tdfs)))
      (make-g-edge
       :id (next-edge) :category (indef-type-of-tdfs tdfs)
       :rule rule :dag tdfs
       :orth-tdfs otdfs
       :needed nil :dag-restricted (restrict-fs (tdfs-indef tdfs))
       :rels-covered eps :children (list child)
       :leaves (edge-leaves child) :lex-ids (list id)
       :lexemes (if rulesp nil (list fl))))))
  

(defun extract-strings-from-gen-record ()
  (when *gen-record*
    ;; LOGON assumptions are incompatible with post-generation chart mapping
    (if #+:logon nil #-:logon (get-post-generation-mapping-rules)
        (perform-post-generation-mapping)
        (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
               (format nil "~{~a~^ ~}" (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 only, for 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.
        ;;
        #+:logon
        (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 e = (and (numberp id) (find-edge-in-gen-result id edge))
              for lnk = (and e (edge-lnk e))
              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)
  (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)
  ;; Check that the edge's MRS is compatible with the original input MRS.
  ;; We test for _compatibility_ rather than equality - in particular, the semantics
  ;; of a generated string might be more specific than the 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 with 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)
        ;;
        ;; !!! The LOGON scheme of linking EPs to character spans in the output
        ;; string is fundamentally incompatible with post-generation chart mapping,
        ;; since in the latter there's no guarantee of a 1-1 correspondence between
        ;; spans and chart edges (and therefore the EPs associated with them). So we
        ;; have a LOGON-only processing path here and disable post-generation mapping
        ;; in the presence of the :logon feature.  JAC 7-Sep-2022
        ;;
        #+:logon
        (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))
               (solution (mt::compare-mrss imrs input :type :subsumption))
	       (solution (when solution
			   (if *mrs-icons-strict-check-p*
			       (when (mrs::mrs-equalp imrs input nil nil t t)
				 solution)
			       solution)))
               (distance
                (or (when solution 0)
                    ;;
                    ;; _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)
                    #+:logon
                    (when (eq *bypass-equality-check* :filter)
                      (let ((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.
                            ;;
                            (types '(("i" "u"))))
                        (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 (eql 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 ((new-edge
                            (make-g-edge :id (next-edge)
                                         :category (indef-type-of-tdfs unif)
                                         :rule start-symbol
                                         :dag 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
                                         (collect-semantic-variables-in-fs unif))))
                      (unless *gen-packing-p*
                        ;; it would be misleading to add a post-unpacking edge to chart
                        (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))
  (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
      when (loop for root in roots
               for rule = (g-edge-rule edge)
               thereis
               (and
                 (yaduablep root (g-edge-dag edge))
                 (or (null *gen-packing-p*)
                     (stringp rule) ; a bare lexical entry?
                     ;; also check the rule's full FS since packing restrictor might have
                     ;; removed features relevant for filtering
                     (yaduablep root
                       (tdfs-at-end-of (car (rule-order rule)) (rule-full-fs rule))))))
      do
        (when (and *additional-root-condition-warning-p*
                full-check-p
                (not (satisfies-additional-root-condition-p (edge-dag edge))))
          (format t "~%Warning: additional root condition failed on a generator output")
          ;; prevent any further warnings of this kind for this input
          (setq *additional-root-condition-warning-p* nil))
      and 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 an alist. Each element of the alist is of the form
;;; (index ((rx a1 a2 ...) (ry a3 ...) ...) . ((rz p1 ...) ...)),
;;; where index is the semantic index of the edges in that element, r is an integer
;;; representing the relation set of the associated edges, the a's are active edges,
;;; and the p's are passive edges.
;;;
;;; 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 input-rels)
  (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))))
         (rels-covered (g-edge-rels-covered edge))
         (entry (assoc index *gen-chart* :test #'equal))) ; index is a type (symbol/string)
    (setf (g-edge-index edge) index)
    (unless entry
      (setq entry (list* index nil nil))
      (setq *gen-chart* (nconc *gen-chart* (list entry))))
    ;; is edge active or passive?
    (if (g-edge-needed edge)
        (let ((rels-actives (assoc rels-covered (cadr entry)))) ; rels-covered is an integer
           (if rels-actives
               (push edge (cdr rels-actives))
               (setf (cadr entry)
                 (merge 'list
                   (list (list rels-covered edge)) (cadr entry) #'<
                   :key #'(lambda (x) (gen-chart-set-cardinality (car x)))))))
        (progn
          (when (and *gen-packing-p*
                  input-rels
                  ;; prevent a potential root being packed, otherwise root filter not correct
                  (not (gen-chart-check-covering edge input-rels)))
            (dolist (entry *gen-chart*)
              (when (greatest-common-subtype (car entry) index)
                (loop
                    with forwardp = nil
                    with backwardp = nil
                    for inact in (cdr (assoc rels-covered (cddr entry)))
                    when
                      (and
                        (not (g-edge-foo inact)) ; avoid previously unpacked part of forest
                        (progn
                          (multiple-value-setq (forwardp backwardp)
                            (restrictors-subsuming-p
                              (g-edge-dag-restricted inact) (g-edge-dag-restricted edge) nil))
                           ;; we pack only in case of forward subsumption or equivalence
                           forwardp)
                        ;; 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)))
                    do
                      (multiple-value-bind (forwardp backwardp)
                          (dag-subsumes-p
                            (tdfs-indef (g-edge-dag inact)) (tdfs-indef (g-edge-dag edge))
                            forwardp backwardp)
                        (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-from gen-chart-add-with-index nil))))))) ; packed it
          (let ((rels-passives (assoc rels-covered (cddr entry))))
            (if rels-passives
                (push edge (cdr rels-passives))
                (setf (cddr entry)
                  (merge 'list
                    (list (list rels-covered edge)) (cddr entry) #'<
                    :key #'(lambda (x) (gen-chart-set-cardinality (car x)))))))))
    index))


(defun gen-chart-retrieve-with-index (index mode &optional (rels 0))
  ;; return all active/inactive edges in chart keyed by a type compatible with index, and
  ;; which cover a set of relations that's disjoint from rels
  (let ((res nil))
    (dolist (entry *gen-chart* res)
      (when (greatest-common-subtype (car entry) index)
        (loop
            for rels-edges in (case mode (active (cadr entry)) (inactive (cddr entry)))
            when (gen-chart-set-disjoint-p (car rels-edges) rels)
            do (push (cdr rels-edges) res))))))


;;; Daughter paths in a rule, in the order that they should be instantiated. Second
;;; value is the zero-based index of the key daughter (the daughter identified as best
;;; constraining rule applicability)

(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 nil input-rels)))
    ;; no index, so was 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 (g-edge-rels-covered edge)))
      (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 key daughter
    ;; 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 key-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 key-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 key-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) ; key daughter path
             (nth key-index (rule-daughters-restricted rule)) ; key restrictor
             key-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+ key-index))
                  :lex-ids
                  (gen-make-list-and-insert
                     ndaughters (g-edge-lex-ids edge) (1+ key-index))
                  :leaves
                  (gen-make-list-and-insert
                     ndaughters (g-edge-leaves edge) (1+ key-index))
                  :lexemes (g-edge-lexemes edge)
                  :accessible (g-edge-accessible edge))
               chart-index)))))


(defun gen-chart-test-active (inact act input-sem input-rels)
   ;; 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 (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-key) daughters in active edge are filled in L->R 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)))))
               (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 (g-edge-rule act))))
                 (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 (g-edge-rels-covered act)))
            (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
   (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)))))))
   (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)))
   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 combining an inactive edge with a grammar rule
   ;; or 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)))
      ;; if the inactive edge has empty semantics then any FS resulting from the
      ;; unification could potentially be used again to extend the current hypothesis
      ;; - therefore in new dag nodes, record 'safe not to be copied' as false
      (let ((*safe-not-to-copy-p*
              (and *safe-not-to-copy-p*
                   (gen-chart-set-non-empty-p (g-edge-rels-covered 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 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 fs daughter-path))))
           (unify-restrict-fs
              (unify-existing-dag-at-end-of (tdfs-indef rule-tdfs) (first needed)))
           (gen-chart-dag-index
              (unify-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 chart-index)
                                    (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 chart-index)
                                    (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 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
                   (mapcan
                     #'(lambda (rels-edges) (copy-list (cdr rels-edges)))
                     (append (cadr entry) (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