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

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

(in-package :XLE)

(defun nth-solution-choices (disjunctions-tree solution-nr)
  (collecting
    (labels ((dis-choices (dis-branches n)
	       (cond ((null dis-branches)
		      nil)
		     ((>= n (caar dis-branches))
		      (dis-choices (cdr dis-branches) (- n (caar dis-branches))))
		     (t
		      (destructuring-bind (name node-id summand . sub-nodes) (cdar dis-branches)
			(collect (list name node-id summand))
			(con-choices sub-nodes n)))))
	     (con-choices (con-branches n)
	       (cond ((null con-branches)
		      nil)
		     ((null (cdr con-branches))
		      (dis-choices (cdr (cdddar con-branches)) n))
		     (t
		      (multiple-value-bind (x y) (floor n (caar con-branches))
			(dis-choices (cdr (cdddar con-branches)) y)
			(con-choices (cdr con-branches) x))))))
      (con-choices (cddddr disjunctions-tree) solution-nr))))

;; maps disjunction variables to solution numbers
(defun build-disjunction-solutions (disjunctions-tree)
  (let ((dis-list ()))
    (dotimes (i (car disjunctions-tree))
      (labels ((dis-choices (dis-branches n)
		 (cond ((null dis-branches)
			nil)
		       ((>= n (caar dis-branches))
			(dis-choices (cdr dis-branches) (- n (caar dis-branches))))
		       (t
			(destructuring-bind (name node-id summand . sub-nodes) (cdar dis-branches)
			  (unless (getf dis-list name)
			    (setf (getf dis-list name)
				  (make-array (car disjunctions-tree) :element-type 'bit :initial-element 0)))
			  (setf (aref (getf dis-list name) i) 1)
			  (con-choices sub-nodes n)))))
	       (con-choices (con-branches n)
		 (cond ((null con-branches)
			nil)
		       ((null (cdr con-branches))
			(dis-choices (cdr (cdddar con-branches)) n))
		       (t
			(multiple-value-bind (x y) (floor n (caar con-branches))
			  (dis-choices (cdr (cdddar con-branches)) y)
			  (con-choices (cdr con-branches) x))))))
	(con-choices (cddddr disjunctions-tree) i)))
    dis-list))

;; (normal-form (resolve-context equivalences term-context))

#+test
(print (resolve-context *equivalences* 'cv_009))
#+test
(print (context-solutions *xle-graph* 'cv_002))

;;; >>>>>>>>>>>>>>>>> those should be made obsolete

(defun normal-form (context)
  #+debug(print (list :context context))
  (cond ((eq context 1)
	 context)
	((eq context '\1)
	 1)
	((equal context '(or 1))
	 1)
	((equal context '(or \1))
	 1)
	((atom context)
	 (list 'or context))
	(t
	 (labels ((remove-subsumption (operands op)
		    #+debug(print (list :operands operands :op op))
		    (loop for (first . rest) on (sort operands (if (eq op 'and) #'< #'>) :key #'length)
			  unless (find first rest
				       :test (if (eq op 'and)
						 #'subsetp
						 (lambda (f r) (subsetp r f))))
			  collect first))
		  (combine (list set op)
		    (let ((first-list (car list)))
		      (cond ((null list)
			     set)
			    ((null set)
			     (combine (cdr list) first-list op))
			    (t
			     (let ((product-set
				    (collecting
				      (dolist (s set)
					(dolist (l first-list)
					  #+debug(print (list :l l :s s))
					  (collect (remove-duplicates (append l s)
								      ;;:test
								      #+test(lambda (xx yy)
									(and (eq (length xx) (length yy))
									     (loop for x in xx
										   always (find x yy))))
								      )))))))
			       (combine (cdr list) product-set op))))))
		  (walk (list)
		    #+debug(print (list :list list))
		    (cond ((atom list)
			   (list (list list)))
			  ((eq (car list) 'and)
			   (combine (mapcar #'walk (cdr list)) nil 'and))
			  ((eq (car list) 'or)
			   (reduce #'append (mapcar #'walk (cdr list)))))))
	   (let ((disjunctions (mapcar (lambda (and) (cons 'and and))
				       (remove-subsumption (walk context) 'or))))
	     #+debug(print (list :dis disjunctions))
	     (if t;;(cdr disjunctions)
		 (cons 'or disjunctions)
		 (car disjunctions)))))))

(defun resolve-context (equivalences context)
  (labels ((flatten (or-list)
	     (cond ((atom or-list)
		    (list or-list))
		   ((eq 'or (car or-list))
		    (collecting
		      (dolist (form (cdr or-list))
			(cond ((atom form)
			       (collect form))
			      ((and (eq (car form) 'and)
				    (not (cddr form)))
			       (collect (cadr form)))
			      (t
			       (collect-append (flatten form)))))))
		   (t
		    (error "Not implemented: form: ~s" or-list)))))
    (cons 'or (flatten (%resolve-context equivalences context)))))

(defun %resolve-context (equivalences context)
  (or (getf equivalences context)
      (if (atom context)
	  context
	  (cons (car context)
		(mapcar (lambda (term) (%resolve-context equivalences term))
			(cdr context))))))

#+buggy ;; in memoizing, should be something like get-equal()
(defmethod context-solutions ((graph xle-graph) context)
  (with-slots (disjunction-solutions equivalences) graph
    (or (getf disjunction-solutions context)
	(setf (getf disjunction-solutions context)
	      (cond ((eq context 1)
		     1)
		    ((null context)
		     nil)
		    (t
		     (let ((context (resolve-context equivalences context)))
		       (apply #'map #+sbcl '(vector bit) #-sbcl'(simple-array bit)
			      (lambda (&rest bits)
				(if (find 1 bits) 1 0))
			      (mapcar (lambda (dis-var)
					(getf disjunction-solutions dis-var))
				      (cdr context))))))))))

;; to do: memoizing (equal-key!)
(defmethod context-solutions ((graph xle-graph) context)
  (with-slots (disjunction-solutions equivalences) graph
    (or #+test(getf disjunction-solutions context)
	;;(setf (getf disjunction-solutions context)
	(cond ((eq context 1)
	       1)
	      ((null context)
	       nil)
	      ((vectorp context)
	       context)
	      (t
	       (let ((context (resolve-context equivalences context)))
		 (apply #'map #+sbcl '(vector bit) #-sbcl '(simple-array bit)
			(lambda (&rest bits)
			  (if (find 1 bits) 1 0))
			(mapcar (lambda (dis-var)
				  (getf disjunction-solutions dis-var))
				(cdr context)))))))))

(defmethod %solution-vector ((graph xle-graph) nf-context)
  (cond ((eq nf-context 1)
	 1)
	(t
	 (reduce #'context-s-union
		 (mapcar (lambda (con-list)
			   (reduce #'context-s-intersection
				   (mapcar (lambda (ctx) (context-solutions graph ctx)) (cdr con-list))
				   :initial-value 1))
			 (cdr nf-context))
		 :initial-value nil))))

(defun context-satisfied-p (context choices)
  (cond ((find context '(1 \1))
	 t)
	((atom context)
	 (if (atom choices)
	     (eq context choices)
	     (find context choices :key #'car)))
	((eq (car context) 'or)
	 (loop for sub in (cdr context)
	       thereis (context-satisfied-p sub choices)))
	((eq (car context) 'and)
	 (loop for sub in (cdr context)
	       always (context-satisfied-p sub choices)))
	((eq (car context) 'not)
	 (not (context-satisfied-p (cadr context) choices)))
	(t
	 (error "Not implemented: context: ~s, choices: ~s." context choices))))

;;; <<<<<<<<<<<<<<<

#+test
(print (%solution-vector *xle-graph* '(OR (AND A2))))

#+test
(print (build-disjunction-solutions *disjunctions*))
#+test
(progn (print *disjunctions*)
       (dotimes (i (car *disjunctions*))
	 (print (cons i (nth-solution-choices *disjunctions* i)))))

(defun extract-var-id (term)
  (labels ((walk (branch)
	     (cond ((atom branch)
		    nil)
		   ((and (eq (car branch) 'eq) (eq (caadr branch) 'var)) ;; packed prolog rep.
		    (return-from extract-var-id (cadadr branch)))
		   ((eq (car branch) 'in_set)
		    (walk (caddr branch)))
		   ((eq (car branch) 'var)
		    (return-from extract-var-id (cadr branch)))
		   (t
		    (mapc #'walk (cdr branch))))))
    (walk term)))

;; for debugging
(defvar *disjunctions* nil)
(defvar *disjunction-solutions* nil)
(defvar *equivalences* nil)
(defvar *xle-graph* nil)

;; checks if context is true for solution-nr
(defun solution-context-p (context solution-nr)
  (cond ((null context)
	 nil)
	((eq context 1)
	 t)
	(t
	 (= (aref context solution-nr) 1))))

(defun context-s-intersection (ctx1 ctx2 &optional (context 1))
  (cond ((null context)
	 nil)
	((not (eq context 1))
	 (context-s-intersection ctx1 (context-s-intersection ctx2 context)))
	((eq ctx1 1)
	 ctx2)
	((eq ctx2 1)
	 ctx1)
	((null ctx1)
	 nil)
	((null ctx2)
	 nil)
	(t
	 (let* ((one-found-p nil)
		(intersection
		 (map #+sbcl'(vector bit) #-sbcl'(simple-array bit)
		      (lambda (bit1 bit2) (if (and (= bit1 1) (= bit2 1))
					      (progn (setf one-found-p t)
						     1)
					      0))
		      ctx1 ctx2)))
	   (if one-found-p intersection nil)))))

;;(print (proper-1-context-intersection-p #*11100000 #*10101010))

;; nonempty and intersection is smaller than ctx1
(defun proper-1-context-intersection-p (ctx1 ctx2)
  (cond ((null ctx2)
	 nil)
	((eq ctx1 1)
	 (and (not (eq ctx2 1)) (find 0 ctx2)))
	((eq ctx2 1)
	 nil)
	((null ctx1)
	 nil)
	(t
	 (loop with proper-1-p = nil and common-found-p = nil
	       for bit1 across ctx1 and bit2 across ctx2
	       do (cond ((and (not common-found-p)
			      (= bit1 bit2 1))
			 (setf common-found-p t))
			((and (not proper-1-p)
			      (= bit1 1)
			      (zerop bit2))
			 (setf proper-1-p t)))
	       when (and proper-1-p common-found-p)
	       do (return t)))))

(defun context-s-union (ctx1 ctx2)
  (cond ((eq ctx1 1)
	 1)
	((eq ctx2 1)
	 1)
	((eq ctx1 -1)
	 ctx2)
	((eq ctx2 -1)
	 ctx1)
	((null ctx1)
	 ctx2)
	((null ctx2)
	 ctx1)
	(t
	 (let* ((zero-found-p nil)
		(union
		 (map #+sbcl '(vector bit) #-sbcl '(simple-array bit)
		      (lambda (bit1 bit2)
			(if (or (= bit1 1) (= bit2 1))
			    1
			    (progn (setf zero-found-p t)
				   0)))
		      ctx1 ctx2)))
	   (if zero-found-p union 1)))))

;; ctx1 - ctx2; destructively modifies ctx1
(defun context-s-difference (ctx1 ctx2)
  (cond ((eq ctx2 1)
	 nil)
	((null ctx2)
	 ctx1)
	((null ctx1)
	 nil)
	((eq ctx1 1)
	 (map #+sbcl '(vector bit) #-sbcl'(simple-array bit)
	      (lambda (bit)
		(if (zerop bit) 1 0))
	      ctx2))
	(t
	 (loop for b2 across ctx2
	       for i from 0
	       when (= b2 1) do (setf (aref ctx1 i) 0))
	 (when (find 1 ctx1) ctx1))))

(defun context-subsumed-p (ctx1 ctx2)
  (cond ((or (eq ctx1 1) (and ctx1 (not (find 0 ctx1))))
	 (if (or (eq ctx2 1) (and ctx2 (not (find 0 ctx2))))
	     :equal
	     t))
	((or (eq ctx2 1) (and ctx2 (not (find 0 ctx2))))
	 nil)
	((null ctx1)
	 (when (null ctx2) :equal))
	((null ctx2)
	 t)
	(t
	 (let ((sp :equal))
	   (loop for c1 across ctx1
		 for c2 across ctx2
		 do (if (zerop c1)
			(unless (zerop c2)
			  (return-from context-subsumed-p nil))
			(when (zerop c2)
			  (setf sp t))))
	   sp))))

(defun reduced-context (context env-context)
  (cond ((null context) ())
	((null env-context) ())
	((and (eq env-context 1)
	      (eq context 1))
	 1)
	((eq env-context 1)
	 context)
	((eq context 1)
	 1)
	(t
	 (let* ((zero-found-p nil)
		(rc (loop for c across context
			  for e across env-context
			  when (= e 1)
			  collect (progn 
				    (when (zerop c)
				      (setf zero-found-p t))
				    c))))
	   (if zero-found-p
	       (coerce rc #+sbcl '(vector bit) #-sbcl '(array bit))
	       1)))))

(defun context-trivial-p (context env-context)
  (cond ((null context) nil)
	((null env-context) t)
	((and (eq env-context 1)
	      (eq context 1))
	 t)
	((eq env-context 1)
	 (not (find 0 context)))
	((eq context 1)
	 t)
	(t
	 (loop for c across context
	       for e across env-context
	       when (and (= e 1) (zerop c))
	       do (return-from context-trivial-p nil))
	 t)))

(defun solution-list (context env-context)
  (cond ((null context) ())
	((null env-context) ())
	((and (eq env-context 1)
	      (eq context 1))
	 1)
	((eq env-context 1)
	 (loop for c across context
	       for i from 0
	       when (= c 1)
	       collect i))
	((eq context 1)
	 (loop for e across env-context
	       for i from 0
	       when (= e 1)
	       collect i))
	(t
	 (loop for c across context
	       for e across env-context
	       for i from 0
	       when (= c e 1)
	       collect i))))

#+test
(print (select [prolog] :from [parsed-sentence] :where [= [unique-id] 211153]))
#+test
(with-open-file (stream "/~test1.fs" :direction :input)
  (write-packed-choices stream nil)
  )

;; #*00100000000110001000000000

;; context has to be pos of only selected solution
(defmethod write-selected-context-prolog ((graph xle-graph) &key stream out-stream context)
  (with-slots (disjunctions-tree) graph
    (let ((*package* (find-package :xle))
	  (*readtable* *prolog-form-readtable*)
	  (selections (mapcar #'car (nth-solution-choices disjunctions-tree context)))
	  (define-found-p nil)
	  (firstp t)
	  (first-line-p t)
	  (in-equivalences-p nil))
      (with-stream-lines (stream line)
	(unless (and in-equivalences-p (zerop (length (string-trim '(#\space #\tab) line))))
	  (when (search "% Equivalences:" line)
	    (setf in-equivalences-p t))
	  (when (search "define(" line)
	    (setf define-found-p t))
	  (when (and in-equivalences-p
		     (string= (string-trim '(#\space #\tab) line) "],"))
	    (dolist (label selections)
	      (cond ((and firstp (not define-found-p))
		     (format out-stream "~%~cselect(~a, 1)" #\tab label))
		    (t
		     (write-char #\, out-stream)
		     (format out-stream "~%~cselect(~a, 1)" #\tab label)))
	      (setf firstp nil))
	    ;;(terpri out-stream)
	    (setf in-equivalences-p nil))
	  (if first-line-p
	      (setf first-line-p nil)
	      (terpri out-stream))
	  (write-string line out-stream)))
      (terpri out-stream))))

(defun sort-choice-labels (label-list)
  (sort label-list (lambda (lc1 lc2)
		     (or (< (car lc1) (car lc2))
			 (and (= (car lc1) (car lc2))
			      (< (cdr lc1) (cdr lc2)))))
	:key (lambda (l) (label-choice (symbol-name l)))))

(defmethod write-reduced-context-prolog ((graph xle-graph) &key stream out-stream context)
  (when (listp context)
    (let ((ctx (make-array (solution-count graph) :element-type 'bit :initial-element 0)))
      (dolist (i context)
	(setf (bit ctx i) 1))
      (setf context ctx)))
  (if (eql context 1)
      ;; simply write the original prolog file, but insert the sentence if missing
      (with-stream-lines (stream line)
	(cond ((string= line "fstructure('',") ;; this means that the sentence text is not included; happens when fst is not used
	       (write-string "fstructure('" out-stream)
	       (write-string (sentence graph) out-stream)
	       (write-line "'," out-stream))
	      (t
	       (write-line line out-stream))))
      ;; keep those lines whose contexts intersect non-trivially with the reduced context;
      ;; replace the context by the intersection context
      (with-slots (disjunctions-tree) graph
	(let ((*package* (find-package :xle))
	      (*readtable* *prolog-form-readtable*)
	      (firstp t)
	      (%disjunctions ())
	      (eq-classes (make-hash-table :test #'equal))
	      (choices-list
	       (delete-duplicates
		(collecting
		  ;; bitvector
		  (loop for i from 0 for bit across context
			when (= bit 1)
			do (collect-append (mapcar #'car (nth-solution-choices disjunctions-tree i)))))))
	      (reduced-choices ())
	      (reduced-labels (list 1))
	      (in-choices-p nil))
	  (labels ((get-equiv (ch)
		     (let ((equiv (gethash ch eq-classes)))
		       (if (and equiv (not (eq equiv :ambig)))
			   (get-equiv equiv)
			   ch)))
		   (get-equiv1 (ch)
		     (if (find ch reduced-labels)
			 ch
			 (let ((equiv (gethash ch eq-classes)))
			   (when (and equiv (not (eq equiv :ambig)))
			     (or (get-equiv1 equiv) equiv))))))
	    #+debug(print choices-list)
	    (with-stream-lines (stream line)
	      (cond ((search "choice(" line)
		     (setf in-choices-p t)
		     (let* ((choice-term (read-from-string (prefix-to-infix line)))
			    (children (cdadr choice-term))
			    (parents (caddr choice-term))
			    (reduced-parents ())
			    (reduced-children (collecting
						(dolist (p children)
						  (when (find p choices-list)
						    (collect p #+ignore(gethash p eq-classes p)))))))
		   
		   
		       (labels ((reduce-parents (p)
				  (cond ((atom p)
					 (when (or (find p choices-list) (eq p 1))
					   (pushnew p #+ignore(gethash p eq-classes p) reduced-parents)))
					((eq (car p) 'or)
					 (dolist (p-or (cdr p))
					   (reduce-parents p-or)))
					(t
					 (error "Choice not recognized: ~s" choice-term)))))
			 (reduce-parents parents)
			 (when (or reduced-children reduced-parents)
			   (when (context-subsumed-p (context-solutions graph (cons 'or reduced-parents)) context)
			     (setf reduced-parents 1))
			   (unless (or (cdr reduced-children) (atom reduced-parents) (cdr reduced-parents))
			     (if (gethash (car reduced-children) eq-classes)
				 (setf (gethash (car reduced-children) eq-classes) :ambig)
				 (setf (gethash (car reduced-children) eq-classes) (car reduced-parents))))
			   #+debug
			   (print (list :c reduced-children
					:p reduced-parents
					)))
			 #+test
			 (when (and reduced-children reduced-parents (not (cdr reduced-children)))
			   (setf (gethash (car reduced-children) eq-classes)
				 (if (cdr reduced-parents)
				     reduced-parents
				     (car reduced-parents))))
			 (when (and reduced-parents (cdr reduced-children))
			   (push (list reduced-children reduced-parents) reduced-choices)
			   #+debug
			   (print (list :reduced-children reduced-children
					:reduced-parents reduced-parents))))
		       (labels ((add-parents (p)
				  (cond ((atom p)
					 (push (cdadr choice-term) (getf %disjunctions p)))
					((eq (car p) 'or)
					 (dolist (p-or (cdr p))
					   (add-parents p-or)))
					(t
					 (error "Choice not recognized: ~s" choice-term)))))
			 (add-parents parents))))
		    ((string= (string-trim '(#\space #\tab) line) "],")
		     (when in-choices-p
		       (setf in-choices-p nil)
		       (let ((firstp t))
			 ;;(terpri out-stream)
			 (dolist (reduced-choice (nreverse reduced-choices))
			   (cond (firstp
				  (setf firstp nil)
				  #+debug
				  (maphash (lambda (key value)
					     (print (list :key key :value value)))
					   eq-classes))
				 (t
				  (write-char #\, out-stream)))
			   (destructuring-bind (children parents) reduced-choice
			     (let ((equiv-children (mapcar #'get-equiv children)))
			       (format out-stream "~%~cchoice([~{~a~^,~}], "
				       #\tab
				       equiv-children)
			       (dolist (ch equiv-children)
				 (pushnew ch reduced-labels)))
			     (labels ((write-or-tree (chl)
					(cond ((atom chl)
					       ;;(print (list chl :get-equiv (get-equiv chl))) 
					       (write (get-equiv chl) :stream out-stream))
					      ((null (cdr chl))
					       (write (get-equiv (car chl)) :stream out-stream))
					      (t
					       (write-string "or(" out-stream)
					       (loop for (ch . rest) on chl
						     do (write-or-tree ch)
						     when rest
						     do (write-char #\, out-stream))
					       (write-string ")" out-stream)))))
			       (write-or-tree parents))
			     (write-string ")" out-stream)
			     ))
			 ;;(terpri out-stream)
			 ))
		     (terpri out-stream)
		     (write-string line out-stream))
		    ((string= (string-trim '(#\space #\tab) line) "[")
		     (terpri out-stream)
		     (write-string line out-stream)
		     (setf firstp t))
		    ((search "define(" line)
		     ;; We assume that definitions are not recursive.
		     (let* ((define-term (read-from-string (prefix-to-infix line)))
			    (cv (cadr define-term))
			    (or-tree (caddr define-term))
			    (or-set ()))
		       (labels ((reduce-or-tree (or-list)
				  (dolist (term (if (eq (car or-list) 'or)
						    (cdr or-list)
						    or-list))
				    (cond ((listp term)
					   (reduce-or-tree term))
					  (t
					   (when (find term choices-list) 
					     (let ((eq-choice (get-equiv term)))
					       (if (atom eq-choice)
						   (pushnew eq-choice or-set)
						   ;; does not happen
						   (reduce-or-tree eq-choice)))))))))
			 (reduce-or-tree or-tree))
		       (cond ((null or-set)
			      (setf (gethash cv eq-classes) nil))
			     ((context-subsumed-p (context-solutions graph cv) context)
			      (setf (gethash cv eq-classes) 1))
			     (t	;;(< (length or-set) 5)
			      (setf (gethash cv eq-classes) (sort-choice-labels or-set))
			      #+debug(print (list :cv cv :or (gethash cv eq-classes))) 
			      )
			     #+ignore-yet
			     (t
			      (unless firstp (write-char #\, out-stream))
			      (format out-stream "~%~cdefine(~a, or(~{~a~^,~}))"
				      #\tab
				      cv
				      or-set)
			      (setf firstp nil)))))
		    ((search "cf(" line)
		     (labels ((context-end (pos level)
				(case (char line pos)
				  (#\( (context-end (1+ pos) (1+ level)))
				  (#\) (context-end (1+ pos) (1- level)))
				  (#\, (if (zerop level)
					   pos
					   (context-end (1+ pos) level)))
				  (otherwise
				   (context-end (1+ pos) level)))))
		       (let* ((term (read-from-string (prefix-to-infix (copy-seq line))))
			      (start (+ (search "cf(" line) 3))
			      (end (context-end start 0))
			      (ctx (cadr term))
			      (ctx-s (context-solutions graph ctx))
			      (reduced-context ())) ;; (get-equiv1 context)))
			 ;;(print (list ctx-s context))
			 (cond ((context-subsumed-p ctx-s context)
				(setf reduced-context 1))
			       (t
				(block reduce
				  (labels ((reduce-or-tree (or-list)
					     (cond ((listp or-list)
						    (dolist (term (if (eq (car or-list) 'or)
								      (cdr or-list)
								      or-list))
						      (reduce-or-tree term)))
						   ((eql or-list 1)
						    (setf reduced-context 1)
						    (return-from reduce))
						   #+ignore
						   ((find or-list choices-list)
						    (pushnew or-list reduced-context))
						   (t
						    (let ((eq-choice (get-equiv1 or-list)))
						      #+debug(print (list :ol or-list :eq eq-choice))
						      (cond ((null eq-choice)
							     nil)
							    ((eql eq-choice 1)
							     (setf reduced-context 1)
							     (return-from reduce))
							    ((atom eq-choice)
							     (pushnew eq-choice reduced-context))
							    (t
							     (reduce-or-tree eq-choice))))))))
				    (reduce-or-tree ctx)
				    (when (consp reduced-context)
				      (setf reduced-context (sort-choice-labels reduced-context)))))))
			 (when reduced-context
			   (unless firstp (write-char #\, out-stream))
			   (setf firstp nil)
			   (cond ((eql reduced-context 1)
				  (format out-stream "~%~ccf(1" #\tab))
				 ((not (cdr reduced-context))
				  (format out-stream "~%~ccf(~a" #\tab (car reduced-context)))
				 (t
				  (format out-stream "~%~ccf(or(~{~a~^,~})" #\tab reduced-context)))
			   (write-string line out-stream
					 :start end
					 :end (if (char= (char line (1- (length line))) #\,)
						  (1- (length line))
						  (length line)))))))
		    ((string= line "fstructure('',") ;; this means that the sentence text is not included; happens when fst is not used
		     (terpri out-stream)
		     (write-string "fstructure('" out-stream)
		     (write-string (sentence graph) out-stream)
		     (write-string "'," out-stream))
		    (t
		     (terpri out-stream)
		     (write-string line out-stream))))))
	(terpri out-stream))))

;; to do: recognize char encoding
(defmethod parse-prolog ((graph xle-graph)
			 &key (packed-p t)
			 (parse-constraints-p t) ;; if NIL only Choices and Equivalences are parsed
			 packed-f-structure-p packed-c-structure-p solution
			 (build-c-structure-p t) disjunction-choice sort-attributes-p
			 prolog-p #+obsolete(ranking-p t) prolog-destination &allow-other-keys)
  #+debug(print (list :packed-p packed-p
		      :parse-constraints-p parse-constraints-p
		      :packed-f-structure-p packed-f-structure-p :packed-c-structure-p packed-c-structure-p
		      :solution solution :build-c-structure-p build-c-structure-p
		      :disjunction-choice disjunction-choice
		      :sort-attributes-p sort-attributes-p :prolog-p prolog-p
		      :prolog-destination prolog-destination))
  (setf *xle-graph* graph)
  (let ((%disjunctions ())
	(parent-table (make-hash-table))
	(root-id nil)
	#+ignore
	(f-structure-p t)
	(disjunction-tree-built-p nil))
    (with-slots (grammar graph-address prolog prolog-terms var-array c-var-array var-list
			 disjunction-choices equivalences discriminants
			 disjunctions disjunctions-tree disjunction-solutions solution-nr
			 solution-count ranking global-projection-fs-ids
			 phi-list inverse-phi-list subsume-list semform-edge-list
			 ;; phi-lists inverse-phi-lists subsume-lists ;; used for un-packed graph
			 top-f-node-var fragments-p statistics) graph
      (with-slots (root-cat reparse-cat) grammar
	#+debug(print (list :root-cat root-cat :graph-root-cat (root-cat graph) :reparse-cat reparse-cat 
			    :disjunctions disjunctions :solution-nr solution-nr :solution-count
			    solution-count))
	(labels ((ranked-solution (solution-nr)
		   (if nil ;;(and #+ignore ranking-p ranking)
		       (car (aref ranking solution-nr))
		       solution-nr)))
	  (setf var-array (make-array 0 :fill-pointer 0 :adjustable t)
		c-var-array (when build-c-structure-p (make-array 0 :fill-pointer 0 :adjustable t))
		var-list ()
		phi-list ()
		inverse-phi-list ()
		semform-edge-list ()
		global-projection-fs-ids ())
	  (let ((%prolog
		 (with-output-to-string (stream)
		   (collecting-into (%lines)
		     (block parse
		       ;; this calls print-prolog-graph() if :lines and :prolog is nil
		       (do-parse-output-lines (line (if packed-p graph-address (or solution (solution graph)))
						    :lines (and packed-p prolog-terms) ;; has precedence over :prolog
						    :prolog (and prolog (> (length prolog) 0) prolog)
						    :prolog-destination prolog-destination)
			 (when (stringp line)
			   #+debug(write-line line)
			   (cond ((null grammar)
				  nil)
				 ((equal (language grammar) "tur")
				  (setf line (encode-sentence :tur line nil)))
				 ((equal (language grammar) "ara")
				  (setf line (encode-sentence :ara line nil)))
				 ((equal (language grammar) "slv")
				  (setf line (encode-sentence :slv line nil)))
				 ((equal (language grammar) "ava")
				  (setf line (encode-sentence :ava line nil)))))
			 (when (and prolog-p (stringp line))
			   (write-line line stream))
			 ;;(unless prolog-terms (collect-into %lines %line))
			 ;;(setf line (copy-seq %line)) ;; copy-seq() since prefix-to-infix() is destructive. Do away with copying!
			 (when (and (stringp line) (search "C-Structure" line))
			   (if build-c-structure-p
			       nil ;; (setf f-structure-p nil)
			       (return-from parse)))
			 (let* ((*package* (find-package :xle))
				(*readtable* *prolog-form-readtable*))
			   (cond ((and (stringp line) (search "'statistics'('" line))
				  (let ((start (+ (search "'statistics'('" line) 14))
					(end (search "')" line)))
				    (setf statistics (subseq line start end))))
				 ((and (stringp line) (search "'rootcategory'('" line))
				  (let ((start (+ (search "'rootcategory'('" line) 16))
					(end (search "')" line)))
				    (setf root-cat (subseq line start end))))
				 ((and (stringp line) (search "choice(" line))
				  #+debug(print line)
				  (unless disjunctions
				    (let* ((choice-term (read-from-string (prefix-to-infix line)))
					   (parents (caddr choice-term)))
				      (labels ((add-parents (p)
						 (cond ((atom p)
							(push (cdadr choice-term) (getf %disjunctions p)))
						       ((eq (car p) 'or)
							(dolist (p-or (cdr p))
							  (add-parents p-or)))
						       (t
							(error "Choice not recognized: ~s" choice-term)))))
					(add-parents parents)))))
				 ((and (stringp line) (search "define(" line))
				  #+debug(print line)
				  (unless disjunctions
				    (let ((define-term (read-from-string (prefix-to-infix line))))
				      (setf (getf equivalences (cadr define-term)) (caddr define-term)))))
				 ((or (consp line) (search "cf(" line))
				  ;; this code relies on the fact that the choice and define sections come before the cf
				  #+debug(print (list :disjunctions disjunctions :disjunction-choice disjunction-choice
						      :disjunction-tree-built-p disjunction-tree-built-p))
				  (unless disjunction-tree-built-p
				    (let ((node-id -1))
				      (labels ((build-disjunctions-tree (dis sum mult)
						 #+debug(print (list :dis dis :sum sum :mult mult))
						 (let* ((%con-list (getf %disjunctions dis))
							(multiplier mult)
							(con-list
							 (mapcar
							  (lambda (con)
							    (let* ((part-sum (if (eq con (car %con-list)) sum 0))
								   (dis-list
								    (collecting
								      (dolist (dis con)
									(let ((node (build-disjunctions-tree dis part-sum multiplier)))
									  (collect node)
									  (incf part-sum (car node))))))
										   
								   (first-dis-name (when (cdr %con-list) (cadr (car dis-list))))
								   (dis-set-name (when first-dis-name
										   (intern
										    (string-right-trim "1234567890"
												       (symbol-name first-dis-name))
										    :xle)))
								   (subtree-size (reduce #'+ dis-list :key #'car))
								   (con-list
								    (list* subtree-size	;; subtree-size
									   dis-set-name	;; name
									   (incf node-id) ;; id
									   part-sum ;; summand
									   dis-list)))
							      (dolist (dis dis-list)
								#+debug(print (list :dis-key (caddr dis) :val con-list))
								(setf (gethash (caddr dis) parent-table) con-list))
							      (setf multiplier (* multiplier subtree-size))
							      con-list))
							  %con-list))
							(dis-list
							 (list* (if con-list (reduce #'* con-list :key #'car :initial-value 1) 1) ;; subtree-size
								dis ;; name
								(incf node-id) ;; id
								(* sum mult) ;; summand
								con-list)))
						   (dolist (con con-list)
						     #+debug(print (list :con-key (caddr con) :val dis-list))
						     (setf (gethash (caddr con) parent-table) dis-list))
						   dis-list)))
					(unless disjunctions
					  (setf disjunctions (build-disjunctions-tree 1 0 1)
						disjunctions-tree disjunctions
						*disjunctions* disjunctions
						*equivalences* equivalences
						disjunction-solutions (build-disjunction-solutions disjunctions)
						*disjunction-solutions* disjunction-solutions
						solution-count (car disjunctions))
					  #+disabled(when ranking-p (rank-solutions graph)))))
				    (when disjunction-choice
				      (collecting
					(labels ((build-choice-set (branch con-p first-p)
						   (destructuring-bind (size name node-id summand . sub-nodes) branch
						     (declare (ignore size))
						     (cond (sub-nodes
							    (if con-p
								(let ((priority 0))
								  (collecting-into (summands choice-list)
								    (dolist (dis sub-nodes)
								      (multiple-value-bind (summand choices pt)
									  (build-choice-set dis nil (eq dis (car sub-nodes)))
									(when summand
									  (collect-into summands summand)
									  (collect-into choice-list choices))
									(setf priority (max priority pt))))
								    (values summands (list* :and name choice-list) priority)))
								(let ((priority 0)
								      (summands nil)
								      (choice-list nil))
								  (dolist (con sub-nodes)
								    (multiple-value-bind (summand choices pt)
									(build-choice-set con t (eq con (car sub-nodes)))
								      (when summand
									(when (> pt priority)
									  (setf priority pt
										summands summand
										choice-list choices)))))
								  (values summands (list name choice-list) priority))))
							   ((find node-id disjunction-choices :key #'cadr)
							    (values summand name (if (eq node-id disjunction-choice)
										     3 ;; force
										     2))) ;; old
							   ((eq node-id disjunction-choice)
							    (values summand name 3)) ;; force
							   (first-p
							    (values summand name 1)) ;; default
							   (t
							    nil)))))
					  (multiple-value-bind (summands choices)
					      (build-choice-set disjunctions t t)
					    (declare (ignore choices))
					    (labels ((add-up (summands)
						       (if (atom summands)
							   summands
							   (reduce #'+ (mapcar #'add-up summands)))))
					      ;;(assert (null ranking-p))
					      (setf solution-nr (add-up summands)))))))
				    (setf disjunction-tree-built-p t))
				  ;;(unless prolog-terms (collect-into %lines %line))
				  #+debug(write-line line)
				  (when parse-constraints-p
				    (let ((term nil)
					  (term-context nil)
					  (context-solutions nil))
				      (if (and packed-p prolog-terms)
					  (setf context-solutions (car line)
						term-context (cadr line)
						term (cddr line))
					  (let* ((packed-term (read-from-string (prefix-to-infix line))))
					    (setf term-context (cadr packed-term)
						  term-context (if (eq term-context '\1) 1 term-context)
						  context-solutions (context-solutions graph term-context)
						  term (caddr packed-term))
					    #+debug
					    (with-slots (disjunction-solutions equivalences) graph
					      (when (equal context-solutions #*)
						(print (list :context-solutions context-solutions :term-context term-context
							     :disjunction-solutions disjunction-solutions :equivalences equivalences))))
					    (collect-into %lines (list* context-solutions term-context term))))
				      (cond (;; f-structure
					     (find (car term) '(eq in_set scopes subsume))
					     (when (cond (solution-nr
							  #+debug(print (list :sol solution-nr :ranked-sol (ranked-solution solution-nr)))
							  (solution-context-p context-solutions
									      (ranked-solution solution-nr)))
							 ((not packed-f-structure-p)
							  (or (eq term-context 1)
							      (and solution-nr (solution-context-p context-solutions (ranked-solution solution-nr)))
							      (context-satisfied-p (resolve-context equivalences term-context) disjunction-choices)))
							 (t
							  (let ((ctx-s context-solutions))
							    (or (eq ctx-s 1)
								(null discriminants)
								(eq (s-context discriminants) 1)
								(context-s-intersection (s-context discriminants) ctx-s)))))
					       #+debug(if (stringp line) (write-line line) (print line))
					       #+debug(print (list* context-solutions term-context term))
					       (let ((var-id (extract-var-id term)))
						 (cond ((and (eq (car term) 'eq)
							     (consp (cadr term))
							     (eq (caadr term) 'var))
							(if (or solution-nr
								(and discriminants
								     (context-trivial-p context-solutions (s-context discriminants))))
							    (setf (getf var-list var-id) (copy-tree (caddr term)))
							    (let ((patched-term (cons (if packed-f-structure-p term-context 1)
										      (list 'eq
											    (list 'attr (cadr term) "=")
											    (copy-tree (caddr term))))))
							      #+debug(print (list :term (cons term-context term) :patched-term patched-term))
							      (loop until (< var-id (fill-pointer var-array))
								    do (vector-push-extend nil var-array))
							      (push patched-term (aref var-array var-id)))))
						       ((eq (car term) 'subsume) ;; only relevant for packed f-structures
							(when (consp (cadr term)) ;; ; check why (not consp()) can happen!
							  (destructuring-bind ((%var var . subsume-rest) rhs) (cdr term)
							    (declare (ignore %var rhs))
							    (unless subsume-rest ;; semform; check why this can happen!
							      (pushnew (cons (if (and packed-c-structure-p (not solution-nr))
										 (context-solutions graph term-context)
										 1)
									     term)
								       (getf subsume-list var)
								       :test #'equal)))))
						       (t
							(loop until (< var-id (fill-pointer var-array))
							      do (vector-push-extend nil var-array))
							(push (cons (if (and packed-f-structure-p (not solution-nr)) term-context 1)
								    (copy-tree term))
							      (aref var-array var-id)))))))
					    (t ;; c-structure
					     #+debug(print (list :term term))
					     (when (and (find (car term) '(subtree terminal surfaceform phi semform_edge semform_data))
							#+debug(print (list* context-solutions term-context term))
							(cond (solution-nr
							       #+debug(print (list :nr solution-nr :cs context-solutions))
							       (solution-context-p context-solutions (ranked-solution solution-nr)))
							      ((not packed-c-structure-p)
							       (context-satisfied-p (resolve-context equivalences term-context)
										    disjunction-choices))
							      (t
							       (let ((ctx-s context-solutions))
								 #+debug(if (stringp line) (write-line line) (print line))
								 #+debug(when discriminants (print (list ctx-s (s-context discriminants))))
												  
								 (or (eq ctx-s 1)
								     (null discriminants)
								     (eq (s-context discriminants) 1)
								     (context-s-intersection (s-context discriminants) ctx-s))))))
					       #+debug(if (stringp line) (write-line line) (print line))
					       (let ((id (cadr term)))
						 #+debug(print (list (root-cat graph) root-cat :cdr-term (cdr term)))
						 (when (stringp (caddr term))
						   (when (if grammar
							     (string= (caddr term) reparse-cat)
							     (find (caddr term) '("FRAGMENTSTOP" "FRAGMENTS") :test #'string=))
						     (setf fragments-p t))
						   (when (and (null root-id)
							      (or (string= (caddr term) "*TOP*")
								  (string= (caddr term) (or (root-cat graph) (and grammar root-cat) "ROOT"))
								  (if grammar
								      (string= (caddr term) reparse-cat)
							     (find (caddr term) '("FRAGMENTSTOP" "FRAGMENTS") :test #'string=))))
						     (setf root-id id))
						   #+debug(print (list :root-id root-id)))
						 (cond ((eq (car term) 'phi)
							(destructuring-bind (node (%var var)) (cdr term)
							  (declare (ignore %var))
							  (push (cons (if (and packed-c-structure-p (not solution-nr))
									  term-context 1) term) (getf phi-list var))
							  (push (cons (if (and packed-c-structure-p (not solution-nr))
									  (context-solutions graph term-context)
									  1)
								      var)
								(getf inverse-phi-list node))))
						       ((find (car term) '(semform_edge semform_data)) ;; semform_edge is for backward compatibility
							(pushnew (cons (if (and packed-c-structure-p (not solution-nr))
									(context-solutions graph term-context)
									1)
								    (caddr term))
								 (getf semform-edge-list (cadr term))
								 :test #'equal)
							#+debug(Print term))
						       (t
							(loop until (< id (fill-pointer c-var-array))
							      do (vector-push-extend nil c-var-array))
							(push (cons (if (and packed-c-structure-p (not solution-nr)) term-context 1) term)
							      (aref c-var-array id)))))))))))))))
		     (unless (and prolog-terms packed-p)
		       (setf prolog-terms %lines))))))
	    #+debug(print (list :semform-edge-list semform-edge-list))
					      
	    (when parse-constraints-p
	      (unless (string= %prolog "") (setf prolog %prolog))
	      #+debug(print (list :phi phi-list :inv-phi inverse-phi-list))
	      #+debug(print (list :var-list var-list))
	      #+debug(print (list :subsume-list subsume-list))
	      (when sort-attributes-p
		;; move PREDs and "=" to front
		(loop for terms across var-array for i from 0
		      do (setf (aref var-array i)
			       (move-pred-and-eq-to-front terms))))
	      ;; recursively replace lhs vars by rhs vars
	      (labels ((walk (form)
			 (unless (atom form)
			   (loop for tail on form
				 for first in form
				 do
				 (cond ((atom first)
					nil)
				       ((eq (car first) 'var)
					(let ((rep (get-rhs-replacement var-list (cadr first))))
					  (when rep
					    (walk rep) ;; fixme: do some memoizing here!
					    ;;(print (list :var (cadr first) :rep rep))
					    (setf (car tail) rep))))
				       (t
					(walk first)))))))
		(loop for terms across var-array
		      for id from 0
		      do
		      ;; fixme: should terms be moved to their new lhs var index (if new?) ;; John says no.
		      #+debug
		      (when (and terms (get-rhs-replacement var-list id))
			(print (list :id id :rep (get-rhs-replacement var-list id) :terms terms)))
		      (walk terms))
		(walk subsume-list))
	      (let ((top-rep (get-rhs-replacement var-list 0)))
		(setf top-f-node-var (if top-rep (cadr top-rep) 0)))
	      #+debug(print (list :rhs-rep (get-rhs-replacement var-list 0)))
	      #+debug(print (list :subsume-list subsume-list))
	      #+debug(print (list root-id phi-list var-array ))
	      #+debug(print (list :c-var-array c-var-array))
	      (values var-array c-var-array root-id prolog))))))))

(defun move-pred-and-eq-to-front (term-list)
  (stable-sort term-list
	       (lambda (term1 term2)
		 (or (and (eq (cadr term1) 'eq)
			  (eq (caaddr term1) 'attr)
			  (equal (caddr (caddr term1)) "PRED"))
		     (and (and (eq (cadr term1) 'eq)
			       (eq (caaddr term1) 'attr)
			       (equal (caddr (caddr term1)) "="))
			  (not (and (eq (cadr term2) 'eq)
				    (eq (caaddr term2) 'attr)
				    (equal (caddr (caddr term2)) "PRED"))))))))

(defun get-rhs-replacement (var-list var)
  (let ((repl (getf var-list var)))
    (if (and (consp repl)
	     (eq (car repl) 'var))
	(or (get-rhs-replacement var-list (cadr repl))
	    repl)
	repl)))

(defun find-scopes (var-array)
  (collecting
   (loop for terms across var-array for i from 0
       do (mapc (lambda (ctx.term)
		  (let ((term (cdr ctx.term)))
		    (destructuring-bind (left right) (cdr term)
		      (when (and (eq (car term) 'scopes))
			(collect (cons (cons (path var-array (cadr left) '("m::" "RELS_EL"))
					     (path var-array (cadr left)  '("m::" "H-CONS_EL")))
				       (cons (or (path var-array (cadr right) '("m::" "RELS_EL"))
						 (path var-array (cadr right) '("m::")))
					     (path var-array (cadr right)  '("m::" "H-CONS_EL")))))))))
		terms))))

(defun path (var-array id atts-or-projections)
  #+debug(print (list :path id atts-or-projections))
  (let ((aop (car atts-or-projections)))
    (cond ((null id)
	   nil)
	  ((null atts-or-projections)
	   id)
	  ((and (= (length aop) 3)
		(string= aop "::" :start1 1))
	   (path var-array (find-projection var-array id aop) (cdr atts-or-projections)))
	  (t
	   (path var-array (find-att-value var-array id aop) (cdr atts-or-projections))))))

(defun find-projection (var-array id type)
  #+debug(print (list :find-projection id type (length var-array)))
  (when (< id (length var-array))
    (mapc (lambda (context.term)
	    (let ((term (cdr context.term)))
	      (destructuring-bind (left right) (cdr term)
		(when (and (eq (car term) 'eq)
			   (eq (car left) 'proj)
			   (string= (caddr left) type))
		  (return-from find-projection (values (cadr right) right))))))
	  (aref var-array id))
    nil))

(defun find-att-value (var-array id type)
  #+debug(print (list :find-att-value id type (length var-array)))
  (when (< id (length var-array))
    (mapc (lambda (context.term)
	    (destructuring-bind (ctx op left right) context.term
	      (when (and (eq op 'eq)
			 (eq (car left) 'attr)
			 (string= (caddr left) type))
		(return-from find-att-value (if (consp right) (values (cadr right) right) right)))))
	  (aref var-array id))
    nil))

(defmethod find-contexted-att-value ((graph xle-graph) var-array id type context)
  (let ((values ()))
    (labels ((walk (id type-found-p context)
	       ;;(print (list :walk id))
	       (mapc (lambda (context.term)
		       #+debug(print (list :context.term context.term))
		       (destructuring-bind (ctx op left right) context.term
			 (let ((intersection (context-s-intersection (context-solutions graph ctx) context)))
			   (cond ((not (eq op 'eq))
				  nil)
				 ((null intersection)
				  nil)
				 ((and (eq (car left) 'attr)
				       (or (string= (caddr left) type)
					   (string= (caddr left) "=")))
				  ;;(print (list :attr-walk context.term))
				  (cond ((not (consp right))
					 (let ((val-cons (find right values :test #'equal :key #'cdr)))
					   (if val-cons
					       (setf (car val-cons) (context-s-union (car val-cons) intersection))
					       (push (cons intersection right) values)))
					 #+old
					 (collect (cons intersection right)))
					((eq (car right) 'var)
					 (walk (cadr right) (or type-found-p (string= (caddr left) type)) intersection))
					(t
					 (let ((val-cons (find (cadr right) values :test #'equal :key #'cdr)))
					   (if val-cons
					       (setf (car val-cons) (context-s-union (car val-cons) intersection))
					       (push (cons intersection (cadr right)) values)))
					 #+old
					 (collect (cons intersection (values (cadr right) right))))))))))
		     (aref var-array id))))
      (walk id nil (context-solutions graph context)))
    values))

;; dedicated parser object; never set active-p to NIL!
(defparameter *parser* nil)

(defmethod parse ((sentence string) &optional trace &key root-cat (parser *parser*) (grammar *grammar*)
		  (cg-preparse-on-zero-solutions-p nil)
		  ranking) ;; is ranking obsolete?
  (declare (ignore trace))
  (unless (and parser (parser-valid-p parser))
    ;; :task changed from :tsdb to :www as we work with solely one parser fttb
    (if (eq parser *parser*)
	(setf parser (get-parser grammar :force-p t :task :www)
	      *parser* parser)
	(setf parser (get-parser grammar :force-p t :task :www))))
  #+debug(print (list :parser parser :grammar (grammar-path grammar)))
  (let ((graph (make-instance (graph-class grammar)
			      :sentence sentence
			      :parser parser
			      :root-cat root-cat
			      :ranking-p ranking
			      :set-ot-p nil
			      :cg-preparse-p nil)))
    (when (and cg-preparse-on-zero-solutions-p (zerop (restricted-solutions-count graph)))
      (setf graph (make-instance (graph-class grammar)
				 :sentence sentence
				 :parser parser
				 :root-cat root-cat
				 :ranking-p ranking
				 :set-ot-p nil
				 :cg-preparse-p t)))
    #+debug(print (list :graph graph))
    graph))

#+test
(let ((graph (parse "Det regnet." nil)))
  (get-next-solution graph)
  (print (ranking graph)))

(defmethod parse ((sentence-lattice integer) &optional trace &key root-cat (parser *parser*) (grammar *grammar*))
  (declare (ignore trace))
  (unless (and parser (parser-valid-p parser))
    ;; :task changed from :tsdb to :www as we work with solely one parser fttb
    (if (eq parser *parser*)
	(setf parser (get-parser grammar :force-p t :task :www)
	      *parser* parser)
	(setf parser (get-parser grammar :force-p t :task :www))))
  (make-instance (graph-class grammar)
		 :lattice sentence-lattice
		 :parser *parser*
		 :root-cat root-cat
		 :ranking-p t
		 :cg-preparse-p t))

(defmethod graph-has-mrs-p ((graph xle-graph)) nil)
(defmethod graph-has-mrs-p ((graph xle-mrs-graph)) t)

(defmethod get-solution ((graph xle-graph) &key (max-solutions 100) valid-only-p prefetch-p
			 build-c-structure-p build-f-structure-p previous-p)
  (with-slots (solution c-structure-list current-c-structure
			var-array-list current-var-array parser) graph
    (let ((mrs-p (graph-has-mrs-p graph)))
      (labels ((get-next ()
		 (unless (and max-solutions (= -1 (decf max-solutions)))
		   (get-next-solution graph :reclaim-memory-p prefetch-p :packed-p nil)
		   #+debug(print (list :graph graph :solution solution))
		   (unless (eql solution 0)
		     (multiple-value-bind (var-array c-str-array root-id)
			 (parse-prolog graph :solution nil :build-c-structure-p build-c-structure-p :packed-p nil)
		       (unless (zerop (fill-pointer var-array))
			 (multiple-value-bind (mrs valid-p)
			     (and mrs-p (build-mrs graph var-array))
			   #+debug(mrs::output-mrs1 mrs 'mrs::simple *standard-output*)
			   #+debug(print (list :psoa (mrs::psoa-p mrs)))
			   #+debug(print (list :frag (mrs::fragmentp mrs)))
			   (let ((c-structure (when (and build-c-structure-p root-id)
						(build-c-structure graph c-str-array root-id :packed-p nil))))
			     (cond ((or valid-p (not valid-only-p))
				    (values var-array c-structure mrs))
				   (t
				    (get-next)))))))))))
	(cond ((null prefetch-p)
	       (when previous-p (error "previous-p = T is only allowed when prefetch-p = T"))
	       (get-next))
	      (t
	       (when (null var-array-list)
		 (loop with mrs and c-str and var-array
		       do (multiple-value-setq (var-array c-str mrs) (get-next))
		       while var-array
		       collect mrs into %mrs-list
		       collect c-str into %c-structure-list
		       collect var-array into %var-array-list
		       finally (progn (setf c-structure-list %c-structure-list
					    var-array-list %var-array-list)
				      (when mrs-p (setf (mrs-list graph) %mrs-list))
				      (when parser
					(setf (parser-active-p parser) nil
					      parser nil))))
		 (setf solution 0))
	       (if previous-p
		   (let ((pos (position (current-c-structure graph) (c-structure-list graph))))
		     (values (when build-f-structure-p
			       (setf current-var-array
				     (if current-var-array
					 (if (> pos 0)
					     (nth (1- pos) var-array-list)
					     (car (last var-array-list)))
					 (car var-array-list))))
			     (when build-c-structure-p
			       (setf current-c-structure
				     (if current-c-structure
					 (if (> pos 0)
					     (nth (1- pos) c-structure-list)
					     (car (last c-structure-list)))
					 (car c-structure-list))))
			     (when mrs-p
			       (setf (current-mrs graph)
				     (if (current-mrs graph)
					 (if (> pos 0)
					     (nth (1- pos) (mrs-list graph))
					     (car (last (mrs-list graph))))
					 (car (mrs-list graph)))))
			     (length (var-array-list graph))
			     (position (current-var-array graph) (var-array-list graph))))
		   (values (when build-f-structure-p
			     (setf current-var-array
				   (if current-var-array
				       (or (cadr (member current-var-array var-array-list)) (car var-array-list))
				       (car var-array-list))))
			   (when build-c-structure-p
			     (setf current-c-structure
				   (if current-c-structure
				       (or (cadr (member current-c-structure c-structure-list)) (car c-structure-list))
				       (car c-structure-list))))
			   (when mrs-p
			     (setf (current-mrs graph)
				   (if (current-mrs graph)
				       (or (cadr (member (current-mrs graph) (mrs-list graph))) (car (mrs-list graph)))
				       (car (mrs-list graph)))))
			   (length (var-array-list graph))
			   (position (current-var-array graph) (var-array-list graph))))))))))

(defmethod validate-discriminants ((graph xle-graph) context)
  (with-slots (discriminants equivalences disjunctions) graph
    (when discriminants
      (let ((*package* (find-package :xle))
	    (*print-level* nil))
	(setf (context discriminants)
	      (cons 'or
		    (collecting
		      (dolist (con (cdr (context-intersection context (context discriminants))))
			(when (choice-valid-p disjunctions (cdr con))
			  (collect con)))))))
      (with-slots (discriminants-array constituent-discriminants) discriminants
	(dolist (disc constituent-discriminants)
	  (dolist (rule-disc (rules disc))
	    (let ((rule-disc (aref discriminants-array rule-disc)))
	      (setf (discriminant-valid-p rule-disc)
		    (if (and (loop for con in (cdr (context-intersection (context discriminants) (context rule-disc)))
				   thereis (choice-valid-p disjunctions (cdr con)))
			     (loop for con in (cdr (context-intersection (context discriminants) (context-negation rule-disc)))
				   thereis (choice-valid-p disjunctions (cdr con))))
			t nil))))
	  (setf (discriminant-valid-p disc)
		(if (loop for disc in (rules disc)
			  thereis (discriminant-valid-p (aref discriminants-array disc)))
		    t nil)))))))

(defun context-s-negation (context)
  (cond ((null context)
	 1)
	((eq context 1)
	 nil)
	(t
	 (map #+sbcl '(vector bit) #-sbcl'(simple-array bit) (lambda (bit) (if (= bit 1) 0 1)) context))))

;; obsolete?
(defmethod validate-s-discriminants ((graph xle-graph) s-context &key recalculate-context-p)
  (with-slots (discriminants) graph
    (when discriminants
      (validate-s-discriminants discriminants s-context :recalculate-context-p recalculate-context-p))))

#+copy ;; from treebank.lisp
(defmethod apply-discriminant-choice ((s treebank-sentence) discriminant-choice
				      &key complementp &allow-other-keys)
  (with-slots (treebank sentence xle-graph prolog-terms) s
    (with-slots (grammar) treebank
      (let ((*grammar* grammar))
	(with-slots (discriminants) xle-graph
	  (let* ((undo-p (find discriminant-choice (chosen-discriminants discriminants)))
		 (disc (aref (discriminants-array discriminants) discriminant-choice))
		 (ctx (s-context disc))
		 (ctx (if complementp (context-s-negation ctx) ctx)))
	    (assert (not (and undo-p complementp)))
	    (if undo-p
		(setf (chosen-discriminants discriminants)
		      (delete discriminant-choice (chosen-discriminants discriminants)))
		(push discriminant-choice (chosen-discriminants discriminants))) 
	    (if (discriminant-chosen-p disc)
		(setf (discriminant-chosen-p disc) nil
		      (discriminant-complement-chosen-p disc) nil)
		(setf (discriminant-chosen-p disc) t
		      (discriminant-complement-chosen-p disc) complementp))
	    
	    (validate-s-discriminants xle-graph (if undo-p 1 ctx) :recalculate-context-p undo-p)
	    (multiple-value-bind (var-array c-str-array root-id)
		(parse-prolog xle-graph
			      :solution nil
			      :build-c-structure-p t
			      :packed-p t
			      :packed-c-structure-p t
			      :packed-f-structure-p t
			      :sort-attributes-p t)
	      (let ((cs (build-c-structure xle-graph c-str-array root-id :packed-p t))
		    (fs (build-f-structure xle-graph :var-array var-array)))
		(setf (var-array-list xle-graph) (list var-array)
		      (c-structure-list xle-graph) (list cs))))))))))

(defmethod get-packed-solution ((graph xle-graph) &key valid-only-p 
				build-c-structure-p build-f-structure-p disjunction-choice
				discriminant-choice complementp previous-p next-p get-mrs-p ranking-p)
  (with-slots (solution-nr solution-count c-structure-list current-c-structure
	       var-array-list current-var-array parser disjunctions discriminants ranking) graph
    #+debug(print (list :get-packed-solution graph :solution-nr solution-nr
			:ranking ranking :disc discriminants
			:disc-choice discriminant-choice :disj-choice disjunction-choice
			valid-only-p build-c-structure-p build-f-structure-p :get-mrs-p get-mrs-p))
    (if (and discriminant-choice discriminants)
	(let* ((undo-p (find discriminant-choice (chosen-discriminants discriminants)))
	       (disc (aref (discriminants-array discriminants) discriminant-choice))
	       (ctx (s-context disc))
	       (ctx (if complementp (context-s-negation ctx) ctx)))
	  ;;(setf (discriminant-chosen-p disc) t)
	  (assert (not (and undo-p complementp)))
	  (if undo-p
	      (setf (chosen-discriminants discriminants)
		    (delete discriminant-choice (chosen-discriminants discriminants)))
	      (push discriminant-choice (chosen-discriminants discriminants))) 
	  (if (discriminant-chosen-p disc)
	      (setf (discriminant-chosen-p disc) nil
		    (discriminant-complement-chosen-p disc) nil)
	      (setf (discriminant-chosen-p disc) t
		    (discriminant-complement-chosen-p disc) complementp))
	  #+debug(print (list :validate :disc disc :disc-ctx (context disc) (s-context disc) :ctx ctx :undo undo-p :comp complementp))
	  (validate-s-discriminants discriminants (if undo-p 1 ctx) :recalculate-context-p undo-p))
	(setf discriminants nil))
    (let ((mrs-p (graph-has-mrs-p graph)))
      #+debug(print (list :mrs mrs-p))
      (cond ((and get-mrs-p (null solution-nr))
	     (setf solution-nr 0))
	    (discriminant-choice
	     nil)
	    (previous-p
	     (when (or (null solution-nr) (zerop solution-nr))
	       (setf solution-nr solution-count))
	     (decf solution-nr))
	    (next-p
	     (when (or (null solution-nr) (= solution-nr (1- solution-count)))
	       (setf solution-nr -1))
	     (incf solution-nr))
	    (t
	     nil)
	    #+ignore
	    (solution-nr
	     (incf solution-nr)
	     (when (= solution-nr solution-count)
	       (setf solution-nr 0))))
      (labels ((get-next ()
		 (multiple-value-bind (var-array c-str-array root-id)
		     (parse-prolog graph
				   :solution nil
				   :build-c-structure-p build-c-structure-p
				   :disjunction-choice disjunction-choice
				   ;;:context (or (and discriminants (context discriminants)) 1)
				   :packed-p t
				   :packed-c-structure-p t
				   :packed-f-structure-p t
				   :sort-attributes-p t
				   :ranking-p ranking-p)
		   (unless (zerop (fill-pointer var-array))
		     (multiple-value-bind (mrs valid-p)
			 #+allegro(and get-mrs-p mrs-p (build-mrs graph var-array))
			 #+sbcl nil ;; prelim
		       (let ((c-structure (when (and build-c-structure-p root-id)
					    (build-c-structure graph c-str-array root-id :packed-p t))))
			 #+debug(print (list :c-structure c-structure))
			 #+debug(describe (discriminants graph))
			 (cond ((or valid-p (not valid-only-p))
				(values var-array c-structure mrs disjunctions))
			       (t
				(get-next)))))))))
	(multiple-value-bind (var-array c-str mrs) (get-next)
	  (setf c-structure-list (list c-str)
		var-array-list (list var-array))
	  (when mrs-p
	    (setf (mrs-list graph) (list mrs)))
	  (when parser
	    (setf (parser-active-p parser) nil
		  parser nil)))
	(values (when build-f-structure-p
		  (setf current-var-array
			(if current-var-array
			    (or (cadr (member current-var-array var-array-list)) (car var-array-list))
			    (car var-array-list))))
		(when build-c-structure-p
		  (setf current-c-structure
			(if current-c-structure
			    (or (cadr (member current-c-structure c-structure-list)) (car c-structure-list))
			    (car c-structure-list))))
		(when mrs-p
		  (setf (current-mrs graph)
			(if (current-mrs graph)
			    (or (cadr (member (current-mrs graph) (mrs-list graph))) (car (mrs-list graph)))
			    (car (mrs-list graph)))))
		solution-count
		solution-nr)))))

(defmethod get-current-solution ((graph xle-graph))
  (with-slots (current-c-structure var-array-list current-var-array) graph
    (values current-var-array
	    current-c-structure
	    nil
	    (length var-array-list)
	    (position current-var-array var-array-list))))

(defmethod get-current-solution ((graph xle-mrs-graph))
  (with-slots (mrs-list current-mrs current-c-structure
	       var-array-list current-var-array) graph
    (values current-var-array
	    current-c-structure
	    current-mrs
	    (length mrs-list)
	    (position current-mrs mrs-list))))

(defmethod get-current-packed-solution ((graph xle-graph))
  (with-slots (solution-count solution-nr current-c-structure current-var-array) graph
    (values current-var-array
	    current-c-structure
	    nil
	    solution-count solution-nr)))

(defmethod get-current-packed-solution ((graph xle-mrs-graph))
  (with-slots (solution-count solution-nr current-mrs current-c-structure
			       current-var-array) graph
    (values current-var-array
	    current-c-structure
	    current-mrs
	    solution-count solution-nr)))

#+test
(update-and-reload-grammar :force-p nil :reload-only-p nil)

;; Copying the entire English grammar:
;; "rsync --rsync-path=/usr/local/bin/rsync --archive --rsh=ssh ling.uib.no:/space/opt/xledir/pargram/english/ english"


;; *xle-graph*

#+test
(with-slots (graph-address) *xle-graph*
  (with-cstr (mode "w")
    (with-open-file (stream "projects:treebank;parse-selection;test1.fs"
			    :direction :output :if-exists :supersede)
      (let ((cstream (fdopen (excl::stream-output-handle stream) mode)))
	(print-prolog-graph cstream graph-address "")
	(fflush cstream)))))

(defun reduce-context-tree (ctx disjunctions &optional equivalences)
  (cond ((consp ctx)
	 (let ((reduced-list
		(collecting
		  (dolist (sub-ctx (cdr ctx))
		    (let ((re (reduce-context-tree sub-ctx disjunctions equivalences)))
		      (when re (collect re)))))))
	   (if (cdr reduced-list)
	       (cons 'or reduced-list)
	       (car reduced-list))))
	((eq ctx 1)
	 ctx)
	((find ctx disjunctions)
	 ctx)
	((getf equivalences ctx)
	 ctx)
	(t
	 (setf reduced-p t)
	 nil)))

(defmethod reduced-context-disjunctions ((graph xle-graph) context)
  (with-slots (disjunctions-tree disjunction-solutions equivalences) graph
    #+debug(print (list disjunctions-tree disjunction-solutions equivalences))
    (let* ((matching-disjunctions
	    (loop for (dis ctx) on disjunction-solutions by #'cddr
		  when (context-s-intersection context ctx)
		  collect dis))
	   (reduced-equivalences
	    (loop for (equi or-list) on equivalences by #'cddr
		  collect equi
		  collect (reduce-context-tree or-list matching-disjunctions))))
      (values matching-disjunctions reduced-equivalences))))

(defun prolog-format-or-tree (or-tree)
  (with-output-to-string (stream)
    (labels ((walk (tree)
	       (cond ((atom tree)
		      (write tree :stream stream))
		     ((eq (car tree) 'or)
		      (write-string "or(" stream)
		      (loop for (branch . rest) on (cdr tree)
			    do (walk branch)
			    when rest do (write-char #\, stream))
		      (write-char #\) stream)))))
      (walk or-tree))))

(defmethod reduced-context-prolog ((graph xle-graph) &key prolog (out-stream t) context)
  (multiple-value-bind (matching-disjunctions reduced-equivalences)
      (reduced-context-disjunctions graph context)
    #-debug(print (list :context context :matching-disjunctions matching-disjunctions))
    (let ((define-done-p nil)
	  (newline-pending-p nil)
	  (*package* (find-package :xle))
	  (*readtable* *prolog-form-readtable*))
      (do-parse-output-lines (line nil :prolog prolog)
	(let* ((paren-start (position #\( line))
	       (type (when paren-start
		       (intern (string-upcase (string-trim '(#\Tab) (subseq line 0 paren-start)))
			       :keyword))))
	  (case type
	    (:choice
	     (let* ((*package* (find-package :xle))
		    (*readtable* *prolog-form-readtable*)
		    (choice-term (read-from-string (prefix-to-infix (copy-seq line)))))
	       (destructuring-bind (lhs rhs) (cdr choice-term)
		 ;;(print (list :lhs lhs :rhs rhs))
		 (let ((reduced-lhs (delete-if (lambda (dis) (not (find dis matching-disjunctions)))
					       (cdr lhs)))
		       (reduced-rhs (if (consp rhs)
					(reduce-context-tree rhs matching-disjunctions)
					rhs)))
		   (when reduced-lhs
		     (when newline-pending-p (write-line "," out-stream))
		     (format out-stream "~cchoice([~{~a~^,~}], ~a)" #\Tab reduced-lhs
			     (prolog-format-or-tree reduced-rhs))
		     (setf newline-pending-p t))
		   #+ignore(print (list choice-term reduced-lhs reduced-rhs)))
		 )))
	    (:define
		(unless define-done-p
		  (loop for (equi or-tree) on reduced-equivalences by #'cddr
			when or-tree
			do
			(when newline-pending-p (write-line "," out-stream))
			(format out-stream "~cdefine(~a, ~a)" #\tab equi (prolog-format-or-tree or-tree))
			(setf newline-pending-p t))
		  (setf define-done-p t)))
	    (:cf
	     (let* ((comma-pos
		     (block pos
		       (loop for i from (1+ paren-start) with level = 0
			     do (case (char line i)
				  (#\( (incf level))
				  (#\) (decf level))
				  (#\, (when (zerop level)
					 (return-from pos i)))))))
		    (context (cadr (read-from-string (prefix-to-infix (copy-seq line)))))
		    (reduced-context
		     (reduce-context-tree context matching-disjunctions reduced-equivalences)))
	       #+debug(print (list :context context :reduced-context reduced-context))
	       (when reduced-context
		 (when newline-pending-p (write-line "," out-stream))
		 (format out-stream "~ccf(~a~a" #\Tab (prolog-format-or-tree reduced-context)
			 (if (char= (char line (1- (length line))) #\,)
			     (subseq line comma-pos (1- (length line)))
			     (subseq line comma-pos)))
		 (setf newline-pending-p t))))
	    (otherwise
	     (when newline-pending-p
	       (if (char= (char (string-trim '(#\space #\tab) line) 0) #\])
		   (terpri out-stream)
		    (write-line "," out-stream)))
	     (setf newline-pending-p nil)
	     (write-line line out-stream))))))))

#+test
(let* ((in-file "projects:treebank;parse-selection;test.fs")
       (prolog (with-output-to-string (stream)
		 (with-file-lines (line in-file)
		   (write-line line stream))))
       (*grammar* (find-grammar-by-filename "bokmal-mrs-fst.lfg"))
       (xle-graph (make-instance (graph-class *grammar*) :fs-prolog-file in-file :force-p t)))
  (parse-prolog xle-graph
		:solution nil
		;;:build-c-structure-p build-c-structure-p
		:packed-p t
		:packed-c-structure-p t
		:packed-f-structure-p t)
  (with-open-file (out-stream "projects:treebank;parse-selection;test-out.fs"
			      :direction :output :if-exists :supersede)
    (reduced-context-prolog xle-graph :prolog prolog :context #*00100000000
			    :out-stream out-stream)))

#+test
(print (nth-value 1 (reduced-context-disjunctions *xle-graph* #*11111111000)))

(defmethod semform-string-positions ((graph xle-graph) semform-id &key left-only-p (ctx-solutions 1))
  (with-slots (semform-edge-list c-var-array) graph
    (if semform-edge-list
	(let* ((left.right (cons nil nil))
	       (ctx.edge (find-if (lambda (ctx.edge) ;; is it guaranteed that only one satisfies the cond?
				    (context-s-intersection ctx-solutions (car ctx.edge)))
				  (getf semform-edge-list semform-id))) 
	       (subtree (cond ((null ctx.edge)
			       nil)
			      (ctx-solutions
			       (cdr (find-if (lambda (c.s)
					       (context-subsumed-p (context-solutions graph (car c.s))
								   ctx-solutions))
					     (aref c-var-array (cdr ctx.edge)))))
			      (t
			       (cdar (aref c-var-array (cdr ctx.edge))))))) ;; to do: integrate context
	  (when subtree
	    (labels ((find-leaves (term direction)
		       (case (car term)
			 (subtree
			  (destructuring-bind (id label left right) (cdr term)
			    (let ((child-id (if (or (eq direction :right) (eq left '-))
						right left)))
			      (find-leaves (cdar (aref c-var-array child-id)) direction))))
			 (terminal
			  (destructuring-bind (id label (bracket surface-id)) (cdr term)
			    (declare (ignore bracket))
			    (find-leaves (cdar (aref c-var-array surface-id)) direction)
			    ))
			 (surfaceform
			  (destructuring-bind (id label start end) (cdr term)
			    (ecase direction (:left start) (:right end)))))))
	      (let* ((left (find-leaves subtree :left))
		     (right (unless left-only-p (find-leaves subtree :right))))
		(if left-only-p
		    left
		    (list :characters left right))))))
	(warn "semform-edge-list was empty"))))

:eof