(require 'common-list-functions)
;(load "/users/sofya/format/format3")
;;;The variable parameter:who shows what state yenta is currently in.
;;;It's used to find out current conditions for resetting parameters
;;;It can take one of the following values:
#| Anytime (:anytime)			
   Yenta restart required [:restart-required] 
   Recompilation required [:recompilation-required] 
   Only resettable by author [:by-author] 
   Only resettable via protocol version increment [:protocol-increment] 
|#
(define parameter:who ':by-author)

(defmacro def-yenta-parameter (. options)
  (let ((names (parameter:names options)))
        (unless names
            (format-error "Didn't find names in ~S" options))
    (let* ((human-name (parameter:names->human names))
           (scheme-options (parameter:names->scheme names))
           (c-options (parameter:names->c names)))
      (if (and scheme-options (symbol? (parameter:scheme->name scheme-options)))
          (parameter:set-scheme->file! scheme-options *load-pathname*)
          (format-error "Didn't find a scheme name in ~S~%Scheme name has to be a symbol." options))
      (if c-options
          (if (or (null? c-options)
                  (not (pair? (parameter:c->name-and-type c-options)))
                  (null? (parameter:c->files c-options)))
              (format-error
               "c-options~%~S~%do not satisfy the correct syntax: (c: (name type) file1 ... fileN)"
               c-options))) 
      (unless human-name
              (format-error "Didn't find a human name in ~S" options))
      (parameter:check-and-evaluate-supplied-options options)
      ;;we are done with error checking
      ;;now do real work
      (let* ((expanded-options (parameter:supply-defaulted-options options))
	     ; Default current & suggested from shipped, etc.
             (current-value (parameter:current expanded-options)))
        `(begin
           (pushnew-replace!
            ',expanded-options parameter:*parameters* ; Update our table.
            (lambda (one two)
              (let* ((first-names (parameter:names one))
                     (first-human (parameter:names->human first-names))
                     (first-scheme (parameter:names->scheme-name first-names))
                     (first-c (parameter:names->c-name first-names))
                     (scheme-name ',(parameter:scheme->name scheme-options))
                     (c-name ,(parameter:c->name c-options)))
                (cond ((string-ci=? first-human ,human-name)
                       (format
			#t
			"!Warning: You are redefining parameter ~S which was defined ~:[by user~;in ~:*~A~]~%"
			first-human
			(parameter:names->scheme-file first-names)))
                      ((and first-c c-name (string-ci=? first-c c-name)
                           (format t
                               "!Warning: Parameters ~S and ~S have identical c names: ~S~%"
			       first-human ,human-name c-name) #f))
                      ((eq? first-scheme scheme-name)
                           (format t
                               "!Warning: Parameters ~S and ~S have identical scheme names: ~S~%"
			       first-human ,human-name scheme-name) #f)
                      (else #f)))))
           (define ,(parameter:scheme->name scheme-options) ,current-value)))))) ; Define the actual parameter in the Scheme image.

(defvar parameter:*parameters* '())	; Table of all parameters.

(define *options*			; Currently-defined options.
  '(:doc :resettable :suggested :current :shipped :validator :units :names))

(defvar *dependencies* '())		; Keeps track of parameter dependencies.  Uses human names as data.

;;; Mutator for the table of dependencies.
(define (update-dependencies! name i-depend-on-list)
  (pushnew-replace! (cons name i-depend-on-list) *dependencies*
		    (lambda (one two)
		      (string-ci=? (car one) (car two)))))

(define (delete-dependency! human-name)
  (let ((dependency (assoc name *dependencies*)))
    (if dependency 
	(set! *dependencies* (delete dependency *dependencies*)))
    dependency))

;;; Accessor for the table of dependencies.
(define (parameter:human-name->depends-on-me human-name)
  (map car (remove-if-not
	    (lambda (entry) (member human-name (cdr entry))) *dependencies*)))

(define (parameter:human-name->i-depend-on name)
  (let ((dependency (assoc name *dependencies*)))
    (if dependency
	(cdr dependency)
	'())))

;;;This is a list where defaults for parameter options are specified.
;;;Any default has to be a symbol,  () 
;;;or a procedure that takes supplied options and returns required default.
;;;The reason for that is that each default is going to be evaluated with eval unless
;;;it is a symbol or an empty list.
;;;Note: if you want your default to be a list, you have to write a cludge,
;;;namely, procedure that takes one argument and returns the list you want when evaluated 
;;;in global environment
(define *options-defaults*
  '((:shipped (lambda (options)
		  (let ((suggested-val (parameter:suggested options)))
		    (if suggested-val
			suggested-val
			(let ((current-val (parameter:current options)))
			  (if current-val
			      current-val
			      (format-error 
			       "At least one of :shipped, :current, :suggested has to be specified")))))))
    (:current (lambda (options)
		  (let ((shipped-val (parameter:shipped options)))
		    (if shipped-val
			shipped-val
			(let ((suggested-val (parameter:suggested options)))
			  (if suggested-val
			      suggested-val
			      (format-error
			       "At least one of :shipped, :current, :suggested has to be specified")))))))
    (:suggested (lambda (options)
		  (let ((shipped-val (parameter:shipped options)))
		    (if shipped-val
			shipped-val
			(let ((current-val (parameter:current options)))
			  (if current-val
			      current-val
			      (format-error
			       "At least one of :shipped, :current, :suggested has to be specified")))))))
;;;    (:i-depend-on ())    ;stored in *dependencies*, not in parameter:*parameters*
;;;    (:depends-on-me ())  ;computed from :i-depend-on and kept in *dependencies* table
    (:resettable :anytime)
    (:doc "")))
;    (:doc-short (get-first-line (parameter:doc options)))))

;;;Options that do not have defaults are required no matter what.
;;;Some option is required only under specific conditions, for example, if some other option is not supplied.
;;;Such options are implemented using procedures supplied in *options-defaults* 
(define *options-required*
  (remove-if (lambda (opt) (assoc opt *options-defaults*)) *options*))

#|Is not currently used
(defmacro def-parameter-option (opt . default)
  `(if (memq ',opt *options*)
       (format-error "Parameter option ~A is already defined" ',opt)
       (begin (create-accessor ,opt)
	      (append! *options* '(,opt))
	      ,(if (not (null? default))
		   `(append! *options-defaults* '((,opt ,(car default))))
		   `nil)
	      ',opt)))
|#
;;;checks whether all required options are supplied
;;;and whether supplied values of :shipped :current and :suggested are valid
;;;right now does not evaluate anything
(define (parameter:check-and-evaluate-supplied-options options)
  (for-each (lambda (option)
	      (if (not (assoc option options)) ;violates obstruction barrier
		  (format-error "Option ~A is required" option)))
	    *options-required*)
;;;check the validity of supplied values
  (define validator (parameter:validator options))
  (for-each (lambda (option)
	      (let ((option-pair (assoc option options))) ;violates obstruction barrier
		(if option-pair
		    (let ((value (eval (cadr option-pair))))
		      (unless (parameter:passes-validator? validator value)
;			  (set-car! (cdr option-pair) value)
			  (format-error "Value ~S does not pass the validator ~A for option ~A"
					value validator option))))))
	    '(:current :shipped :suggested))
  ;;check whether :i-depend-on value is correct and update *dependencies* table
  (let* ((dependency-pair (assoc ':i-depend-on options))
	 (dependency (if dependency-pair (cdr dependency-pair) '()))) ;not (parameter:i-depend-on options)
					;because it would look up in *dependencies* 
    (if (not (null? dependency))
	(update-dependencies! (parameter:human-name options) dependency))))

;;;this procedure will supply defaults for options
;;;as specified in *options-defaults*
;;;any default can be either symbol or procedure that takes supplied options
;;;and returns required default.
;;;Also it will remove any options that are used for information only, and are not stored in
;;;parameter:*parameters* 
(define (parameter:supply-defaulted-options options)
  (for-each
   (lambda (option-pair)
     (let* ((option (car option-pair))
	    (default (cadr option-pair))
	    (supplied (assoc option options))) ;violates obstruction barrier
       (if (not supplied)
	   (set! options
		 (cons (list option
			     (if (and (list? default) (not (null? default)))
				 (eval (list default `',options))
				 default)) options)))))
   *options-defaults*)
  (set! options (delete-if (lambda (x) (eq? (car x) ':i-depend-on)) options))
  options)
	   

;mutators
(define (parameter:change-current! opt value)
    (set-car! (cdr (assoc ':current opt)) value))

;;;Uses depth first search to propagate changes and to catch cycles in *dependencies*
(defmacro parameter:set-current! (name value error-port)
  `(let ((par (parameter:find-par ,name))
	 (error-string "done")
	 (GRAY '())
	 (BLACK '()))
     (define (parameter:track-changes scheme-name par value)
       (let* ((bindings (assoc scheme-name BLACK))
	      (resettable (parameter:resettable par)))
	 (cond
	  ;;grey node
	  ((assoc scheme-name GRAY)
	   (set! error-string "the graph of parameter dependencies contains a cycle"))
	  ;;black node
	  (bindings
	   (if (parameter:passes-validator? (parameter:validator par) value)
	       (set-cdr! bindings value)
	       (set! error-string
		     (format nil "parameter value ~S does not pass validator ~A for parameter ~S."
			     value (parameter:validator par) scheme-name))))
	  ;;white node
	  ((not (parameter:resettable? resettable))
	   (set! error-string
		 (format nil "parameter ~A has parameter:resettable field set to ~S.
You can't reset it." scheme-name resettable)))
	  ((not (parameter:passes-validator? (parameter:validator par) value))
	   (set! error-string
		 (format nil "Parameter value ~S does not pass validator ~A."
			 value (parameter:validator par))))
	  (else (set! GRAY (cons (list scheme-name value) GRAY)) ;color WHITE node GRAY
		(do ((rest (parameter:human-name->depends-on-me (parameter:human-name par)) (cdr rest)))
		    ((or (null? rest)
			 (not (string-ci=? error-string "done")))
		     (and (string-ci=? error-string "done")
			  (set! BLACK (cons (assoc scheme-name GRAY) BLACK)) ;color GRAY node BLACK
			  (set! GRAY (remove-if
				      (lambda (x)
					(eq? scheme-name (car x))) GRAY))
			  ))
		  (let* ((next-human-name (car rest))
			 (next-par (parameter:find-par next-human-name)))
		    (if (not next-par)
			(set! error-string
			      (format #f "parameter ~A is not defined" next-human-name))
			(parameter:track-changes
			 (parameter:scheme-name par)
			 next-par
			 (eval-in-new-env (parameter:current par) '()) ;use new-env in case it has side effects
			 ))))))))
     (cond ((not par)
	    (set! error-string (format #f "parameter ~A is not defined" ,name)))
	   (else (parameter:track-changes (parameter:scheme-name par) par ,value)))
     (cond ((string-ci=? error-string "done")
	   ; (pp BLACK)
	    (for-each (lambda (bindings)
			(let* ((par (parameter:find-par (coerce-to-string (car bindings))))
			      (cur (parameter:current  par)))
			  (eval (cons 'define bindings))
			  ;if :current is a literal, we need to change it
			  (if (or (number? cur)
				  (string? cur)) ;%anything else?
			      (set-cdr! (parameter:pair ':current par) (cdr bindings))))) BLACK)
	    (cons #t error-string))
	   (else (and (zero? (length BLACK))
		      (<= (length GRAY) 1)
		      (set! error-string (format "Re-evaluation of parameters ~S and parameters dependent on it gave the following error message:~% ~A" ,name error-string)))
		 (if ,error-port
		     (format ,error-port error-string))
		 (cons #f error-string)))))

(define (parameter:passes-validator? validator value)
    (eval (list validator value)))

#|old
(defmacro parameter:set-current! (name value error-port)
  (let ((par (parameter:find-par name))
	(error-string "done"))
    (if (not par)
	(set! error-string (format nil "Parameter ~A is not defined" name))
	(let ((scheme-name (parameter:scheme-name par))
	      (resettable (parameter:resettable par)))
	  (cond ((not scheme-name)
		 (set! error-string
		       (format nil "Parameter ~A does not have a scheme name" name)))
		((not (parameter:resettable? resettable))
		 (set! error-string
		       (format nil "Parameter:resettable is ~S. You can't reset it." resettable)))
		((not (eval (list (parameter:validator par) value)))
;;;		((not (parameter:type-and-range-check
;;;		       value
;;;		       (parameter:units par)
;;;		       (parameter:minimum par)
;;;		       (parameter:maximum par)))
		 (set! error-string
		       (format nil "Parameter value ~S does not pass validator ~A." value (parameter:validator par)))))))
    (if (string-ci=? error-string "done")
	(begin (parameter:change-current! par (eval value))
	       `(begin (define ,(parameter:scheme-name par) ,value)
		       (cons #t ,error-string)))
	`(begin
	   (if ,error-port
	       (format ,error-port ,error-string))
	   (cons #f ,error-string)))))
|#
		       
(define (parameter:resettable? resettable-value)
  (case resettable-value
    ((:anytime) (legal-resettable-value? parameter:who))
    (else (eq? resettable-value parameter:who))))
#|
;validator function replaced this
(define (parameter:type-and-range-check value units min max)
  (case units
   ((:nonneg-int)
    (and (nonneg-int? value)
	 (or (eq? max 'infinity)
	     (>= max value))))
   ((:integer)
    (and (integer? value)
	 (or (eq? max 'infinity)
	     (>= max value))
	 (or (eq? min '-infinity)
	     (<= min value))))
   ((:float)
    (and (number? value)
	 (or (eq? max 'infinity)
	     (>= max value))
	 (or (eq? min '-infinity)
	     (<= min value))))
   ((:yenta-id) (yenta-id? value)) 
   ((:pathname) (pathname? value)) 
   ((:string) (string? value))
   (else (format-error "Illigal units ~S in parameter:type-and-range-check" units))))

(define (legal-units? units)
  (memq units '(:nonneg-int :integer :float :yenta-id :pathname :string)))
|#

;%%should probably return the list of names that can be reset
(define (legal-resettable-value? resettable-value)
  (memq resettable-value '(:anytime :restart-required :recompilation-required :by-author :protocol-increment)))	

(defmacro parameter:find-parameter (name)
  `(parameter:find-par (coerce-to-string1 ,name)))
;finds the first one that matches
;if we expect to have conflicts, should replace find-if with remove-if-not
(define (parameter:find-par name)
  (find-if (lambda (par)
	     (let ((names (parameter:names par)))
	       (or (string-ci=? name (parameter:names->human names))
		   (string-ci=? name (symbol->string (parameter:names->scheme-name names)))
		   (string-ci=? name (parameter:names->c-name names)))))
	   parameter:*parameters*))
;;;
(defmacro parameter:find-parameter-from-regex (regexp)
  `(parameter:find-parameter-regex (coerce-to-string1 ,regexp)))

(define (parameter:find-parameter-regex regexp)
  (string-downcase! regexp)
  (remove-if-not (lambda (par)
	       (let ((names (parameter:names par)))
		 (or (regmatch? regexp
				(string-downcase (parameter:names->human names)))
		     (regmatch? regexp (symbol->string (parameter:names->scheme-name names)))
		     (regmatch? regexp (string-downcase (parameter:names->c-name names))))))
	     parameter:*parameters*))


(define (parameter:all-parameters)
  (pretty-print
   (sort parameter:*parameters*
	 (lambda (one two)
	   (string-ci<? (parameter:human-name one) (parameter:human-name two))))))
  
(define (parameter:parameter-count) (length parameter:*parameters*))

;%%%takes any name? as a string?
(define (parameter:delete-parameter! name . prompting)
  (let ((par (parameter:find-par name)))
    (if (null? prompting)
	(cond ((not par) (format t "Parameter ~S is not defined~%" name))
	      (else (format t "Do you really want to delete parameter ~S?" name)
		    (let read-loop ()
		      (format t "~&(y/n/s/?) ")
		      (case (read)
			((?) (format t "y - yes, delete the parameter~%n - no, don't delete anything; i don't know what I am doing~%s - show me the parameter you are going to delete~%? - show this menue") (read-loop))
			((s) (pretty-print par) (read-loop))
			((y) (format t "deleting~%"))
			((n) (format t "exiting~%") (set! par #f))
			(else (format t "invalid command; type ? to get the list of commands")
			      (read-loop)))))))
    (define human-name (parameter:human-name par))
    (set! *dependencies* (delete-if (lambda (x) (string-ci=? human-name (car x))) *dependencies*))
    (define dependent (parameter:human-name->depends-on-me human-name)) 
    (format t "~:[!Warning: The following parameters depend on ~A:~{~&~S~}~&~;~]"
	    (null? dependent) name dependent)
    (set! parameter:*parameters* (delete par parameter:*parameters*))
    par))

;end of file