(in-package "KPML")

;;; ----------------------------------------------------------------------
;;; File: string-cleanups.lisp
;;; 1.0.24

;;; Provides a more accessible way of defining clean-up methods for
;;; final strings: this is the place to put removals of duplicated
;;; punctuation, for example, that gets there due to the mismatch
;;; between punctuation rules and syntactic structure.

;;; A declaration is provided of cleanups that is made language
;;; sensitive in the same way as punctuation rules and default orderings.
;;; Resources typically inherit the standard list from English but may
;;; change these in the property files as required.

;;; ----------------------------------------------------------------------
;;; Note that there are some nasty things plus old redundent code in 
;;; express.lisp for massaging strings into shape. This also includes
;;; the ITRI French de le -> du, etc. changes, which should be
;;; parameterized. Things with the spacing are also going on there,
;;; and so should be fixed up some time.
;;;
;;; 2.0 phonological-processing is now made a method that can be
;;;     specialized for particular langauges. Note that the difference
;;;     between phonological-processing changes and string clean-ups
;;;     is that the former still has a notion of word or element in
;;;     structure, the latter is purely a string operation.
;;;
;;;     N.B. THESE METHODS ARE NOW IN morphology.lisp
;;; ----------------------------------------------------------------------

(defvar *string-cleanup-list*
    '(:multilingual
      (T                                ;;; this is the default

       ("," " & *[*")			; it is necessary to 
       (" "  "*[* ")			; take account of structure in order 
       (""  "*[*")			; to replace and's by commas in lists 
       ("and" "&")			; appropriately.
       
       ("," ",,")			; these  deal with the occasional
       ("." ",.")			; multiple punctuation that
       ("." ".,")			; occurs due to embedding...
       ("?" "?.")	
       ("!" "!.")

       ("." " .")                       ; these deal with some extra spaces
       ("," " ,")			; that come in from the morphology
       (" " "  ")                       ; code. They could go if that code
       ("?" " ?")			; was more careful about where it
       ("!" " !")                       ; put spaces in!
       )))



;;; ----------------------------------------------------------------------
;;; The user access...

(defmacro DEFINE-STRING-CLEAN-UPS
  (&key (language nil)(clean-ups nil))
  (if (and language clean-ups)
      `(merge-in-string-clean-ups ,language ',clean-ups)
    (warning "Ill-formed string clean-up definition!")))

(defun MERGE-IN-STRING-CLEAN-UPS (lg clean-ups)
  (cond ((eq (car *string-cleanup-list*) :multilingual)
	 (let* ((consumed nil)
		(modified-cleanup-list
		 (loop for lg-cleanups in (cdr *string-cleanup-list*)
		     when (eq (first lg-cleanups) lg)
		     collect 
		       (progn 
			 (warning "String clean-ups for language " lg
				  " being updated.")
			 (setf consumed t)
			 (cons lg clean-ups))
		     else collect lg-cleanups)))
	   (unless consumed (push (cons lg clean-ups) modified-cleanup-list))
	   (setf *string-cleanup-list* 
	     (cons :multilingual modified-cleanup-list))))
	(t
	 (when *string-cleanup-list*
	       (warning "Previous ill-formed string cleanup list for "
			lg " is being over-written."))
	 (setf *string-cleanup-list* 
	   (cons :multilingual
		 (list (cons lg clean-ups)))))))


(defun ML-STRING-CLEAN-UPS ()
  (cond ((eq (car *string-cleanup-list*) :multilingual)
	 (let ((clean-ups (assoc curlan (cdr *string-cleanup-list*))))
	   (if clean-ups (rest clean-ups)
	     (rest (assoc T (cdr *string-cleanup-list*))))))
	(t
	 (warning "Ill-formed string clean-up list: " *string-cleanup-list*)
	 nil)))

;;; ----------------------------------------------------------------------
;;; Replaces function from mouseable-generated-strings.lisp

(defun GRAPHOLOGICAL-PROCESSING (string pointers)
  (let ((result string))
    (loop for (new old) in (ml-string-clean-ups)
	do
	  (setq result 
	    (substitute-preserving-ptrs 
	     (typecase new
	       (cons (case (first new)
		       (:string (second new))
		       (:lexeme (fetch-lexicon-info (second new) 'spelling))))
	       (t new))
	     (typecase old
	       (cons (case (first old)
		       (:string (second old))
		       (:lexeme (fetch-lexicon-info (second old) 'spelling))))
	       (t old))
	     result pointers)))
    result))

;;; ----------------------------------------------------------------------
;;; And the corresponding writing function...

(defun WRITE-STRING-CLEANUP-DECLARATIONS (stream lg-specifier)
  (format stream "~2%(define-string-clean-ups
  :language ~S 
  :clean-ups ~S)" lg-specifier (ml-string-clean-ups)))

;;; ----------------------------------------------------------------------
;;; 0.9 a little something for fairly drastic forcing of the
;;;     final string into presentable form. Any spaces before 
;;;     a member of the punctuation bag are removed and sequences of
;;;     spaces are replaced by a single space.
;;; 3.1 was missing very short strings with extra spaces in...
;;; 4.0 the definition of the punctuation characters is moved out
;;;     to the initialization/variables as it is useful in a couple
;;;     of other places too. Also needed extending for Spanish, so
;;;     contains non ASCII-characters already.
;;; ----------------------------------------------------------------------

(defun CLEAN-UP-FINAL-STRING (s)
  (if (and s
	   (stringp s))
      (if (> (length s) 3)
          (string-trim '(#\space)
		       (coerce
		        (append
		         (loop for i from 0 to (- (length s) 2)
			       as ch1 = (elt s i)
			       as ch2 = (elt s (1+ i))
			       unless (and (member ch2 *punctuation-bag*)
				           (char= ch1 #\space))
			       collect ch1)
		         (cons (elt s (1- (length s))) nil))
		        'string))
        (string-trim  '(#\space) s))
  s))



