; $Id: var.scm,v 1.51 2008/01/28 09:20:10 logik Exp $
; 3. Variables
; ============

; A variable of an object type is interpreted by a continuous functional
; (object) of that type.  We speak of variables and not program
; variables, since continuous functionals are not necessarily
; computable.

; As variable names we will commonly use
; pp qq       for total objects of type  boole
; n m k l     for total objects of type  nat

; To have infinitely many variables available, we allow appended
; indices: n1, n2, n3,... will be variables for total natural numbers.

; We also want to use variables ranging over not necessarily total
; objects.  They are formed by appending ^ to the variable name.  Hence
; e.g. n^, n^1, n^2,... are names for possibly undefined natural
; numbers.  Such variables are given the degree of totality 0, and the
; ones without ^ have degree of totality 1.  Alternatively, total
; variables can be written with underscores e.g. n_1, n_2,...

; Instead of variable names one can also use type expressions
; e.g. nat^13 or (nat=>nat)_7 creating numerated variables.  The scanner
; is able to relate variable names and the appropriate type.

; For the convenient display of variables, we may provide default
; variable names for certain types.

(define DEFAULT-VAR-NAMES '())
(define INITIAL-DEFAULT-VAR-NAMES DEFAULT-VAR-NAMES)

(define (default-var-name type)
  (let ((info (assoc type DEFAULT-VAR-NAMES)))
    (if info (cadr info) "")))

(define (set-default-var-name type string)
  (set! DEFAULT-VAR-NAMES (cons (list type string) DEFAULT-VAR-NAMES)))

(define VARIABLES '())
(define VARIABLE-NAMES '())
(define INITIAL-VARIABLES VARIABLES)

(define (add-var-name . x)
  (if (null? x)
      (myerror "add-var-name" "arguments expected")
      (let* ((rev (reverse x))
	     (type (car rev))
	     (strings (reverse (cdr rev))))
	(if (not (type? type))
	    (myerror "add-var-name" "type expected" type))
	(for-each
	 (lambda (string)
	   (if (and (string? string) (not (string=? string "")))
	       (if (is-used? string type 'var)
		   *the-non-printing-object*
		   (begin
		     (set! VARIABLES (cons (list string type) VARIABLES))
		     (if (member string VARIABLE-NAMES)
			 (remove-token string)
			 (set! VARIABLE-NAMES (cons string VARIABLE-NAMES)))
		     (add-token string 'var-name (cons type string))
		     (if (string=? "" (default-var-name type))
			 (set-default-var-name type string))
		     (comment "ok, variable " string ": "
				   (type-to-string type) " added")))
	       (myerror "add-var-name" "string expected" string)))
	 strings))))

(define av add-var-name)

(define (remove-var-name . strings)
  (define (rv1 string)
    (let ((info (assoc string VARIABLES)))
      (if info
	  (let* ((type (cadr info))
		 (info1 (assoc type DEFAULT-VAR-NAMES)))
	    (do ((l VARIABLES (cdr l))
		 (res '() (if (string=? (caar l) string)
			      res
			      (cons (car l) res))))
		((null? l) (set! VARIABLES (reverse res))))
	    (do ((l DEFAULT-VAR-NAMES (cdr l)) ;added 01-05-24
		 (res '() (if (string=? (cadar l) string)
			      res
			      (cons (car l) res))))
		((null? l) (set! DEFAULT-VAR-NAMES (reverse res))))
	    (remove-token string)
	    (add-token string 'var-name (cons #f string))
	    (comment "ok, variable " string " is removed")
	    (if (and info1 (string=? (cadr info1) string))
		(comment
		 "warning: " string " was default variable of type "
		 (type-to-string type))))
	  (comment "remove-var-name: variable name expected " string))))
  (for-each rv1 strings))

(define rv remove-var-name)

; Variables are implemented as lists ('var type index t-deg name).  If a
; variable carries no index, we let the index be -1.  name is a string
; (the name of the variable), to be used for output.  Notice that the
; name string may be empty; then we have one of our numerated variables.

; To make sure that variables generated by the system are different from
; all user introduced variables, we maintain a global counter
; MAXVARINDEX.  Whenever the user introduces a variable, e.g. n^25, then
; MAXVARINDEX is incremented to at least 25.  

(define MAXVARINDEX -1)
(define INITIAL-MAXVARINDEX MAXVARINDEX)

; Degrees of totality

(define t-deg-zero 0)
(define t-deg-one 1)

(define (t-deg-zero? t-deg)
  (and (integer? t-deg) (zero? t-deg)))

(define (t-deg-one? t-deg)
  (and (integer? t-deg) (positive? t-deg)))

(define (t-deg? x)
  (and (integer? x) (not (negative? x))))

; Constructor, accessors and tests for variables:

(define (make-var type index t-deg name)
  (set! MAXVARINDEX (max index MAXVARINDEX))
  (list 'var type index t-deg name))

(define (var-form? x) (and (pair? x) (eq? 'var (car x))))

(define var-to-type cadr)
(define var-to-index caddr)
(define var-to-t-deg cadddr )
(define (var-to-name var) (car (cddddr var)))

; Complete test:

(define (var? x)
  (and (list? x)
       (= 5 (length x))
       (let ((tag (car x))
	     (type (cadr x))
	     (index (caddr x))
	     (t-deg (cadddr x))
	     (name (car (cddddr x))))
	 (and (eq? 'var tag)
	      (type? type)
	      (integer? index) (<= -1 index)
	      (t-deg? t-deg)
	      (or (string=? "" name)
		  (member name VARIABLE-NAMES))))))

; For convenience we add mk-var with options.  Options are index
; (default -1), t-deg (default t-deg-one), and name (default
; given by (default-var-name type)).

(define (mk-var type . options)
  (let ((index -1)
	(t-deg t-deg-one)
	(name (default-var-name type)))
    (if (pair? options)
	(begin (set! index (car options))
	       (set! options (cdr options))))
    (if (pair? options)
	(begin (set! t-deg (car options))
	       (set! options (cdr options))))
    (if (pair? options)
	(begin (set! name (car options))
	       (set! options (cdr options))))
    (if (pair? options)
	 (myerror "make-var" "unexpected argument" options))
  (cond ((not (and (integer? index) (<= -1 index)))
	 (myerror "make-var" "index >= -1 expected" index))
	((not (t-deg? t-deg))
	 (myerror "make-var" "t-deg expected" t-deg))
	((not (string? name))
	 (myerror "make-var" "string expected" name))
	(else (make-var type index t-deg name)))))

; For display purposes we use var-to-string

(define (var-to-string var)
  (let* ((type (var-to-type var))
	 (index (var-to-index var))
	 (t-deg (var-to-t-deg var))
	 (name (var-to-name var))
	 (name1 (if (and (not (string=? "" name))
			 (let ((info (assoc name VARIABLES)))
			   (and info (equal? (cadr info) type))))
		    name
		    (type-to-string type)))
	 (stringlist (string->list name1))
	 (parentheses? (or (and (or (arrow-form? type) (star-form? type))
				(not (assoc type DEFAULT-VAR-NAMES)))
			   (member #\space stringlist)))
	 (modifier
	  (if (t-deg-one? t-deg)
	      (if (and (not (= index -1))
		       (or parentheses?
			   (char-numeric?
			    (string-ref name1 (- (length stringlist) 1)))))
		  "_" "") "^"))
	 (name1-with-parentheses (if parentheses?
				     (string-append "(" name1 ")")
				     name1))
	 (index-string (if (= index -1) "" (number-to-string index))))
    (string-append name1-with-parentheses modifier index-string)))

; Code discarded 2006-09-15
; (define (var-to-string var)
;   (let* ((type (var-to-type var))
; 	 (index (var-to-index var))
; 	 (t-deg (var-to-t-deg var))
; 	 (name (var-to-name var))
; 	 (name1 (if (and (not (string=? "" name))
; 			 (let ((info (assoc name VARIABLES)))
; 			   (and info (equal? (cadr info) type))))
; 		    name
; 		    (type-to-string type)))
; 	 (stringlist (string->list name1))
; 	 (modifier (if (t-deg-one? t-deg)
; 		       (if (and (not (= index -1))
; 				(char-numeric?
; 				 (string-ref name1 (- (length stringlist) 1))))
; 			   "_" "") "^"))
; 	 (parentheses? (or (and (or (arrow-form? type) (star-form? type))
; 				(not (assoc type DEFAULT-VAR-NAMES)))
; 			   (member #\space stringlist)))
; 	 (name1-with-parentheses (if parentheses?
; 				     (string-append "(" name1 ")")
; 				     name1))
; 	 (index-string (if (= index -1) "" (number-to-string index))))
;     (string-append name1-with-parentheses modifier index-string)))

; Code discarded 2006-09-12
; (define (var-to-string var)
;   (let* ((type (var-to-type var))
; 	 (index (var-to-index var))
; 	 (t-deg (var-to-t-deg var))
; 	 (name (var-to-name var))
; 	 (name1 (if (string=? "" name)
; 		    (type-to-string type)
; 		    name)))
;     (string-append
;      (if (string=? "" name)
; 	 ""
; 	 (let ((info (assoc name VARIABLES)))
; 	   (if (or (eq? info #f)
; 		   (not (equal? (cadr info) type)))
; 	       (string-append (type-to-string type) "_")
; 	       "")))
;      (if
;       (t-deg-one? t-deg)
;       (if (= index -1)
; 	  name1
; 	  (let ((stringlist (string->list name1)))
; 	    (cond
; 	     ((or (and (or (arrow-form? type) (star-form? type))
; 		       (not (assoc type DEFAULT-VAR-NAMES)))
; 		  (char-numeric? (string-ref name1 (- (length stringlist) 1)))
; 		  (member #\space stringlist))
; 	      (string-append "(" name1 ")_" (number-to-string index)))
; 	     ((and (tvar-form? type)
; 		   (not (assoc type DEFAULT-VAR-NAMES)))
; 	      (string-append name1 "_" (number-to-string index)))
; 	     (else (string-append name1 (number-to-string index))))))
;       (if (= index -1)
; 	  (string-append name1 "^")
; 	  (let ((stringlist (string->list name1)))
; 	    (if (or (and (or (arrow-form? type) (star-form? type))
; 			 (not (assoc type DEFAULT-VAR-NAMES)))
; 		    (char-numeric? (string-ref name1 (- (length stringlist) 1)))
; 		    (member #\space stringlist))
; 		(string-append "(" name1 ")^" (number-to-string index))
; 		(string-append name1 "^" (number-to-string index)))))))))

; Code discarded 2005-06-26
; (define (var-to-string var)
;   (let* ((type (var-to-type var))
; 	 (index (var-to-index var))
; 	 (t-deg (var-to-t-deg var))
; 	 (name (var-to-name var))
; 	 (name1 (if (string=? "" name)
; 		    (type-to-string type)
; 		    name)))
;     (if
;      (= t-deg 1)
;      (if (= index -1)
; 	 name1
; 	 (let ((stringlist (string->list name1)))
; 	   (if (or (and (or (arrow-form? type) (star-form? type))
; 			(not (assoc type DEFAULT-VAR-NAMES)))
; 		   (char-numeric? (string-ref name1 (- (length stringlist) 1)))
; 		   (member #\space stringlist))
; 	       (string-append "(" name1 ")_" (number-to-string index))
; 	       (string-append name1 (number-to-string index)))))
;      (if (= index -1)
; 	 (string-append name1 "^")
; 	 (let ((stringlist (string->list name1)))
; 	   (if (or (and (or (arrow-form? type) (star-form? type))
; 			(not (assoc type DEFAULT-VAR-NAMES)))
; 		   (char-numeric? (string-ref name1 (- (length stringlist) 1)))
; 		   (member #\space stringlist))
; 	       (string-append "(" name1 ")^" (number-to-string index))
; 	       (string-append name1 "^" (number-to-string index))))))))

(define (vars-to-comma-string vars)
  (if (null? vars)
      ""
      (do ((l (cdr vars) (cdr l))
	   (res (var-to-string (car vars))
		(string-append res "," (var-to-string (car l)))))
	  ((null? l) res))))

(define (vars-to-string vars)
  (if (null? vars) "()"
      (do ((l (cdr vars) (cdr l))
	   (res (var-to-string (car vars))
		(string-append res "," (var-to-string (car l)))))
	  ((null? l) (string-append "(" res ")")))))


; For automatic generation of variables we need

(define (numerated-var? var)
  (and (string=? "" (var-to-name var))
       (<= 0 (var-to-index var))))

(define (numerated-var-to-index x) (var-to-index x))

(define (type-to-new-var type . optional-var)
  (make-var type (+ 1 MAXVARINDEX)
	    (if (null? optional-var)
		t-deg-one
		(var-to-t-deg (car optional-var)))
	    (default-var-name type)))

; (define (type-to-new-var type . var)
;   (if (null? var)
;       (make-var type (+ 1 MAXVARINDEX) 1 (default-var-name type))
;       (make-var type (+ 1 MAXVARINDEX) 
; 		(var-to-t-deg (car var))
; 		(default-var-name type))))
		
(define (type-to-new-partial-var type . optional-var)
  (make-var type (+ 1 MAXVARINDEX)
	    (if (null? optional-var)
		t-deg-zero
		(var-to-t-deg (car optional-var)))
	    (default-var-name type)))

(define (default-var? var)
  (and (string=? (default-var-name (var-to-type var))
		 (var-to-name var))
       (<= 0 (var-to-index var))))

; Occasionally we may want to create a new variable with the same name
; (and degree of totality) as a given one.  This is useful e.g. for
; bound renaming.  Therefore we supply

(define (var-to-new-var var)
  (make-var
   (var-to-type var)
   (+ 1 MAXVARINDEX)
   (var-to-t-deg var)
   (var-to-name var)))

; var-to-new-partial-var creates a new partial variable with the same
; name and type as the given one.

(define (var-to-new-partial-var var)
  (make-var
   (var-to-type var)
   (+ 1 MAXVARINDEX)
   t-deg-zero
   (var-to-name var)))

