(in-package "KPML")

;;; File: image-makers.lisp
;;; This file contains various support functions for maintenance of the
;;; KPML system....
;;;
;;;                                                  John: 5 Aug 94 (Kyoto)
;;;   0.9 Allegro added (John: Dec 95).
;;;   1.0.25 Patches can be installed regardless of what directory KPML
;;;          is running in 

;;;----------------------------------------------------------------------
;;; Functions for making images of the loaded system... 
;;;
;;; 0.9 version was overkeen, no need to do fancy stuff to be able to use the
;;; emacs environment, since this restart function returns control
;;; to its caller. Need to reactivate the commented out parts when
;;; no Lisp interaction is envisioned.
;;; 0.9.24 added here: support for acl4.3
;;; 1.0.29: add the no-window startup option for KPML images...
;;; 2.0 restart function broken out to be independently available...
;;; 3.2.49
  ;; some keywords added from kpml-i::startup for more flexible startup
  ;; from scratch. Also check that we have an interface around to
  ;; startup if someone just calls this function for fun! Note that
  ;; there is no option of configuring because this is done in any
  ;; case by the restart function.
;;; ----------------------------------------------------------------------

(defun KPML-RESTART-FUNCTION 
  (&key (reset T)
	(frame-manager nil)
	(protocol T))
  (load-kpml-configuration-file)
  (load-kpml-patches)
  (load-kpml-user-specific-patches)
  (describe-kpml)
  (setf common-lisp:*package* (find-package "KPML")) ;; 2.1
  (unless (member "-nowindow"                        ;; 1.0.29
                  #+(and allegro excl)
                  (system:command-line-arguments :application nil)
		  #+aclpc
		  nil                                ;; 2.1 placeholder
                  #+(and common-lispworks lcl5.0)
                  (x-utilities::command-line-args)
                  #+lispworks4
                  (io::io-get-command-line-arguments)
		  #+lispworks5
		  (break)
                  :test #'string=)
    (if (find-package "KPML-I")
	(apply (find-symbol "STARTUP" (find-package "KPML-I"))
	       `(:reset ,reset                  ;; allow this one to go thru
		 :color ,kpml::*monochrome*     ;; can be set by config
		 :configure NIL                 ;; no point 
		 :frame-manager ,frame-manager  ;; also allow variation
		 :protocol ,protocol            ;; and here...
		 ))
      (format T "Warning: No KPML graphical user interface present!"))))

;;; ------------------------------------------------
;; Note:
;; following is from the Allegro manual, p8-8
;; and allows us to startup from an emacs buffer
;; iff we want...
;; (let ((e-arg (member "-e" 
;;                 (system:command-line-arguments
;;			     :application nil)
;;			    :test #'string=)))
;;	(when e-arg
;;	  (eval (with-standard-io-syntax
;;		  (read-from-string (cadr e-arg))
;;; -------------------------------------------------
	   
#+(or allegro lucid)
(defun MAKE-KPML-IMAGE (file-name)
;;; 0.7.21 changes during a session were not included in the
;;;        *penman-features* structure
  (in-package "KPML")
  (set-penman-feature :language all_languages)
  (set-penman-feature :site (common-lisp:short-site-name))
  (setf *kpml-creation-timestamp* (kpml::time-stamp))
  #+LUCID
  (lcl::disksave file-name
		 :restart-function #'kpml-restart-function
		 :full-gc t
		 :gc t)
  #+(and :allegro :excl)
  (:version-case (":ALLEGRO-V")
		 ((- "4.3")
		  (excl::dumplisp :name file-name
				  :restart-function #'kpml-restart-function))
		 (t      ;; was: 0.9.24, i.e., #+allegro-v4.3 and above
		  (progn
		    (setf excl:*restart-init-function* #'kpml-restart-function)
		    (excl:dumplisp :name file-name))))
  )

;;;----------------------------------------------------------------------
;;; 3.0 made more resistant to nasty DOS control Ms.....
;;; 4.1 report whether and which Upper Model is on board...

(defun DESCRIBE-KPML (&optional (stream t)(label "KPML IMAGE"))
  (let ((description-strings 
	 '(
	   "   ~A"
	   "   ~A"
	   "     Version: ~A"
	   "     (User level: ~A)"
	   "     Configured for languages: ~A"
	   "     Morphology: ~A"
	   "     Created at: ~A"
	   "     Interface version: ~A"
	   "     Knowledge representation system used: ~A"
	   "     Upper Model version: ~A"
	   "     Image made on: ~A	"
	   "     Standalone: ~A"
	   "     (~A systems loaded)"
	   "     (Lisp used: ~A)")))
    (format stream "~2%--------------------------------------~%")
    (loop for info-label in description-strings
	as info in (list 
		    label
		    (make-array (length label)
				:element-type 'character
				:initial-contents 
				(loop for i from 1 to (length label) collect #\=))
		    (get-penman-feature :version)
		    (kpml-user-level-describer)
		    (get-penman-feature :language)
		    (get-penman-feature :morphology)
		    (get-penman-feature :site)
		    (get-penman-feature :interface)
		    (kpml-kr-system-describer)
		    (get-penman-feature :semantics)
		    *kpml-creation-timestamp*
		    (if *standalone* "yes" "no")
		    (length systems)
		    (kpml-lisp-describer))
	do (format stream info-label info)
	   (format stream "~%"))
    (kpml-subversion-describer stream)
    (kpml-tools-describer stream)
    (format stream "~2%---------------------------------------~2%")
    ))

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

(defun KPML-LISP-DESCRIBER ()
  #-clisp
  "Shows that KPML has recognized the Lisp version being used (or not)"
  "Unknown"
  #+harlequin-pc-lisp 
  (:version-case (":LISPWORKS")
		 ((- "4.0") "Some Harlequin, PC, before Lispworks 4.0")
		 ("4.0"     "Harlequin, PC, Lispworks 4.0")
		 ("4.1"     "Harlequin, PC, Lispworks 4.1")
		 ((+ "4.1") "Some Harlequin, PC, Lispworks higher than 4.1")
		 (t         "Some Harlequin, PC Lisp, not Lispworks"))
#+(and harlequin-common-lisp win32)
  (:version-case (":LISPWORKS")
		 ((- "4.0") "Some Harlequin, PC, before Lispworks 4.0")
		 ("4.0"     "Harlequin, PC, Lispworks 4.0")
		 ("4.1"     "Harlequin, PC, Lispworks 4.1")
		 ("4.2"     "PC Lispworks 4.2")
		 ((+ "4.9") "PC Lispworks, 5.0 or higher")
		 (t         "Some Harlequin, PC Lisp, not Lispworks"))
  #+(and aclpc acl3.0) "Franz, Allegro, PC, ACL3.0"
  #+allegro
  (:version-case (":ALLEGRO-V")
		 ((- "4.3")   "Franz, Allegro, Unix, CL4.2 or earlier")
		 ("4.3"       "Franz, Allegro, Unix, CL4.3")
		 ("4.3.1"     "Franz, Allegro, Unix, CL4.3.1")
		 ("5.0"       "Franz, Allegro, ACL5.0")
		 ("5.0.1"     "Franz, Allegro, ACL5.0.1")
		 (("5.0.2"  "5.9") "Some Franz Allegro Lisp higher than 5.0.1")
		 ((+ "5.9") "Some Franz Allegro Lisp higher than 6.0")
		 (t           "Some unknown Franz Allegro Lisp"))
  #+clisp
  "GNU CLISP"
  )
  

(defun KPML-USER-LEVEL-DESCRIBER ()
  (if (member :kpml-level>= *features*)
      (cond ((member :kpml-unrestricted *features*)
	     "unrestricted")
	    ((member :kpml-l3 *features*)
	     "level 3")
	    ((member :kpml-l2 *features*)
	     "level 2")
	    ((member :kpml-l1 *features*)
	     "level 1")
	    ((member :kpml-l0 *features*)
	     "novice (level 0)")
	    (t
	     "strange setting"))
    "uninstalled"))

;;; 4.0
(defun KPML-KR-SYSTEM-DESCRIBER ()
  (cond ((not cl-user::*load-kr-system?*)
	 "none")
	(t
	 (case cl-user::*kpml-kr-system-name*
		(cl-user::kpml-loom 
		 #+loom
		 (:version-case 
		  (":LOOM")
		  ((- "2.0")   "A very old Loom (ISI)")
		  ("2.0"       "Loom (ISI) 2.0")
		  ("2.1"       "Loom (ISI) 2.1")
		  ("3.0"       "Loom (ISI) 3.0")
		  ("4.0"       "Loom (ISI) 4.0")
		  ((+ "4.0")   "Loom (ISI) higher than 4.0")
		  (t           "Loom (ISI) version unknown"))
		 #-loom
		 "A defective Loom installation")
		(cl-user::kpml-racer "Racer (Hamburg)")
		(cl-user::kpml-agile "Agile KR (ITRI, Brighton)")
		(otherwise
		 "unknown")))))

;;; 3.0
(defun KPML-SUBVERSION-DESCRIBER (stream)
  (when (and (boundp '*kpml-features*)
	     *kpml-features*)
    (format stream "~%     Release date/build: ~S" *kpml-features*)))
	   

;;; 2.1 stub
(defun KPML-TOOLS-DESCRIBER (&optional (stream T))
  (format stream "~%     No additional KPML extension tools installed."))


;;; ----------------------------------------------------------------------
;;; Change wrt 0.9 and before: new patching behaviour. First checks
;;; to see if there is a patch tar file. If this is the case, the
;;; patches are installed. If not, the patches are loaded.
;;;
;;; More detailed operation is as follows:
;;; i) on startup (or on restarting an image), the system looks to see
;;;    if there is a new patch tar file in the root directory,
;;;    if there is, 
;;;        a) all old Patches are deleted,
;;;        b) the new file is uncompressed, untar-ed, 
;;; ii) when there are patches (which may have been created in step (i)),
;;;     a file patch-defsys.lisp (which must redefine the system 
;;;     kpml-patches to be useful) is loaded if it exists,
;;;     then the system kpml-patches is loaded (compiling first if necessary).
;;;     If there is no redefinition of kpml-patches, the default
;;;     holds: this expects two files, kpml-body-patches.lisp and
;;;     kpml-interface-patches.lisp.
;;;
;;;     2.1 default changed from Unix compress to gzip.
;;; ----------------------------------------------------------------------

(defun LOAD-KPML-PATCHES (&key (recompile nil))
  (if *standalone* 
      (unless (catch 'patch-error-tag 
		(load-compiled-kpml-patches-only))
	(format t "~%;;; Loading KPML compiled patches ABANDONED."))
    (if recompile (recompile-and-load-kpml-patches)
      (when *load-patches*
	(let* ((patchdir (if (stringp *load-patches*) *load-patches*
			   common-lisp-user::*root-of-kpml*))
	       (new-patches 
		(directory
		 (merge-pathnames (pathname patchdir)
				  "kpml-patches*.tar.gz"))))
	  (when new-patches (install-patches new-patches))
	  (unless (catch 'patch-error-tag (load-installed-patches))
	    (format t "~%;;; Loading KPML patches ABANDONED."))
	  )))))

;;; ----------------------------------------------------------------------
;;; This option is quite useful but got forgot... we should
;;; be able *force* recompilation of the patches.
;;;
;;; 2.0.37 (could also be made available as a keyword option
;;;         to load-kpml-patches: 2.1 Done.)
;;; ----------------------------------------------------------------------

(defun RECOMPILE-AND-LOAD-KPML-PATCHES ()
  (when *load-patches*
	(let ((directory (if (stringp *load-patches*)
			     (pathname *load-patches*)
			   (merge-pathnames 
			    (coerce-directory "patches")
			    (pathname common-lisp-user::*root-of-kpml*)))))
	  #+acl3.0 (setf directory (coerce-directory directory))
	  (cond (directory
		 (format t "~%;;; Loading precompiled KPML patches...")
		 ;; args in wrong order here too (for extra fussy ACL-PC)
		 (load (merge-pathnames "patch-defsys.lisp" directory)
                        :if-does-not-exist nil)
                 (format t "~%;;; Recompiling KPML patches....")
		 (cl-user::without-redefinition-warnings
		  (make:operate-on-system 'kpml-patches :compile :force T
					  :compile-during-load nil
					  :load-source-instead-of-binary nil)
		  (unless (catch 'patch-error-tag (load-installed-patches))
		    (format t "~%;;; Loading KPML patches ABANDONED.")))
		 (format t "~%;;; Loading recompiled KPML patches completed."))
		(t
		 (format t "~%;;; No KPML patches."))))))

;;; ----------------------------------------------------------------------
;;; If we find a gzipped tarred patches file, then we try and uncompress
;;; and detar, or else report that we can't in the particular Lisp
;;; being used.
;;; ----------------------------------------------------------------------

(defun INSTALL-PATCHES (new-patch-list)
  #+lispworks (print "LISPWORKS AUTO KPML-PATCH EXPANSION UNSUPPORTED.")
  #-lispworks
  (let* ((newest (namestring (first new-patch-list)))
	 (newest-unc (subseq newest 0 (position #\. newest :from-end T))))
    (format t "~%;;; Installing new patches: ~A" newest)
    (loop for file in (directory
		       (coerce-directory
			(merge-pathnames 
			 (pathname common-lisp-user::*root-of-kpml*)  
			 "patches"))) ;; 2.0 name changed
	do (delete-file file))
    #+ALLEGRO (excl:run-shell-command 
	       (format nil
		       *kpml-patch-restoration-commands*
		       (coerce-directory 
			(pathname common-lisp-user::*root-of-kpml*))
		       newest 
		       newest-unc))
    #+LUCID (lcl::run-program *lucid-uncompression-command* 
			      :arguments (list newest))
    #+LUCID (print "LUCID AUTO KPML-PATCH LOADING UNSUPPORTED.")
    #-(or allegro lucid) 
    (error "KPML patch loading not yet supported if not Allegro or Lucid")
    (delete-file newest-unc)
    (loop for file in (cdr new-patch-list) do (delete-file file))
    (format t "~%;;; Patch file processed.")))


;;; ----------------------------------------------------------------------
;;; Patches are already in place, so we load them...
;;; ----------------------------------------------------------------------

(defun LOAD-INSTALLED-PATCHES ()
  (when *load-patches*
    (let ((directory (if (stringp *load-patches*)
			 (pathname *load-patches*)
		       (merge-pathnames 
			(coerce-directory "patches")
			(pathname common-lisp-user::*root-of-kpml*)))))
      ;; acl-pc is a pain...
      #+acl3.0 (setf directory (coerce-directory directory))

      (cond (directory
	     (format t "~%;;; Loading KPML patches...")
	     ;; N.B. arguments were in wrong order for ACL-PC...
	     (load (merge-pathnames "patch-defsys.lisp" directory)
		   :if-does-not-exist nil)
	     (make:operate-on-system 'kpml-patches :load 
				     :compile-during-load T
				     :load-source-instead-of-binary nil)
	     (format t "~%;;; Loading KPML patches completed."))
	    (t
	     (format t "~%;;; No KPML patches.")))))
  T)



(defun LOAD-COMPILED-KPML-PATCHES-ONLY ()
  (when *load-patches*
	(let ((directory (if (stringp *load-patches*)
			     (pathname *load-patches*)
			   (merge-pathnames 
			    (coerce-directory "Patches")
			    (pathname common-lisp-user::*root-of-kpml*)))))
	  #+acl3.0 (setf directory (coerce-directory directory))
	  (cond (directory
		 (format t "~%;;; Loading precompiled KPML patches...")
		 ;; args in wrong order here too (for extra fussy ACL-PC)
		 (load (merge-pathnames 
			#+(or lispworks acl3.0) "patch-defsys.fsl"
			#-(or lispworks acl3.0) "patch-defsys.fasl"
			directory)
		       :if-does-not-exist nil)
		 (make:operate-on-system 'kpml-patches :load 
					 :compile-during-load nil
					 :load-source-instead-of-binary nil)
		 (format t "~%;;; Loading compiled KPML patches completed."))
		(t
		 (format t "~%;;; No KPML patches."))))))


;;; ----------------------------------------------------------------------
;;; Change wrt 0.9 and before, user-specifics.lisp is only
;;; for individual users, and an additional file site-specifics.lisp
;;; is for particular installations. Site patches are loaded
;;; before user patches.
;;; ----------------------------------------------------------------------

(defvar *user-specifics-filename* "user-specifics.lisp")

(defun LOAD-KPML-USER-SPECIFIC-PATCHES ()
  (let* ((site-patches 
	  (merge-pathnames (if (stringp *load-site-specifics*)
			       (pathname *load-site-specifics*)
			     (pathname common-lisp-user::*root-of-kpml*))
			   "site-specifics.lisp"))
	 (site-patches? (open site-patches :direction :probe))
	 (old-site-patches 
	  (merge-pathnames (pathname common-lisp-user::*root-of-kpml*)  
			   "user-specifics.lisp"))
	 (old-site-patches? (open old-site-patches :direction :probe))
	 (user-patches
	  (merge-pathnames 
	   *user-specifics-filename* 
	   (if (stringp *load-user-specifics*)
	       (pathname *load-user-specifics*)
	     (user-homedir-pathname))))
	 (user-patches? (open user-patches :direction :probe)))
    (when old-site-patches?
      (warning "Site patches should now be in a file site-patches.lisp!")
      (load old-site-patches))
    (when (and *load-site-specifics* site-patches?) (load site-patches))
    (when (and *load-user-specifics* user-patches?) (load user-patches))))

;;;----------------------------------------------------------------------
;;; 2.1
;;;
;;; Function for checking whether patches are being loaded wrt the correct
;;; version of the system... Correct means that the current patch level of 
;;; KPML is at least as high as the minimum requirement. Thus 
;;; (check-patch-ok-for :kpml-2.0.23) will succeed for all versions 
;;; 2.0.23 and above which are still 2.0. It will not succeed for
;;; any version KPML 2.1... Nor will it succeed for any version before
;;; 2.0.23 (e.g., 2.0.22 or 1.0.34). 
;;;
;;; Also, nonmatching patches will *not* be loaded! This is different
;;; to before.
;;; ----------------------------------------------------------------------

(defun CHECK-PATCH-OK-FOR (required-version-number)
  (format t "~%;;; PATCHING...")
  (cond ((not (boundp '*penman-features*))
	 (format t "~%SERIOUS VERSION MISMATCH OR KPML NOT LOADED!!! ")
	 (format t "~%NO RELIABLE RESULTS CAN BE EXPECTED!!!~%")
	 (throw 'patch-error-tag nil))
	(t
	 (let* ((version-code 
		 (cl-user::transform-versionstring
		  (subseq (string (get-penman-feature :version)) 5)))
		(required
		 (cl-user::transform-versionstring
		  (subseq (string required-version-number) 5)))
		(ok?
		 (if (equal (first version-code) (first required))
		     (if (equal (second version-code) (second required))
			 (if (cl-user::lexical-ordering-p 
			      (cddr version-code)
			      (cddr required))
			     (progn
			       (format t "version compatibility checked ok.")
			       T)
		       (format t "Patch level jumps: patches are missing!"))
		   (format t "Warning: KPML minor version mismatch."))
		 (format t "WARNING! KPML major version mismatch."))))
	   (if ok?
	       (format t "~%...PATCHING: updating beyond ~A~%" 
		       required-version-number)
	     (format t "~2%...PATCHING: ERROR IN VERSION NUMBER; CURRENT PATCHES 
ARE NOT APPROPRIATE FOR THE INSTALLED VERSION: ~A~%
NOT LOADING.~%"
		     (get-penman-feature :version)
		     required-version-number))
	   (unless ok? (throw 'patch-error-tag nil))))))


(defun RECORD-PATCH (new-version-id &optional (id nil))
;;; 0.7.2: added description of patch printing.
  (if id
      (format *trace-output* "~%~A ... ~A" 
	      new-version-id id))
  (unless (eq (get-penman-feature :version) :KPML-defective)
	  (set-penman-feature :version new-version-id)))

;;; ----------------------------------------------------------------------
;;; Following will not work well with the above patch checking
;;; apparatus...
;;; ----------------------------------------------------------------------

(defun EXPERIMENTAL-VERSION (version)
  (intern (concatenate 'string (string version) ".E") :keyword))

;;; ----------------------------------------------------------------------
;;; 1.0.10
;;; Following two can be added to the get-penman-feature macro
;;; when a new release happens, meanwhile...
;;; 4.0 
;;;  made robust so that they cannot fail when a major or minor
;;;  version number is not given for some reason (e.g., with a beta
;;;  test version or something). The default is then a clear
;;;  designator.

(defun MICRO-VERSION-NR ()
  (let* ((version (string (penman::get-penman-feature :version)))
	 (pos (position #\. version :from-end T)))
    (if (and pos (find #\. (subseq version 0 (1- pos))))
	(read-from-string (subseq version (1+ pos)))
      0)))

(defun MAJOR-VERSION-NR ()
  (let* ((version (string (penman::get-penman-feature :version)))
	 (pos1 (position #\. version :from-end T))
	 (pos2 (position #\- version)))
    (if (and (numberp pos1) pos2)
        (subseq version (1+ pos2)
	        (if (find #\. (subseq version 0 (1- pos1))) pos1
	          nil))
      "nonrelease")))

;;; ----------------------------------------------------------------------
;;; An additional function for incrementally expanding a standard
;;; KPML release to support stratification...

(defun ACTIVATE-STRATIFICATION ()
  #+(and acl3.0 aclpc)
  (progn
    (setf acl::*warn-on-redefinition* nil)
    (setf acl::*warn-on-protected-function-redefinition* nil))
  (make:operate-on-system 'stratification  :compile :force nil)
  (make:operate-on-system 'stratification  :load
			  :compile-during-load nil
			  :load-source-instead-of-binary nil)
  (when common-lisp-user::*window-interface-required?*
    (make:operate-on-system 'ui-stratification :compile :force nil)
    (make:operate-on-system 'ui-stratification
			    :load 
			    :compile-during-load nil
			    :load-source-instead-of-binary nil))
  #+(and acl3.0 aclpc)
  (progn
    (setf acl::*warn-on-redefinition* T)
    (setf acl::*warn-on-protected-function-redefinition* T)))


