(in-package "USER")

(defun edge2trees (chart edge)
  ;;
  ;; return all trees subsumed by .edge.; compute all consistent instantiations
  ;; for the right-hand side (complete()), convert embedded edges into trees,
  ;; cross multiply the sequence of resulting trees, and then fold out into a
  ;; full forest.
  ;;
  (let* ((root (edge-lhs edge))
         (analyzed (edge-analyzed edge))
         (daughters 
          (complete chart analyzed (edge-start edge) (edge-span edge))))
    (if daughters
      (mapcan #'(lambda (analysis)
                  ;;
                  ;; for each decomposition of the right-hand side determine
                  ;; the corresponding tree(s) and then add the tree root;
                  ;; accumulate all results in a flat list
                  ;;
                  (let ((trees (cross-product 
                                (mapcar #'(lambda (edge) 
                                            (edge2trees chart edge))
                                        analysis))))
                    (mapcar #'(lambda (tree)
                                (cons root tree))
                            trees)))
              daughters)
      (list (cons root analyzed)))))

(defun cross-product (lists)
  ;;
  ;; ((a b) (1 2)) --> ((a 1) (a 2) (b 1) (b 2))
  ;;
  (if (null (rest lists))
    (mapcar #'list (first lists))
    (mapcan #'(lambda (prefix)
                (mapcar #'(lambda (suffix)
                            (cons prefix suffix))
                        (cross-product (rest lists))))
            (first lists))))

(defun alternative-cross-product (lists)
  ;;
  ;; `loop' instead of `map':
  ;; Allegro compiler produces much more efficient code!
  ;; try: (time (cross-product (make-list 6 :initial-element (make-list 10))))
  ;;
  (if (null (rest lists))
      (loop for element in (first lists)
	    collect (list element))
    (loop with cross-product-of-rest = (alternative-cross-product (rest lists))
	  for element in (first lists)
	  append (loop for list in cross-product-of-rest
		       collect (cons element list)))))


(defun find-edges (chart &key (lhs nil lhs-p) 
                              (analyzed nil analyzed-p) 
                              (unanalyzed nil unanalyzed-p)
                              (start 0 start-p)
                              (span 0 span-p))
  ;;
  ;; successively select edges from .chart. that meet the criteria specified through
  ;; the optional .lhs. to .span. arguments; unspecified arguments do not constrain
  ;; the selection (i.e. match any actual value).
  ;;
  (let* ((start (if start-p (aref chart start) (reduce #'append chart)))
         (span (if span-p (find! span start :key #'edge-span) start))
         (unanalyzed (if unanalyzed-p 
                       (find! unanalyzed span :key #'edge-unanalyzed) 
                       span))
         (analyzed (if analyzed-p 
                     (find! analyzed unanalyzed :key #'edge-analyzed) 
                     unanalyzed))
         (lhs (if lhs-p (find! lhs analyzed :key #'edge-lhs) analyzed)))
    lhs))

(defun complete (chart rhs start span)
  ;;
  ;; find all complete instantiations for .rhs. in .chart.; since there may
  ;; well be multiple decompositions with different edge boundaries, walk
  ;; through .rhs. category by category, find corresponding edges, and then
  ;; cross multiply with all instantiations for the remainder of .rhs.
  ;;
  (cond ((<= span 0) nil)
        ((null (rest rhs))
         (mapcar #'list (find-edges chart 
                                    :lhs (first rhs) :unanalyzed nil
                                    :start start :span span)))
        (t
         (mapcan #'(lambda (edge)
                     (mapcar #'(lambda (completion)
                                 (cons edge completion))
                             (complete chart (rest rhs) 
                                       (+ start (edge-span edge))
                                       (- span (edge-span edge)))))
                 (find-edges chart
                             :lhs (first rhs) :unanalyzed nil
                             :start start)))))