;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: LKB -*-


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


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;        file: active.lsp
;;;      module: experimental key-driven ((hyper-)active) parser for the LKB
;;;     version: 0.0 (16-jun-99)
;;;  written by: oe, coli saarbruecken
;;; last update: 20-jan-00
;;;  updated by: oe, coli saarbruecken
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; author            | date        | modification
;;; ------------------|-------------|------------------------------------------
;;;                   |             |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package :lkb)

;;;
;;; in order to experiment with various strategies, some of the extra functionality
;;; over vanilla active parsing is conditionalized with features, so that we
;;; can obtain precise profiles without interference.  the conditionals make
;;; the code awkward to read, though, and should ultimately disappear.
;;;
(defparameter *retroactivity-p* t)

(defparameter *hyper-activity-p* t)

(defparameter *scoring-hook* nil)

;;;
;;; Append the results of applying key to each of an indeterminate number of lists
;;; without copying the final one; faster and/or more space efficient than idioms
;;; such as mapcan/#'copy-list, reduce/#'append/:from-end=t, loop/append, etc.
;;;
(defun append-lists (lists &key (key #'identity))
  (cond ((null lists) nil)
        ((null (cdr lists)) (funcall key (car lists)))
        (t (append (funcall key (car lists)) (append-lists (cdr lists) :key key)))))

;;;
;;; chart packing under (partial) subsumption is now the default; one shortcoming:
;;;
;;;   - packing is only attempted within phrasal parsing, not during morphology
;;;     or lexical rule application; thus, similar lexical edges may well
;;;     proliferate and make life harder than necessary.
;;;

(defvar *active-edge-id* 0)
(defvar *maximum-number-of-active-edges* nil)

(defun next-active-edge ()
  (incf (statistics-aedges *statistics*))
  (when (> (abs *active-edge-id*) 
           (or *maximum-number-of-active-edges* *maximum-number-of-edges*))
     ;; in the case of *maximum-number-of-active-edges* being nil, the limit imposed
     ;; by *maximum-number-of-edges* is applied to active and passive edges
     ;; separately, not in aggregate
     (error "Hit limit of ~a active edges, possibly because `key' (most constraining) ~
             daughters are not well-chosen (see documentation for ~a)"
            (or *maximum-number-of-active-edges* *maximum-number-of-edges*)
            (if *maximum-number-of-active-edges*
              "*maximum-number-of-active-edges*"
              "*maximum-number-of-edges*")))
  (decf *active-edge-id*))

(defvar *achart* (make-array '(1 2) :initial-element nil))
(declaim (type (simple-array t (* 2)) *achart*) #+:sbcl (sb-ext:always-bound *achart*))

(defun clear-achart ()
  (let ((nvertices (1+ *chart-limit*)))
    (unless (and (arrayp *achart*)
                 (= (array-dimension *achart* 0) nvertices)
                 (= (array-dimension *achart* 1) 2))
      (setq *achart* (make-array (list nvertices 2)))))
  (dotimes (i (array-total-size *achart*))
    (setf (row-major-aref *achart* i) nil))
  (setf *active-edge-id* 0))

;;;
;;; add `chart reduction' support analoguous to PET (and first implemented in
;;; DFKI PAGE, following a proposal by Dr. Mueller).  given a set of pairs of
;;; paths into signs <source , target>+, after chart initialization (lexical
;;; look-up), check that for each lexical entry with a valid type at one of the
;;; source paths there is an item in the chart whose type at one of the target
;;; paths is compatible (i.e. unifiable) with the source type.  in other words,
;;; for all selectional restrictions, as found in a source path, some lexical
;;; entry must supply the appropriate value.  for instance, the `rely on' lexical
;;; entry will only survive if an `_on_rel_s' is provided somewhere in the chart.
;;;
(defvar *chart-dependencies* nil)

(defvar *cd-debug* nil) ; t/nil

(defun reduce-chart (&optional (n 1))
  (when *cd-debug*
    (if (= n 1) (format t "~&Chart reduction starting~%") (format t "~&Iteration ~A~%" n)))
  (flet ((prune (edge)
           ;; used to freeze edge but now delete it - makes chart display much clearer
           (when *cd-debug* (format t "~&Pruning ~A~%" edge))
           (let ((s (edge-from edge)) (e (edge-to edge)))
             (setf (aref *chart* s e) (delete edge (aref *chart* s e) :test #'eq)))))
    (loop
        with prunedp = nil
        with p2vs = nil
        with edges = (loop for s from 0 to (1- *chart-max*)
                           append
                           (loop for e from (1+ s) to *chart-max*
                                 append (remove-if #'edge-partial-tree (aref *chart* s e))))
        for e1 in edges
        unless
        (loop for (p1 p2) on *chart-dependencies* by #'cddr
              for p1v = (get-value-at-end-of (tdfs-indef (edge-dag e1)) p1)
              ;; if edge e1 has a value for path p1, then for e1 to survive there has to
              ;; be another edge e2 with a value for p2 and the values must unify
              always
              (or (null p1v)
                  (loop initially
                        (when *cd-debug*
                          (format t "~&Edge ~A at < ~{~A ~^: ~}> looking for ~A~%"
                            (edge-id e1) p1 p1v))
                        for e2 in edges
                        for p2v in
                          (or (getf p2vs p2) 
                              (setf (getf p2vs p2) ; cache p2 values across all edges
                                (loop for e in edges
                                      collect
                                      (get-value-at-end-of (tdfs-indef (edge-dag e)) p2))))
                        thereis
                        (and p2v
                             (not (eq e2 e1))
                             ;; !!! the following test correctly captures the intent of the
                             ;; mechanism, but we don't apply it since some DELPH-IN grammars
                             ;; rely on incorrect behaviour
                             ;; (or (>= (edge-from e2) (edge-to e1))  ; do e1 and e2 have
                             ;;     (<= (edge-to e2) (edge-from e1))) ; disjoint spans?
                             (greatest-common-subtype p1v p2v)
                             (progn
                               (when *cd-debug*
                                 (format t "~&  satisfied by ~A at < ~{~A ~^: ~}> in edge ~A~%"
                                   p2v p2 (edge-id e2)))
                               t)))))
        do (prune e1) (setq prunedp t)
        finally (when prunedp (reduce-chart (1+ n))))) ; !!! iterate until fixpoint reached
  (when (and *cd-debug* (= n 1))
    (format t "~&Reached fixpoint~%Chart reduction finished~%")))

(defmacro actives-looking-backward (position)
  `(aref *achart* ,position 1))

(defmacro actives-looking-forward (position)
  `(aref *achart* ,position 0))

(defun rule-and-passive-task (rule passive)
  (let ((task (cons rule passive)))
    (if (or *first-only-p* *chart-packing-p*)
        (let ((priority
                (if *scoring-hook*
                  (funcall *scoring-hook* task)
                  (let ((start (edge-from passive))
                        (end (edge-to passive)))
                    (if (and *first-only-p* (null *unpacking-scoring-hook*))
                      ;; non-exhaustive mode: combine rule priority with weighted span
                      (+ (* (rule-priority rule) 1000)
                         (- end (/ start (float *maximal-vertex*))))
                      ;; exhaustive: prioritise rightmost start, then smallest end (i.e. span)
                      (- (* start *maximal-vertex*) end))))))
          (agenda-insert *agenda* priority task))
        (process-rule-and-passive task))))

(defun active-and-passive-task (active passive arule)
  (let ((task (cons active passive)))
    (if (or *first-only-p* *chart-packing-p*)
        (let ((priority
                (if *scoring-hook*
                  (funcall *scoring-hook* task)
                  (if (and *first-only-p* (null *unpacking-scoring-hook*))
                    ;; non-exhaustive mode
                    (let* ((forwardp (edge-forwardp active))
                           (start (edge-from (if forwardp active passive)))
                           (end (edge-to (if forwardp passive active))))
                      (+ (* (rule-priority arule) 1000)
                         (- end (/ start (float *maximal-vertex*)))))
                    ;; exhaustive: as rule-and-passive-task but with small penalty
                    (let ((start (edge-from passive))
                          (end (edge-to passive)))
                      (- (* start *maximal-vertex*) end 0.5))))))
          (agenda-insert *agenda* priority task))
        (process-active-and-passive task))))

(defun passive-edges-from-chart (ignore-partial-p)
  ;; remove edges from passive chart and return them - but leaving behind partial-tree
  ;; edges if ignore-partial-p is true
  (loop with res = nil
      for s from 0 to (1- *chart-max*)
      do
      (loop for e from (1+ s) to *chart-max*
          do
          (setf (aref *chart* s e)
            (loop for edge in (aref *chart* s e)
                when (and ignore-partial-p (edge-partial-tree edge))
                  collect edge
                else
                  do (push edge res))))
      finally (return (nreverse res))))
                
(defun active-chart-parse ()
  (when *cm-debug*
    (format t "~&Lexical parsing starting~%"))
  ;;
  ;; lexical parsing - unconditionally run it in exhaustive mode and with packing
  ;; disabled (=> non-agenda-driven processing); packing would give little benefit and
  ;; would complicate lexical filtering and chart reduction
  ;;
  (let ((*parser-rules* *parser-lexical-rules*)
        (*chart-packing-p* nil)
        (*first-only-p* nil))
    (loop for edge in (passive-edges-from-chart nil)
        do
        ;; parse forest unpacking expects odag of leaf edges to contain full FS
        (setf (edge-odag edge) (edge-dag edge))
        (fundamental4passive edge)))
  (when *cm-debug*
    (format t "~&Lexical parsing finished - last lexical edge id ~A~%" *edge-id*))
  ;;
  ;; invoke lexical filtering if token mapping enabled; chart reduction comes after
  ;; lexical parsing (the default order for other DELPH-IN processors)
  ;;
  (when *token-type* (perform-lexical-filtering))
  (when *chart-dependencies* (reduce-chart))
  ;;
  ;; phrasal parsing - NB lexical rules are excluded, and therefore cannot apply to
  ;; phrases (c.f. 'The (New) LKB System' section 5.3.4); if they were included in phrasal
  ;; parsing then we'd have to prevent them from applying to edges they'd already applied
  ;; to in lexical parsing. (Also, we'd have the odd situation of lexical filtering and
  ;; chart reduction happening before lexical rules had finished applying)
  ;;
  (let ((*parser-rules*
          (remove-if #'lexical-rule-p *parser-rules*))
        (agenda-driven-p
          (or *first-only-p* *chart-packing-p*)))
    (loop for edge in (passive-edges-from-chart t)
        do
        ;; copy each lexical parsing output to ensure we don't get spurious reentrancies
        ;; from lexical entries used more than once in a sentence (in the presence of
        ;; chart mapping and generic LEs, the previous approach of selective copying of
        ;; individual LEs via sentence-wide *lexical-entries-used* / copy-lex-fs-as-needed
        ;; results in massive over-copying of generic LEs)
        (setf (edge-dag edge)
          (if *chart-packing-p*
              (copy-tdfs-partially (edge-dag edge))
              (copy-tdfs-completely (edge-dag edge))))
        (if agenda-driven-p
            (let ((priority
                    (if *scoring-hook*
                        (funcall *scoring-hook* edge)
                        ;; check whether we're in non-exhaustive mode
                        (if (and *first-only-p* (null *unpacking-scoring-hook*))
                            (+ (* (lex-priority edge) 1000) 1) ; span of 1 vertex
                            (- (* *maximal-vertex* *maximal-vertex*) (edge-to edge)))))) ; max pri
              (agenda-insert *agenda* priority edge))
            (fundamental4passive edge)))
    (when agenda-driven-p (complete-chart))))

(defun complete-chart ()
  (loop
      until (agenda-empty-p *agenda*)
      for task = (agenda-extract-max *agenda*)
      when (edge-p task) do
        (fundamental4passive task)
      else when (rule-p (first task)) do
        (process-rule-and-passive task)
      else do
        (process-active-and-passive task)))

(defun check-postulate-spanning-filter (key open begin end)
  ;; return nil if the edge we're about to postulate could never span complete input
  ;; 
  (cond
    ((null open) ; is this spanning rule unary?
       (and (= begin *minimal-vertex*) (= end *maximal-vertex*)))
    ((< key (first open)) ; is key daughter leftmost?
       (= begin *minimal-vertex*))
    ((> key (car (last open))) ; is key daughter rightmost?
       (= end *maximal-vertex*))))

(defun postulate (passive)
  ;; create parsing tasks for each rule that could fire with .passive. in its
  ;; key daughter.
  ;;
  #+:adebug (print-trace :postulate passive)

  (loop
      with begin fixnum = (edge-from passive)
      with end fixnum = (edge-to passive)
      with prule of-type (or string rule) = (edge-rule passive)
      with orthographemics = (edge-partial-tree passive)
      for rule in (if orthographemics
                      (let* ((next (pt-node-rule (first orthographemics)))
                             (rule (get-lex-rule-entry next)))
                        (unless rule
                          (error "postulate(): ~a requires unknown rule `~(~a~)'.~%"
                            passive next))
                        (cons rule
                          (loop
                              for plr in *parser-lexical-rules*
                              when (check-sp-lr-feeding rule plr)
                              collect plr)))
                      *parser-rules*)
      for rhs = (rule-rhs rule)
      for open = (rest rhs)
      for key = (first rhs)
      unless (and open ; does passive reach begin/end vertex but rule has further
               (or     ; daughter(s) beyond the key daughter in that direction?
                 (and (= begin *minimal-vertex*)
                      (< (first open) key))
                 (and (= end *maximal-vertex*)
                      (> (car (last open)) key))))
      do
        (if (and (check-rule-filter rule prule key)
                 (or (not (rule-spanning-only-p rule))
                     (check-postulate-spanning-filter key open begin end))
                 (restrictors-compatible-p
                   (nth key (rule-daughters-restricted rule))
                   (edge-dag-restricted passive)))
            (rule-and-passive-task rule passive)
            (incf (statistics-ftasks *statistics*)))))

(defun check-extend-spanning-filter (active passive)
  ;; return nil if .passive. doesn't extend to the relevant begin/end vertex and there
  ;; are no further daughters to fill
  ;; 
  (or 
    (if (edge-forwardp active)
        (= (edge-to passive) *maximal-vertex*)
        (= (edge-from passive) *minimal-vertex*))
    (rest (edge-open active))))

(defun fundamental4active (active)
  #+:adebug (print-trace :fundamental4active active)
  
  (let* ((begin (edge-from active))
         (end (edge-to active))
         (arule (edge-rule active))
         (dtr (first (edge-open active)))
         (avector (edge-dag-restricted active)))
    (declare (fixnum begin end) (type rule arule))
    ;;
    ;; add .active. to appropriate active chart cell.
    ;;
    (if (edge-forwardp active)
        (push active (actives-looking-forward end))
        (push active (actives-looking-backward begin)))
    ;;
    ;; try to combine .active. with adjacent passive edges (on the side that we want
    ;; to fill next) and create new tasks for combinations that pass the filter.
    ;;
    (flet ((active-and-passives (passives)
             (loop
                 for passive in passives
                 unless (or (edge-frozen passive) (edge-partial-tree passive))
                 do
                   (if (and (check-rule-filter arule (edge-rule passive) dtr)
                            (or (not (rule-spanning-only-p arule))
                                (check-extend-spanning-filter active passive))
                            (restrictors-compatible-p
                              avector
                              (edge-dag-restricted passive)))
                       (active-and-passive-task active passive arule)
                       (incf (statistics-ftasks *statistics*))))))
      (if (edge-forwardp active)
          (loop for e fixnum from *maximal-vertex* downto (1+ end)
              do
              (active-and-passives (aref *chart* end e)))
          (loop for s fixnum from (1- begin) downto *minimal-vertex*
              do
              (active-and-passives (aref *chart* s begin)))))))

(defun fundamental4passive (passive)
  #+:adebug (print-trace :fundamental4passive passive)
  
  #+:null
  (when *scoring-hook*
    (setf (edge-score passive) (funcall *scoring-hook* passive)))
  
  (let* ((prule (edge-rule passive))
         (pvector (edge-dag-restricted passive))
         (begin (edge-from passive))
         (end (edge-to passive)))
    (declare (type (or string rule) prule))
    ;;
    ;; add .passive. to appropriate passive chart cell.
    ;;
    (push passive (aref *chart* begin end))
    ;;
    ;; if we are in quick first-only (non-exhaustive) mode, check to see whether
    ;; .passive. is a complete parsing result; trigger non-local exit when the
    ;; target number of readings (to compute) has been reached.
    ;;
    (when (and *first-only-p* (null *unpacking-scoring-hook*)
               (= begin *minimal-vertex*) (= end *maximal-vertex*)
               (not (edge-partial-tree passive)))
      (let ((results (parses-from-spanning-edges (list passive) *first-only-p*)))
        (when results
          (setq *parse-record* (append *parse-record* results))
          (decf *first-only-p* (length results))
          (when (< *first-only-p* 1)
            (throw :best-first t)))))
    ;;
    ;; create new tasks through postulation of rules over .passive.
    ;;
    (postulate passive)
    ;;
    ;; try to combine .passive. with left- and right-adjacent active edges that
    ;; want to extend forward/backward respectively and that pass the filters.
    ;;
    (flet ((passive-and-actives (actives)
             (loop
                 for active in actives
                 do
                   (let ((dtr (first (edge-open active)))
                         (arule (edge-rule active)))
                     (if (and (check-rule-filter arule prule dtr)
                              (or (not (rule-spanning-only-p arule))
                                  (check-extend-spanning-filter active passive))
                              (restrictors-compatible-p
                                (edge-dag-restricted active)
                                pvector))
                         (active-and-passive-task active passive arule)
                         (incf (statistics-ftasks *statistics*)))))))
      (passive-and-actives (actives-looking-forward begin))
      (passive-and-actives (actives-looking-backward end)))))

;;;
;;; packing is substantially more complex in retroactive mode: when a new edge
;;; (.edge.) is found to subsume an existing edge (.oedge.), we need to
;;;
;;;   - pack .oedge. into .edge. (unless .oedge. is frozen, see below);
;;;   - raise all packings from .oedge. into .edge.;
;;;   - delete .oedge. from the chart;
;;;   - make sure .oedge. will not be processed further (including pending 
;;;     tasks on the agenda that involve .oedge.);
;;;   - block further processing for all edges that were already derived from
;;;     .oedge. (since .edge. is guaranteed to derive host edges for them).
;;;
;;; given the `release' (jul-99) grammar and the input `then, i guess that is
;;; settled' we get the following situation:
;;;
;;;   [62] { [158 < 157; 150 < 149] and [157] { [149 < 74 148]
;;;
;;; because [150] is packed already when [149] gets packed retroactively.  this
;;; situation requires that we further complicate our notion of edge freezing.
;;;
;;; to block processing of edges and their derivatives when they are packed
;;; retroactively, the `frozen' slot in the edge structure is used.  any edge
;;; that was frozen is ignored by the parser.  however, in the unpacking phase
;;; [149] still represents a valid reading, while [150] is a spurious duplicate
;;; of the tree [158 < 149].  hence, the following distinction is made:
;;;
;;;   - edges that were frozen to block further processing because they were
;;;     packed retroactively;
;;;   - edges that were globally invalidated because one of their children was
;;;     packed retroactively.
;;;
;;; the second class is marked with a negative `frozen' value and ignored in
;;; the unpacking phase.  this was hard to debug.          (17-sep-99  -  oe)
;;;

(defun packed-edge-p (start end edge)
  (labels (#+:pdebug
           (edge-label (edge)
             (format nil "<~(~a~) ~d>"
               (if (rule-p (edge-rule edge))
                   (rule-id (edge-rule edge))
                   (edge-rule edge))
               (edge-id edge)))
           (freeze (edge id &optional recursivep)
             (when (or (null (edge-frozen edge))
                       (plusp (edge-frozen edge))
                       (minusp id))
               #+:pdebug
               (format t
                 "~&freeze(): freezing ~a for <~d>.~%" (edge-label edge) id)
               (setf (edge-frozen edge) id)
               ;;
               ;; _fix_me_
               ;; there is reason to suspect we may end up counting duplicate
               ;; freezings here.                           (29-jan-03; oe)
               ;;
               (when (minusp id) (incf (statistics-frozen *statistics*))))
             (loop
                 with id = (if recursivep id (- id))
                 for parent in (edge-parents edge) do
                   (freeze parent id t))))
    (loop
        with res = nil
        with deletep = nil
        with forwardp = nil
        with backwardp = nil
        for tail on (aref *chart* start end)
        for oedge = (car tail)
        when (and (null (edge-partial-tree oedge)) ; avoid edge inside a morph process
                  (not (edge-foo oedge)) ; avoid previously unpacked part of forest
                  (progn
                    (multiple-value-setq (forwardp backwardp)
                      (restrictors-subsuming-p
                        (edge-dag-restricted oedge) (edge-dag-restricted edge)))
                    (or forwardp backwardp)))
        do
          (multiple-value-bind (forwardp backwardp)
              (dag-subsumes-p (tdfs-indef (edge-dag oedge)) (tdfs-indef (edge-dag edge))
                forwardp backwardp)
            (when (and forwardp (null (edge-frozen oedge)))
              #+:pdebug
              (format t
                "~&packed-edge-p(): [~d:~d] packing ~a ~:[-->~;==~] ~a.~%"
                start end (edge-label edge) backwardp (edge-label oedge))
              (cond
                (backwardp
                  (push edge (edge-equivalent oedge))
                  (incf (statistics-equivalent *statistics*)))
                (t
                  (push edge (edge-packed oedge))
                  (incf (statistics-proactive *statistics*))))
              (setf res oedge)
              (loop-finish))
            (when (and backwardp *retroactivity-p*)
              #+:pdebug
              (format t
                "~&packed-edge-p(): [~d:~d] ~:[~;(re)~]packing ~a <-- ~a.~%"
                start end (edge-frozen oedge) (edge-label edge) (edge-label oedge))
              ;;
              ;; use nconc() here since .edge. can collect packings from more
              ;; than one existing .oedge. in this loop()
              ;;
              (setf (edge-packed edge)
                (nconc (edge-packed edge) (edge-packed oedge)))
              (setf (edge-equivalent edge)
                (nconc (edge-equivalent edge) (edge-equivalent oedge)))
              (setf (edge-packed oedge) nil)
              (setf (edge-equivalent oedge) nil)
              (setf (car tail) nil) ; actually do the deletion at end since we must
              (setq deletep t)      ; not destructively modify the cdr chain here
              (unless (edge-frozen oedge)
                (push oedge (edge-packed edge))
                (incf (statistics-retroactive *statistics*)))
              (freeze oedge (edge-id edge))))
        finally
          (when deletep
            (setf (aref *chart* start end)
              (delete nil (the list (aref *chart* start end)) :test #'eq)))
          (return res))))

(defun process-rule-and-passive (task)

  #+:adebug
  (print-trace :process-rule-and-passive (first task) (rest task))
  (when (edge-frozen (rest task))
    (return-from process-rule-and-passive nil))
  
  (let* ((rule (first task))
         (rtdfs (if *chart-packing-p* (rule-rtdfs rule) (rule-full-fs rule)))
         (rhs (rule-rhs rule))
         (open (rest rhs))
         (key (first rhs))
         (daughters (rest (rule-order rule)))
         (path (nth key daughters))
         (passive (rest task))
         (ptdfs (edge-dag passive))
         (orthographemics (edge-partial-tree passive))
         (otdfs (when (and (rule-orthographemicp rule)
                           (stringp (second (first orthographemics))))
                  (make-orth-tdfs (second (first orthographemics)))))
         (nedge
           (with-unification-context (ignore)
             (incf (statistics-etasks *statistics*))
             (let ((tdfs (yadu! rtdfs ptdfs path)))
               (when tdfs
                 (let* ((root (tdfs-at-end-of (first (rule-order rule)) tdfs))
                        (root (if otdfs (yadu root otdfs) root))
                        (cfrom (edge-cfrom passive))
                        (cto (edge-cto passive))
                        (copy (cond
                                ((and open *hyper-activity-p*) 3) ; allow 2 replays, copy on 3rd
                                (open (copy-tdfs-elements tdfs))
                                (t (restrict-and-copy-tdfs root :cfrom cfrom :cto cto)))))
                   (when copy
                     (let ((category (if (numberp copy)
                                         (unify-get-type (tdfs-indef tdfs))
                                         (indef-type-of-tdfs copy)))
                           (vector (cond
                                     ((numberp copy)
                                        (tdfs-qc-vector tdfs (nth (first open) daughters)))
                                     (open
                                        (restrict-fs (existing-dag-at-end-of (tdfs-indef copy)
                                                       (nth (first open) daughters))))
                                     (t (restrict-fs (tdfs-indef copy))))))
                       (make-edge :id (if open (next-active-edge) (next-edge))
                                  :category category :rule rule
                                  :children (list passive)
                                  :dag copy :dag-restricted vector
                                  :lex-ids (edge-lex-ids passive)
                                  :leaves (edge-leaves passive)
                                  :orth-tdfs otdfs
                                  :partial-tree (if (rule-orthographemicp rule)
                                                    (rest orthographemics)
                                                    orthographemics)
                                  :from (edge-from passive)
                                  :to (edge-to passive)
                                  :cfrom cfrom :cto cto)))))))))
    (when nedge
      (incf (statistics-stasks *statistics*))
      (cond
        (open
          (setf (edge-open nedge) open)
          (setf (edge-forwardp nedge) (< key (first open)))
          ;;
          ;; _fix_me_
          ;; it seems active edges are not recorded in the parent relation, 
          ;; so will never be frosted.  right now, uc and i fail to explain
          ;; why that should be unnecessary.                 (27-may-03; oe)
          ;;
          (fundamental4active nedge))
        (t
          (when *chart-packing-p*
            (loop
                for edge in (edge-children nedge)
                do (push nedge (edge-parents edge)))
            (when (packed-edge-p (edge-from nedge) (edge-to nedge) nedge)
              (return-from process-rule-and-passive nil)))
          (fundamental4passive nedge))))))

(defun process-active-and-passive (task)

  #+:adebug
  (print-trace :process-active-and-passive (first task) (rest task))

  (when (and *chart-packing-p*
             (or (edge-frozen (rest task))
                 (loop
                     for edge in (edge-children (first task))
                     thereis (edge-frozen edge))))
    (return-from process-active-and-passive nil))

  (let* ((active (first task))
         (key (first (edge-open active)))
         (open (rest (edge-open active)))
         (forwardp (edge-forwardp active))
         (atdfs (edge-dag active))
         (achildren (edge-children active))
         (arule (edge-rule active))
         (daughters (rest (rule-order arule)))
         (path (nth key daughters))
         (passive (rest task))
         (ptdfs (edge-dag passive))
         (nedge
           (flet ((replay-active-unifs ()
                    (loop
                        with atdfs =
                          (if *chart-packing-p* (rule-rtdfs arule) (rule-full-fs arule))
                        with starti =
                          (position (length achildren) (the list (rule-rhs arule)) :test #'>)
                        for edge in achildren
                        for tdfs = (edge-dag edge)
                        for path in (nthcdr starti daughters)
                        do (setq atdfs (yadu! atdfs tdfs path))
                        finally (return atdfs))))

             (when (numberp atdfs)
               (decf atdfs)
               (when (zerop atdfs)
                 (with-unification-context (ignore)
                   #+:adebug (print-trace :reconstruct-and-copy active)
                   (setq atdfs (replay-active-unifs))
                   (setq atdfs (copy-tdfs-elements atdfs))))
               (setf (edge-dag active) atdfs))

             (with-unification-context (ignore)
               (incf (statistics-etasks *statistics*))

               (unless (tdfs-p atdfs)
                 #+:adebug (print-trace :reconstruct active)
                 (setq atdfs (replay-active-unifs)))

               (let ((tdfs (yadu! atdfs ptdfs path)))
                 (when tdfs
                   (let* ((root (tdfs-at-end-of (first (rule-order arule)) tdfs))
                          (children (if forwardp
                                        (append achildren (list passive))
                                        (cons passive achildren)))
                          (cfrom (edge-cfrom (first children)))
                          (cto (edge-cto (first (last children))))
                          (copy (cond
                                  ((and open *hyper-activity-p*) 3) ; allow 2 replays, copy on 3rd
                                  (open (copy-tdfs-elements tdfs))
                                  (t (restrict-and-copy-tdfs root :cfrom cfrom :cto cto)))))
                     (when copy
                       (let ((category (if (numberp copy)
                                           (unify-get-type (tdfs-indef tdfs))
                                           (indef-type-of-tdfs copy)))
                             (vector (cond
                                       ((numberp copy)
                                          (tdfs-qc-vector tdfs (nth (first open) daughters)))
                                       (open
                                          (restrict-fs (existing-dag-at-end-of (tdfs-indef copy)
                                                         (nth (first open) daughters))))
                                       (t (restrict-fs (tdfs-indef copy))))))
                         (make-edge :id (if open (next-active-edge) (next-edge))
                                    :category category :rule arule
                                    :children children
                                    :dag copy :dag-restricted vector
                                    :lex-ids (append-lists children :key #'edge-lex-ids)
                                    :leaves (append-lists children :key #'edge-leaves)
                                    :from (edge-from (first children))
                                    :to (edge-to (first (last children)))
                                    :cfrom cfrom :cto cto))))))))))
    (when nedge
      (incf (statistics-stasks *statistics*))
      (cond
        (open
          (setf (edge-open nedge) open)
          (setf (edge-forwardp nedge) (< key (first open)))
          (fundamental4active nedge))
        (t
          (when *chart-packing-p*
            (loop
                for edge in (edge-children nedge)
                do (push nedge (edge-parents edge)))
            (when (packed-edge-p (edge-from nedge) (edge-to nedge) nedge)
              (return-from process-active-and-passive nil)))
          (fundamental4passive nedge))))))

(defun restrict-and-copy-tdfs (tdfs &key cfrom cto)
  ;; delete arcs just holding constituents' feature structures; also have to
  ;; check whether any of the deleted dags contain a cycle - in which case the
  ;; whole rule application should fail
  (let* ((dag (deref-dag (tdfs-indef tdfs))) ; yes, definitely need to deref
         (new (clone-dag dag))
         (restricted nil))
    (flet ((remove-restricted-arcs (arcs)
             (when arcs
               (loop with to-delete list = *deleted-daughter-features*
                   for arc in arcs
                   if (find (dag-arc-attribute arc) to-delete :test #'eq)
                   do (push (dag-arc-value arc) restricted)
                   else collect arc))))
      (setf (dag-arcs new)
        (remove-restricted-arcs (dag-arcs new)))
      (setf (dag-comp-arcs new)
        (remove-restricted-arcs (dag-comp-arcs new)))
      (when (and *characterize-p* (or cfrom cto))
        (set-characterization-indef-within-unification-context new cfrom cto))
      (let ((copy (copy-dag new)))
        (if (and copy
                 ;; cyclic check after copy-dag since it may already have checked parts of rdags
                 (loop for rdag in restricted never (cyclic-dag-p rdag)))
            (progn
              (incf (statistics-copies *statistics*))
              (make-tdfs :indef copy :tail (copy-tdfs-tails tdfs))) ; c.f. copy-tdfs-elements
            (progn
              ;; charge copy failure to last successful unification
              (decf (statistics-stasks *statistics*)) ; JAC - was incf but should surely be decf
              nil))))))

(defun tdfs-qc-vector (tdfs &optional path)
  (let* ((dag (unify-existing-dag-at-end-of (tdfs-indef tdfs) path))
         (vector (unify-restrict-fs dag)))
    #+:qcdebug
    (format t "tdfs-qc-vector(): ~s;~%" vector)
    vector))

#+:adebug
(defun debug-label (object)
  (cond
   ((edge-p object)
    (format 
     nil 
     "~(~a~)" 
     (if (rule-p (edge-rule object))
       (rule-id (edge-rule object)) 
       (edge-rule object))))
   ((stringp object) object)
   ((rule-p object) (rule-id object))
   (t "unknown")))

#+:adebug
(defun print-trace (context object &optional argument)
  (if (rule-p object)
    (let* ((label (debug-label object))
           (open (rule-rhs object)))
      (format
       t
       "~@[~(~a~)():~] `~(~a~)' [open: ~{~a~^ ~}]~:[;~%~; +~]"
       context label open argument))
    (let* ((edge object)
           (begin (edge-from edge))
           (end (edge-to edge))
           (label (debug-label edge))
           (id (edge-id edge))
           (children (loop 
                         for child in (edge-children edge)
                         collect (edge-id child)))
           (open (edge-open object))
           (forwardp (edge-forwardp object)))
      (format 
       t
       "~@[~(~a~)():~] ~d:~d ~a (~a < ~{~a~^ ~})~
        ~@[ [open: ~{~a~^ ~} - ~:[backwards~;forward~]]~]~:[;~%~; +~]"
       context begin end label id children open forwardp argument)))
  (when argument (print-trace nil argument)))

(defun count-nodes (edge &key (mark (gensym)) ignorep packingp chartp)
  (let* ((current (cond
                   (ignorep
                    (setf (edge-dag-restricted edge) mark)
                    0)
                   ((eq (edge-dag-restricted edge) mark) 0)
                   (t
                    (setf (edge-dag-restricted edge) mark)
                    (if chartp
                      (if (find-edge-given-id (edge-id edge)) 1 0)
                      1))))
         (children (loop
                       for edge in (edge-children edge)
                       sum (count-nodes edge :mark mark :chartp chartp
                                        :packingp packingp)))
         (packings (if packingp
                     (+ (loop
                            for edge in (edge-packed edge)
                            sum (count-nodes edge :mark mark 
                                             :packingp packingp
                                             :ignorep t :chartp chartp))
                        (loop
                            for edge in (edge-equivalent edge)
                            sum (count-nodes edge :mark mark 
                                             :packingp packingp
                                             :ignorep t :chartp chartp)))
                     0)))
    (+ current children packings)))