(in-package "KPML")

;;; File: utilities.lisp
;;; 
;;; General utilities for various bits of functionality, some left
;;; over from Penman and not yet weeded out, most new.

 ;; --------------------------------------------------
 ;; But first...
 ;; for some Lispworks appear not
 ;; to have heard of this function!

#+(and lispworks win32)
(eval-when (compile load)
	   (when (find-package "WIN32")
	     (unless (fboundp 'WIN32::LB_SETTOPINDEX-AUX)
	       (defun WIN32::LB_SETTOPINDEX-AUX (&rest args) 0))))

 ;; --------------------------------------------------


;;; ----------------------------------------------------------------------
;;; General KPML function for marking objects, files, etc. for their
;;; date and time of creation...
;;; 2.1 make to produce leading zeros.
;;; ----------------------------------------------------------------------

(defun TIME-STAMP ()
  (multiple-value-bind (second minute hour date month year) (get-decoded-time)
    (format nil "~a-~a-~a ~2,'0d:~2,'0d:~2,'0d" 
	    date month year hour minute second)))

;;; ----------------------------------------------------------------------
;;; 1.1
;;; The following is quite important and new. It provides a non-compiler
;;; based option for making standalone images that may be freely 
;;; distributed.
;;; ----------------------------------------------------------------------

;;; ----------------------------------------------------------------------
;;; Following does all the work of interpreting KPML-exprs. The macro
;;; is used in kpml-eval below and in the loader.
;;; ----------------------------------------------------------------------

(defmacro EVAL-KPML-FORM ()
  '(case (first form)
    (KPML-LOAD
     (setf opn-count (1+ opn-count))
     (kpml-load (rest form)))
    (CLEAR
     (setf opn-count (1+ opn-count))
     (generic-resource-clearing (rest form)))
    (SET-LOADING-DEFAULTS
     (setf opn-count (1+ opn-count))
     (setf kpml::*in-ml-region* T)
     (setf kpml::*current-default-languages* (rest form)))
    (CLEAR-LOADING-DEFAULTS
     (setf opn-count (1+ opn-count))
     (setf kpml::*in-ml-region* nil)
     (setf kpml::*current-default-languages* nil))
    (SYSTEM 
     (setf system-count (1+ system-count))
     (load-ml-system (rest form) :system))
    (GATE 
     (setf system-count (1+ system-count))
     (load-ml-system (rest form) :gate))
    (CHOOSER
     (setf chooser-count (1+ chooser-count))
     (load-ml-chooser (rest form)))
    ((ASKOPERATOR IDENTIFYOPERATOR)
     (setf inquiry-count (1+ inquiry-count))
     (load-ml-inquiry (rest form)))
    (LEXICAL-ITEM
     (setf lexeme-count (1+ lexeme-count))
     (load-ml-lexicon (rest form)))
    (EXAMPLE
     (setf example-count (1+ example-count))
     (example-1 (rest form)))
    (DEFINE-DEFAULT-ORDERS
	(setf declaration-count (1+ declaration-count))
	(merge-in-default-order (extract-keyword :language)
	 (extract-keyword :orders)))
    (DEFINE-DEPENDENCY-SET
	(setf declaration-count (1+ declaration-count))
	(register-system-dependency-set 
	 (extract-keyword :language)
	 (extract-keyword :name)
	 (extract-keyword :systems-list)))
    (DEFINE-SYSTEM-DEPENDENCIES
	(setf declaration-count (1+ declaration-count))
	(merge-in-system-dependencies 
	 (extract-keyword :language)
	 (extract-keyword :dependencies)))
    (DEFINE-PRE-PUNCTUATION 
	(setf declaration-count (1+ declaration-count))
	(merge-in-pre-punctuation 
	 (extract-keyword :language)
	 (extract-keyword :punctuation-rules)))
    (DEFINE-POST-PUNCTUATION 
	(setf declaration-count (1+ declaration-count))
	(merge-in-post-punctuation
	 (extract-keyword :language)
	 (extract-keyword :punctuation-rules)))
    (DEFINE-POST-SELF-PUNCTUATION 
	(setf declaration-count (1+ declaration-count))
	(merge-in-post-self-punctuation
	 (extract-keyword :language)
	 (extract-keyword :punctuation-rules)))
    (DEFINE-PRE-SELF-PUNCTUATION 
	(setf declaration-count (1+ declaration-count))
	(merge-in-pre-self-punctuation
	 (extract-keyword :language)
	 (extract-keyword :punctuation-rules)))
    (DEFINE-STRING-CLEAN-UPS
	(setf declaration-count (1+ declaration-count))
	(merge-in-string-clean-ups
	 (extract-keyword :language)
	 (extract-keyword :clean-ups)))
    ((DISABLE-SYSTEM ENABLE-SYSTEM)
     (apply (first form) (rest form)))
    (DEFSPL-DEFAULT
	(setf declaration-count (1+ declaration-count))
	(let ((env-name (first (rest form)))
	      (features (cddr form)))
	  (if (eq (first features) 'constant)
	      (define-default-env 
		  env-name 
		  (process-features (rest features) nil)
		:constant t)
	    (define-default-env 
		env-name (process-features features nil)))))
    (DEFSPL-MACRO
	(setf declaration-count (1+ declaration-count))
	(defspl-macro-1 (second form) (third form)))
    (BEGIN-DEFAULT
     (setf declaration-count (1+ declaration-count))
     (begin-default-env (cadr form)))
    (END-DEFAULT
     (setf declaration-count (1+ declaration-count))
     (end-default-env (cadr form)))
    (DEFINE-LANGUAGE-STANDARD-DEFAULTS
	(setf declaration-count (1+ declaration-count))
	(setf *language-standard-defaults*
	  (merge-in-spl-defaults-declaration 
	   (intern 
	    (string (extract-keyword :language)) :keyword)
	   (extract-keyword :defaults)
	   *language-standard-defaults*)))
    ;; 2.0
    (DEFINE-LANGUAGE-STANDARD-ABBREVIATION 
	(setf declaration-count (1+ declaration-count))
	(pushnew (cons 
		  (extract-keyword :language)
		  (extract-keyword :abbreviation))
	 *contrastive-labels*
	 :test #'equal))
    (ENSURE-LANGUAGE-RANGE 
     (setf declaration-count (1+ declaration-count))
     (let ((only (first (rest form)))
	   (lgs (cddr form)))
       (if (second only)
	   (setf all_languages lgs)
	 (loop for lg in lgs
	     do (pushnew lg all_languages)))))
    (DEFINE-LANGUAGE-DESCRIPTION
      (setf declaration-count (1+ declaration-count))
      (let ((language nil)
	    (style nil)
	    (description (cddr form)))
      (let* ((form (second form)))
	(setf language (extract-keyword :language)
	      style    (extract-keyword :style :allow-nil-p T)))
      (setf *language-description-profiles*
	    (merge-in-description-declaration 
	     (intern (string language) :keyword)
	     (if style style :html)
	     description
	     *language-description-profiles*))))
    (DEFINE-EXSET-DESCRIPTION
      (setf declaration-count (1+ declaration-count))
      (let ((language nil)
	    (name nil)
	    (version nil)
	    (style nil)
	    (description (cddr form)))
      (let* ((form (second form)))
	(setf language (extract-keyword :language)
	      version  (extract-keyword :version)
	      name     (extract-keyword :name)
	      style    (extract-keyword :style :allow-nil-p T)))
      (setf *language-exset-profiles*
	    (merge-in-exset-description-declaration 
	     (intern (string language) :keyword)
	     name style version description 
	     *language-exset-profiles*))
      ))
    (DEFINE-LANGUAGE-FONT-REQUIREMENTS
	(setf declaration-count (1+ declaration-count))
	(let ((font (extract-keyword :font :allow-nil-p T))
	      (inspector 
	       (extract-keyword :inspector :allow-nil-p T))
	      (popup
	       (extract-keyword :popup :allow-nil-p T))
              ;; 3.1 addition
              (code-page
               (extract-keyword :code-page :allow-nil-p T)))
	  (unless (and (or font inspector) (or font popup))
	    (extract-keyword :nonsense))
	  (setf *language-font-profiles*
	    (merge-in-font-profile-declaration 
	     (intern 
	      (string (extract-keyword :language)) :keyword)
             (if code-page code-page nil)
	     (if inspector inspector font)
	     (if popup popup font)
	     *language-font-profiles*))))
    (DECLARE-GRAPH-STOP-POINTS
     (declare-graph-stop-points-fn (rest form)))
    (DEFINE-LANGUAGE-MORPHOLOGY-REQUIREMENTS
	(setf declaration-count (1+ declaration-count))
	(setf *language-morphology-profiles*
	  (merge-in-morphology-declaration 
	   (intern 
	    (string (extract-keyword :language)) :keyword)
	   (extract-keyword :systemicized :allow-nil-p T)
	   (extract-keyword :generator-fn :allow-nil-p T)
	   (extract-keyword :generator-file :allow-nil-p T)   ;; 3.3
	   *language-morphology-profiles*)))
    (IN-PACKAGE
     (setf declaration-count (1+ declaration-count)))
    (IN-REGION
     (setf declaration-count (1+ declaration-count))
     (setf *in-ml-region*           t
	   *current-default-region* (extract-keyword :name)
	   *current-default-languages* 
	   (approve-languages 
	    (if (listp
		 (extract-keyword :languages :allow-nil-p T))
		(mapcar #'(lambda (x)
			    (intern (string x) :keyword))
			(extract-keyword :languages
					 :allow-nil-p T))
	      (list 
	       (intern (string 
			(extract-keyword :languages))
		       :keyword))))))
    (IN-LANGUAGE
     (setf *in-ml-region* T 
	   *current-default-languages* 
	   (approve-languages
	    (remove-duplicates
	     (if (listp (extract-keyword :languages
					 :allow-nil-p T))
		 (mapcar #'(lambda (x)
			     (intern (string x) :keyword))
			 (extract-keyword :languages
					  :allow-nil-p T))
	       (list 
		(intern 
		 (string 
		  (extract-keyword :languages))
		 :keyword)))))))
    (END-REGION (clear-region-and-language-defaults))
    (LOAD-LINGUISTIC-RESOURCES
     (setf opn-count (1+ opn-count))
     (apply #'load-linguistic-resources (rest form)))
    (START-EMACS-SERVER
     #+acl3.0
     (when (find-package "DDE")
	   (funcall (intern "EDITI-PATCH-DDE" 'dde))
	   (setq acl::*editi-dde-port* nil)
	   (acl::editi-open-server)))
    (SET-LANGUAGE
     (setf opn-count (1+ opn-count))
     (setf curlan (second form)))
    
    (otherwise
     (cond 
      ((fboundp (first form))
       (apply (first form) (rest form)))
      ((equal (first form) 'setq)
       (setf opn-count (1+ opn-count))
       (set (second form) (third form)))
      ((equal (first form) 'defun)
       (format *trace-output*
	       "~%;;; Warning: cannot KPML-eval a defun! ~A" (second form))
       nil)
      (t
       (let ((message 
	      (format nil "Unrecognised form in evaluation: ~A" 
		      (subseq form 0 (min 4 (length form))))))
	 (warning message)
	 (format *trace-output* "~%;;; ~A" message)))
    ))))

;;; ----------------------------------------------------------------------
;;; Calls to the following function replace all uses of eval in KPML
;;; code using the above methods. 
;;; ----------------------------------------------------------------------

(defun KPML-EVAL (form)
  (if (not *standalone*)
      (eval form)
    (let ((system-count 0)
	  (chooser-count 0)
	  (inquiry-count 0)
	  (lexeme-count 0)
	  (example-count 0)
	  (declaration-count 0)
	  (opn-count 0)
	  )
      (cond ((or (numberp form)(null form)(stringp form))
	     (return-from KPML-EVAL form))
	    ((symbolp form)
	     (return-from KPML-EVAL 
	       (if (boundp form) (symbol-value form) nil))))
      (labels ((EXTRACT-KEYWORD (key &key (allow-nil-p nil))
		 (let ((p (position key form))
		       (res nil))
		   (cond ((and (numberp p) (< p (length form)))
			  (setf res (nth (1+ p) form))
			  (if res 
			      (return-from EXTRACT-KEYWORD 
				(if (and (consp res)
					 (eq (first res) 'quote))
				    (second res)
				  res))
			    (if allow-nil-p (return-from EXTRACT-KEYWORD nil)
			      (progn
				(format 
				 *trace-output* 
				 "~%;;; ... kpml eval error (nil arg): ~S" 
				 form)
				(throw 'kpml-load-error nil)))))
			 (allow-nil-p (return-from EXTRACT-KEYWORD nil))
		       (t
			(format *trace-output* 
				"~%;;; ... kpml eval error: ~S" form)
			(throw 'kpml-load-error nil))))))

	(catch 'kpml-load-error
	  (eval-kpml-form))))))

;;; ----------------------------------------------------------------------
;;; For the editing protocol when a user makes changes to loaded 
;;; resources via the KPML interface and Emacs.
;;; ----------------------------------------------------------------------

(defvar *editing-protocol* T)
(defvar *sparsam* nil)

;;; ----------------------------------------------------------------------
;;; 2.0.42, Dec98
;;; Previous protocol recording was still a bit too
;;; sensitive to system crashes (yes, this is mostly
;;; for PCs... how did you guess?). Also was a little ugly
;;; in that it opened a stream at the outset and kept it
;;; open throughout the KPML session: this is what makes it
;;; more sensitive than it need be, since it cannot be
;;; absolutely clear what happens to an open stream in
;;; a system crash. So we update to always open and close
;;; the editing protocol each time we protocol something.
;;; Also changed so that actions only occur when the flag
;;; *editing-protocol* is set T.
;;; 
;;; The former global kpml::*kpml-editing-changes-stream* is no
;;; longer used, which lets us get rid of some tiresome conditionalizations
;;; anyway. The defvar for this can be removed from variables.lisp
;;; and the comment there about protocolling updated.
;;; ----------------------------------------------------------------------

(defun OPEN-AND-START-EDITING-LOG ()
  (when *editing-protocol*
    (with-open-file (stream (pathname kpml::*kpml-editing-changes-log*)
		     :direction :output 
                     :if-does-not-exist :create
                     :if-exists (if *sparsam* :rename 
                                  #+unix :new-version
                                  #-unix :append
                                  ))
      (format stream "~2%;;; FILE OF RESOURCE CHANGES MADE FROM KPML.")
      (format stream "~%;;;  (STARTED AT ~A)"  (kpml::time-stamp)))
    T))

(defun PROTOCOL-EDIT (protocol)
  (when *editing-protocol*
    (with-open-file (stream (pathname kpml::*kpml-editing-changes-log*)
		     :direction :output 
		     :if-exists :append
		     :if-does-not-exist :create)
      (format stream "~2%;;; ~A -- current language is ~S" 
	      (kpml::time-stamp) curlan)
      (if (stringp protocol)
	  (format stream "~%~A" protocol)
	(format stream "~%~S" protocol))))
  protocol)

(defun CLOSE-EDIT-PROTOCOL-STREAM ()
  (when *editing-protocol*
    (with-open-file (stream (pathname kpml::*kpml-editing-changes-log*)
		     :direction :output 
		     :if-exists :append
		     :if-does-not-exist nil)
      (format stream "~2%;;; FILE OF RESOURCE CHANGES CLOSED AT ~A.~2%"
	      (kpml::time-stamp))
      )))

;;; ----------------------------------------------------------------------
;;; Stubbs... generally overwritten if the interface is also loaded.
;;; ----------------------------------------------------------------------

;;; stubb, redefined if the interface is loaded.
(defun DECLARE-GRAPH-STOP-POINTS-FN (list)
  nil)

(defmacro DECLARE-GRAPH-STOP-POINTS (&rest args)
  `(declare-graph-stop-points-fn ',args))

;;; Stubbs when no coder loaded...
(defun UPDATE-CODING-STATS ()  nil)
(defun GET-CODINGS-FOR-SYSTEMS (l) (declare (ignore l)) nil)

;;;------------------------------------------------------------
;;; Utility function for multiple language merging...
;;;
;;; Takes two association lists, and replaces all the values of
;;; the old list which are keyed in the new list, as well as
;;; adding in fully new elements contains in the new list.
;;; ----------------------------------------------------------------------

(defun REPLACE-KEYED-ELEMENTS (alist-old alist-new)
  (let ((alist-result alist-new))
    (dolist (pair alist-old)
	    (unless (assoc (first pair) alist-result)
		    (push pair alist-result)))
    (sort alist-result #'(lambda (x y) (string< (first x) (first y))))))

;;; ----------------------------------------------------------------------
;;; Odds and ends...
;;; ----------------------------------------------------------------------

(defun REMOVE-ASSOC-LIST-ELT (elt list)
  (prog ((found (assoc elt list)))
	(return (cond (found
		       (dremove found list))
		      (t
		       list)))))

(defun LIST-SKIPPING-NILS (&rest body)
  (let ((final-list nil))
    (dolist (x body)
      (when x
	(setq final-list (append final-list x))))
    final-list))

(defun SET-EQUAL (set1 set2)
  (and (subsetp set1 set2)
       (subsetp set2 set1)))

(defun NOT-NULL (x)
  (or (consp x)
      (and (stringp x)
	   (not (string= x "")))))

(defun INTERSECTION-USING-EQUAL-TEST (list1 list2)
  "This uses equal and (intersection nil '(a b)) gives t"
  (if (not list1)
      t
      (intersection list1 list2 :test #'equal)))

(defun FLATTEN (list)
  (cond ((null list) nil)
	((listp (car list))
	 (append (flatten (car list))
		 (flatten (cdr list))))
	(t
	 (cons (car list)
	       (flatten (cdr list))))))

(defun FLATTEN-TILL (list mark)
  (cond ((null list) nil)
	((and (listp (car list))
              (not (equal (caar list) mark)))
	 (append (flatten-till (car list) mark)
		 (flatten-till (cdr list) mark)))
	(t
	 (cons (car list)
	       (flatten-till (cdr list) mark)))))

;;; ----------------------------------------------------------------------
;;; Check if CONS is a singleton list (from Knut: Feb98)
;;; ----------------------------------------------------------------------

(defun SINGLETON (cons)
   (and (consp cons) (= 1 (length cons))))

;;; ----------------------------------------------------------------------
;;; Very old Penman function. Not much idea what it is
;;; for (John:March97). TOPLSUBST
;;; 2.1 removed: not used in KPML.
;;; ----------------------------------------------------------------------

;;; ----------------------------------------------------------------------
;;; SPL utility... Following additional function makes sure that the argument
;;; (if it is quoted) ends up in the right package for 
;;; SPL specs...
;;; ----------------------------------------------------------------------

(defun INTERN-FEATURE (arg)
  (if (and (consp arg)
	   (eq (first arg) 'quote))
      `(quote ,(intern (string (second arg)) *spl-specs-package*))
    arg))

;;; ----------------------------------------------------------------------
;;; Hashtable manipulation...
;;; ----------------------------------------------------------------------

(defun HASHTABLE-TO-LIST (hashtable)
  (let ((result-list nil))
    (maphash #'(lambda (key val)
		 val
		 (push key result-list))
	     hashtable)
    result-list))

(defun HASHVALUES-TO-LIST (hashtable)
  (let ((result-list nil))
    (maphash #'(lambda (key val)
		 (declare (ignore key))
		 (push val result-list))
	     hashtable)
    result-list))

;;; --------------------------------------------------------------------
;;; Functions that extract lists of things from various data structures. 
;;; Used by some of the print functions. (at least).
;;; ----------------------------------------------------------------------

(defun list-of-brownboard-elt-functionlist (bundle)
  "returns the list of the conflation alias and the conflation othernodes of the 
   fucntion list of a brownboard element"
    (append (list (conflation-alias (brownboard-elt-functionlist bundle)))
	    (conflation-othernodes (brownboard-elt-functionlist bundle))))

(defun list-of-brownboard-elt-featurespecs (bundle)
  "returns the list of all feature specs of a bundle"
  (let((result nil))
    (dolist (item (brownboard-elt-featurespecs bundle))
      (push (list (selection-def-id item)
		  (selection-def-fn item)
		  (selection-def-features item))
	    result))
    result))

(defun list-of-brownboard-elt (bundle)
  (list (list-of-brownboard-elt-functionlist bundle)
	(list-of-brownboard-elt-featurespecs bundle)))

;;; ----------------------------------------------------------------------
;;; The following is needed to make runtime evaluated setf's work 
;;; under ACL runtime for PCs... It should be used
;;; instead of issuing an (eval '(setf ... )) form. Its a bit ugly
;;; and very dependent on ACL-specifics...
;;; ... if someone knows a better way, please tell me...
;;; (John:Oct97)
;;; ----------------------------------------------------------------------

#+(and acl3.0 aclpc)
(defun KPML-APPLY-ACL-SETF-OF (function-name place value)
  (let ((setf-function nil)
	(property-list (symbol-plist function-name)))
    ;; there appear to be a variety of ways in which ACL record the
    ;; information about setf-methods. 

  (cond ((setf setf-function (getf property-list 'acl::simple-setf))
	 ;; The simplest is when there
	 ;; is a function to call that has been defined straightforwardly
	 ;; with a (defsetf f accessor-f) form. To recognize this we
	 ;; can look for an acl::simple-setf on the property-list of
	 ;; the function-name symbol

	 (funcall setf-function place value))

	((setf setf-function (getf property-list 'acl::fmacro-assist))
	 ;; Another case is when we have a structure slot accessor,
	 ;; in these cases there is a property acl::fmacro-assist (uggh!)
	 ;; In this case, we can make a change of the slot value
	 ;; with the form (sys::sset structure slot-number value)
	 (sys::sset place (second setf-function) value))

	(t
	 (format *trace-output* 
		 ";;; Unknown setf-method for: ~S (plist: ~S )"
		 function-name property-list)))))


;;; ----------------------------------------------------------------------
;;; 3.1 
;;;  in an overrapid autoconversion away from string-append to concatenate
;;;  it was being overlooked that some of the arguments were not always
;;;  strings... This now then breaks. So the function is provided again...
;;; ----------------------------------------------------------------------

(defun STRING-APPEND (&rest args)
  (apply #'concatenate
         (cons 'string
               (loop for a in args 
                     if (stringp a)
                     collect a
                     else
                     collect (format nil "~S" a)))))


;;; 3.2.70 not sure if we have got one of these already...
;;; 4.0    case sensitivity option added

(defun SUBSTRING (sub string &key (case-sensitive T))
  (labels ((compare (c1 c2)
                    (if case-sensitive
                        (char= c1 c2)
                      (char= (char-upcase c1)(char-upcase c2)))))
    (loop for i from 0 to (- (length string)(length sub))
	  when (compare (char string i)(char sub 0))
	  do
	  (if 
	      (loop for j from 0 to (1- (length sub))
		    for k from i
		    always (compare (char sub j)(char string k)))
	    (return T)
	  (return NIL)))))



;;; ----------------------------------------------------------------------
;;; Utilities for Unicode and XML processing
;;; ----------------------------------------------------------------------

  ;; Following checks to see if we have a Unicode file at hand. Relies
  ;; on the convention that XML files seem to have of starting with
  ;; a recogniseable character so that tools can detect and switch
  ;; appropriately. Only looks if we are in Lispworks (for the
  ;; the present...). Note that we have to be very explicit about
  ;; the external format mode otherwise Lispworks under certain
  ;; conditions appears to ignore it.
  ;;
  ;; Still to check: whether ACL5 and 6 allow the same treatment,
  ;;                 whether the external-format value has to differ
  ;;                   for different systems and Lisps.
  ;;
(defun UNICODE-FILE-P (file)
  #-lispworks nil
  #+lispworks
  (with-open-file 
   (stream (pathname file)
	   :direction :input 
	   :external-format '(:UNICODE :EOL-STYLE :CRLF))
   
   (char= #\Zero-Width-No-Break-Space (read-char stream))
   ))


   ;;
   ;; Following checks to see if we have something that might
   ;; be an XML file... nothing sophisticated: does it start
   ;; with an angle bracket!
   ;;
(defun XML-FILE-P (file &optional (unicode-input? nil))
  #-lispworks nil
  #+lispworks
  (if unicode-input?
      (with-open-file 
       (stream (pathname file)
	       :direction :input 
	       :external-format '(:UNICODE :EOL-STYLE :CRLF))
       (read-char stream)
       (char= (read-char stream) #\<))
    (with-open-file 
     (stream (pathname file)
	     :direction :input)
     (char= (read-char stream) #\<))))


