;;; ------------------------------------------------------------------------
;;
;; WPP: Write Production Rule (Prule) Parameters
;;
;; Hedderik van Rijn, 011202
;;
;; Call:
;;
;;   start-write-prule-parameters (file prule-constraints par-list &optional minprules)
;;
;; to start recording (to the file "file".dat) the parameters specified in
;; par-list (e.g., '(:c :p)) for the production rules matching
;; prule-constraints (e.g., '("PRODUCTION-" "START-PROCESS")). If the number
;; of prules matching the constraints is lower than minprules, add the
;; neseccary colums to simulate the parameters for minprules. (Value used is
;; -99.)
;;
;; And call:
;;
;;  stop-write-prule-parameters
;;
;; to stop recording and close the output file. The names of the matching
;; prules combined with the parameters are written to "file".hdr.
;;
;; See plot-prule-par.r for S/R-script to plot parameters.
;;
;;; ------------------------------------------------------------------------




(defun return-matching-symbols (constraints symbols)
  "Returns a list of symbols of which the symbol-name contained one of the constraints"
  ;; Constraints XYZ returns both the prules XYZ _and_ XYZABC. So name your prules carefully :-)
;;  #-cmu (error "Note the intersection has to be returned in the same ORDER as in the symbols list for the wpp functions to work!")
  (reverse (intersection symbols constraints :test (lambda (s c) (search c (symbol-name s))))))

(defvar **write-prule-pars-file** nil)
(defvar **write-prule-pars-basefile** nil)
(defvar **write-prule-pars-constraints** nil)
(defvar **write-prule-pars-pars** nil)
(defvar **write-prule-pars-minprules** -1)

(defun return-matching-prules (prule-constraints)
  (return-matching-symbols prule-constraints (mapcar 'car *procedural-memory*)))

(defun write-prule-parameters (prule-constraints par-list &key (minprules -1))
  (let* ((prule-list (return-matching-prules prule-constraints))
	 (params (if prule-list (no-output (spp-fct (mapcar (lambda (x) (list* x par-list)) prule-list)))
		   '())))
    ;; Add additional information to write a fixed number of columns
    (unless (= minprules -1)
      (nconc params (make-list (- minprules (length params))
			       :initial-element (make-list (length par-list) :initial-element -99))))
    ;; Probably, this isn't the most lispy way to do things...
    (dolist (parset params)
      (dolist (par parset)
 	(format **write-prule-pars-file** " ~12S" par)))
     (format **write-prule-pars-file** "~%")))
;;	(format t " ~12S" par)))
;;    (format t "~%")))

(defun do-write-prule-parameters () ;;(&optional (inst nil))
  (write-prule-parameters **write-prule-pars-constraints**
			  **write-prule-pars-pars**
			  :minprules **write-prule-pars-minprules**))

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

(defun write-prule-parameters-p ()
  (if **write-prule-pars-pars**
      t
    nil))

(defun start-write-prule-parameters (file prule-constraints par-list &optional (minprules -1))
  (if **write-prule-pars-pars**
      (error "File already open!~%Probably you should call stop-write-prule-parameters first.")
    (progn
;;       (format t "~%Delete wpp data file? ")
;;       (if (equal (read) 'y)
;; 	  (delete-file (concatenate 'string file ".dat"))
;; 	(format t "Keeping file~%"))
      (setf **write-prule-pars-file** (open (concatenate 'string file ".dat") :direction :output
					    :if-exists :append :if-does-not-exist :create))
      (setf **write-prule-pars-basefile** file)
      (setf **write-prule-pars-constraints** (mapcar 'string-upcase (if (listp prule-constraints) prule-constraints (list prule-constraints))))
      (setf **write-prule-pars-pars** par-list)
      (setf **write-prule-pars-minprules** minprules))))

(defun stop-write-prule-parameters ()
  (close **write-prule-pars-file**)
  (delete-file (concatenate 'string **write-prule-pars-basefile** ".hdr"))
  (setf **write-prule-pars-file** (open (concatenate 'string **write-prule-pars-basefile** ".hdr") :direction :output
					:if-exists :append :if-does-not-exist :create))
  (let ((prule-list (return-matching-symbols **write-prule-pars-constraints**
					     (mapcar 'car *procedural-memory*))))
;;    (format t "~S" prule-list)
    (dolist (prule prule-list)
      (dolist (par **write-prule-pars-pars**)
	(format **write-prule-pars-file** " ~S~S" prule par))))
  (format **write-prule-pars-file** "~%")
  (close **write-prule-pars-file**)

  (setf **write-prule-pars-file** nil)
  (setf **write-prule-pars-basefile** nil)
  (setf **write-prule-pars-constraints** nil)
  (setf **write-prule-pars-pars** nil)
  (setf **write-prule-pars-minprules** -1))