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

;; (do-parse-output-lines (line solution) @body) maps over the lines in the prolog file
;; of the given solution and executes body for each line

#-graph
(defclass node ()
  ((value :initform nil :initarg :value :accessor node-value)
   (label :initform nil :initarg :label :accessor node-label)
   (parents :initform () :initarg :parents :accessor node-parents)
   (children :initform () :initarg :children :accessor node-children)))

;; If the graph package is used (#+graph), a c-structure node is represented by a node object with main
;; slots VALUE, LABEL and CHILDREN.
;;#+graph
(defclass c-node (#+graph display-node #-graph node)
  ((type :initform :node :initarg :type :accessor node-type)
   (xle-graph :initform nil :initarg :xle-graph :reader xle-graph)
   (context :initform 1 :initarg :context :accessor node-context)
   (intersected-context :initform nil :initarg :intersected-context :accessor node-intersected-context)
   (surface-string :initform nil :initarg :surface-string :accessor node-surface-string)
   (span :initform (cons 0 0) :initarg :span :accessor span) ;; (start . end) of the substring this node is spanning
   (projection-fs-ids :initform nil :accessor projection-fs-ids)
   (inactive-children :initform () :accessor node-inactive-children)
   (triangled-p :initform nil :accessor node-triangled-p)))

#+graph
(defvar *display-node-id* nil)

#+graph
(defmethod initialize-instance :after ((node c-node) &key &allow-other-keys)
  (when *display-node-id*
    (setf (display-node-id node) (incf *display-node-id*))))

;;#+graph
(defclass c-surface-node (c-node)
  ((morphology :initform nil :initarg :morphology :accessor node-morphology)))

(defclass discriminants ()
  ((discriminants-context :initform 1 :initarg :context :accessor context)
   (discriminants-s-context :initform 1 :initarg :s-context :accessor s-context) ;; to replace context
   (discriminants-array :initform (make-array 0 :adjustable t :fill-pointer 0)
			:initarg :array
			:reader discriminants-array)
   (chosen :initform () :accessor chosen-discriminants)
   (constituent-discriminants :initform () :accessor constituent-discriminants)
   (rule-discriminants :initform () :accessor rule-discriminants)
   (morph-discriminants :initform () :accessor morph-discriminants)
   (f-structure-discriminants :initform () :accessor f-structure-discriminants)
   (lex-discriminants :initform () :accessor lex-discriminants)
   (secondary-discriminants :initform () :accessor secondary-discriminants)
   (grammar :initform nil :initarg :grammar :reader grammar)))

;; needed b/o &allow-other-keys and key :sentence in method for sql-discriminants
(defmethod initialize-instance :after ((discriminants discriminants) &key &allow-other-keys)
  nil)

(defclass discriminant ()
  ((id :initform nil :initarg :id :reader discriminant-id)
   (discriminants :initarg :discriminants :reader discriminants)
   (context :initform nil :initarg :context :accessor context)
   (s-context :initform nil :initarg :s-context :accessor s-context)
   (context-negation :initform nil :initarg :context-negation :accessor context-negation)
   (valid-p :initform t :initarg :valid-p :accessor discriminant-valid-p)
   (redundant-p :initform nil :initarg :redundant-p :accessor discriminant-redundant-p)
   (chosen-p :initform nil :initarg :chosen-p :accessor discriminant-chosen-p)
   (complement-chosen-p :initform nil :initarg :complement-chosen-p :accessor discriminant-complement-chosen-p)
   (anchor :initform -1 :initarg :anchor :accessor discriminant-anchor :type integer)))

(defmethod initialize-instance :after ((disc discriminant) &key (extend-p nil) &allow-other-keys)
  (when extend-p ;; means not recreated from database; rename!
    (with-slots (id discriminants) disc
      (setf id (fill-pointer (discriminants-array discriminants)))
      (vector-push-extend disc (discriminants-array discriminants)))))

(defclass f-structure-discriminant (discriminant)
  ((path-segment :initform nil :initarg :path-segment :accessor path-segment)
   (right-anchor :initform nil :initarg :right-anchor :accessor discriminant-right-anchor :type integer)))

(defmethod initialize-instance :after ((disc f-structure-discriminant) &key (extend-p nil) &allow-other-keys)
  (when extend-p
    #+debug(print (list :push disc))
    (with-slots (discriminants) disc
      (push disc (f-structure-discriminants discriminants)))))

(defmethod print-object ((disc f-structure-discriminant) stream)
  (with-slots (path-segment s-context anchor) disc
    (print-unreadable-object (disc stream :type t :identity t)
      (format stream "~d:[~a] ~s" anchor (if (eq s-context 1) "+" (count 1 s-context)) path-segment))))

(defmethod discriminant-string ((disc f-structure-discriminant))
  (path-segment disc))

(defclass constituent-discriminant (discriminant)
  ((constituents :initform () :initarg :constituents :accessor constituents)
   (rules :initform () :initarg :rules :accessor rules)))

(defmethod initialize-instance :after ((disc constituent-discriminant) &key (extend-p nil) &allow-other-keys)
  (when extend-p ;; means not recreated from database; rename!
    (with-slots (discriminants) disc
      (push disc (constituent-discriminants discriminants)))))

(defmethod print-object ((disc constituent-discriminant) stream)
  (with-slots (constituents s-context anchor) disc
    (print-unreadable-object (disc stream :type t :identity t)
      (format stream "~d:[~a] ~s" anchor (if (eq s-context 1) "+" (count 1 s-context)) constituents))))

(defmethod discriminant-string ((disc constituent-discriminant))
  (constituents disc))

(defclass rule-discriminant (discriminant)
  ((rule :initform nil :initarg :rule :accessor rule)
   (constituents :initform nil :initarg :constituents :accessor constituent-discriminant)))

(defmethod initialize-instance :after ((disc rule-discriminant) &key (extend-p nil) &allow-other-keys)
  (when extend-p ;; means not recreated from database; rename!
    (with-slots (discriminants) disc
      (push disc (rule-discriminants discriminants)))))

(defmethod print-object ((disc rule-discriminant) stream)
  (with-slots (rule s-context anchor) disc
    (print-unreadable-object (disc stream :type t :identity t)
      (format stream "~d:[~a] ~s" anchor (if (eq s-context 1) "+" (count 1 s-context)) rule))))

(defmethod discriminant-string ((disc rule-discriminant))
  (rule disc))

(defclass lex-discriminant (discriminant)
  ((rule :initform nil :initarg :rule :accessor rule)))

(defmethod initialize-instance :after ((disc lex-discriminant) &key (extend-p nil) &allow-other-keys)
  (when extend-p ;; means not recreated from database; rename!
    (with-slots (discriminants) disc
      (push disc (lex-discriminants discriminants)))))

(defmethod print-object ((disc lex-discriminant) stream)
  (with-slots (rule anchor) disc
    (print-unreadable-object (disc stream :type t :identity t)
      (format stream "~d:~s" anchor rule))))

(defmethod discriminant-string ((disc lex-discriminant))
  (rule disc))

(defclass morph-discriminant (discriminant)
  ((morph-features :initform nil :initarg :morph-features :accessor morph-features)
   (var :initform nil :initarg :surfaceform-var :reader surfaceform-var)))

(defmethod initialize-instance :after ((disc morph-discriminant) &key (extend-p nil) &allow-other-keys)
  (when extend-p ;; means not recreated from database; rename!
    (with-slots (discriminants) disc
      #+debug(print (list :initializing disc))
      (push disc (morph-discriminants discriminants)))))

(defmethod discriminant-string ((disc morph-discriminant))
  (morph-features disc))

(defclass secondary-discriminant (discriminant)
  ((path-segment :initform nil :initarg :path-segment :accessor path-segment)
   (right-anchor :initform nil :initarg :right-anchor :accessor discriminant-right-anchor :type integer)))

(defmethod initialize-instance :after ((disc secondary-discriminant) &key (extend-p nil) &allow-other-keys)
  (when extend-p
    #+debug(print (list :push disc))
    (with-slots (discriminants) disc
      (push disc (secondary-discriminants discriminants)))))

(defmethod print-object ((disc secondary-discriminant) stream)
  (with-slots (path-segment s-context anchor) disc
    (print-unreadable-object (disc stream :type t :identity t)
      (format stream "~d:[~a] ~s" anchor (if (eq s-context 1) "+" (count 1 s-context)) path-segment))))

(defmethod discriminant-string ((disc secondary-discriminant))
  (path-segment disc))

;;#+graph
(defmethod node-morphology ((node c-node)) nil)

(defun partition-morphology (morph-list sol-count)
  #+debug(print (list :sol-count sol-count :morph-list morph-list))
  (let ((morph-list (nreverse morph-list)))
    (unless (null morph-list)
      (let ( ;;(sol-count (length (caar morph-list)))
	    (morph-count (length morph-list))
	    (partition (dat::make-string-tree)))
	(dotimes (i sol-count)
	  ;; could be more efficient
	  (let* ((morph-str (apply #'concatenate 'string
				   (sort (collecting
					   (dolist (morph-cons morph-list)
					     (when (or (eq (car morph-cons) 1)
						       (= (bit (car morph-cons) i) 1))
					       (collect (cadr morph-cons)))))
					 ;;#'string>
					 #'<
					 :key #'caddr
					 )))
		 (bv (dat::string-tree-get partition morph-str)))
	    (unless bv
	      (setf bv (make-array sol-count :element-type 'bit :initial-element 0)
		    (dat::string-tree-get partition morph-str) bv))
	    (setf (bit bv i) 1)))
	#+debug
	(dat::do-string-tree (string bv partition)
	  (print (cons bv string)))
	partition))))

(defun partition-morphology-tree (morph-tree sol-count)
  #+debug(print (list :sol-count sol-count :morph-tree morph-tree))
  (unless (null morph-tree)
    (let ((partition (dat::make-string-tree)))
      (dotimes (i sol-count)
	;; could be more efficient
	(let ((morph-str ""))
	  (labels ((walk (tree)
		     (when tree
		       (destructuring-bind (ctx . rest) tree
			 (when (or (eql ctx 1) (= (bit ctx i) 1))
			   (cond ((stringp (car rest))
				  (setf morph-str (concatenate 'string morph-str (car rest))))
				 ((null (car rest))
				  (mapc #'walk (cdr rest)))
				 (t
				  (mapc #'walk rest))))))))
	    (mapc #'walk morph-tree)
	    (let ((bv (dat::string-tree-get partition morph-str)))
	      (unless bv
		(setf bv (make-array sol-count :element-type 'bit :initial-element 0)
		      (dat::string-tree-get partition morph-str) bv))
	      (setf (bit bv i) 1)))))
      #+debug
      (dat::do-string-tree (string bv partition)
	(print (cons bv string)))
      partition)))

;; more structure sharing if T
(defparameter *tight-p* nil)

(defparameter *unramified-rule-discriminants-p* nil)
(defparameter *lex-rule-discriminants-p* t) ;; keep T, NIL is still buggy (constituent discriminant should always be redundant!)
(defparameter *suppress-complex-categories-p* nil)

#+debug
(defparameter *graph* nil)

;; if listp is true, build list representation of c-structure, else NODE-object representation
(defmethod build-c-structure ((graph xle-graph) var-array root-id
			      &key (ignore-base-p t) ;; no sublexical nodes?
			      listp (context 1) packed-p
			      (calculate-discriminants-p t) include-trivial-discriminants-p psentence)
  #+debug(setf *graph* graph)
  #+debug(setf context #*0100)
  #+debug(print (list :context context :build-c-structure :root-id root-id :var-array var-array :calculate-discriminants-p calculate-discriminants-p))
  (when (and root-id (not (zerop (fill-pointer var-array))))
    (with-slots (equivalences disjunctions disjunction-choices discriminants solution-count) graph
      (setf disjunction-choices 1 disjunctions 1) ;; fixme!
      #+debug(print (list :disjunctions disjunctions :disjunction-choices disjunction-choices))
      (let ((node-table (make-hash-table :test #'equal))
	    #+graph(*display-node-id* 0)
	    (discriminant-id -1)
	    (calculate-discriminants-p (and calculate-discriminants-p (null discriminants) packed-p))
	    (global-ctx context))
	#+debug(print (list :graph graph :grammar (grammar graph) :packed-p packed-p
			    :disjunction-choices disjunction-choices :calculate-discriminants-p calculate-discriminants-p :discriminants discriminants))
	(when calculate-discriminants-p
	  (setf discriminants (make-instance (discriminants-class graph) :psentence psentence :grammar (grammar graph))))
	#+debug(describe discriminants)
	(labels ((build-node (id context active-p)
		   ;; find the term corresponding to node id
		   (let* ((contexted-p nil)
			  (ctx.terms (collecting (dolist (ctx.term (aref var-array id))
						   (destructuring-bind (ctx . term) ctx.term
						     (when (and (find (car term) '(subtree terminal))
								(context-s-intersection (context-solutions graph context)
											(context-solutions graph ctx)
											global-ctx))
						       (collect ctx.term))))))
			  (nodes
			   (mapcar (lambda (ctx.term)
				     #+debug(print (list :ctx.term ctx.term))
				     (destructuring-bind (ctx type node-id label next-sibling &optional child) ctx.term
				       (setf label (substitute #\' #\" label))
				       ;; The child nodes of this node (ID) are the child node constructed here plus all the child
				       ;; nodes from the successive next-sibling nodes constructed in BUILD-SIBLINGS().
				       (let* ((active-p nil
						#+disabled(and active-p
							       (context-satisfied-p (resolve-context equivalences ctx)
										    disjunction-choices)))
					      (node
					       (cond (child
						      #+debug(print (list :child child))
						      (let ((child-id child)
							    (prev-child child))
							(multiple-value-bind (child child-contexted-p) (build-node child ctx active-p)
							  (setf contexted-p (or contexted-p child-contexted-p))
							  ;; if IGNORE-BASE-P is true ignore nodes labelled _BASE,
							  ;; i.e. make their children children of the base node's parent
							  (if (and ignore-base-p
								   (search "_BASE"
									   (if listp
									       (if (stringp child) child (symbol-name (car child)))
									       (car (node-value child)))
									   :test #'equal))
							      (if listp
								  (cons (intern label :xle) (cdr child))
								  (multiple-value-bind (children children-contexted-p)
								      (build-siblings next-sibling (list child) ctx active-p)
								    (let ((node-children (if (and (parser graph) (equal (name (grammar (parser graph))) "Welsh"))
											     (node-children (car children)) ;; bug fix for Ingo, still has some problems
											     (node-children child))))
								      #+debug(print (list :label label :child child :children children
											  :node-children node-children
											  :children+sub
											  (mapcar (lambda (c) (cons c (node-children c)))
												  children)))
								      (when calculate-discriminants-p
									(let ((morphology ()))
									  (labels ((ctx-morph-nodes (node ctx)
										     (let* ((morph (node-morphology node))
											    (n-ctx (context-solutions graph (node-context node)))
											    (i-ctx (context-s-intersection ctx n-ctx)))
										       #+debug(print (list :n node :c ctx :n-ctx n-ctx :i-ctx i-ctx
													   :m (node-morphology node)
													   :c (node-children node)))
										       (when i-ctx
											 ;;(when morph (print (list :m morph (context-solutions graph (node-context node)))))
											 (or morph (cons i-ctx (mapcar (lambda (n) (ctx-morph-nodes n i-ctx))
														       (node-children node)))))))
										   #+old
										   (morph-nodes (node)
										     (let ((morph (node-morphology node)))
										       (if morph
											   (let ((morph-cons (find morph morphology :test #'string= :key #'cadr))
												 (ctx (context-solutions graph (node-context node))))
											     (if morph-cons
												 (setf (car morph-cons)
												       (context-s-union ctx (car morph-cons)))
												 (push (list ctx morph) morphology)))
											   (mapc #'morph-nodes (node-children node))))))
									    (setf morphology (mapcar (lambda (n)
												       (ctx-morph-nodes n (context-solutions graph (node-context child))))
												     children))
									    #+old
									    (mapc #'morph-nodes children))
									  ;;(print (partition-morphology morphology solution-count))
									  #+debug
									  (let ((*print-level* nil))
									    (print (list :morph morphology)))
									  (setf morphology (partition-morphology-tree morphology solution-count))
									  ;; build morphology discriminants
									  (dat::do-string-tree (morph-features ctx morphology)
									    #+debug(print (list :morph-features morph-features ctx))
									    (unless (or (string= morph-features "")
											(char= (char morph-features 0) #\+)
											(null (context-s-intersection ctx (s-context discriminants)))
											(context-trivial-p ctx (s-context discriminants)))
									      (let ((disc (find-if (lambda (disc)
												     (and (= (discriminant-anchor disc) (car (span child)))
													  (string= (morph-features disc) morph-features)))
												   (morph-discriminants discriminants))))
										(if disc
										    (setf (s-context disc) (context-s-union (s-context disc) ctx))
										    (make-instance (morph-discriminant-class graph)
												   :discriminants discriminants
												   :morph-features morph-features
												   :surfaceform-var id
												   :anchor (car (span child))
												   :context ctx
												   :s-context ctx
												   :psentence psentence
												   :extend-p t)))))))
								      (make-instance
								       'c-node
								       :value (cons label id) 
								       :xle-graph graph
								       :type (if active-p :data-active :data)
								       :context ctx
								       ;;:s-context ctx
								       :label (if *suppress-complex-categories-p*
										  (subseq label 0 (position #\[ label))
										  label)
								       :surface-string (reduce #'append (mapcar #'node-surface-string node-children))
								       :span (cons (car (span (car node-children)))
										   (cdr (span (car (last node-children)))))
								       :children node-children))))
							      (multiple-value-bind (children children-contexted-p)
								  (build-siblings next-sibling (list child) ctx active-p)
								(setf contexted-p (or contexted-p children-contexted-p))
								(if listp
								    (cons (intern label :xle) children)
								    (progn (let* ((node (make-instance
											 'c-node
											 :value (cons label id) 
											 :xle-graph graph
											 :type (if active-p :data-active :data)
											 :context ctx
											 ;;:s-context ctx
											 :label (if *suppress-complex-categories-p*
												    (subseq label 0 (position #\[ label))
												    label)
											 :surface-string 
											 (reduce #'append (mapcar #'node-surface-string children))
											 :span (cons (car (span (car children)))
												     (cdr (span (car (last children)))))
											 :children children))
										  (stored-node (gethash (cons ctx id) node-table)))
									     ;;(print (cons label id))
									     (or #+test(and (not (search "_SUFF_BASE" label)) stored-node)
										 (setf (gethash (cons ctx id) node-table)
										       node))))))))))
						     ((not (eq '_bracket (car next-sibling)))
						      nil)
						     (ignore-base-p ;; (cadr next-sibling) points to surface form
						      (let ((node (build-surface-form (cadr next-sibling) ctx active-p label)))
							;;(setf (node-morphology node) (print label))
							node))
						     (listp
						      (list (intern label :xle) (build-surface-form (cadr next-sibling) ctx active-p)))
						     (t
						      (make-instance 'c-node
								     :value (cons label id)
								     :xle-graph graph
								     ;; :display-node-id (incf display-node-id)
								     :label (if *suppress-complex-categories-p*
										(subseq label 0 (position #\[ label))
										label)
								     :context ctx
								     :children (list (build-surface-form (cadr next-sibling) ctx active-p)))))))
					 node)))
				   ctx.terms)))
		     #+debug(print (list :start :id id :ctx.terms ctx.terms :nodes nodes)) 
		     (values (if (cdr nodes) ;; should not occur for #-graph
				 (let ((children ;; necessary to build them also when they aren't needed for packed c-structure display!
					(mapcar (lambda (node)
						  (make-instance 'c-node
								 :value (cons (let ((*package* (find-package :xle)))
										(format nil "~s" (node-context node)
											#+orig(resolve-context equivalences (node-context node))))
									      id)
								 :xle-graph graph
								 ;; :display-node-id (incf display-node-id)
								 :type (if (find (node-type node) '(:data-active :context-active :child-context-active))
									   :context-active :context)
								 :label (let ((*package* (find-package :xle)))
									  (concatenate 'string "[" (format-context graph (node-context node) t) "]"))
								 :context (node-context node)
								 :surface-string (node-surface-string node)
								 :span (span node)
								 :children (list node)))
						nodes)))
				   #+debug(assert (null (cdr nodes)))
				   (setf contexted-p t)
				   #+debug(print (list :children children))
				   (or (let ((node (gethash (cons context id) node-table)))
					 (when (and node active-p)
					   (setf (node-children node) children))
					 node)
				       (setf (gethash (cons context id) node-table)
					     (make-instance 'c-node
							    :value (cons (format nil "~s" context) id)
							    :xle-graph graph
							    ;; :display-node-id (incf display-node-id)
							    :type (if active-p :context-active :context)
							    :label (let ((*package* (find-package :xle)))
								     (concatenate 'string "[" (format-context graph context t) "]"))
							    :surface-string (node-surface-string (car children))
							    :context context ;; &&&&&&&&&
							    :span (span (car children))
							    :children children))))
				 (if (or (not *tight-p*) contexted-p)
				     (progn #+debug
					    (print (list :id id :ctx.terms ctx.terms
							 :nodes nodes))
					    (assert (car nodes))
					    (car nodes))
				     (or (let ((stored-node (gethash (cons context id) node-table)))
					   (when stored-node
					     (when active-p
					       (setf (node-children stored-node) (node-children (car nodes))
						     (node-type stored-node) (node-type (car nodes)))))
					   stored-node)
					 (setf (gethash (cons context id) node-table)
					       (car nodes)))))
			     contexted-p)))
		 (build-siblings (id right-children context active-p)
		   #+debug(print (list :sibling id))
		   (let ((contexted-p nil))
		     (cond ((eq id '-)
			    right-children)
			   (t
			    (let* ((ctx.terms (collecting (dolist (ctx.term (aref var-array id))
							    (destructuring-bind (ctx . term) ctx.term
							      (when (and (eq (car term) 'subtree)
									 (context-s-intersection (context-solutions graph context)
												 (context-solutions graph ctx)
												 global-ctx))
								(collect ctx.term))))))
				   (active-p-list (mapcar (lambda (ctx.term)
							    (and active-p
								 (context-s-intersection
								  (context-solutions graph (car ctx.term))
								  disjunction-choices)))
							  ctx.terms))
				   (node-lists (mapcar (lambda (ctx.term active-p)
							 (destructuring-bind (ctx d1 d2 d3 next-sibling &optional child) ctx.term
							   (declare (ignore d1 d2 d3))
							   (multiple-value-bind (node children-contexted-p)
							       (build-node child ctx active-p)
							     (setf contexted-p (or contexted-p children-contexted-p))
							     (multiple-value-bind (children children-contexted-p)
								 (build-siblings next-sibling (cons node right-children) ctx active-p)
							       (setf contexted-p (or contexted-p children-contexted-p))
							       #+debug(print (list :node node :child child :children children))
							       #+test(delete-if #'null children) ;; should not be necessary!
							       children))))
						       ctx.terms active-p-list)))
			      (values (if (cdr node-lists)
					  (progn (setf contexted-p t)
						 (mapcar (lambda (node-list ctx.term)
							   (let ((active-p
								  (and active-p
								       (context-s-intersection
									(context-solutions graph (car ctx.term))
									disjunction-choices)
								       #+orig
								       (context-satisfied-p (resolve-context equivalences (car ctx.term))
											    disjunction-choices))))
							     (make-instance
							      'c-node
							      :value (cons (format-context graph (car ctx.term) t)
									   id)
							      :xle-graph graph
							      ;; :display-node-id (incf display-node-id)
							      :type (if active-p :child-context-active :child-context)
							      :surface-string (when (eq node-list (car node-lists))
										(reduce #'append (mapcar #'node-surface-string node-list)))
							      :span (when (eq node-list (car node-lists))
								      (cons (car (span (car node-list)))
									    (cdr (span (car (last node-list))))))
							      :label (let ((*package* (find-package :xle)))
								       (concatenate 'string "[" (format-context graph (car ctx.term) t) "]"))
							      :context (car ctx.term) ;; &&&&&&&
							      :children node-list)))
							 node-lists ctx.terms))
					  (car node-lists))
				      contexted-p))))))
		 ;; the surface form gets special treatment
		 (build-surface-form (id context active-p &optional bracket-label)
		   #+debug(print (list :surface id bracket-label (aref var-array id)))
		   (let* ((surface-terms (remove-if-not (lambda (ctx.term) (eq (cadr ctx.term) 'surfaceform)) (aref var-array id)))
			  (labels (mapcar (lambda (ctx.terms) (substitute #\' #\" (cadddr ctx.terms)))
					  surface-terms))
			  (spans (remove-duplicates (mapcar (lambda (ctx.terms) (cons (nth 4 ctx.terms) (nth 5 ctx.terms)))
							    surface-terms))))
		     (assert (null (cdr labels)))
		     (assert (null (cdr spans)))
		     (if listp
			 (car labels)
			 (make-instance 'c-surface-node
					:value (cons (car labels) id)
					;; :display-node-id (incf display-node-id)
					:xle-graph graph
					:context context
					:surface-string labels
					:type (if active-p :surface-form-active :surface-form)
					:morphology (cond ((null bracket-label)
							   nil)
							  ((char= (char bracket-label 0) #\+)
							   bracket-label)
							  (t
							   ;;(format nil "~d:~a" id bracket-label)
							   bracket-label))
					:span (car spans)
					:label (format nil "~{~a~^|~}" labels))))))
	  ;; start with root node
	  #+debug(print (list :root-id root-id))
	  (let ((root-node (build-node root-id context t)))
	    (prog1 root-node
	      ;;#+graph
	      (unless listp
		;; test: reset and rebuild intersected contexts
		(let ((seen-nodes ())
		      (nodes-to-delete ()))
		  (labels ((build-parents-slot-and-projection-fs-ids (node)
			     #+debug(print (list :node node :c (node-children node)))
			     (unless nil;(find node seen-nodes)
			       ;;(push node seen-nodes)
			       (set-projection-fs-ids node)
			       #+old(setf (node-intersected-context node) nil)
			       (mapc (lambda (c) (pushnew node (node-parents c))) (node-children node))
			       (mapc #'build-parents-slot-and-projection-fs-ids (node-children node))))
			   (build-ic (node)
			     ;; to do: remove redundant context nodes (which do occur because we don't have total structure sharing)
			     #+debug(if (find node seen-nodes)
					(print (list :seen node :ctx (node-context node)
						     :parents (node-parents node)
						     ':children (node-children node)))
					(print (list :new node :ctx (node-context node)
						     :parents (node-parents node)
						     :children (node-children node))))
			     (unless (find node seen-nodes)
			       ;;(push node seen-nodes) ;; can't push here because there might be a parent to be built
			       (let ((to-build-parent (find-if-not #'node-intersected-context (node-parents node))))
				 #+debug(print (list :build node :build-parent to-build-parent))
				 (cond ((null (node-parents node))
					#+debug
					(print (list :root-node :children (node-children node)))
					(setf (node-intersected-context node) 1)
					(mapc #'build-ic (node-children node)))
				       (to-build-parent
					#+debug
					(print (list :build-parent to-build-parent)) 
					(build-ic to-build-parent))
				       (t
					(push node seen-nodes)
					#+debug
					(print (list :node node
						     :parent-ics
						     (mapcar (lambda (p) (cons (node-label p) (node-intersected-context p))) (node-parents node))
						     :child-ics
						     (mapcar (lambda (p) (cons p (node-intersected-context p))) (node-children node))
						     :ctx (node-context node) (context-solutions graph (node-context node))))
					(setf (node-intersected-context node)
					      ;;(context-s-union
					      ;;(node-intersected-context node) ;; ################
					      (or (context-s-intersection (context-solutions graph (node-context node))
									  (reduce #'context-s-union (node-parents node)
										  :key #'node-intersected-context
										  :initial-value nil))
						  -1))
					#+debug
					(print (list :node node :ic (node-intersected-context node)))
					#+orig(mapc #'build-ic (node-children node))
					;; new
					(when (eql (node-intersected-context node) -1)
					  (pushnew node nodes-to-delete))
					(if nil;(eql (node-intersected-context node) -1)
					    (dolist (parent (node-parents node))
					      (setf (node-children parent) (delete node (node-children parent))))
					    (mapc #'build-ic (node-children node)))))))))
		    ;;#+graph
		    (when t ;;packed-p ;; not yet implemented for non-packed terms
		      (build-parents-slot-and-projection-fs-ids root-node))
		    (setf seen-nodes ())
		    ;;#+graph
		    (build-ic root-node)
		    ;; new
		    (dolist (node nodes-to-delete)
		      (dolist (parent (node-parents node))
			(setf (node-children parent) (delete node (node-children parent)))))))
		;;#-(or :pargram :xle-web)
		(when calculate-discriminants-p
		  (let ((seen-nodes ()))
		    (with-slots (discriminants-context constituent-discriminants rule-discriminants
						       lex-discriminants discriminants-array) discriminants
		      (labels ((calculate-node-discriminants (node)
				 ;;(describe node)
				 (unless (find node seen-nodes)
				   (push node seen-nodes)
				   #+debug(print (list (node-intersected-context node) node (mapcar #'node-label (node-children node))))
				   (when (node-children node)
				     (when (find (node-type node) '(:data :data-active))
				       (context-children node (node-children node) () (node-intersected-context node)))
				     (mapc #'calculate-node-discriminants (node-children node)))))
			       (context-children (node children sstr ictx)
				 #+debug(print (list ictx node children))
				 (if (null children)
				     (when 
					 (or (cdr sstr)
					     (and *lex-rule-discriminants-p*
						  (equal (caar sstr) (cadar sstr)))
					     *unramified-rule-discriminants-p*)
				       (let* ((*package* (find-package :xle))
					      (segmentation
					       (format nil "~{~a~^ || ~}"
						       (mapcar (lambda (rs)
								 (format nil "~{~a~^ ~}" (cdr rs)))
							       (reverse sstr))))
					      (rule (when (or (cdr sstr)
							      (not (equal (caar sstr) (cadar sstr))))
						      (format nil "~a -> ~{~a~^ ~}" (node-label node)
							      (mapcar #'car (reverse sstr)))))
					      (lex-rule (unless rule (format nil "'~a': ~a" (caar sstr) (node-label node))))
					      (anchor (car (span node))))
					 #+debug(print (list :rule rule :segmentation segmentation :valid-context ictx))
					 #+debug(print (list :vc valid-context :sstr sstr))
					 (let* ((constituent-disc
						 (find-if (lambda (d)
							    (and (string= (constituents d) segmentation)
								 (= (discriminant-anchor d) anchor)))
							  constituent-discriminants))
						(rule-disc-id
						 (when (and rule constituent-disc)
						   (find rule (rules constituent-disc)
							 :key (lambda (id) (rule (aref discriminants-array id)))
							 :test #'string=)))
						(lex-rule-disc
						 (find-if (lambda (d)
							    (and (string= (rule d) lex-rule)
								 (= (discriminant-anchor d) anchor)))
							  lex-discriminants)))
					   (when (and rule constituent-disc)
					     (setf (s-context constituent-disc)
						   (context-s-union (s-context constituent-disc) ictx)
						   (context constituent-disc) (s-context constituent-disc))) ;; fixme
					   (cond (lex-rule-disc
						  (setf (s-context lex-rule-disc)
							(context-s-union (s-context lex-rule-disc) ictx)
							(context lex-rule-disc) (s-context lex-rule-disc))
						  #+debug(print (list (rule lex-rule-disc) ictx (s-context lex-rule-disc)))
						  )
						 (lex-rule
						  #+debug(print (list :lex-rule lex-rule anchor ictx))
						  (make-instance (lex-discriminant-class graph)
								 :discriminants discriminants
								 :rule lex-rule
								 :anchor anchor
								 :context ictx
								 :s-context ictx
								 :disjunctions disjunctions
								 :psentence psentence
								 :extend-p t))
						 (rule-disc-id
						  (let ((rule-disc (aref discriminants-array rule-disc-id)))
						    (setf (s-context rule-disc)
							  (context-s-union (s-context rule-disc) ictx)
							  (context rule-disc) (s-context rule-disc))))
						 (t
						  (let ((rule-disc (make-instance (rule-discriminant-class graph)
										  :discriminants discriminants
										  :rule rule
										  :anchor anchor
										  :context ictx
										  :s-context ictx
										  :disjunctions disjunctions
										  :psentence psentence
										  :extend-p t)))
						    (push (discriminant-id rule-disc)
							  (rules (or constituent-disc
								     (make-instance (constituent-discriminant-class graph)
										    :discriminants discriminants
										    :constituents segmentation
										    :anchor anchor
										    :context ictx
										    :s-context ictx
										    :disjunctions disjunctions
										    :psentence psentence
										    :extend-p t))))))))))
				     (destructuring-bind (child . siblings) children
				       (cond (;; children are contexted children of parent node
					      (find (node-type child) '(:child-context :child-context-active))
					      (dolist (ctx-node children)
						(context-children node (node-children ctx-node) sstr ictx)))
					     (;; nodes are context nodes
					      (find (node-type child) '(:context :context-active))
					      (dolist (sub-node (node-children child))
						(context-children node (cons sub-node siblings) sstr ictx)))
					     (t
					      #+debug(print (list :child-label (node-label child)
								  :ictx (node-intersected-context child)))
					      (context-children node siblings
								(cons (list* (node-label child)
									     (node-surface-string child))
								      sstr)
								(context-s-intersection (node-intersected-context child)
											ictx disjunctions))))))))
			#+debug(print (list :node node :ctx intersected-context))
			(calculate-node-discriminants root-node))))
	      
		  #+debug(Print (list :done :calculate-discriminants-p calculate-discriminants-p))
		  ;; remove redundant discriminants
		  (with-slots (discriminants-array constituent-discriminants rule-discriminants lex-discriminants morph-discriminants) discriminants
		    (let ((objects-to-delete ()))
		      (setf rule-discriminants
			    (collecting
			      (dolist (rule-disc rule-discriminants)
				(if (or (null (s-context rule-disc))
					(and (eq (s-context rule-disc) 1)
					     (not include-trivial-discriminants-p)))
				    (pushnew rule-disc objects-to-delete)
				    (collect rule-disc))))
			    lex-discriminants
			    (collecting
			      (dolist (lex-disc lex-discriminants)
				(if (or (null (s-context lex-disc))
					(and (eq (s-context lex-disc) 1)
					     (not include-trivial-discriminants-p)))
				    (pushnew lex-disc objects-to-delete)
				    (collect lex-disc))))
			    morph-discriminants
			    (collecting
			      (dolist (morph-disc morph-discriminants)
				(if (or (null (s-context morph-disc))
					(and (eq (s-context morph-disc) 1)
					     (not include-trivial-discriminants-p)))
				    (pushnew morph-disc objects-to-delete)
				    (collect morph-disc)))))
		      (dolist (const-disc constituent-discriminants)
			(dolist (rule (rules const-disc))
			  (setf (constituent-discriminant (aref discriminants-array rule)) (discriminant-id const-disc))
			  #+orig
			  (setf (constituent-discriminant rule) const-disc)))
		      (dolist (const-disc constituent-discriminants)
			(setf (rules const-disc)
			      (remove-if-not (lambda (rule-disc) (find rule-disc rule-discriminants :key #'discriminant-id))
					     (rules const-disc)))
			#+debug(print (list :rules-set (rules const-disc))))
		      (setf constituent-discriminants
			    (collecting
			      (dolist (const-disc constituent-discriminants)
				(setf (discriminant-redundant-p const-disc) ;; redundant ones are shown but are not clickable
				      (or (null (s-context const-disc)) (eq (s-context const-disc) 1)))
				(if (and (discriminant-redundant-p const-disc)
					 (null (rules const-disc)))
				    (pushnew const-disc objects-to-delete)
				    (collect const-disc)))))
		      (dolist (obj objects-to-delete)
			;; to do: remap discriminants in array?
			(setf (aref discriminants-array (discriminant-id obj)) nil)
			(delete-discriminant-object obj)))))))))))))

(defmethod delete-discriminant-object ((obj discriminant))
  nil)

;;#+graph
(defmethod find-eq-vars ((graph xle-graph) var phi-ctxt &key (i-context 1))
  (with-slots (var-array realized-vars) graph
    (or (collecting
	  (when (< var (length var-array))
	    (dolist (ctx.term (aref var-array var))
	      #+debug(print (list :ctx.term ctx.term))
	      (destructuring-bind (ctx . term) ctx.term
		(let ((ctxi (context-s-intersection
			     phi-ctxt
			     (context-s-intersection (context-solutions graph ctx)
						     i-context))))
		  (when (and ctxi
			     (eq (car term) 'eq)
			     (eq (caadr term) 'attr)
			     (equal (caddr (cadr term)) "=")
			     (not (find var realized-vars)))
		    (collect-append (find-eq-vars (cadr (caddr term)) ctxi
						  :i-context i-context))))))))
	(list var))))

;;#+graph
(defmethod find-subsumed-vars ((graph xle-graph) fs-id &key (i-context 1) (context 1))
  (with-slots (var-array realized-vars subsume-list) graph
    #+debug(print (list :fs-id fs-id :realized-vars realized-vars))
    (unless (find fs-id realized-vars)
      (collecting
	(let ((ctx.subsume-list (getf subsume-list fs-id)))
	  (dolist (ctx.subsume ctx.subsume-list)
	    #+debug(print (list (car ctx.subsume) (context-solutions graph context)))
	    (when (context-s-intersection (car ctx.subsume) (context-solutions graph context))
	      (let* ((rhs (cadr (cddr ctx.subsume)))
		     #+bug??(subs (if (consp rhs) (cadr rhs) rhs)) ;; looks fishy
		     (subs (and (consp rhs) (cadr rhs))))
		(when subs
		  #+debug(print (list :ctx.subsume ctx.subsume
				      :subs subs
				      :fs-id fs-id
				      :subs-list (getf subsume-list subs)
				      :subsumed-vars (find-subsumed-vars graph subs
									 :i-context i-context
									 :context context)
				      :eq-vars (find-eq-vars graph subs 1 :i-context i-context)))
		  #+test ;; fixme: fails for "Paa Byfjellene kan du ..."
		  (assert (or (null (getf subsume-list subs))
			      (eq subs fs-id)
			      (not (find-if-not (lambda (s) (eq s subs))
						(find-subsumed-vars graph subs
								    :i-context i-context
								    :context context)))))
		  ;; necessary?? do intersection with result intersections??
		  (collect-append (find-eq-vars graph subs 1 :i-context i-context)))))))))))

;;#+graph
(defmethod set-projection-fs-ids ((node c-node))
  (with-slots (context intersected-context xle-graph projection-fs-ids) node
    (with-slots (var-list var-array inverse-phi-list subsume-list global-projection-fs-ids) xle-graph
      (let ((ctx.phi-list (getf inverse-phi-list (cdr (node-value node))))
	    (fs-ids ()))
	#+debug(print (list :ctx.phi-list ctx.phi-list))
	(dolist (ctx.phi ctx.phi-list)
	  #+debug(print (list :ctx.phi ctx.phi))
	  (when (context-s-intersection (car ctx.phi) (context-solutions xle-graph context))
	    (let ((fs-id (or (cadr (get-rhs-replacement var-list (cdr ctx.phi)))
			     (cdr ctx.phi))))
	      (dolist (var (find-eq-vars xle-graph fs-id (car ctx.phi)
					 :i-context intersected-context))
		(pushnew var fs-ids))))
	  (setf fs-ids
		(collecting
		  (dolist (fs-id fs-ids)
		    (collect-append
		     (or (find-subsumed-vars xle-graph fs-id :i-context intersected-context :context context)
			 (list fs-id)))))))
	(dolist (id fs-ids)
	  (pushnew id global-projection-fs-ids))
	;; fixme: should apply find-eq-vars() again (cf. "Jeg husker og liker gutten.") Intersperse find-eq-vars() and form above!
	(setf projection-fs-ids (delete-duplicates fs-ids))))))

#+graph
(defclass c-graph (display-lattice)
  ()
  (:default-initargs :node-class 'c-node
    :layout (make-instance 'tight-top-down-layout :delta-x 3 :delta-y 40)))

;; obs: solution is 1-based
(defmethod extract-c-structure ((graph xle-graph) solution &key (packed-p t) (listp t) (ranking-p t) (as-string-p t))
  (when packed-p (setf (solution-nr graph) (1- solution)))
  (multiple-value-bind (foo va root)
      (parse-prolog graph :solution (unless packed-p solution)
		    :build-c-structure-p t :packed-p packed-p :ranking-p ranking-p)
    (declare (ignore foo))
    (unless (zerop (fill-pointer va))
      (let ((derivation (build-c-structure graph va root :listp t :packed-p nil :listp listp)))
        (when derivation
          (with-standard-io-syntax
            (let ((*package* (find-package :xle)))
	      (if as-string-p
		  (write-to-string derivation)
		  derivation))))))))

#+test
(unload-grammar (find-grammar "bokmal-mrs"))

:eof