;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: XLE; Base: 10; Readtable: augmented-readtable -*-

;;;; XLE-Web users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.

;;;; Author: Paul Meurer (paul.meurer@aksis.uib.no)
;;;; Aksis, Unifob, University of Bergen, Norway
;;;; http://www.aksis.uib.no

;; Using graph-id in hidden field makes sure that no two sessions accidentally access the same graph.

(in-package :XLE)

(defparameter *suppressed-atts* '(#+ignore "CHECK" #+ignore "AGREEMENT"))

(defun ctx-trivial-p (ctx)
  (or (null ctx) #-orig (eq ctx 1)))

(defvar *seen-nodes*)
(defvar *seen-fs-nodes* nil)
;;(defvar *seen-av-nodes* nil) ;; new

(defclass dag-node ()
  ((id :initform nil :initarg :id :reader id)
   (var :initform nil :initarg :var :reader var)
   (pending-p :initform nil :accessor pending-p) ;; not used??
   (sub-disc :initform nil :initarg :sub-disc)))

(defclass contexted-dag-node (dag-node)
  ((context :initform 1 :initarg :context :reader context)
   (ctx-string :initform nil :initarg :ctx-string :reader ctx-string)
   (expanded-context :initform 1 :initarg :expanded-context :reader expanded-context)
   (has-sub-pred-p :initform nil :initarg :has-sub-pred-p :accessor has-sub-pred-p)))

(defmethod has-sub-pred-p ((object t)) nil)

(defmethod initialize-instance :after ((dgn dag-node) &key var &allow-other-keys)
  (unless (getf *seen-nodes* var)
    (setf (getf *seen-nodes* var) dgn)))

;; new
#+ignore
(defmethod initialize-instance :after ((dgn fs) &key var &allow-other-keys)
  (unless (getf *seen-fs-nodes* var)
    (setf (getf *seen-fs-nodes* var) dgn)))
#+ignore
(defmethod initialize-instance :after ((dgn av-pair) &key var &allow-other-keys)
  (unless (getf *seen-av-nodes* var)
    (setf (getf *seen-av-nodes* var) dgn)))

(defclass fs (contexted-dag-node) ;; context needed for set elements
  ((pred :initform nil :initarg :pred :reader pred)
   (anchor :initform 0 :accessor fs-anchor) 
   (av-pairs :initform () :initarg :av-pairs :reader av-pairs)
   (context-set :initform nil :initarg :context-set :reader context-set)
   (fs-set :initform () :initarg :fs-set :accessor fs-set)))

(defmethod justifications ((fs fs)) nil)

(defclass top-fs (fs)
  ((justifications :initform nil :initarg :justifications :reader justifications)))

(defclass av-pair (contexted-dag-node)
  ((attribute :initform nil :initarg :attribute :reader attribute)
   (value :initform nil :initarg :value :reader value)
   (justification :initform nil :initarg :justification :reader justification)))


(defclass fs-value (contexted-dag-node)
  ((value :initform () :initarg :value :reader value)))

(defclass semform (contexted-dag-node)
  ((lemma :initform nil :initarg :lemma :reader lemma)
   (sem-var :initform nil :initarg :sem-var :reader sem-var)
   (string-pos :initform nil :initarg :string-pos :reader string-pos)
   (subcat-frame :initform () :initarg :subcat-frame :reader subcat-frame)
   (athematic-frame :initform () :initarg :athematic-frame :reader athematic-frame)))

(defmethod print-object ((obj fs) stream)
  (with-slots (var) obj
     (print-unreadable-object (obj stream :type t :identity t)
       (format stream "(~d)" var))))

(defmethod print-object ((obj av-pair) stream)
  (with-slots (var attribute value) obj
     (print-unreadable-object (obj stream :type t :identity nil)
       (format stream "(~d) ~s -> ~s" var attribute value))))

(defmethod format-semform ((semform semform) stream &key print-var-p var &allow-other-keys)
  (with-slots (lemma sem-var subcat-frame athematic-frame string-pos) semform
    ;;(print lemma)
    (format stream
	    "'~a~@[:~d~]~a~{~a~^,~}~a~{~a~^,~}'"
	    ;;"~a:'~a~@[:~d~]~a~{~a~^,~}~a~{~a~^,~}'" string-pos
	    lemma
	    (when (or var print-var-p) (or var sem-var))
	    (if subcat-frame "<" "")
	    (mapcar (lambda (sub) (if (stringp sub) sub "[]"))
		    subcat-frame)
	    (if subcat-frame ">" "")
	    (mapcar (lambda (sub) (if (stringp sub) sub "[]"))
		    athematic-frame))))

(defmethod print-object ((obj semform) stream)
  (print-unreadable-object (obj stream :type t :identity nil)
    (with-slots (sem-var) obj
      (format stream "(~d) " sem-var)
      (format-semform obj stream))))

#+obsolete
(defclass fs-set (dag-node)
  ((fs-list :initform () :initarg :fs-list :reader fs-list)))

(defclass context-set ()
  ((ctx-list :initform () :initarg :ctx-list :reader ctx-list)))
(defvar *lexids* ())

(defmethod filter-terms ((graph xle-graph) term-list context)
  (if nil;(eql context 1)
      term-list
      (collecting
	(dolist (ctx.term term-list)
	  (let ((context-solutions (context-solutions graph (car ctx.term)))
		(term (cdr ctx.term)))
	    (when (context-s-intersection context-solutions context)
	      #+ignore
	      (print (list :trivialp (context-trivial-p context-solutions context)
			   :term term))
	      #-orig
	      (collect ctx.term)
	      #+test
	      (collect (if (and (not (context-trivial-p context-solutions context))
				(eq (car term) 'eq)
				(consp (cadr term))
				(eq (caadr term) 'var))
			   (progn (print :patched)
			   (print (cons (car ctx.term)
				 (list 'eq
				       (list 'attr (cadr term) "=")
				       (copy-tree (caddr term))))))
			   ctx.term
			   ))))))))


(defparameter *discriminant-attributes*
  t
  #+ignore
  (list "DET-TYPE" "DIGVALUE" "NUM" "COMMON" "TENSE" "MOOD" "GRAIN"
	"NUM" "PERS" "CLASS" "LEXID"))

(defparameter *excluded-discriminant-attributes*
  (list "CHECK"))

(defmethod format-context ((graph xle-graph) ctx &optional format-1-p)
  (with-slots (discriminants) graph
    (if (or (eq ctx 1)
		(and discriminants
		     (eq (reduced-context (context-solutions graph ctx) (s-context discriminants)) 1)))
	(when format-1-p "1")
	(labels ((consecutive-ctxts-p (ctx1 ctx2)
		   (let* ((eq-length (string/= (string ctx1) (string ctx2)))
			  (i1 (parse-integer (string ctx1) :start eq-length :junk-allowed t))
			  (i2 (parse-integer (string ctx2) :start eq-length :junk-allowed t)))
		     (and i1 i2 (= i2 (1+ i1))))))
	  (with-output-to-string (stream)
	    (let ((ctx (normal-form ctx)))
	      (cond ((and (consp ctx)
			  (eq (car ctx) 'or))
		     #+debug(print ctx)
		     (loop for (and-term . rest) on (cdr ctx) with start-ctx and end-ctx
			   do (let* ((and-term-p (and (consp and-term)
						      (eq (car and-term) 'and)))
				     (and-term (if (and and-term-p (null (cddr and-term)))
						   (progn (setf and-term-p nil) (cadr and-term))
						   and-term)))
				(cond (and-term-p
				       (when end-ctx
					 (cond ((eq start-ctx end-ctx)
						(format stream "~(~a~)|" start-ctx))
					       (t
						(format stream "~(~a-~a~)|" start-ctx end-ctx))))
				       (format stream "~{~(~a~)~^ &amp; ~}" (cdr and-term)))
				      ((consp and-term)
				       (error "and-term ~s not allowed." and-term))
				      ((null rest)
				       (cond ((null start-ctx)
					      (format stream "~(~a~)" and-term))
					     ((consecutive-ctxts-p end-ctx and-term)
					      (format stream "~(~a-~a~)" start-ctx and-term))
					     ((eq start-ctx end-ctx)
					      (format stream "~(~a|~a~)" start-ctx and-term))
					     (t
					      (format stream "~(~a-~a|~a~)" start-ctx end-ctx and-term))))
				      ((not start-ctx)
				       (setf start-ctx and-term end-ctx and-term))
				      ((consecutive-ctxts-p end-ctx and-term)
				       (setf end-ctx and-term))
				      ((eq start-ctx end-ctx)
				       (format stream "~(~a~)|" start-ctx)
				       (setf start-ctx and-term end-ctx and-term))
				      (t
				       (format stream "~(~a-~a~)|" start-ctx end-ctx)
				       (setf start-ctx and-term end-ctx and-term))))
			   when (and rest (not start-ctx))
			   do (write-string "|" stream)))
		    (t
		     (format stream "~(~a~)" ctx)))))))))

(defmethod format-normal-form ((graph xle-graph) ctx equiv)
  (format-context graph (normal-form (resolve-context equiv ctx))))

(defmethod build-f-structure ((graph xle-graph)
			      &key var-array (context 1) (top-f-structure-only-p t) suppress-check-p &allow-other-keys)
  (when (not (zerop (fill-pointer var-array)))
    (setf *xle-graph* graph)
    #+debug(print (list :fragm (fragment-analysis-p graph)))
    #+debug(print (list :var-array var-array :context context))
    #+debug(print :f-structure-xml)
    (with-slots (equivalences phi-list subsume-list realized-vars global-projection-fs-ids top-f-node-var) graph
      #+debug(print (list :top-f-node-var top-f-node-var))
      (setf realized-vars ())
      (let ((*seen-nodes* ())
	    (id -1)
	    (seen-variables ())
	    (semform-lnks (dat::make-string-tree))
	    (global-context #+orig #*0100 context))
	(labels ((build (var) ;; &optional (parent-ctx 1))
		   #+debug(print (list :var var))
		   (or (getf *seen-nodes* var)
		       (let* ((fs nil)
			      (term-list (when (< var (length var-array))
					   (filter-terms graph (aref var-array var) global-context)))
			      (value-list
			       (labels ((build-fs (&key (context 1))
					  (unless fs (setf fs (make-instance 'fs
									     :id (incf id)
									     :var var
									     :context context)))) ;; check this!!
					(build-lemma (lemma l-ctx)
					  (if (stringp lemma)
					      (list (cons lemma l-ctx))
					      ;; if lemma is not a string, resolve the equations unless we get strings. Necessary for discriminants.
					      (let* ((var (cadr lemma))
						     (term-list (when (< var (length var-array))
								  (filter-terms graph (aref var-array var) global-context))))
						(collecting
						  (dolist (ctx.term term-list)
						    (destructuring-bind (ctx op left right) ctx.term
						      (let ((ctx-sol (context-solutions graph ctx)))
							(ecase op
							  (eq
							   (let ((ictx (context-s-intersection l-ctx ctx-sol)))
							     (when ictx
							       (collect-append (build-lemma right ictx))))))))))))))
				 (collecting
				   (dolist (ctx.term term-list)
				     (destructuring-bind (ctx op left right) ctx.term
				       (let ((ctx-sol (context-solutions graph ctx)))
					 #+debug(print (list :var var :ctx-sol ctx-sol :ctx.term ctx.term))
					 (ecase op
					   (in_set
					    #+debug(print (list :var var :ctx.term ctx.term))
					    (build-fs)
					    (let ((ctx-string (format-context graph ctx)))
					      (push (cond ((not (consp left))
							   (cons (cons ctx-sol ctx-string)
								 (make-instance 'fs-value
										:id (incf id)
										:var var
										:value left
										:context ctx-sol
										:ctx-string ctx-string
										:has-sub-pred-p (has-sub-pred-p left)
										:expanded-context (format-normal-form graph ctx equivalences))))
							  (t
							   (cons (cons ctx-sol ctx-string) (build (cadr left)))))
						    (fs-set fs))))
					   (eq
					    (ecase (car left)
					      (attr
					       (let ((attribute (caddr left)))
						 (cond ((find attribute *suppressed-atts* :test #'string=)
							nil)
						       ((and suppress-check-p (string= attribute "CHECK"))
							nil)
						       #+new
						       ((and (equal attribute "=")
							     (context-trivial-p ctx-sol global-context))
							nil)
						       ((not (consp right))
							(build-fs)
							#+debug
							(print (list :att attribute :ctx ctx-sol :global-ctx global-context
								     :trivialp (context-trivial-p ctx-sol global-context)))
							#+new
							(let ((trivialp (context-trivial-p ctx-sol global-context)))
							  (collect
							   (make-instance 'av-pair
									  :id (incf id)
									  :var var
									  :attribute attribute
									  :value right
									  :context ;; ctx-sol
									  (if trivialp 1 ctx-sol)
									  :ctx-string (if trivialp "" (format-context graph ctx))
									  :expanded-context (format-normal-form graph ctx equivalences))))
							#-orig
							(collect
							 (make-instance 'av-pair
									:id (incf id)
									:var var
									:attribute attribute
									:value right
									:context ;; ctx-sol
									(if (context-trivial-p ctx-sol global-context) 1 ctx-sol)
									:ctx-string (format-context graph ctx)
									:expanded-context (format-normal-form graph ctx equivalences))))
						       ((eq (car right) 'semform)
							(destructuring-bind (lemma
									     sem-var
									     (%br1 . %subcat-frame)
									     (%br2 . %athematic-frame))
							    (cdr right)
							  (declare (ignore %br1 %br2))
							  (build-fs)
							  (dolist (lemma.ctx-sol (build-lemma lemma ctx-sol))
							    (destructuring-bind (lemma . ctx-sol) lemma.ctx-sol
							      (collect
							       (make-instance
								'av-pair
								:id (incf id)
								:var var
								:attribute attribute
								:context ctx-sol
								:ctx-string (format-context graph ctx)
								:expanded-context (format-normal-form graph ctx equivalences)
								:has-sub-pred-p t
								:value
								(let* ((semform (make-instance
										 'semform
										 :id (incf id)
										 :lemma lemma
										 :sem-var sem-var
										 :string-pos (setf (fs-anchor fs)
												   (semform-string-positions
												    graph sem-var
												    :ctx-solutions ctx-sol
												    :left-only-p t))
										 :has-sub-pred-p t
										 :context ctx-sol
										 :ctx-string (format-context graph ctx)
										 :expanded-context (format-normal-form graph ctx equivalences))))
								  (with-slots (subcat-frame athematic-frame) semform
								    (setf subcat-frame
									  (collecting
									    (dolist (sub %subcat-frame)
									      (if (stringp sub)
										  (collect sub)
										  (collect (build (cadr sub))))))
									  athematic-frame
									  (collecting
									    (dolist (sub %athematic-frame)
									      (if (stringp sub)
										  (collect sub)
										  (collect (build (cadr sub))))))))
								  (pushnew sem-var (dat::string-tree-get semform-lnks (format-semform semform nil))) 
								  semform)))))))
						       ((eq (car right) 'var)
							(build-fs)
							(let ((value (build (cadr right))))
							  (collect
							   (make-instance
							    'av-pair
							    :id (incf id)
							    :var var
							    :attribute attribute
							    :context ctx-sol
							    :ctx-string (format-context graph ctx)
							    :expanded-context (format-normal-form graph ctx equivalences)
							    :has-sub-pred-p (has-sub-pred-p value)
							    :value value)))))))
					      (proj
					       nil)))
					   (scopes
					    nil)))))))))
			 #+debug(print (list :value-list value-list))
			 (cond ((and (null value-list) (not fs))
				nil)
			       ((subtypep (type-of (car value-list)) (find-class 'av-pair))
				(setf (fs-set fs) (nreverse (fs-set fs)))
				(with-slots (pred av-pairs context-set fs-set has-sub-pred-p) fs
				  (setf pred (find "PRED" value-list :key #'attribute :test #'string=)
					av-pairs (remove-if (lambda (pair) (find (attribute pair) '("=" "PRED") :test #'string=)) value-list)
					context-set (remove-if-not (lambda (pair) (equal (attribute pair) "=")) value-list)
					has-sub-pred-p (or pred
							   (find-if #'has-sub-pred-p av-pairs)
							   (find-if #'has-sub-pred-p context-set)
							   (find-if #'has-sub-pred-p (fs-set fs) :key #'cdr))))
				fs)
			       (t
				(setf (fs-set fs) (nreverse (fs-set fs))
				      (has-sub-pred-p fs) (find-if #'has-sub-pred-p (fs-set fs) :key #'cdr))
				fs))))))
	  (let (#+disabled(scopes (find-scopes var-array))
			  #+disabled(s-var (find-projection var-array 0 "s::")))
	    (push 0 realized-vars)
	    #+debug(print (sort (loop for (var term) on phi-list by #'cddr collect var) #'<))
	    (values (setf *fs*
			  (if top-f-structure-only-p
			      (build top-f-node-var)
			      (collecting
				#+debug(let ((*package* (find-package :xle)))
					 (print (list :phi-list phi-list
						      :inverse-phi-list (inverse-phi-list graph)
						      :subsume-list subsume-list)))
				(dolist (var (sort (loop for (var term) on phi-list
							 by #'cddr
							 when (find var global-projection-fs-ids)
							 collect var)
						   #'<))
				  (dolist (var (or (find-subsumed-vars graph var) (list var)))
				    (unless (or (getf seen-variables var)
						(>= var (fill-pointer var-array))
						(null (filter-terms graph (aref var-array var) global-context)))
				      (collect (cond ((= var top-f-node-var)
						      (build var))
						     (t
						      (let ((realized-vars ()))	;; discard them
							(build var)))))))))))
		    semform-lnks)))))))

(defvar *f-disc-list*)

#-debug
(defparameter *derived-tree* nil)

(dat::do-string-tree (string val *derived-tree*)
  (print val))

;; remove semform-lnks!
(defmethod build-discriminants ((graph xle-graph) fs &key semform-lnks)
  (let* ((*f-disc-list* ())
	 (tree (dat::make-string-tree))
	 (derived-tree (dat::make-string-tree))
	 (secondary-tree (dat::make-string-tree))
	 (string nil) ;; string + anchor will be key in tree
	 (derived-string nil) ;; string for derived discriminants
	 (pred-string nil)
	 (anchor 0)
	 (right-anchor nil)
	 (sem-vars))
    (build-sub-discriminants graph fs nil sem-vars)
    #+debug(print (length *f-disc-list*))
    (dolist (ctx.path *f-disc-list*)
      (let* ((main-path (member :ctx (cdr ctx.path) :key (lambda (node) (and (consp node) (car node)))))
	     (main-ctx (cdar main-path)))
	(when main-path
	  (loop for (elt . rest) on (cdr ctx.path)
		until (eq rest main-path)))
	(when main-path (setf ctx.path (cons main-ctx (cdr main-path))))
	#+debug(print (list :ctx.path ctx.path))
	(destructuring-bind (ctx . path) ctx.path	
	  (labels ((add-discriminant (string derived-string anchor right-anchor pred)
		     #+debug(print (list :add-discriminant ctx string derived-string anchor right-anchor pred))
		     (let* ((key (format nil "~a:~d:~d" string anchor right-anchor))
			    (u-ctx+dis (dat::string-tree-get tree key)))
		       (destructuring-bind (&optional u-ctx &rest dis) u-ctx+dis
			 (declare (ignore dis))
			 (setf (dat::string-tree-get tree key)
			       (list (context-s-union u-ctx ctx) string anchor right-anchor))))
		     ;; derived discriminants
		     (let* ((key (format nil "~d:~d:~a" anchor right-anchor derived-string))
			    (u-ctx+dis (dat::string-tree-get derived-tree key)))
		       (destructuring-bind (&optional u-ctx &rest dis) u-ctx+dis
			 (declare (ignore dis))
			 (setf (dat::string-tree-get derived-tree key)
			       (list (context-s-union u-ctx ctx) derived-string anchor right-anchor pred))))))
	    (block loop
	      #+debug(print (list :path path))
	      (loop with att-found-p = nil
		    for (node . rest) on path
		    do ;;(print (list :node node))
		    (cond ((equal node "_TOP")
			   (setf string (concatenate 'string node " ")
				 derived-string ""
				 pred-string ""
				 anchor 0))
			  ((consp node)
			   (when (eq (car node) :pred)
			     (when string
			       (setf string (concatenate 'string string (cadr node)))
			       (add-discriminant string derived-string anchor (caddr node) (cadr node)))
			     (setf string ;; (format nil "~d:~a " (caddr node) (cadr node)) ;; new start
				   (concatenate 'string (cadr node) " ")
				   derived-string ""
				   pred-string (cadr node)
				   anchor (caddr node)
				   ;; reset atts whose values we want to record
				   att-found-p nil)))
			  ((not (and (or (eq *discriminant-attributes* t)
					 (find node *discriminant-attributes* :test #'string=))
				     (not (find node *excluded-discriminant-attributes* :test #'string=))))
			   (return-from loop nil))
			  ((and (null rest) att-found-p)
			   (when string
			     #+debug(print (list :string+node string node))
			     (setf string (concatenate 'string string node)
				   derived-string (concatenate 'string derived-string node))
			     (add-discriminant string derived-string anchor nil pred-string)))
			  (t
			   (setf att-found-p t)
			   (setf string (concatenate 'string string node " ")
				 derived-string (concatenate 'string derived-string node " ")))))))))
      (setf string nil))
    #+debug
    (setf *derived-tree* derived-tree)
    (dat::do-string-tree (string ctx+dis derived-tree)
      (destructuring-bind (ctx dis-string left-anchor right-anchor pred) ctx+dis
	(unless (find dis-string '("" "> ") :test #'equal)
	  (dat::do-string-tree (string ctx+dis derived-tree :prefix (format nil "~d:NIL:" right-anchor))
	    (destructuring-bind (sub-ctx sub-dis-string sub-left-anchor sub-right-anchor sub-pred) ctx+dis
	      (let ((i-ctx (context-s-intersection ctx sub-ctx)))
		#+debug(print (list i-ctx ctx dis-string left-anchor right-anchor :sub sub-ctx sub-dis-string sub-left-anchor sub-right-anchor))
		(when (and i-ctx
			   (equal pred sub-pred)) ;; fixme: shouldn't we rather check that they originate from the same f-structure?
		  (let* ((string (concatenate 'string dis-string sub-dis-string))
			 (key (format nil "~a:~d" string left-anchor))
			 (u-ctx+dis (dat::string-tree-get secondary-tree key)))
		    #+debug(unless (eq i-ctx 1)
			      (print (list i-ctx dis-string left-anchor right-anchor pred sub-pred sub-dis-string sub-left-anchor sub-right-anchor)))
		    (destructuring-bind (&optional u-ctx &rest dis) u-ctx+dis
		      (declare (ignore dis))
		      (setf (dat::string-tree-get secondary-tree key)
			    (list (context-s-union u-ctx i-ctx) string left-anchor nil))))
		  #+ignore
		  (print (list i-ctx (concatenate 'string dis-string sub-dis-string) left-anchor nil)))))))))
    #+debug
    (dat::do-string-tree (string ctx+dis secondary-tree)
      (print (list string ctx+dis)))
    (values tree secondary-tree)))

(defmethod build-sub-discriminants ((graph xle-graph) (fs fs) root-path sem-vars)
  (with-slots (var context pred av-pairs fs-set context-set sub-disc pending-p) fs
    #+debug(print (list :var var :root-path root-path :sem-vars sem-vars))
    (or sub-disc
	(unless nil;;(> (count var root-path :key #'car) 1) ;; ?? detects cyclic structures
	  (let ((pp pending-p))
	    (unwind-protect
		 (let ((sd
			(collecting
			  (setf pending-p t)
			  (let* ((pred-list
				  (when pred
				    (unless (> (count (cons (id pred) :pred) root-path :test #'equal) 1)
				      (build-sub-discriminants graph pred (cons (cons (id pred) :pred) root-path) sem-vars))))
				 (av-list
				  (collecting
				    (dolist (av-pair av-pairs)
				      (unless (> (count (cons (id av-pair) :av-pair) root-path :test #'equal) 1) ;; ?? detects cyclic structures
					(dolist (ctx.value-path
						  (build-sub-discriminants graph av-pair (cons (cons (id av-pair) :av-pair) root-path) sem-vars))
					  #+debug(print (list :ctx.value-path-av-pair ctx.value-path))
					  (destructuring-bind (ctx . value-path) ctx.value-path
					    (let ((i-ctx (context-s-intersection context ctx)))
					      (when i-ctx
						(if (and (consp (car value-path))
							 (eq (caar value-path) :pred))
						    (push (list* i-ctx "PRED" (cdar value-path)) pred-list) ;; <<<<<<<<<<<<<<<****
						    (collect (list* i-ctx value-path)))))))))
				    (dolist (eq-pair context-set)
				      (unless (> (count (cons (id eq-pair) :eq) root-path :test #'equal) 1) ;; ?? detects cyclic structures
					(dolist (ctx.value-path (build-sub-discriminants graph eq-pair
											 (cons (cons (id eq-pair) :eq) root-path) sem-vars))
					  (destructuring-bind (ctx . value-path) ctx.value-path
					    #+debug(print (list :ctx.value-path-eq-pair ctx.value-path))
					    (let ((i-ctx (context-s-intersection context ctx)))
					      (when i-ctx
						(if (and (consp (car value-path))
							 (eq (caar value-path) :pred))
						    (push (list* i-ctx "PRED" (cdar value-path)) pred-list) ;; <<<<<<<<<<<<<<<****
						    (collect (list* i-ctx value-path))))))))))))
			    (if pred-list
				(let ((accumulated-pred-ctx nil))
				  #+debug(print (list :var var :context context :pred pred :pred-listx pred-list))
				  (dolist (pred pred-list)
				    (destructuring-bind (pred-ctx p . pred-name+anchor) pred
				      (declare (ignore p))
				      (let ((pred-i-ctx (context-s-intersection pred-ctx context)))
					(when pred-i-ctx
					  (setf accumulated-pred-ctx (context-s-union accumulated-pred-ctx pred-i-ctx))
					  (collect (list pred-i-ctx (cons :pred pred-name+anchor)))
					  (dolist (av av-list)
					    #+debug(when (eq var 15) (print (list :av av)))
					    (destructuring-bind (av-ctx . path) av
					      (let ((i-ctx (context-s-intersection pred-i-ctx av-ctx)))
						#+debug(when (and (eq var 58) #+ignore(find "SUBJ" path :test #'equal))
							 (print (list :i-ctx i-ctx :pred pred :av-ctx av-ctx :path path)))
						(when i-ctx
						  (when (and path (not (consp (car path))))
						    (unless (> (count :pred path :key (lambda (node) (and (consp node) (car node)))) 1)
						      (push (list* i-ctx (cons :pred pred-name+anchor) path) *f-disc-list*))
						    #+extended-discriminants
						    (unless (or ;; buggy (eq i-ctx 1)
								(> (count :pred path :key (lambda (node) (and (consp node) (car node)))) 1))
						      (collect (list* i-ctx
								      (cons :ctx i-ctx)
								      (cons :pred pred-name+anchor)
								      path))))
						  (when (zerop var)
						    (unless nil ;;(eq i-ctx 1) ;; new
						      (push (list i-ctx "_TOP" (cons :pred pred-name+anchor)) *f-disc-list*)))))))))))
				  (dolist (av av-list)
				    #+debug(print (list :acc accumulated-pred-ctx :av av))
				    (let* ((i-ctx (car av))
					   (ctx-diff (context-s-difference i-ctx accumulated-pred-ctx)))
				      (when ctx-diff
					#+debug(print (list :ctx-diff ctx-diff))
					(setf (car av) ctx-diff)
					(collect av)))))
				(collect-append av-list)))
			  (loop for fs in fs-set
				for i from 1
				do (dolist (ctx.value-path (build-sub-discriminants graph (cdr fs) root-path sem-vars))
				     (destructuring-bind (ctx . value-path) ctx.value-path
				       (let ((i-ctx (context-s-intersection (caar fs) (context-s-intersection context ctx)))) ;; simplify?!
					 (when i-ctx
					   (if (zerop var)
					       (push (list* i-ctx "_TOP" ">" value-path) *f-disc-list*)
					       (collect (list* i-ctx
							       ;;(format nil ">~d.~d" var i)
							       ">"
							       value-path)))))))))))
		   (unless pp (setf sub-disc sd))
		   #+debug(print (list :sd sd))
		   sd)
	      (unless pp (setf pending-p nil))))))))

(defmethod build-sub-discriminants ((graph xle-graph) (av-pair av-pair) root-path sem-vars)
  (with-slots (var attribute value context sub-disc pending-p) av-pair
    (or sub-disc
	(let ((pp pending-p))
	  (setf pending-p t)
	  (unwind-protect
	       (let ((sd (collecting
			   (dolist (ctx.value-path (build-sub-discriminants graph value root-path sem-vars))
			     (destructuring-bind (ctx . value-path) ctx.value-path
			       (let ((i-ctx (context-s-intersection context ctx)))
				 (cond ((null i-ctx)
					nil)
				       ((string= attribute "=")
					(collect (list* i-ctx value-path)))
				       (t
					(collect (list* i-ctx attribute value-path))))))))))
		 (unless pp (setf sub-disc sd))
		 sd)
	    (unless pp (setf pending-p nil)))))))

(defmethod build-sub-discriminants ((graph xle-graph) (semform semform) root-path sem-vars)
  (let ((pos (position (sem-var semform) sem-vars)))
    (list (list 1 (format-semform semform nil :var (when pos (1+ pos))) (string-pos semform)))))

(defmethod build-sub-discriminants ((graph xle-graph) (string string) root-path sem-vars)
  (declare (ignore sem-vars))
  (list (list 1 string)))

(defmethod build-sub-discriminants ((graph xle-graph) (value t) root-path sem-vars)
  (declare (ignore root-path sem-vars))
  nil)

;; used in xle-interface.lisp (get-next-solution()) and xle-www.lisp (f-structure-xml())
(defmethod build-f-structure-discriminants ((graph xle-graph) (discriminants discriminants) disc-tree
					    &key include-trivial-discriminants-p psentence)
  (unless (zerop (car disc-tree))
    (dat::do-string-tree (key context+dis disc-tree)
      ;;(declare (ignore key))
      (destructuring-bind (context string anchor &optional right-anchor) context+dis
	#+debug(print (list :ctx context :string string :dis context+dis))
	(unless (or (null context) (and (eq context 1) (not include-trivial-discriminants-p)))
	  (unless (and (eq context 1) (not include-trivial-discriminants-p))
	    (make-instance (f-structure-discriminant-class graph)
			   :discriminants discriminants
			   :path-segment string
			   :context context
			   :s-context context
			   :psentence psentence
			   :anchor anchor
			   :right-anchor right-anchor
			   :extend-p t)))))))

(defmethod build-secondary-discriminants ((graph xle-graph) (discriminants discriminants) disc-tree
					    &key include-trivial-discriminants-p psentence)
  (unless (zerop (car disc-tree))
    (dat::do-string-tree (key context+dis disc-tree)
      ;;(declare (ignore key))
      (destructuring-bind (context string anchor &optional right-anchor) context+dis
	#+debug(print (list :ctx context :string string :dis context+dis))
	(unless (or (null context) (and (eq context 1) (not include-trivial-discriminants-p)))
	  (unless (and (eq context 1) (not include-trivial-discriminants-p))
	    (make-instance (secondary-discriminant-class graph)
			   :discriminants discriminants
			   :path-segment string
			   :context context
			   :s-context context
			   :psentence psentence
			   :anchor anchor
			   :right-anchor right-anchor
			   :extend-p t)))))))

#+extended-discriminants
(defmethod build-f-structure-discriminants ((graph xle-graph) (discriminants discriminants) disc-tree
					    &key include-trivial-discriminants-p psentence)
  (unless (zerop (car disc-tree))
    (dat::do-string-tree (string context+dis disc-tree)
      (print (list string context+dis))
      (destructuring-bind (context . dis) context+dis
	#+debug(print (list :ctx context :string string :dis dis))
	(unless (or (null context) (and (null dis) (eq context 1) (not include-trivial-discriminants-p)))
	  (cond ((or (null dis)
		     (null (cdr dis)))
		 (unless (and (eq context 1) (not include-trivial-discriminants-p))
		   (make-instance (f-structure-discriminant-class graph)
				  :discriminants discriminants
				  :path-segment string
				  :context context
				  :s-context context
				  :psentence psentence
				  :extend-p t ;;:disjunctions disjunctions
				  )))
		(t
		 (dolist (pair dis)
		   (destructuring-bind (dis-str . dis-ctx) pair
		     (unless (and (eq dis-ctx 1) (not include-trivial-discriminants-p))
		       (make-instance (f-structure-discriminant-class graph)
				      :discriminants discriminants
				      :path-segment (concatenate 'string dis-str string)
				      :context dis-ctx
				      :s-context dis-ctx
				      :psentence psentence
				      :extend-p t ;;:disjunctions disjunctions
				      )))))))))))

#+orig
(defmethod build-f-structure-discriminants ((graph xle-graph) (discriminants discriminants) disc-tree)
  (unless (zerop (car disc-tree))
    (dat::do-string-tree (string context disc-tree)
      (unless (or (null context) (eq context 1))
	(make-instance (f-structure-discriminant-class graph)
		       :discriminants discriminants
		       :path-segment string
		       :context context
		       :s-context context
		       ;;:disjunctions disjunctions
		       )))))

:eof