;;; -*- 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 *generalising-p* t) ; values nil / t / :lcs - latter is still experimental

(defparameter *hyper-activity-p* t)

(defparameter *scoring-hook* nil)

;;; The arcs just holding daughters' feature structures used to be checked for
;;; cycles every time a tdfs was constructed for a new passive edge. This check is
;;; now deferred until the parse forest is unpacked. The forest still won't contain
;;; any (invalid) cyclic feature structures, but it may now contain invalid
;;; constituents; these will be filtered out during unpacking. Controlled by the
;;; parameter *defer-dd-cyclic-check-p*
;;;
(defparameter *defer-dd-cyclic-check-p* t)

;;;
;;; 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 (iter 1))
  ;; NB published descriptions of chart reduction do not point out that the operation
  ;; must iterate until a fixpoint is reached - this is because pruning an edge could
  ;; cause another edge to lose its 'support' and hence that edge should also be pruned
  (when *cd-debug*
    (if (= iter 1)
        (format t "~&Chart reduction starting~%") (format t "~&Iteration ~A~%" iter)))
  (flet ((collect-complete-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)))))
         (prune (edge)
           ;; previously we froze edge, however deleting 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 (the list (aref *chart* s e)) :test #'eq)))))
    (loop
        with prunedp = nil
        with p2vs = nil
        with edges = (collect-complete-edges)
        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' types must unify
              always
              (or (null p1v)
                  (loop initially
                        (when (if (numberp *cd-debug*) (> *cd-debug* 1) *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))
                             ;; !!! allow any edge e2 to provide value, even if it overlaps e1
                             (greatest-common-subtype p1v p2v)
                             (progn
                               (when (if (numberp *cd-debug*) (> *cd-debug* 1) *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+ iter)))))
  (when (and *cd-debug* (= iter 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))

(defmacro agenda-driven-p ()
  '(or *chart-packing-p* (typep *first-only-p* '(and fixnum (integer 1 *)))))

(defmacro exhaustive-mode-p ()
  '(or *unpacking-scoring-hook* (typep *first-only-p* '(or null (eql 0)))))

;;; Priority scores for agenda tasks are mainly based on edge spans. Beyond this, take
;;; full advantage of the CPU cache by including small extra factors in passive/rule
;;; and passive/active priorities to give distinct scores to tasks involving distinct
;;; rules or active edges, respectively. This groups task execution into batches that
;;; involve the same rule/edge, making it more likely for that rule/edge to be in the
;;; cache.
;;;
;;; Scores are single floats. Single floats should have at least 24 bits of precision,
;;; which corresponds to a little over 7 decimal digits. We bucket the rule and edge ids
;;; in the fractional part using 3-4 decimal digits; the span-based part of the score
;;; uses the non-fractional part. This results in an exact representation of the score
;;; for sentences of up to 31 tokens, and an almost-exact one for up to 100 tokens.
;;; Beyond that we lose information from the fractional part.

(defun initial-passive-task (edge)
  (if (agenda-driven-p)
      (let ((priority
              (if *scoring-hook*
                  (funcall *scoring-hook* edge)
                  (if (exhaustive-mode-p)
                      ;; prioritise over the other kinds of task, then leftmost end
                      (- (* *maximal-vertex* *maximal-vertex*) (edge-to edge))
                      ;; combine lexical priority with span of 1 vertex
                      (+ (* (lex-priority edge) 1000) 1)))))
        (agenda-insert *agenda* priority edge))
      (fundamental4passive edge)))

(defun rule-and-passive-task (rule passive)
  (let ((task (cons rule passive)))
    (if (agenda-driven-p)
        (let ((priority
                (if *scoring-hook*
                    (funcall *scoring-hook* task)
                    (let ((start (edge-from passive))
                          (end (edge-to passive)))
                      (declare (type (integer 0 1000) start end))
                      (if (exhaustive-mode-p)
                          ;; prioritise rightmost start, then smallest end (i.e. span),
                          ;; and arrange for each rule (bucket) to get a distinct score
                          (- (* start *maximal-vertex*) end
                             (* (rem (rule-apply-index rule) 500) 0.001)) ; 500 buckets
                          ;; combine rule priority with weighted span
                          (+ (* (rule-priority rule) 1000)
                             (- end (/ start (float *maximal-vertex*)))))))))
          (agenda-insert *agenda* priority task))
        (process-rule-and-passive task))))

(defun active-and-passive-task (active passive arule)
  (let ((task (cons active passive)))
    (if (agenda-driven-p)
        (let ((priority
                (if *scoring-hook*
                    (funcall *scoring-hook* task)
                    (if (exhaustive-mode-p)
                        ;; similar to rule-and-passive-task, but here bucket active edges
                        (let ((start (edge-from passive))
                              (end (edge-to passive)))
                          (declare (type (integer 0 1000) start end))
                          (- (* start *maximal-vertex*) end
                             0.5 ; occupied by rule/passive task scores, remaining 0.5 free
                             (* (rem (- (edge-id active)) 5000) 0.0001))) ; 5000 buckets
                        ;; similar to rule-and-passive-task
                        (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*)))))))))
          (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 - always runs 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 are never applied to phrases;
  ;; if lexical rules could be applied to phrases, as suggested in 'The (New) LKB
  ;; System' section 5.3.4, 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*))
        (*partial-constraints-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
        ;; resulted in massive over-copying of generic LEs); anyway we must copy partially
        ;; when chart packing is enabled
        (setf (edge-dag edge)
          (if *chart-packing-p*
              (copy-tdfs-partially (edge-dag edge))
              (copy-tdfs-completely (edge-dag edge))))
        (initial-passive-task 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)
      with genp = (edge-generalisedp 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 (or genp ; edge could be more general than its top rule, prule
                     (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 dtr) (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 (or (edge-generalisedp passive)
                                (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 ((begin (edge-from passive))
        (end (edge-to passive)))
    ;;
    ;; 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 (not (exhaustive-mode-p))
               (= 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
                 with genp = (edge-generalisedp passive)
                 with prule of-type (or string rule) = (edge-rule passive)
                 with pvector = (edge-dag-restricted passive)
                 for active in actives
                 do
                   (let ((dtr (first (edge-open active)))
                         (arule (edge-rule active)))
                     (if (and (or genp (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)
             (when (or (null (edge-frozen edge))
                       (plusp (edge-frozen edge))
                       (minusp id))
               #+:pdebug
               (format t "~&freeze(): freezing ~a for <~d>.~%" (edge-label edge) id)
               (unless (or (plusp id)
                           (and (numberp (edge-frozen edge)) (minusp (edge-frozen edge))))
                 (incf (statistics-frozen *statistics*)))
               (setf (edge-frozen edge) id))
             (loop
                 with id = (if (minusp id) id (- id))
                 for parent in (edge-parents edge) do (freeze parent id)))
           (unary-descendant-of (edge oedge) ; is oedge a descendant of edge via a unary chain?
             (let ((c (edge-children edge)))
               (and (consp c) (null (cdr c))
                    (or (eq (car c) oedge) (unary-descendant-of (car c) oedge))))))
    (loop
        with retrop = nil
        with forwardp = nil and backwardp = nil and genp = nil
        for tail on (aref *chart* start end)
        for oedge = (car tail)
        when (and (not (edge-frozen oedge)) ; don't interact with frozen edges
                  (not (edge-partial-tree oedge)) ; avoid edge inside a morph process
                  (null (edge-unpacked-edges oedge)) ; avoid previously unpacked part of forest
                  (not (unary-descendant-of edge oedge)) ; avoid creating a circularity
                  (progn
                    (multiple-value-setq (forwardp backwardp genp)
                      (restrictors-subsuming-p
                        (edge-dag-restricted oedge) (edge-dag-restricted edge) *generalising-p*))
                    (or forwardp backwardp genp)))
        do
          (multiple-value-bind (forwardp backwardp gdag)
              (dag-subsumes-p
                (tdfs-indef (edge-dag oedge)) (tdfs-indef (edge-dag edge))
                forwardp backwardp
                genp (eq *generalising-p* :lcs))
            (when (and forwardp (not retrop)) ; don't pack edge forward if already packed backward
              #+: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*))))
              (return oedge))
            (when (and (null (edge-parents oedge)) ; !!! skip if we'd have to freeze parent edges
                       (or (and backwardp *retroactivity-p*) gdag))
              #+:pdebug
              (format t "~&packed-edge-p(): [~d:~d] ~:[~;(re)~]packing ~a ~:[<--~;<G>~] ~a.~%"
                start end (edge-frozen oedge) (edge-label edge) gdag (edge-label oedge))
              (when gdag ; generalise edge so oedge can be packed into it
                (setf (edge-dag edge) (make-nondefault-tdfs gdag))
                (setf (edge-dag-restricted edge) (restrict-fs gdag))
                (setf (edge-category edge) (type-of-fs gdag))
                (setf (edge-generalisedp edge) t) ; indicate that rule filter shouldn't be applied
                (incf (statistics-generalised *statistics*)))
              (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 remove oedge from chart cell at end since
              (setq retrop t)       ; we must not destructively modify the cdr chain here
              (unless (edge-frozen oedge)
                (push oedge (edge-packed edge))
                (unless gdag (incf (statistics-retroactive *statistics*))))
              (freeze oedge (edge-id edge))))
        finally
          (when retrop
            (setf (aref *chart* start end)
              (delete nil (the list (aref *chart* start end)) :test #'eq)))
          (return nil))))

(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 ()
             (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
                                     :cyclic-check-p (not *defer-dd-cyclic-check-p*))))))
                   (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 ()
                   #+: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 ()
               (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
                                       :cyclic-check-p (not *defer-dd-cyclic-check-p*))))))
                     (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 (let ((a (edge-lex-ids active))
                                                   (p (edge-lex-ids passive)))
                                                (if forwardp (append a p) (append p a)))
                                    :leaves (let ((a (edge-leaves active))
                                                  (p (edge-leaves passive)))
                                               (if forwardp (append a p) (append p a)))
                                    :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 (cyclic-check-p t))
  ;; delete arcs just holding constituents' feature structures; also when
  ;; cyclic-check-p is true, check whether any of these deleted arcs 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)))
    (flet ((remove-restricted-arcs (arcs)
             (loop with to-delete list = *deleted-daughter-features*
                 for arc in arcs
                 unless (find (dag-arc-attribute arc) to-delete :test #'eq)
                 collect arc)))
      (setf (dag-arcs new)
        (remove-restricted-arcs (dag-arcs new)))
      (when (dag-comp-arcs new) ; non-empty comp-arcs is possible but would be strange
        (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
                 (or (not cyclic-check-p)
                     (not (cyclic-dag-p dag)))) ; check deleted parts not already done by copy-dag
            (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)))