(in-package "KPML")

;;; File: examples.lisp
;;; 
;;; Contains definition of the linguistic object: example.
;;;
;;;   Adds the multilingual treatment of
;;;   examples, including the ability to merge them when identically
;;;   named examples are loaded corresponding to distinct 
;;;   languages. Based on the code already debugged in KPML-beta's 
;;;   ml-newstyle-loading for systems, choosers, and inquiries. 
;;;   (Now factored out to the individual object definition files.) 
;;;   Also adds in the
;;;   use of (in-language ...) declarations (region not being that
;;;   relevant).
;;;
;;; ----------------------------------------------------------------------
;;; Development history...
;;;
;;;   First version: John, IPSI: March 1995, for KPML 0.8
;;;       The only slots to be affected by merging are:
;;;         --   name, targetform, generatedform, logicalform,
;;;              as well as the new slot source-file.
;;;       all other slot values are lost if examples are merged;
;;;       this is supposed not to be serious since most of this
;;;       information is in any case transitory, but may well need
;;;       extension some day.
;;;  (Note: using the weakened form of strip-lx throughout)
;;;
;;; Additions/Modifications:
;;;  0.9 small bug in the maintenance of the examples variable fixed.
;;;  1.1 exercise set names added for explicit maintenance
;;;  2.0 selectionexpressions also maintained multilingually.
;;;      Structure of selectionexpressions also changed at this point
;;;      so that the grammatical constitutent for each selection expression
;;;      is also identified. Previously selection expressions were only
;;;      indexable by hub, which caused some strange workarounds/behaviours
;;;      in the interface.  (Feb98)
;;;      record of preselections made also added.
;;;  2.1 glosses added. The form of a gloss entry is a multilingual expression
;;;      identifying the language of the *glosses* not the language of the
;;;      example. The currently selected gloss language is maintained in
;;;      the global kpml::*gloss-language* (default, of course, :english :-)
;;;  3.2 clisp use out
  ;; --------------------------------------------------------------------
  ;; 3.2.2 some of the object-to-list functions were neglecting to do 
  ;;       anything about the comments slot, which means that information
  ;;       here was going missing whenever the systems, etc. were written
  ;;       out! Corrected here and the ragbag of functions cleared up 
  ;;       slightly. The effected functions are: X-to-list-multi-to-mono,
  ;;       X-to-list-multi-to-multi, X-instance-to-list-multi-to-mono,
  ;;       X-instance-to-list-multi-to-multi, with X unfortunately ranging
  ;;       over system, chooser, inquiry, lexeme and example: that is 20
  ;;       functions. Fortunately comments were only overlooked in systems
  ;;       and examples however.
  ;; --------------------------------------------------------------------
;;;
;;; 4.0 slot for expansion info added...
;;; ----------------------------------------------------------------------

(defstruct (EXAMPLE 
	    (:predicate example-instance-p))
	   (name nil)
	   (targetform nil)              ;; name changed for KPML 0.8
	   (englishform nil)             ;; preserved to load old resources
	   (generatedform nil)           ;; added for KPML 0.7
	   (gloss nil)                   ;; added for KPML 2.1
	   (logicalform nil)
	   (structure nil)               ;; added for KPML 0.8
	   (expansions nil)              ;; added for KPML 4.0
	   (rootnode nil)                ;; transitory
	   (verbalizationgraph nil)      
	   (quantificationgraph nil)     ;; used?
	   (paragraph-theme nil)         ;; should be multilingual
	   (focus nil)                   ;; should be multilingual
	   (includedhubs nil)            
	   (selectionexpressions nil)
	   (preselections nil)           ;; 2.0
	   (comments nil)                ;; could be multilingual
	   (editor nil)                  ;; could be multilingual
	   (date nil)                    ;; could be multilingual
	   (kbenvironment nil)           ;; transitory? NO!
	   (tpenvironment nil)           ;; transitory? NO!
	   (discoursecontext             ;; transitory?
	    (make-discourse-context))
	   (source-file nil)             ;; added for KPML 0.8
	   (set-name nil)                ;; added for KPML 1.1
	   (ls-set nil)                  ;; added for KPML 0.8
	   )

  ;; ----------------------------------------------------------------------
  ;; 3.2.15
  ;;  add control of which example set to allocate a new example to.
  ;; 3.2.52
  ;;    Add a check on redefinition of an example, since otherwise
  ;;        there is no way of checking whether some set of examples
  ;;        trips over its own feet and removes examples that may have
  ;;        been required. This can only be set from the example manager
  ;;        at present (since that is where one should be if one is 
  ;;        working with sets of example sets). 
  ;;  
  ;; ----------------------------------------------------------------------

(defvar *default-example-set* nil
  "If this is set, all examples that are made get added to the identified
   example set unless they explicitly specify an example set of their
   own.")
(defvar *check-ex-dups-on-loading* nil)

;;; ----------------------------------------------------------------------
;;; 2.0.32 gets caught by monolingualizing non-multilingual selection
;;;        expressions: fixed, or rather hacked around for now...
;;; 2.0.38 folded in. same problem for preselection list of lists.
;;;
;;; Add the following to make it look better...
;;; ----------------------------------------------------------------------

(defmacro PROTECT-LISTS-FROM-ML-EXPRESSION (expr)
  `(if ls 
       (let ((se (wk-st-lx (parse-clause ,expr ls))))
	 (when se
	   (unless (consp (first se))
	     (setf se (list se))))
	 se)
     ,expr))

;;; ----------------------------------------------------------------------
;;; User access...
;;; ----------------------------------------------------------------------

(DEFMACRO Example (&REST ARGLS)  ;;;TYG formerly Make-Example or Example:
  `(Example-1 ',ARGLS))

;;; 1.1
(defvar *EX-SETS* nil "list of named example sets loaded")

;;;----------------------------------------------------------------------
;;; based on fetch-lexicon-info, etc. in ml-penman-lexicon-class.lisp
;;; ----------------------------------------------------------------------

(defun FETCH-EXAMPLE-INFO (ex-name fld-name &optional ls)
  (let* ((x (gethash ex-name penexamples))
         (y nil))
    
    (unless x (return-from fetch-example-info nil))
    (setf y (copy-example x))
    (unless ls (setq ls CurLan))
    (when (eq fld-name 'ls-set)
	  (return-from fetch-example-info (example-LS-set X)))
    (if (and ls (not (member ls (example-LS-set X))))
        (return-from fetch-example-info nil))

    (case fld-name
      ((everything instance) 
       (if ls
	   (block nil
	     (setf (example-targetform y) 
		   (Wk-St-Lx (parse-clause (example-targetform y) ls)))
	     (setf (example-generatedform y)
		   (wk-st-lx (parse-clause (example-generatedform y) ls)))
	     (setf (example-expansions y)
		   (wk-st-lx (parse-clause (example-expansions y) ls)))   ;; 4.0
	     (setf (example-gloss y) 
                   (list kpml::*gloss-language* 
                         (Wk-St-Lx (parse-clause (example-gloss X) kpml::*gloss-language*))))
	     (setf (example-logicalform y)
		   (wk-st-lx (parse-clause (example-logicalform y) ls)))
	     (setf (example-structure y)
		   (wk-st-lx (parse-clause (example-structure y) ls)))
	     (setf (example-selectionexpressions X)
		   (wk-st-lx (parse-clause 
			      (example-selectionexpressions y) ls)))
	     (setf (example-preselections X)
		   (wk-st-lx (parse-clause 
			      (example-preselections y) ls)))
	     (setf (example-source-file X)
		   (wk-st-lx (parse-clause 
			      (example-source-file y) ls)))
	     (setf (example-set-name X)
		   (wk-st-lx (parse-clause 
			      (example-set-name y) ls)))
	     (setf (example-includedhubs y)
		   (wk-st-lx (parse-clause (example-includedhubs y) ls)))
	     (return-from fetch-example-info y)
	     )
	     Y))
                                    
      (name         (if ls (Wk-St-Lx (parse-clause (example-name X) ls))
		      (example-name X)))

      (targetform    (if ls (Wk-St-Lx (parse-clause (example-targetform X) ls))
                       (example-targetform X)))

      (includedhubs   (if ls (Wk-St-Lx (parse-clause 
					(example-includedhubs X) ls))
			(example-includedhubs X)))

      (generatedform  (if ls (Wk-St-Lx (parse-clause 
					(example-generatedform X) ls))
			(example-generatedform X)))
      ;; 4.0
      (expansions     (if ls (Wk-St-Lx (parse-clause (example-expansions X) ls))
			(example-expansions X)))
      (gloss  (Wk-St-Lx (parse-clause (example-gloss X) kpml::*gloss-language*)))
      (logicalform  (if ls (Wk-St-Lx (parse-clause (example-logicalform X) ls))
		      (example-logicalform X)))

      (structure    (if ls (Wk-St-Lx (parse-clause (example-structure X) ls))
		      (example-structure X)))

      (source-file  (if ls (Wk-St-Lx (parse-clause (example-source-file X) ls))
		      (example-source-file X)))

      (set-name  (if ls (Wk-St-Lx (parse-clause (example-set-name X) ls))
		      (example-set-name X)))

      ;; 2.0.32 yeeuch.
      (selectionexpressions 
       (protect-lists-from-ml-expression 
	(example-selectionexpressions X)))
      (preselections   
       (protect-lists-from-ml-expression 
	(example-preselections X)))

      (comments   (example-comments X))
      (date       (example-date X))
      (editor     (example-editor X))
      )
))


;;; ----------------------------------------------------------------------
;;; 2.0
;;; Note that the following did not consider that we may be updating
;;; a single language element of a multilingual structure... It expected
;;; that the value given as new-value already had considered this. This
;;; is now changed so that updates only effect their own language.
;;; 2.1 gloss behaves specially, the structure is inherently multilingual,
;;;     and that multilinguality is independent of the languages of the
;;;     example. That is, the updating has to be done with respect to
;;;     the gloss language. 
;;; ----------------------------------------------------------------------

(defun REPLACE-EXAMPLE-INFO (ex-name fld-name new-value &optional (ls curlan))
  (let ((x (gethash ex-name penexamples))
	(curlan ls))
    (unless x (return-from REPLACE-EXAMPLE-INFO nil))
    (macrolet ((update (slot) 
		 `(setf (,slot X) 
		    (update-slot-for-one-language-only
		     (,slot X) new-value ls))))
      (case fld-name
	(name                 (update example-name))
	(generatedform        (update example-generatedform))
	(expansions           (update example-expansions))
	(targetform           (update example-targetform))
	(logicalform          (update example-logicalform))
	(source-file          (update example-source-file))
	(set-name             (update example-set-name))
	(structure            (update example-structure))
	(includedhubs         (update example-includedhubs))
	(selectionexpressions (update example-selectionexpressions))
	(preselections        (update example-preselections))

;;; Not maintained multilingually... 
	(paragraph-theme (setf (example-paragraph-theme X) new-value))
	(focus           (setf (example-focus X) new-value))
	(comments        (setf (example-comments X) new-value))
	(date            (setf (example-date X) new-value))
	(editor          (setf (example-editor X) new-value))

;;; Special treatment...
	(gloss           (setf (example-gloss X) 
		               (update-slot-for-one-language-only
		                (example-gloss X) new-value kpml::*gloss-language*)))
;;; Meta...
	(LS-set          (setf (example-LS-set X) new-value))
	))))


;;; 2.0 following was way off wrt treatment of the optional parameter,
;;;     which of course has to be done appropriately as a macro
;;;     expansion and not at compile/load time.
(defsetf FETCH-EXAMPLE-INFO (ex-name fld-name &optional (LS nil)) 
	 (new-value) 
  `(replace-example-info ,ex-name ,fld-name ,new-value 
			 (if ,LS ,ls kpml::curlan)) )

;;;----------------------------------------------------------------------
;;; From express.lisp, with the multilingual merging code for systems,
;;; choosers, etc. added in.

(defun EXAMPLE-1 (body)
  (when (null body)
    (warning "Cannot create an empty example")
    (return-from example-1 (values nil)))
  (let* ((instance  (apply #'make-example body))
	 (name (example-name instance))
	 namelst)                         ;; was not declared in 0.8
    (when (null name)
      (warning "Cannot create an example with an empty name")
      (return-from example-1 (values nil)))
    
    ;; 3.2.52
    (when (and *check-ex-dups-on-loading*
	       (example-defined-for-lg-p name curlan))
      (warning "Example named " name 
	       " (previously: "
	       (fetch-example-info name 'set-name) ") being overwritten!! ("
	       (if *currently-used-file*
		   (pathname-name *currently-used-file*)
		 "file unknown")
	       ")"
	       ))

    ;; following allows old example files to be loaded, although this slot
    ;; should not appear in new resources...
    ;;
    (when (example-englishform instance)
	  (setf (example-targetform instance)(example-englishform instance)))

    (setq new-example-loaded t)
    (setf (example-source-file instance) *currently-used-file*)
    (unless (example-set-name instance)
      ;; 2.1.15
      (if *default-example-set*
	  (setf (example-set-name instance) (example-set-name instance))
	(when (pathname-name *currently-used-file*)
	  (setf (example-set-name instance)
		(intern (pathname-name *currently-used-file*) "KPML")))))
    (pushnew (example-set-name instance) *ex-sets*)

    (when (symbolp name)
	  (setf (example-name instance)
		(append 
		 (cond 
		  (*current-default-languages*
		   (check-language-availability *current-default-languages*)
		   *current-default-languages*)
		  (t  all_languages))
		 (cons name nil))))

     (setf NameLst (get-atom-ls (example-name instance)))
     (loop for Ex-id in NameLst do
	  (let ((merged-instance (merge-new-and-old-example-definition
				  (car Ex-id) instance (cdr Ex-id))))
	    (setf (gethash (car Ex-id) penexamples) 
		  merged-instance)
	    (setf (example-LS-set merged-instance) 
		  (union (cdr Ex-id) (example-LS-set merged-instance)))

	    (unless (discourse-context-p 
		     (example-discoursecontext merged-instance))
		    (setf (example-discoursecontext merged-instance)	
			  ;; assume its a list of alternating slots and values
			  (if (example-discoursecontext merged-instance)
			      (apply #'make-discourse-context 
				     (example-discoursecontext 
				      merged-instance))
			    (make-discourse-context))))

	    ;; John:IPSI:Nov94; default generated form is desired form...
	    ;; John:IPSI:Jan96: but only if there is no generated form given...
	    ;;
	    (unless (example-generatedform (gethash (car Ex-id) penexamples))
	      (setf (example-generatedform (gethash (car Ex-id) penexamples))
		(example-targetform (gethash (car Ex-id) penexamples))))

	    ;; John:IPSI:Jan96: 
	    ;;  0.8 was not maintaining examples properly... fixed here.
	    ;;
	    (pushnew (cons (car Ex-Id) (example-LS-set merged-instance))
		     examples)))))



;;; Normal generic merging code, applied to examples...

(defun MERGE-NEW-AND-OLD-EXAMPLE-DEFINITION 
  (name new-instance lg-of-new-instance)
  (setf (example-ls-set new-instance) lg-of-new-instance)
  (when *show-loading-actions*
	(format *trace-output* "~%Loading example definition:  ~A" name))
  (cond ((and *merging-active*
	      (gethash name penexamples))
	 (let* ((old-instance (gethash name penexamples))
		(new-languages lg-of-new-instance)
		(old-languages (example-ls-set old-instance))
		(merged-instance nil)
		(old-lg-instance-pairs 
		 (create-set-of-mono-lingual-instances name :example))
		(new-lg-instance-pairs
		 (create-set-of-mono-lingual-instances new-instance 
						       :example)))

	   (when *show-loading-actions*
		 (format *trace-output* "~%...merging; old languages: ~A; new languages: ~A" 
		   old-languages new-languages))

	   (cond ((equal new-languages old-languages)
		  (when (member :examples *show-merging-actions*)
			(format *trace-output* "~%Example ~A multiply defined, new definition wins."
				name))
		  new-instance)
		 ((intersection new-languages old-languages)
		  (when (member :examples *show-merging-actions*)
			(format *trace-output* "~%Merging for example ~A; shared languages" name))
		  (merge-overlapping-example-instances
		   name old-lg-instance-pairs new-lg-instance-pairs))

		 (t
		  (when (member :examples *show-merging-actions*)
			(format *trace-output* 
                                "~%Merging for example ~A; disjunctive languages" name))
		  (delete-example name)
		  (setf merged-instance 
			(apply #'merge-example-instances 
			       (list
				(append old-lg-instance-pairs 
				        new-lg-instance-pairs))))

		  (when (member :examples *show-merging-actions*)
			(format *trace-output* 
				"~%***Merged: old instance: ~%     ~A~%~
  ***new instance: ~A~%  ***and merged:~A~%" old-instance new-instance merged-instance))
		  merged-instance))))
	(t
	 (let* ((old-instance (gethash name penexamples)))
	   (when old-instance
		 (unless (subsetp (example-ls-set old-instance) 
				  lg-of-new-instance)
			 (warning "Previously existing example: " name
				  " is being overwritten by a definition with narrower language coverage: " lg-of-new-instance " instead of " 
				  (example-ls-set old-instance)
				  "."))
		 (delete-example name)))
	 (return-from merge-new-and-old-example-definition 
		      new-instance))))



(defun MERGE-OVERLAPPING-EXAMPLE-INSTANCES
  (name old-lg-instance-pairs new-lg-instance-pairs)
  
  (let ((merged-instance nil))
    (delete-example name)
    (setf merged-instance 
	  (apply #'merge-example-instances 
		 (list (replace-keyed-elements
			old-lg-instance-pairs 
			new-lg-instance-pairs))))
    
    (when (and *step-by-step-merging-behavior*
	       (member :examples *show-merging-actions*))
	  (format t 
		  "~%***Merged: old language instance pairs: ~%     ~S~%~
  ***new language instance pairs: ~S~%  ***and merged instance:~A~%" old-lg-instance-pairs new-lg-instance-pairs merged-instance))
    merged-instance))



(defun MERGE-EXAMPLE-INSTANCES (list-of-lg-instance-pairs)
  (let ((instance   (generalized-merge-instance
		     list-of-lg-instance-pairs
		     '(example-name
		       example-targetform
		       example-generatedform
		       example-gloss                ;; 2.1 this could go badly wrong!
		       example-logicalform
		       example-structure
		       example-expansions           ;; 4.0
		       example-selectionexpressions ;; 2.0
		       example-preselections        ;; 2.0
		       example-source-file          
		       example-set-name)            ;; 1.1
		     #'make-example)))
    (setf (example-ls-set instance)
	  (mapcar #'first list-of-lg-instance-pairs))
    instance))

  
;;;--------------------------------------------------------------------
;;; Following based on the corresponding functions in
;;; ml-resource-handling-facilities...
;;; 2.1 note that glosses are problematic, because they inherently
;;;     involve a further language!  We'll see if this causes
;;;     problems anywhere...

(defun EXAMPLE-TO-LIST-MULTI-TO-MONO 
  (example
   &optional (lg-var curlan))
  (cond ((example-defined-for-lg-p example lg-var)
	 `(example
	  :name ,example
	  :generatedform ,(fetch-example-info example 'generatedform lg-var)
	  :gloss ,(list kpml::*gloss-language* (fetch-example-info example 'gloss lg-var))
	  :targetform
	    ,(fetch-example-info example 'targetform lg-var)
          :comments                                                 ;; 3.2.2
            ,(fetch-example-info example 'comments lg-var)
	  :logicalform ,(fetch-example-info example 'logicalform lg-var)
	  :structure ,(fetch-example-info example 'structure lg-var)
	  :expansions ,(fetch-example-info example 'expansions lg-var)
	  :selectionexpressions 
	  ,(fetch-example-info example 'selectionexpressions lg-var)
	  :preselections
	  ,(fetch-example-info example 'preselections lg-var)
	  :source-file ,(fetch-example-info example 'source-file lg-var)
	  :set-name ,(fetch-example-info example 'set-name lg-var)
	  ))
	(t nil)))

(defun EXAMPLE-TO-LIST-MULTI-TO-MULTI (example-name)
  (example-instance-to-list-multi-to-multi (gethash example-name penexamples)))

(defun EXAMPLE-INSTANCE-TO-LIST-MULTI-TO-MULTI (example)
  `(example
    :name ,(example-name example)
    :generatedform ,(example-generatedform example)
    :gloss ,(example-gloss example)
    :targetform ,(example-targetform example)
    :comments ,(example-comments example)                           ;; 3.2.2
    :selectionexpressions ,(example-selectionexpressions example)
    :preselections ,(example-preselections example)
    :logicalform ,(example-logicalform example)
    :structure ,(example-structure example)
    :expansions ,(example-expansions example)                       ;; 4.0
    :source-file ,(example-source-file example)
    :set-name ,(example-set-name example)
    ))

(defun EXAMPLE-INSTANCE-TO-LIST-MULTI-TO-MONO 
  (instance &optional (lg-var curlan))
  `(example
    :name ,(wk-st-lx (parse-clause (example-name instance) lg-var))
    :generatedform ,(wk-st-lx 
		     (parse-clause (example-generatedform instance) lg-var))
    :gloss  ,(list kpml::*gloss-language*
                   (Wk-St-Lx (parse-clause (example-gloss instance) 
					   kpml::*gloss-language*)))
    :targetform ,(wk-st-lx 
		  (parse-clause 
                   (example-targetform instance) lg-var))
    :comments ,(wk-st-lx                                             ; 3.2.2
                (parse-clause 
                 (example-comments instance) lg-var))
    :logicalform ,(wk-st-lx 
		   (parse-clause (example-logicalform instance) lg-var))
    :structure ,(wk-st-lx 
		   (parse-clause (example-structure instance) lg-var))
    :expansions ,(wk-st-lx 
		     (parse-clause (example-expansions instance) lg-var)) ;; 4.0
    :selectionexpressions ,(wk-st-lx
			    (parse-clause (example-selectionexpressions instance)
					  lg-var))
    :preselections ,(wk-st-lx
			    (parse-clause (example-preselections instance)
					  lg-var))
    :source-file ,(wk-st-lx 
		   (parse-clause (example-source-file instance) lg-var))
    :set-name ,(wk-st-lx 
		   (parse-clause (example-set-name instance) lg-var))
    ))

;;; Following based on equivalent in ml-new-utilities.lisp

(defun EXAMPLE-DEFINED-FOR-LG-P (name lg)
  (let ((example-instance (gethash name penexamples)))
    (and 
     example-instance ;; 2.1 was missing!
     (member lg (example-ls-set example-instance))
     (eq name (wk-st-lx (parse-clause 
			 (example-name example-instance) lg))))))


(defun EXAMPLE-P (item)
  (member ITEM (mapcar #'car examples)))


;;; ----------------------------------------------------------------------
;;; 2.1 Moved from example-running.lisp
;;;
;;; Predicates and utilities for testing whether mismatch has occured
;;; between an example's target and its generated string. 
;;;
;;; Extended to use the example runner's notion of close and loose matching.
;;; ----------------------------------------------------------------------

(defvar *EXAMPLE-CHECK-EXACTNESS* :loose      ;; or :exact
 "Whether matches have to get even the spaces  (:exact) right or not (:loose)")

(defvar *MISMATCH-WITH-PUNCTUATION* nil
  "Matches have also to get the punctuation exactly right")

;; 2.0.47
(defvar *MISMATCH-WITH-CASE* T "Matches have to be case identical")

(defun GENERATION-MISMATCH-P (target generated)
  ;; 2.1 extended to subsume some of the example runner checking 
  ;;     ...functionality
  (let ((target (case *example-check-exactness*
		  (:exact target)
		  (:loose (clean-up-final-string target))))
	(generated
	        (case *example-check-exactness*
		  (:exact generated)
		  (:loose (clean-up-final-string generated)))))
    (unless *mismatch-with-case*                       ;; 2.0.47
      (setf target (string-downcase target)
	    generated (string-downcase generated)))
    (if *mismatch-with-punctuation*
	(not (string= target generated))
      (not
       (string=
	(remove-if #'(lambda (x) (member x *punctuation-bag*)) generated)
	(remove-if #'(lambda (x) (member x *punctuation-bag*)) target))))))

;;; ----------------------------------------------------------------------
;;; 2.1 new, make sure the user knows just what criteria for matching
;;;     are being reported on...
;;; ----------------------------------------------------------------------

(defun REPORT-EXAMPLE-MISMATCH-FLAG-STATUS (&optional (stream T))
  (format stream "~%;;; Mismatch flags:")
  (format stream 
	  (case *example-check-exactness*
	    (:exact "~%;;;   Match has to be exact with respect to spaces.")
	    (:loose "~%;;;   Match is loose with respect to spaces.")))
  (format stream 
	  (if *mismatch-with-punctuation*
	      "~%;;;   Match has to be correct with respect to punctuation."
	    "~%;;;   Match does not include punctuation."))
  (format stream
	  (if *mismatch-with-case*
	      "~%;;;   Match is case sensitive."
	    "~%;;;   Match ignores case.")))

;;; ----------------------------------------------------------------------
;;; 1.1
;;; 2.1 changed to use the above...
;;; ----------------------------------------------------------------------

(defun TARGET-GENERATED-MATCH-P (e)
  (not
   (generation-mismatch-p 
    (kpml::fetch-example-info e 'kpml::targetform)
    (kpml::fetch-example-info e 'kpml::generatedform))))

;;; ----------------------------------------------------------------------
;;; 1.1+3.0 additions/extensions
;;; ----------------------------------------------------------------------

(defun ACTUALIZE-LIST-OF-EXAMPLE-SETS-LOADED (&optional (lg-restriction t))
  (setf *ex-sets* nil)
  (loop for ex in (if lg-restriction 
                      (list-of-examples)
                    (mapcar #'first examples))
	when (fetch-example-info ex 'set-name)
        do (pushnew (fetch-example-info ex 'set-name) *ex-sets*)))

;;; 0.9 Following did nothing about the examples list, which therefore
;;; gets out of touch with the actually stored examples...

(defun DELETE-EXAMPLE (example)
  (remhash example penexamples)
  (setf examples
    (loop for ex in examples
	unless (eq (first ex) example)
	       collect ex)))

(defun LIST-OF-EXAMPLES (&optional (lg curlan))
  (loop for ex in examples
	when (member lg (cdr ex))
	collect (car ex)))

(defun EXAMPLES-OF-LANGUAGES (languages)
  (if (set-equal languages all_languages)
      (mapcar #'first examples)
    (loop for ex in examples
	  when (intersection languages (cdr ex))
	  collect (car ex))))

(defun FILTER-EXAMPLES-BY-LANGUAGES (example-list languages)
  (if (set-equal languages all_languages)
      example-list
    (loop for ex in example-list
	  when (intersection languages (fetch-example-info ex 'lg-set))
	  collect ex)))

(defun EXAMPLES-OF-EXAMPLE-SET (exset)
  (loop for ex in examples
        when (equal (fetch-example-info (first ex) 'set-name) exset)
        collect ex))

(defun GET-EXAMPLE-ENGLISH (item)
  (if *break-on-no-target*
      (progn
	(printwindow
	 :display-pane
	 (indent-and-fill "Please enter the target to be generated."))
	(setf (fetch-example-info item 'targetform)
	  (askwindow :value "Enter string: " )))
    ""))


;;; ----------------------------------------------------------------------
;;; Following multilingual updates of the original Penman versions
;;; from the Penman file sgdisplay.lisp.
;;; example/exercise set manipulation functions...
;;; (1.1 made clisp independent)

(defun GET-EXAMPLES-WITH-FEATURES 
  (feature-list 
   &optional (list-of-examples (list-of-examples)))      ;; 1.1
  (loop for example in list-of-examples 
      when (example-uses-features-p example feature-list)        ;; 2.0
      collect example))


(defun SHOW-EXAMPLES-WITH-FEATURES (feature-list 
				    &optional (stream *standard-output*))
  (loop for example in (get-examples-with-features feature-list)
      do
	(format stream "~%[~S]   ~S" example
		(fetch-example-info example 'generatedform))))


;;; 1.1 something extra on the lines of the above, for display purposes
;;;     mostly...
;;;     when used with a set of *collected-features* only returned T
;;;     if the entire set is used within a single selection expression!
;;; 2.0 This behaviour is now parameterized...

(defvar *example-using-features-condition* :in-same-selexpr)

(defun EXAMPLE-USES-FEATURES-P 
    (example &optional (feature-list *collected-features*)
		       (comparison-mode *example-using-features-condition*))
  (if feature-list
      (case comparison-mode
	(:in-same-selexpr
	 (loop for selection-expression 
	     in (fetch-example-info example 'selectionexpressions)
	     thereis
	       (loop for feature in feature-list
		   always (member feature selection-expression))))
	(:anywhere
	 (loop for f in feature-list
	     always (loop for s 
			in (fetch-example-info example 'selectionexpressions)
			thereis (member f s))))
	(:some-feature-anywhere
	 (loop for f in feature-list
	     thereis (loop for s 
			 in (fetch-example-info example 'selectionexpressions)
			 thereis (member f s)))))
    nil))


;;; Following function makes a copy of the example whose name
;;; is given as first parameter, and renames that copy to have
;;; the name given as second parameter and holding for the
;;; languages optionally given as third parameter.
;;; The new example is placed without ceremony on the examples
;;; list and in the examples hashtable. Optional keyword
;;; parameter specifies into what file such a new example is
;;; to be saved.

(defun RENAME-EXAMPLE (example new-name 
			       &optional (lgs (list curlan))
			       &key (file "renamed-examples.spl"))
  (let ((example-copy (copy-example (gethash example penexamples))))
    (when (stringp new-name) (setf new-name (intern new-name "KPML")))
    (when (gethash new-name penexamples)
	  (warning "Old example of name " new-name " is being overwritten!")
          (setf examples (remove-if #'(lambda (x) (equal (first x) new-name)) examples)))
    (setf (example-name example-copy)
	  (append lgs (list new-name)))
    (setf (example-ls-set example-copy) lgs)
    (setf (example-source-file example-copy) (pathname file))
    (setf (example-set-name example-copy) 
	  (fetch-example-info example 'set-name))
    (setf (gethash new-name penexamples) example-copy)
    (pushnew (cons new-name lgs) examples)
    example-copy))

;;; ----------------------------------------------------------------------
;;; Removing...

(defun ERASE-EXAMPLES ()
  (clrhash penexamples)
  (setq examples nil)
  (setq *ex-sets* nil))

;;;----------------------------------------------------------------------
;;; KPML 0.8 (2.0 changes present below)
;;; 
;;; Updating of examples taken over again and updated for multilinguality.
;;; Function update-example is called on whiteboard elements from
;;; allparts when the STORE-TO-ENVIRONMENT-FLAG is set.

;;;UPDATE-EXAMPLE: posts grammar pass activity to the example file object
;;; 2.0 grammatical-function arg added.
;;;     updates preselection record too...
(defun UPDATE-EXAMPLE (localhub grammatical-function)
  (let ((instance (gethash example-identifier penexamples)))
    (setf (example-date instance)
      (multiple-value-bind 
	  (second minute hour date month year) 
	  (get-decoded-time)
	(format nil "~2,'0D:~2,'0D:~2,'0D - ~2,'0D:~2,'0D:~2,'0D"  ;; 1.0.17
		year month date hour minute second)))

    (setf (example-KBENVIRONMENT instance) KB)
    (setf (example-TPENVIRONMENT instance) TP)
    (setf (example-INCLUDEDHUBS instance)
      (UNION (example-INCLUDEDHUBS instance) (list LocalHub)))
    (Update-Selection-Field LocalHub grammatical-function)
    (values)))

;;; Note that the discrepancy check contained under Update-Selection-Field
;;; only made sense when the hub name is identical: this is generally
;;; not the case with generation from SPLs and was developed as part
;;; of Penman when most generation was from example sets in deimplemented
;;; mode. It is possible to imagine this still being useful as long as
;;; we don't look at the hub per se but something else, for example the
;;; symbol of the SPL term that the hub points to, or the grammatical
;;; constituent being generated. This checking is now broken out into
;;; a separate function that could consider these alternatives as
;;; required.
;;;
;;; Note also, as usual with Penman, reliance
;;; on the global variable Feature-Selections that contains
;;; the current feature selections known.
;;; 
;;; 2.0 added recording of the grammatical constituent for each selection
;;;     expression also (John:Feb98).
;;;     and preselections.

(defun UPDATE-SELECTION-FIELD (Hub-Name gr-fun)
  (declare (special show-hubname-discrepancy-flag whiteboard-element
		    *Most-Recent-Example*))
  (if (or (not show-hubname-discrepancy-flag)
	  (check-new-old-selexpr-discrepancy hub-name))
      (update-example-selection-expressions hub-name gr-fun))
  (when (whiteboard-elt-featurelist whiteboard-element)
    (update-example-preselections 
     (whiteboard-elt-aliasfn whiteboard-element)
     (whiteboard-elt-featurelist whiteboard-element)))
    )

;;; 2.0 
(defun UPDATE-EXAMPLE-PRESELECTIONS (aliasfn preselections)
  (let ((old-presels 
	 (fetch-example-info *Most-Recent-Example* 'preselections curlan)))
    (unless (assoc aliasfn old-presels)
      (setf (fetch-example-info *Most-Recent-Example* 'preselections curlan)
	`( (,aliasfn ,@preselections)
	   ,@old-presels)))))

;;; 1.0.17 factored out of update-selection-field...
;;; 2.0    made to use the proper multilingual access update methods.
(defun UPDATE-EXAMPLE-SELECTION-EXPRESSIONS (hub-name gr-fun)
  (when feature-selections
    (setf (fetch-example-info 
	   *Most-Recent-Example* 'selectionexpressions curlan)
      `((,Hub-Name ,gr-fun ,@Feature-Selections)
	,@(fetch-example-info 
	   *Most-Recent-Example* 'selectionexpressions)))))


;;; ----------------------------------------------------------------------
;;; Following function is quite an old one which may be called while
;;; generating on each completed constituent. The selection expression
;;; found at that point is compared with the selection expression 
;;; maintained in the example record for that example. A dialog then
;;; checks whether the run is to be accepted or abandoned.
;;;
;;; Probably turned on with some kind of flag somewhere...
;;;
;;; 4.0   made to use the proper multilingual access update methods.
(defun CHECK-NEW-OLD-SELEXPR-DISCREPANCY (hub-name)
  (let* ((Old-Assoc (Assoc Hub-Name 
			   (fetch-example-info *Most-Recent-Example* 'selectionexpressions)
			   :test #'equal))
	 (Old-Selections 
	  (if Old-Assoc (SETQ Old-Selections (CDDR Old-Assoc)) nil)) ;;2.0
	 (New-Assoc (Cons Hub-Name Feature-Selections))
	 (Missing-Selections 
	  (set-difference Old-Selections Feature-Selections))
	 (Added-Selections (set-difference Feature-Selections Old-Selections))
	 (Changes (Or Missing-Selections Added-Selections)))
    (cond (changes
	   (printwindow
	    :display-pane
	    (indent-and-fill
	     (format nil "Discrepancy on hubname ~a inside example ~a. Missing old selections are: ~a. Added new selections are: ~a." Hub-Name *Most-Recent-Example* Missing-Selections Added-Selections )))
	   (askwindow :yes-or-no "Should the new run be retained?" ))
	  (t T))))


;;; ----------------------------------------------------------------------
;;; New KPML 0.8 functionality: comparison of examples, selection
;;; expression by selection expression, top-to-bottom, left-to-right
;;; in the constituency structure. Not yet fully operational...
;;; Left here for future work somewhen.

(defun COMPARE-EXAMPLES (eg1 eg2)
;;; build on following code:
  (let ((eg1-structure (fetch-example-info eg1 'structure))
	(eg2-structure (fetch-example-info eg2 'structure))
	(eg1-selexpr   (fetch-example-info eg1 'selectionexpressions))
	(eg2-selexpr   (fetch-example-info eg2 'selectionexpressions)))

    (loop for structure1 in eg1-structure
	  as  structure2 in eg2-structure
	  do

	  (compare-structures
	   structure1 structure2 eg1-selexpr eg2-selexpr))))

(defun COMPARE-STRUCTURES (st1 st2 se1 se2)
  (if (and (eq (printable-constituent-node-type st1) :terminal)
	   (eq (printable-constituent-node-type st2) :terminal))
      (progn
	(if (set-equal (selexp st1 se1)
		       (selexp st2 se2))
	    (progn
	      (loop for i in (printable-constituent-spelling st1)
		    as  j in (printable-constituent-spelling st2)
		    when (and (printable-constituent-p i)
			      (printable-constituent-p j))
		    do (compare-structures i j se1 se2)))
	  (selection-expression-mismatch
	   st1 st2 se1 se2)))
    (terminals-mismatch st1 st2 se1 se2)))


;;; Not there yet.
(defun SELECTION-EXPRESSION-MISMATCH (a b c d)
  (declare (ignore a b c d))
  nil)
(defun SELEXP (a b)
  (declare (ignore a b))
  nil)
(defun TERMINALS-MISMATCH (a b c d)
  (declare (ignore a b c d))
  nil)

;;; ----------------------------------------------------------------------
;;; 4.0 slight modifications that move in the direction of the above but
;;;     for slightly different purposes...

  ;; This function gets the first selection expression whose spl variable's
  ;; symbol matches the argument. Will not therefore work for more complex
  ;; SPLs where a symbol might occur in more than one place....
  ;;
(defun FETCH-SELEX-FOR-IN (spl-var example)
  (loop for selex in (fetch-example-info example 'selectionexpressions)
	if (equal (term-graph-symbol (symbol-value (first selex))) spl-var)
	return (cddr selex)))

(defun CONTRAST-SELEX-FOR-IN-AND (spl-var ex1 ex2)
  (set-difference 
   (fetch-selex-for-in spl-var ex1)
   (fetch-selex-for-in spl-var ex2)))


;;; ----------------------------------------------------------------------
;;; Used? Should actually be made redundant by the code in generic
;;;       systemic display and resource maintanance. But it is also
;;;       likely this version does a slightly different job which
;;;       should then be folded as an option into the newer code
;;;       at some point.

;;;
;;; KPML 0.8 update: can be used for normal example set file writing
;;;          or for the full glorious details depending on the setting
;;;          of the global *lef* (long example form).

(defun WRITE-EXAMPLES (directory-name &optional (example-list examples))  
  (dolist (example-name example-list)
    (let* ((example-structure (gethash example-name penexamples))
	  (file-name (format nil "~(~a~).ex" example-name))
	  (file-pathname  (merge-pathnames  file-name  directory-name)))
      (unless example-name
	(warning  "write-examples given a NIL example name")
	(return nil))
      (unless example-structure
	(warning  "Unknown example " example-name " in write-examples")
	(return nil))
      (unless file-pathname
	(warning  "Unable to create pathename")
	(return nil))
      (with-open-file (stream file-pathname :direction :output :if-exists :new-version)
	(print-mode-and-copyright stream)
	(format stream "~%(Example")
	(format stream "~%:name ~s" example-name)
	(when (example-Targetform example-structure )
	  (format stream "~%:targetform \"~a\"" (example-Targetform example-structure )))
	(when (example-logicalform example-structure )
	  (format stream "~%:logicalform  ")
	  (pprint (example-logicalform example-structure ) stream ))
	(when (example-rootnode example-structure )
	  (format stream "~%:rootnode ")
	  (pprint (example-rootnode example-structure ) stream ))
	(when (and *lef* (example-verbalizationgraph example-structure ))
	  (format stream "~%:verbalizationgraph ")
	  (pprint (example-verbalizationgraph example-structure ) stream ))
	(when (and *lef* (example-quantificationgraph example-structure ))
	  (format stream "~%:quantificationgraph ")
	  (pprint (example-quantificationgraph example-structure ) stream ))
	(when (example-paragraph-theme example-structure )
	  (format stream "~%:paragraph-theme ")
	  (pprint (example-paragraph-theme example-structure ) stream ))
	(when (example-focus example-structure )
	  (format stream "~%:focus ")
	  (pprint (example-focus example-structure ) stream ))
	(when (and *lef* (example-includedhubs example-structure ))
	  (format stream "~%:includedhubs ")
	  (pprint (example-includedhubs example-structure ) stream ))
	(when (and *lef* (example-selectionexpressions example-structure ))
	  (format stream "~%:selectionexpressions ")
	  (pprint (example-selectionexpressions example-structure ) stream ))
	(when (example-comments example-structure )
	  (format stream "~%:comments \"~a\"" (example-comments example-structure )))
	(when (example-editor example-structure )
	  (format stream "~%:editor \"~a\"" (example-editor example-structure )))
	(when (example-date example-structure )
	  (format stream "~%:date \"~a\"" (example-date example-structure )))
	(when (and *lef* (example-kbenvironment example-structure))
	  (format stream "~%:KBenvironment ")
	  (pprint (example-kbenvironment example-structure) stream ))
	(when (and *lef* (example-tpenvironment example-structure))
	  (format stream "~%:TPenvironment "  )
	  (pprint (example-tpenvironment example-structure) stream ))
	(when (and *lef* (example-discoursecontext example-structure))
	  (format stream "~%:discoursecontext ")
	  (print-dc (example-discoursecontext example-structure) stream))
	(format stream ")")
	))))


;; ----------------------------------------------------------------------
;; 4.0
;;
;; This is a step towards the extended example records, where the
;; selection expression information is properly included within
;; the single structure. Probably make this available on the basis
;; of a flag at some stage.

(defun INCLUDE-SELEXPRS-IN-EXAMPLE-RECORD (exname)
  (let ((s (fetch-example-info exname 'structure))
	(selexprs (fetch-example-info exname 'selectionexpressions)))
    (labels ((update-features 
	       (subcomp &optional (fundle-name nil))
	       (let* ((fundle (kpml::printable-constituent-functions subcomp))
		      (concept (kpml::printable-constituent-concept subcomp))
		      (sel1 (loop for (c f . p) in selexprs
			      when (or (equal f fundle-name)
					(member f fundle :test #'equal))
			      do (return p)
			      finally (return nil))))
		 (setf (printable-constituent-features subcomp)
		       (reverse sel1))))

	      (include-selexprs 
	       (subcomp)
	       (cond ((typep subcomp 'printable-constituent)
		      (unless ;; (or (equal (printable-constituent-node-type subcomp) :terminal)
				  (printable-constituent-features subcomp)
			      ;; )
			(update-features subcomp)
			(loop for sub in (printable-constituent-spelling subcomp)
			  do (include-selexprs sub)))))))
      
      (if (consp s) s (setf s (list s)))
      (loop for s0 in s 
	do 
	(update-features s0 '-top-)
	(dolist (subcomp (printable-constituent-spelling s0))
	  (include-selexprs subcomp))))))

;;; ----------------------------------------------------------------------
;;; The following is a sketch of how to use the *clean-example-records*
;;; flag to do simple comparisons of new and old generations. 
;;; Note though that if the example has been reevaluated
;;; then the old information is in any case lost, so that it is simpler
;;; to compare across versioned examples which does not need any flag
;;; setting anyway.
;;;
;;; When the
;;; flag is unset, the new generation results are simply added into
;;; the example record. Since SPLs create their own hub names on the
;;; fly it is necessary to establish some relation between the new
;;; ones and the old ones. This could be done in a number of ways,
;;; including checking of the term-graphs, or more straightforwardly,
;;; by assuming that approximately the same structure is being built.
;;; In the latter case, taking the list example-includedhubs prior
;;; to generation will give keys for getting at selection expressions.
;;; Taking the new additions to example-includedhubs after generation
;;; *in the same order* will then give keys to the probably corresponding
;;; selection expressions for the new generation. These can then be
;;; compared. 

;;; The following function does the standard comparisons but taking
;;; example names and two hub-names whose selection expressions are
;;; to be compared...

(defun COMPARE-EXAMPLE-SELECTION-EXPRESSIONS 
    (example Hub-Name example-2 Hub-Name-2)
  (PROG (New-selections Missing-Selections 
			Added-Selections Changes Old-Selections)
	(setf Old-Selections
	  (rest (assoc Hub-Name 
		       (example-selectionexpressions 
			(gethash Example penexamples)) :test #'equal)))
	(setf New-selections
	  (rest (assoc Hub-Name-2 
		       (example-selectionexpressions 
			(gethash Example-2 penexamples)) :test #'equal)))
	(SETQ Missing-Selections 
	      (set-difference Old-Selections New-Selections))
	(SETQ Added-Selections 
	      (set-difference New-Selections Old-Selections))
	(SETQ Changes (Or Missing-Selections Added-Selections))
	(cond (changes
	       (printwindow
		:display-pane
		(indent-and-fill
		 (format nil "Discrepancy on hubname pair ~a [~a]/~a [~a]. 
Missing old selections are: ~a. 
Added new selections are: ~a." 
			 Hub-Name Example Hub-Name-2 Example-2
			 Missing-Selections Added-Selections ))))
	      (T
	       (printwindow
		:display-pane
		(indent-and-fill
		 (format nil "No discrepancy on hubname pair ~a [~a]/~a [~a]."
			 Hub-Name example Hub-Name-2 example-2)))))))


;;; ----------------------------------------------------------------------
;;; A more careful attempt to get examples, etc. in an appropriate order
;;; when worked on as a set...
;;;
;;; Example names are interpreted as consisting of either a base followed
;;; immediately by a number (e.g., behrens23) or by a base with a separator
;;; (e.g., new-behrens-23), possibly followed by a further version indicator
;;; (e.g., behrens-23b or behrens-23imperative).
;;;
;;; An example name may be followed by any sequence of characters in square
;;; brackets which are not then significant for the sorting... This only
;;; applies if the final character is a closing square bracket.
;;; ----------------------------------------------------------------------
;;; 2.0.25

(defvar *SYMBOL-NAME-NUMBER-DELIMITER-CHAR* #\-)

(defun EXTRACT-NAME-PARTS (symbol)
  (let* ((string (string symbol)))
    (let* ((string
            (if (and (char= (char string (1- (length string))) #\])
                     (position #\[ string :from-end T))
                (subseq string 0 (position #\[ string :from-end T))
              string))
	   (position 
            (let* ((l (length string)))
              (loop for i = (position 
                             *symbol-name-number-delimiter-char* 
                             (subseq string 0 l)
                             :from-end T)
                    while i
                    if (and (< i (- l 2))
                            (digit-char-p (char string (1+ i))))
                    do (return i)
                    else do (setf l i)
                    finally (return nil))))
	   (position1 (if position (1+ position) 0)))
      (if (and position
	       (< position1 (length string))
	       (digit-char-p (char string position1)))
	  (loop for i from position1 to (1- (length string))
	        while (digit-char-p (char string i))
	        collect (char string i) into number
	        finally 
	        (return 
		 (values (subseq string 0 position)
			 (read-from-string (coerce number 'string))
			 (subseq string i))))
        (if (string= 
	     string
	     (string-right-trim '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
			        string))
	    (values symbol 0 "")
	  (values (string-right-trim (list *symbol-name-number-delimiter-char*)
                                     ;; 3.1 was not quite right when the delimiter was present...
                                     (remove-if #'digit-char-p string :from-end T)
                                     )
		  (read-from-string
		   (subseq string
			   (1+
			    (position-if-not 
			     #'digit-char-p string :from-end T))))
		  ""))))))
  
(defun NUMBERED-NAME-LESSP (name1 name2)
  (multiple-value-bind (base1 number1 affix1)
      (extract-name-parts name1)
    (multiple-value-bind (base2 number2 affix2)
	(extract-name-parts name2)
      (or (string-lessp base1 base2)
	  (and (string= base1 base2)
	       (< number1 number2))
	  (and (string= base1 base2)
	       (= number1 number2)
	       (string-lessp affix1 affix2))))))

;;; ----------------------------------------------------------------------
;;; 3.2.70 Some extra example selection functions...
;;; ----------------------------------------------------------------------

(defun EXAMPLES-WITH-SUBSTRING (sub &key (case-sensitive nil))
  (let ((exs (get-examples-with-substring 
              sub :case-sensitive case-sensitive)))
    (when exs
      (loop for e in exs
	    do (format t "~%~A: ~A"  e (fetch-example-info e 'targetform))))))

 ;; 4.0 variation that just returns the examples rather than
 ;;     printing them...

(defun GET-EXAMPLES-WITH-SUBSTRING (sub &key (case-sensitive nil))
  (loop for e in (list-of-examples)
	when (substring sub (fetch-example-info e 'targetform)
                        :case-sensitive case-sensitive)
        collect e))

;; 4.0 an alias...
(defun SEARCH-EXAMPLES-FOR-SUBSTRING (sub &key (case-sensitive nil))
  (get-examples-with-substring sub :case-sensitive case-sensitive))

