;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  MDH -- 071117 updated for integration with the mainstream MINLOG
;;;  Based on the independent variant finalised in 2006 upon PhD defence 
;;;  This is the unique module for program extraction by Pure, Light or Monotone
;;;  Dialectica interpretation. Based on M.-D. Hernest's PhD thesis
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(newline)
(display "**********************************************************")
(newline)
(display "******  Begin loading DIALECTICA Interpretation extraction module ...")
(newline)
(display "**********************************************************")
(newline)

(define (reset-contr-count)
  (set! CIRC-COUNT 0)
  (comment "***  CIRC-COUNT counter set to ZERO ***")
  (set! CRLC-COUNT 0)
  (comment "***  CRLC-COUNT counter set to ZERO ***"))
(define init-contr-count (reset-contr-count))

(define (contraction-count)
    (begin
               (newline)
	 (display "************************************************")
	 (newline)
	 (display "Number of Non-Computational Contractions was ") (display CIRC-COUNT)
	 (newline)
	  (display "Number of Computationally Relevant Contractions was ") (display CRLC-COUNT)
	 (newline)
	 (display "*************************************************")
	 (newline)
	 ))

(define (reset-IndRule-count)
  (set! IndRuleCOUNTER 0)
  (comment "***  IndRuleCOUNTER counter set to ZERO ***")
  (set! IndRlZeCOUNTER 0)
  (comment "***  IndRlZeCOUNTER counter set to ZERO ***"))
(define init-IndRule-count (reset-IndRule-count))

(define (IndRule-count)
    (begin
               (newline)
	 (display "************************************************")
	 (newline)
	 (display "Number of Induction Rule IR applications was ") (display IndRuleCOUNTER)
	 (newline)
	  (display "Number of QFR Induction Rules - IRzero - was ") (display IndRlZeCOUNTER)
	 (newline)
	 (display "*************************************************")
	 (newline)
	 ))

(define (DIA-reset-counters)
   (reset-contr-count)
   (reset-IndRule-count)
   (set! UNFOLDING-FLAG #f)
   (comment "*** UNFOLDING-FLAG flag set to FALSE ***")
   (set! IMP-ELIM-NORMALIZE #t)
   (comment "*** IMP-ELIM-NORMALIZE flag set to TRUE ***"))

(define (DIA-display-counters)
   (contraction-count)
   (IndRule-count))

;; FLAGS
(set! UNFOLDING-FLAG #f)
(comment "*** UNFOLDING-FLAG flag set to FALSE ***")
;; The "CHECK" flag decides whether any testing should be
;; done at all - it is good to turn it to #t at the first
;; run on some example and let it remain #f for the subsequent runs
(define CHECK #f)
(comment "*** CHECK flag set to FALSE ***")
;; The "PARANOIA" flag decides whether a DEEP testing should be
;; done concerning the arguments of various procedure below. By
;; default only simple coherence tests are performed. This is
;; attained by setting the "PARANOIA" flag to the value "#f".
;; DEEP testing is more resource-consuming and is triggered by
;; a "#t" value of the "PARANOIA" flag. All tests are RUN-TIME!!!
(define PARANOIA #f)
(comment "*** PARANOIA flag set to FALSE ***")
;; The "COMENTARIU" flag decides whether a minimal level
;; of messages is active or not. 
(define COMENTARIU #f)
(comment "*** COMENTARIU flag set to FALSE ***")
(define EXTRACT-VERBOSE #f)
(comment "*** EXTRACT-VERBOSE flag set to FALSE ***")
(define CONTR-VERBOSE #f)
(comment "*** CONTR-VERBOSE flag set to FALSE ***")
;; The "DEBUG" flag decides whether a debug-level of
;; messages is active or not. 
(define DEBUG #f)
(comment "*** DEBUG flag set to FALSE ***")
;; The "DEBUG-IND-RL" flag decides whether a debug-level
;; of messages is active or not in connection with
;; the treatment of the Induction Rule IR. 
(define DEBUG-IND-RL #f)
(comment "*** DEBUG-IND-RL flag set to FALSE ***")
;; The "DEBUG-UGA" flag decides whether a debug-level
;; of messages is active or not in connection with
;; the treatment of User Global Assumptions
(define DEBUG-UGA #f)
(comment "*** DEBUG-UGA flag set to FALSE ***")
;; The "DEBUG-DIDA" flag decides whether a debug-level
;; of messages is active or not inside the procedure
;; DIA-Data which associates the 
;; characteristic term to an avar
(define DEBUG-DIDA #f)
(comment "*** DEBUG-DIDA flag set to FALSE ***")
;; The "DEBUG-MAVD" flag decides whether a debug-level of
;; messages is active or not inside the procedure
;; DIA-make-avar-to-Data which 
;; associate the characteristic term to an avar
(define DEBUG-MAVD #f)
(comment "*** DEBUG-MAVD flag set to FALSE ***")
;; The "DEBUG-STAR" flag decides whether a debug-level of
;; messages is active or not inside the procedures
;; DIA-star-to-tmtuple, DIA-star-to-left and DIA-star-to-right
(define DEBUG-STAR #f)
(comment "*** DEBUG-STAR flag set to FALSE ***")
;; The "DEBUG-NORMALIZE" flag decides whether a debug-level of
;; messages is active or not in connection with
;; nbe-normalize-vatmpair. 
(define DEBUG-NORMALIZE #f)
(comment "*** DEBUG-NORMALIZE flag set to FALSE ***")
;; The "NORMALIZE-PROOF" flag decides whether a normalization 
;; of the proof at input should be performed before beginning
;; the program-extraction process. 
(define NORMALIZE-PROOF #f)
(comment "*** NORMALIZE-PROOF flag set to FALSE ***")
;; The "NORMALIZE-TERMS" flag decides whether a normalization of the
;; extracted terms should be performed during the extraction
;; process or not. 
(define NORMALIZE-TERMS #f)
(comment "*** NORMALIZE-TERMS flag set to FALSE ***")
;; The "THEOREM-NORMALIZE" flag decides whether a normalization of the
;; terms extracted from proofs of theorems should be performed
(define THEOREM-NORMALIZE #f)
(comment "*** THEOREM-NORMALIZE flag set to FALSE ***")
(define ALL-NORMALIZE #f)
(comment "*** ALL-NORMALIZE flag set to FALSE ***")
(define AND-NORMALIZE #f)
(comment "*** AND-NORMALIZE flag set to FALSE ***")
(define IND-RL-NORMALIZE #f)
(comment "*** IND-RL-NORMALIZE flag set to  FALSE ***")
(define CONDN-NORMALIZE #f)
(comment "*** CONDN-NORMALIZE flag set to FALSE ***")
(define IMP-INTRO-NORMALIZE #f)
(comment "*** IMP-INTRO-NORMALIZE flag set to FALSE ***")
(define IMP-ARG-NORMALIZE #f)
(comment "*** IMP-ARG-NORMALIZE flag set to  FALSE ***")
(define IMP-ELIM-NORMALIZE #t)
(comment "*** IMP-ELIM-NORMALIZE flag set to TRUE ***")

(define (DIA-time proc)
   (if EXTRACT-VERBOSE (time proc) proc))


(define (NULL-vatuple? vatup)
  (if (not-vatuple? vatup)
      (myerror "NULL-vatuple?: "
        "vatuple argument expected" vatup)
      (if (null? (cdr vatup)) #t
          (if (null? (cddr vatup)) #f
	 (and  (NULL-vatuple?   (cadr vatup))
	       (NULL-vatuple?  (cddr vatup)))))))

(define (NULL-tmtuple? tmtup)
  (if (not-tmtuple? tmtup)
      (myerror "NULL-tmtuple?: "
        "tmtuple argument expected" tmtup)
      (if (null? (cdr tmtup)) #t
          (if (null? (cddr tmtup)) #f
	 (and  (NULL-tmtuple?   (cadr tmtup))
	       (NULL-tmtuple?  (cddr tmtup)))))))


(define (DIA-set-minus lst tmtupalst)
  (do ((l tmtupalst  (cdr l))
      (res lst (set-minus res (formula-to-free 
		 (avar-to-formula (caar l))))))
      ((null? l) res)))

(define (set-flag FLG VAL)
  (begin
    (if VAL
        (if (not (eq? VAL #t))
            (myerror "set-flag:"
              "Only #t and #f are allowed as values here"
              "You gave me a value equivalent to #t."
              "Please give me THE value #t if that's"
              "what you really want!!!"))
        (if (not (eq? VAL #f))
            (myerror "set-flag:"
              "Only #t and #f are allowed as values here"
              "You gave me a value equivalent to #f."
              "Please give me THE value #f if that's"
              "what you really want!!!")))
    (case FLG
      ((CHECK)
       (begin (set! CHECK VAL)
              (comment "*** CHECK flag set to "
                VAL " ***")
              (if (not VAL)
                  (begin
                    (set! PARANOIA VAL)
                    (comment
                      "*** PARANOIA flag set to "
                      VAL " ***")
                    (set! DEBUG VAL)
                    (comment
                      "*** DEBUG flag set to "
                      VAL " ***")))))                    
      ((PARANOIA)
       (begin (set! PARANOIA VAL)
              (comment
                "*** PARANOIA flag set to "
                VAL " ***")
              (if VAL
                  (begin
                    (set! CHECK  VAL)
                    (comment
                      "*** CHECK flag set to "
                      VAL " ***"))
                  (begin
                    (set! DEBUG VAL)
                    (comment
                      "*** DEBUG flag set to "
                      VAL " ***")))))                    
      ((DEBUG)
       (begin (set! DEBUG VAL)
              (comment
                "*** DEBUG flag set to "
                VAL " ***")
              (if VAL
                  (begin
                    (set! PARANOIA VAL)
                    (comment
                      "*** PARANOIA flag set to "
                      VAL " ***")
                    (set! CHECK VAL)
                    (comment
                      "*** CHECK flag set to "
                      VAL " ***")))))
      ((NORMALIZE-TERMS)
       (begin (set! NORMALIZE-TERMS VAL)
              (comment "*** NORMALIZE-TERMS flag set to "
                VAL " ***")
              (if VAL
                  (begin
                    (set! UNFOLDING-FLAG  #f)
                    (comment
                      "*** UNFOLDING-FLAG flag"
                      "set to FALSE ***")))))
      ((UNFOLDING-FLAG)
       (begin (set! UNFOLDING-FLAG VAL)
              (comment "*** UNFOLDING-FLAG flag set to "
                VAL " ***")))
      (else
        (myerror
          "set-flag: please use one of the following FLAGS:"
          "'CHECK or 'PARANOIA or 'DEBUG or 'NORMALIZE-TERMS"
          "or 'UNFOLDING-FLAG")))))      

(define (aconst-to-repro-formula1 x) (cadr (cddddr x)))
(define (aconst-to-repro-formula2 x) (caddr (cddddr x)))
(define FALSE_tm (make-term-in-const-form false-const))
(define TRUE_tm (make-term-in-const-form true-const))


(define NULL_typ (py "nulltype"))
(define (NULL-typ? ty) (equal? NULL_typ ty))
(add-program-constant "NULL" NULL_typ)
(define NULL_tm (pt "NULL"))
(define (NULL-tm? tm) (equal? NULL_tm tm))

(define (not-avar? x)
  (if (avar? x) #f #t))
(define (not-alg-form? x)
  (if (alg-form? x) #f #t))
(define (not-list? x) (if (list? x) #f #t))
(define (not-null? x) (if (null? x) #f #t))
(define (not-eq? x y) (if (eq? x y) #f #t))
(define (not-pair? x) (if (pair? x) #f #t))
(define (not-type? x) (if (type? x) #f #t))
(define (not-type-form? x) (if (type-form? x) #f #t))
(define (not-var? x) (if (var? x) #f #t))
(define (nvar-form? x) (if (var-form? x) #f #t))
(define (not-term? x) (if (term? x) #f #t))
(define term-DEEP? term?)
(define (not-term-DEEP? x) (if (term-DEEP? x) #f #t))

(define (DIA-formula? x)
  (if CHECK
      (formula? x)
      #t))
(define (not-DIA-formula? x)
  (if (DIA-formula? x) #f #t))
(define (DIA-type? x)
  (if CHECK
      (if PARANOIA (type? x)
          (type-form? x))
      #t))
(define (not-DIA-type? x)
  (if (DIA-type? x) #f #t))
(define (DIA-var? x)
  (if CHECK
      (if PARANOIA (var? x)
          (var-form? x))
      #t))
(define (not-DIA-var? x)
  (if (DIA-var? x) #f #t))
(define (DIA-term? x)
  (if CHECK
      (if PARANOIA (term-DEEP? x)
          (term? x))
      #t))
(define (not-DIA-term? x)
  (if (DIA-term? x) #f #t))

(define (term-to-zero tm)
  (type-to-zero (term-to-type tm)))
(define (var-to-zero va)
  (type-to-zero (var-to-type va)))
(define DIA-ZERO-LIST '())
(define (type-to-zero typ)
  (if (ground-type? typ)
      (type-to-canonical-inhabitant typ)
      (let((info
             (assoc-wrt equal?
               typ DIA-ZERO-LIST)))
        (if info (cadr info)
            (let((new-zero
                   (type-to-zero-aux typ)))
              (begin
                (set! DIA-ZERO-LIST
                  (cons (list typ new-zero)
                    DIA-ZERO-LIST))
                new-zero))))))

(define (type-to-zero-aux typ)
  (if (arrow-form? typ)
      (make-term-in-abst-form 
        (type-to-new-var
          (arrow-form-to-arg-type typ))
        (type-to-zero
          (arrow-form-to-val-type typ)))
      (if (star-form? typ)
          (make-term-in-pair-form 
            (type-to-zero
              (star-form-to-left-type typ))
            (type-to-zero
              (star-form-to-right-type typ)))
          (type-to-canonical-inhabitant typ))))

(define (DIA-type-to-string typ)
  (if CHECK
      (if PARANOIA
          (DIA-type-to-string-aux typ)
          (if (not-type? typ)
              (myerror "DIA-type-to-string:"
                "type argument expected" typ)
              (DIA-type-to-string-aux typ)))
      (DIA-type-to-string-aux typ)))
(define DIA-type-to-string-aux type-to-string)

(define (DIA-var-to-string va)
  (if CHECK
      (if PARANOIA (var-to-string va)
          (if (not-var? va)
              (myerror "DIA-var-to-string:"
                "variable argument expected" va)
              (var-to-string va)))
      (var-to-string va)))

(define (DIA-term-to-string tm)
  (if CHECK
      (if PARANOIA (term-to-string tm)
          (if (not-term-DEEP? tm)
              (myerror "DIA-term-to-string:"
                "term argument expected" tm)
              (term-to-string tm)))
      (term-to-string tm)))

;; DISPLAY PROCEDURES

(define SNL (string #\newline))
(define SBK (string #\backspace))
(define SBK2 (string-append SBK SBK))
(define SBK3 (string-append SBK SBK2))

(define (DIA-comment . x)
  (if COMENTARIU
      (if (not-null? x)
          (begin
            (newline) 
            (display "; ")
            (do ((l x (cdr l)))
                ((null? l) (newline))
              (case (car l)
                ((CNL)
                 (newline) (display "; "))
                (else
                  (display " ")
                  (display (car l)))))))))

(define (DIA-comment-forced . x)
  (if #t
      (if (not-null? x)
          (begin
            (newline) 
            (display "; ")
            (do ((l x (cdr l)))
                ((null? l) (newline))
              (case (car l)
                ((CNL)
                 (newline) (display "; "))
                (else
                  (display " ")
                  (display (car l)))))))))


(define (nldisplay .  strings)  
  (newline)
  (display strings)
  (newline))

(define (normalize-term-to-string term)
  (DIA-term-to-string
    (nbe-normalize-term term)))

(define (tytuple-to-string tytup)
  (if (not-tytuple? tytup)
      (myerror "tytuple-to-string:"
        "tytuple argument expected" tytup)
      (if (null? (cdr tytup)) "ETY"
          (if (null? (cddr tytup))
              (DIA-type-to-string
                (cadr tytup))
              (string-append "{"
                (tytuple-to-string
                  (cadr tytup)) ","
                (tytuple-to-string
                  (cddr tytup)) "}")))))

(define (vatuple-to-string vatup)
  (if (not-vatuple? vatup)
      (myerror "vatuple-to-string:"
        "vatuple argument expected" vatup)
      (if (null? (cdr vatup)) "EVA"
          (if (null? (cddr vatup))
              (DIA-var-to-string
                (cadr vatup))
              (string-append "{"
                (vatuple-to-string
                  (cadr vatup)) ","
                  (vatuple-to-string
                    (cddr vatup)) "}")))))

(define (normalize-tmtuple-to-string tmtpl)
  (tmtuple-to-string
    (nbe-normalize-tmtuple tmtpl)))

(define (tmtuple-to-string tmtup)
  (if (not-tmtuple? tmtup)
      (myerror "tmtuple-to-string:"
        "tmtuple argument expected" tmtup)
      (if (null? (cdr tmtup)) "ETM"
          (if (null? (cddr tmtup))
              (DIA-term-to-string
                (cadr tmtup))
              (string-append "{"
                (tmtuple-to-string
                  (cadr tmtup)) ","
                  (tmtuple-to-string
                    (cddr tmtup)) "}")))))

(define (tmtuplist-to-string tmtuplst)
  (string-append "BEGIN<tmtuplist>"
    SNL "FIRST-TMTUPLE = "
    (tmtuplist-to-string-aux tmtuplst)))

(define (tmtuplist-to-string-aux tmtuplst)
  (if (null? tmtuplst)
      (string-append SNL "END<tmtuplist>")
      (let((car_tmtuplst (car tmtuplst)) 
           (cdr_tmtuplst (cdr tmtuplst)))
        (if (null? cdr_tmtuplst) 
            (string-append
              (tmtuple-to-string
                car_tmtuplst) 
              SNL "END<tmtuplist>")
            (string-append
              (tmtuple-to-string
                car_tmtuplst) 
              SNL "NEXT-TMTUPLE = "
              (tmtuplist-to-string-aux
                cdr_tmtuplst))))))

(define (normalize-tmtuplist-to-string tmtuplst)
  (string-append
    "BEGIN<tmtuplist>" SNL "FIRST-TMTUPLE = "
    (normalize-tmtuplist-to-string-aux tmtuplst)))

(define (normalize-tmtuplist-to-string-aux
          tmtuplst)
  (if (null? tmtuplst)
      (string-append SNL "END<tmtuplist>")
      (let ((car_tmtuplst (car tmtuplst)) 
            (cdr_tmtuplst (cdr tmtuplst)))
        (if (null? cdr_tmtuplst) 
            (string-append
              (normalize-tmtuple-to-string
                car_tmtuplst) 
              SNL "END<tmtuplist>")
            (string-append
              (normalize-tmtuple-to-string
                car_tmtuplst) 
              SNL "NEXT-TMTUPLE = "
              (normalize-tmtuplist-to-string-aux
                cdr_tmtuplst))))))

(define (nbe-normalize-tmtuplist tmtuplst)
  (if (null? tmtuplst)  tmtuplst
      (let((car_tmtuplst (car tmtuplst)) 
           (cdr_tmtuplst (cdr tmtuplst)))
        (if (null? cdr_tmtuplst) 
            (list
              (nbe-normalize-tmtuple
                car_tmtuplst))
            (cons
              (nbe-normalize-tmtuple
                car_tmtuplst) 
              (nbe-normalize-tmtuplist
                cdr_tmtuplst))))))

(define (DIA-avars-to-string avar-lst) 
  (string-append "BEGIN<avar-list>"
    SNL "FIRST-AVAR = " 
    (DIA-avars-to-string-aux avar-lst)))

(define (DIA-avars-to-string-aux avar-lst)
  (if (null? avar-lst)
      (string-append SNL "END<avar-list>")
      (string-append
        (avar-to-string (car avar-lst))
        " of formula " SNL
        (formula-to-string 
          (avar-to-formula (car avar-lst)))
        SNL "NEXT-AVAR = " 
        (DIA-avars-to-string-aux
          (cdr avar-lst)))))

(define (tmtuplealist-to-string tmtplalst) 
  (if (not (tmtuplealist? tmtplalst))
      (myerror "tmtuplealist-to-string:"
        "argument must be tmtuplealist")
      (string-append "BEGIN<tmtuplealist>"
        SNL "FIRST-ASSOCIATION = " SNL
        (tmtuplealist-to-string-aux tmtplalst))))

(define (tmtuplealist-to-string-aux tmtplalst)
  (if (null? tmtplalst)
      (string-append SNL "END<tmtuplealist>")
      (string-append
        "ASSOC-FORMULA = "
        (formula-to-string 
          (avar-to-formula (caar tmtplalst)))
        SNL "ASSOC-TMTUPLE= "
        (tmtuple-to-string (cdar tmtplalst))
        SNL "NEXT-ASSOCIATION = " SNL
        (tmtuplealist-to-string-aux
          (cdr tmtplalst)))))

(define (types-tmtuplealist-to-string tmtplalst) 
  (if (ntmtuplealist? tmtplalst)
      (myerror "types-tmtuplealist-to-string:"
        "argument must be tmtuplealist")
      (string-append "BEGIN<tmtuplealist>"
        SNL "FIRST-ASSOCIATION = " SNL
        (types-tmtuplealist-to-string-aux
          tmtplalst))))
(define (types-tmtuplealist-to-string-aux
          tmtplalst)
  (if (null? tmtplalst)
      (string-append SNL "END<tmtuplealist>")
      (string-append
        "ASSOC-FORMULA = "
        (formula-to-string 
          (avar-to-formula (caar tmtplalst)))
        SNL "ASSOC-TMTUPLE= "
        (tytuple-to-string 
          (tmtuple-to-tytuple (cdar tmtplalst)))
        SNL "NEXT-ASSOCIATION = " SNL
        (types-tmtuplealist-to-string-aux
          (cdr tmtplalst)))))

(define (normalize-tmtuplealist-to-string
          tmtplalst) 
  (if (ntmtuplealist? tmtplalst)
      (myerror
        "normalize-tmtuplealist-to-string:"
        "argument must be tmtuplealist")
      (string-append "BEGIN<tmtuplealist>"
        SNL "FIRST-ASSOCIATION = "
        (normalize-tmtuplealist-to-string-aux
          tmtplalst))))
(define (normalize-tmtuplealist-to-string-aux
          tmtplalst)
  (if (null? tmtplalst) "END<tmtuplealist>"
      (string-append
        "ASSOC-FORMULA = "
        (formula-to-string 
          (avar-to-formula (caar tmtplalst)))
        SNL "ASSOC-TMTUPLE= "
        (normalize-tmtuple-to-string 
          (cdar tmtplalst)) 
        SNL "NEXT-ASSOCIATION = "
        (normalize-tmtuplealist-to-string-aux
          (cdr tmtplalst)))))

(define (nbe-normalize-tmtuplealist tmtplalst)
  (if (null? tmtplalst) tmtplalst
      (cons
        (cons (caar tmtplalst)
          (nbe-normalize-tmtuple
            (cdar tmtplalst)))
        (nbe-normalize-tmtuplealist
          (cdr tmtplalst)))))

(define (typair-to-string typair) 
  (string-append
    "BEGIN<typair>" 
    SNL "TYPAIR-LEFT = "
    (tytuple-to-string (typair-left typair)) 
    SNL "TYPAIR-RIGHT = " 
    (tytuple-to-string (typair-right typair)) 
    SNL "END<typair>"))

(define (vapair-to-string vapr) 
  (string-append
    "BEGIN<vapair>" 
    SNL "VAPAIR-LEFT = "
    (vatuple-to-string (vapair-left vapr)) 
    SNL "VAPAIR-RIGHT = " 
    (vatuple-to-string (vapair-right vapr)) 
    SNL "END<vapair>"))

(define (tmpair-to-string tmpair) 
  (string-append
    "BEGIN<tmpair>" 
    SNL "TMTUPLE = "
    (tmtuple-to-string
      (tmpair-to-tuple tmpair)) 
    SNL "ALIST = " 
    (tmtuplealist-to-string
      (tmpair-to-alist tmpair)) 
    SNL "END<tmpair>"))

(define (types-tmpair-to-string tmpair) 
  (string-append
    "BEGIN<tmpair>" 
    SNL "TMTUPLE = "
    (tytuple-to-string
      (tmtuple-to-tytuple
        (tmpair-to-tuple tmpair)))
    SNL "ALIST = " 
    (types-tmtuplealist-to-string
      (tmpair-to-alist tmpair)) 
    SNL "END<tmpair>"))

(define (normalize-tmpair-to-string tmpair) 
  (string-append
    "BEGIN<tmpair>" 
    SNL "TMTUPLE = "
    (normalize-tmtuple-to-string
      (tmpair-to-tuple tmpair)) 
    SNL "ALIST = " 
    (normalize-tmtuplealist-to-string
      (tmpair-to-alist tmpair)) 
    SNL "END<tmpair>"))

(define (nbe-normalize-tmpair tmpair) 
  (make-tmpair
    (nbe-normalize-tmtuple
      (tmpair-to-tuple tmpair))
    (nbe-normalize-tmtuplealist
      (tmpair-to-alist tmpair))))

(define (vatmpair-to-string vatmpr) 
  (string-append
    SNL "BEGIN<vatmpair>" SNL
    (vapair-to-string
      (vatmpair-to-vapair vatmpr)) 
    SNL  (tmpair-to-string
           (vatmpair-to-tmpair vatmpr))  
    "END<vatmpair>"))

(define (normalize-vatmpair-to-string vatmpr) 
  (string-append
    SNL "BEGIN<vatmpair>" SNL
    (vapair-to-string
      (vatmpair-to-vapair vatmpr)) 
    SNL  (normalize-tmpair-to-string
           (vatmpair-to-tmpair vatmpr))  
    "END<vatmpair>" ))

(define (nbe-normalize-vatmpair-of rule vatmpr)
  (let((new-vatmpr
         (if rule
             (make-vatmpair
               (vatmpair-to-vapair vatmpr) 
               (DIA-time
                 (nbe-normalize-tmpair
                   (vatmpair-to-tmpair vatmpr))))
             vatmpr)))
    (begin
      (if DEBUG-NORMALIZE
          (nldisplay
            "nbe-normalize-vatmpair-of:"
            SNL (vatmpair-to-string
                  new-vatmpr)))
      new-vatmpr)))

(define (nbe-normalize-vatmpair vatmpr)
  (let((new-vatmpr
         (if NORMALIZE-TERMS
             (make-vatmpair
               (vatmpair-to-vapair vatmpr) 
               (nbe-normalize-tmpair
                 (vatmpair-to-tmpair vatmpr)))
             vatmpr)))
    (begin
      (if DEBUG-NORMALIZE
          (nldisplay "nbe-normalize-vatmpair:"
            SNL (vatmpair-to-string
                  new-vatmpr)))
      new-vatmpr)))      

(define (types-vatmpair-to-string vatmpr) 
  (string-append
    SNL "BEGIN<vatmpair>" SNL
    (vapair-to-string
      (vatmpair-to-vapair vatmpr)) 
    SNL  (types-tmpair-to-string
           (vatmpair-to-tmpair vatmpr))  
    "END<vatmpair>"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DATATYPE tylist == a simple list of types
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (tylist? lst)
  (if (not-list? lst) #f
      (tylist?-aux lst)))
(define (tylist?-aux lst)
  (if (null? lst) #t
      (if (DIA-type? (car lst))
          (tylist?-aux (cdr lst))
          #f)))
(define (not-tylist? lst)
  (if (not-list? lst) #t
      (not-tylist?-aux lst)))
(define (not-tylist?-aux lst)
  (if (null? lst) #f
      (if (not-DIA-type? (car lst)) #t
          (not-tylist?-aux (cdr lst)))))

(define (tylist-to-string tylst)
  (begin
    (if PARANOIA
        (if (not-tylist? tylst)
            (myerror "tylist-to-string:"
              "tylist argument expected" tylst)))
    (if (null? tylst) "<| EMPTY-TYLIST |>"
        (string-append "<| "
          (tylist-to-string-aux tylst) " |>"))))
(define (tylist-to-string-aux tylst)
  (if (null? tylst) SBK3
      (string-append
        (type-to-string (car tylst)) " , "
        (tylist-to-string-aux (cdr tylst)))))

(define (tytuple-to-tylist tytup)
  (if (not-tytuple? tytup)
      (myerror "tytuple-to-tylist:"
        "tytuple argument expected" tytup)
      (tytuple-to-tylist-aux tytup)))
(define (tytuple-to-tylist-aux tytup)
  (if (null? (cdr tytup)) '()
      (if (null? (cddr tytup)) (list (cadr tytup))
          (append (tytuple-to-tylist-aux (cadr tytup))
            (tytuple-to-tylist-aux (cddr tytup))))))

(define (tylist-minus-tytuple tylst tytup)
  (begin
    (if PARANOIA
        (if (not-tylist? tylst)
            (myerror "tylist-minus-tytuple:"
              "1st argument must be tylist "
              tylst)))
    (if PARANOIA
        (if (not-tytuple? tytup)
            (myerror "tylist-minus-tytuple:"
              "2nd argument must be tytuple "
              tytup)))
    (tylist-minus-tylist tylst
      (tytuple-to-tylist tytup))))
(define (tylist-minus-tylist tylstOP tylstARG)
  (cond
    ((Eq? tylstOP #f) #f)
    ((null? tylstARG) tylstOP)
    (else
      (tylist-minus-tylist
        (tylist-minus-type tylstOP
          (car tylstARG)) (cdr tylstARG)))))
(define (tylist-minus-type tylst typ)
  (cond
    ((null? tylst) #f)
    ((Equal? (car tylst) typ) (cdr tylst))
    (else
      (cons (car tylst)
        (tylist-minus-type (cdr tylst) typ)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DATATYPE valist == a simple list of vars
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (valist? lst)
  (if (not-list? lst) #f
      (valist?-aux lst)))
(define (valist?-aux lst)
  (if (null? lst) #t
      (if (DIA-var? (car lst))
          (valist?-aux (cdr lst))
          #f)))
(define (not-valist? lst)
  (if (not-list? lst) #t
      (not-valist?-aux lst)))
(define (not-valist?-aux lst)
  (if (null? lst) #f
      (if (not-DIA-var? (car lst)) #t
          (not-valist?-aux (cdr lst)))))

(define (valist-to-string valst)
  (begin
    (if PARANOIA
        (if (not-valist? valst)
            (myerror "valist-to-string:"
              "valist argument expected" valst)))
    (if (null? valst) "<| EMPTY-VALIST |>"
        (string-append "<| "
          (valist-to-string-aux valst) " |>"))))
(define (valist-to-string-aux valst)
  (if (null? valst) SBK3
      (string-append
        (var-to-string (car valst)) " , "
        (valist-to-string-aux (cdr valst)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DATATYPE tmlist == a simple list of terms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (tmlist? lst)
  (if (not-list? lst) #f
      (tmlist?-aux lst)))
(define (tmlist?-aux lst)
  (if (null? lst) #t
      (if (DIA-term? (car lst))
          (tmlist?-aux (cdr lst))
          #f)))
(define (not-tmlist? lst)
  (if (not-list? lst) #t
      (not-tmlist?-aux lst)))
(define (not-tmlist?-aux lst)
  (if (null? lst) #f
      (if (not-DIA-term? (car lst)) #t
          (not-tmlist?-aux (cdr lst)))))

(define (tmtuple-to-tmlist tmtup)
  (if (not-tmtuple? tmtup)
      (myerror "tmtuple-to-tmlist:"
        "tmtuple argument expected" tmtup)
      (tmtuple-to-tmlist-aux tmtup)))
(define (tmtuple-to-tmlist-aux tmtup)
  (if (null? (cdr tmtup)) '()
      (if (null? (cddr tmtup)) (list (cadr tmtup))
          (append (tmtuple-to-tmlist-aux (cadr tmtup))
            (tmtuple-to-tmlist-aux (cddr tmtup))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DATATYPE tytuple -- a binary tree with nodes labeled by types
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define NULL_tytup (cons 'tytuple '()))

(define (type-to-tytuple ty)
  (if (not-DIA-type? ty)
      (myerror "type-to-tytuple:"
        "type argument expected" ty)
      (cons 'tytuple (cons ty '()))))

(define (tytupleSIMP? tytup)
  (if (null? tytup) #f
      (if (not-pair? tytup) #f
          (if (not-eq? (car tytup) 'tytuple) #f
              (if (null? (cdr tytup)) #t
                  (if (not-pair? (cdr tytup)) #f
                      (if (null? (cddr tytup))
                          (type-form? (cadr tytup))
                          (and (tytupleSIMP?
                                 (cadr tytup))
                               (tytupleSIMP?
                                 (cddr tytup))))))))))
(define (ntytupleSIMP? tytup)
  (if (tytupleSIMP? tytup) #f #t))

(define (tytupleDEEP? tytup)
  (if (null? tytup) #f
      (if (not-pair? tytup) #f
          (if (not-eq? (car tytup) 'tytuple) #f
              (if (null? (cdr tytup)) #t
                  (if (not-pair? (cdr tytup)) #f
                      (if (null? (cddr tytup))
                          (type? (cadr tytup))
                      (and (tytupleDEEP?
                             (cadr tytup))
                           (tytupleDEEP?
                             (cddr tytup))))))))))
(define (ntytupleDEEP? tytup)
  (if (tytupleDEEP? tytup) #f #t))

(define (tytuple? tytup)
  (if CHECK
      (if PARANOIA (tytupleDEEP? tytup)
          (tytupleSIMP? tytup))
      #t))
(define (not-tytuple? tytup)
 (if (tytuple? tytup) #f #t))

(define (tytuple-assoc tytup)
  (if (not-tytuple? tytup)
      (myerror "tytuple-assoc:"
        "argument must be a tytuple" tytup)
      (if (null? (cdr tytup))
          (myerror "tytuple-assoc:"
            "argument cannot be NULL_tytup")
          (if (null? (cddr tytup))
              (myerror
                "tytuple-assoc: argument"
                "cannot be SINGLETON tytuple")
              (let((pair (cadr tytup))
                   (C (cddr tytup)))
                (if (null? (cdr pair))
                    (myerror
                      "tytuple-assoc: left of argument"
                      "cannot be NULL_tytup")
                    (if (null? (cddr pair))
                        (myerror
                          "tytuple-assoc: left of argument"
                          "cannot be SINGLETON tytuple")
                        (let((A (cadr pair))
                             (B (cddr pair)))
                          (tytuple-append A
                            (tytuple-append B C
                              "tytuple-assoc 1")
                            "tytuple-assoc 2")))))))))

(define (NULL-tytup? tytup)
  (if (not-tytuple? tytup)
      (myerror "NULL-tytup?:"
        "tytuple argument expected"
        tytup)
      (NULL-tytup?-aux tytup)))
(define (NULL-tytup?-aux tytup)
  (if (null? (cdr tytup)) #t
      (if (null? (cddr tytup))
          (nulltype? (cadr tytup))
          (and (NULL-tytup?-aux (cadr tytup))
               (NULL-tytup?-aux (cddr tytup))))))
  

(define (tytuple-left tytup)
  (if (not-tytuple? tytup)
      (myerror "tytuple-left:"
        "argument must be a tytuple" tytup)
      (if (null? (cdr tytup))
          (myerror
            "tytuple-left: argument"
            "cannot be NULL_tytup" tytup)
          (if (null? (cddr tytup))
              (myerror
                "tytuple-left: argument"
                "cannot be singleton tytuple"
                tytup)
              (cadr tytup)))))

(define (tytuple-right tytup)
  (if (not-tytuple? tytup)
      (myerror "tytuple-right: argument"
        "must be a tytuple" tytup)
      (if (null? (cdr tytup))
          (myerror
            "tytuple-right: argument"
            "cannot be NULL_tytup" tytup)
          (if (null? (cddr tytup))
              (myerror
                "tytuple-right: argument"
                "cannot be singleton tytuple"
                tytup)
              (cddr tytup)))))

(define (tytuple-append ty1 ty2 err) 
  (if (not-tytuple? ty1)
      (myerror "tytuple-append: first"
        "argument must be a tytuple"
        ty1 ty2 err)
      (if (not-tytuple? ty2)
          (myerror "tytuple-append: second"
            "argument must be a tytuple"
            ty1 ty2 err)
	  (tytuple-append-SIMP ty1 ty2))))
(define (tytuple-append-SIMP ty1 ty2)
  (cons 'tytuple (cons ty1 ty2)))
; (define (tytuple-append-SIMP ty1 ty2)
;   (if (null? (cdr ty1)) ty2
;       (if (null? (cdr ty2)) ty1
;           (cons 'tytuple (cons ty1 ty2)))))

(define (make-tytuple-arrow ty1 ty2)
  (if (not-tytuple? ty1)
      (myerror "make-tytuple-arrow: first"
        "argument must be a tytuple"
        ty1 ty2)
      (if (not-tytuple? ty2)
          (myerror "make-tytuple-arrow: second"
            "argument must be a tytuple"
            ty1 ty2)
          (make-tytuple-arrow-aux ty1 ty2))))
(define (make-tytuple-arrow-aux ty1 ty2)
  (if (null? (cdr ty2)) NULL_tytup
      (if (null? (cddr ty2))
          (type-to-tytuple
            (make-tytuple-arrow-aux-aux ty1
              (cadr ty2)))
          (tytuple-append
            (make-tytuple-arrow-aux ty1
              (cadr ty2))
            (make-tytuple-arrow-aux ty1
              (cddr ty2))
            "make-tytuple-arrow"
            ))))

(define (make-tytuple-arrow-aux-aux tytup typ)
  (if (null? (cdr tytup)) typ
      (if (null? (cddr tytup))
          (make-arrow (cadr tytup) typ)
          (make-tytuple-arrow-aux-aux
            (cadr tytup)
            (make-tytuple-arrow-aux-aux
              (cddr tytup) typ)))))


(define (tytuple_Eq? ty1 ty2)
  (if (not-tytuple? ty1)
      (begin (nldisplay "tytuple_Eq?:"
               "first argument is not a tytuple"
               ty1 ty2) #f)
      (if (not-tytuple? ty2)
          (begin (nldisplay "tytuple_Eq?:"
                   "second argument is not a tytuple" 
                   (tytuple-to-string ty1) ty2) #f)
          (tytuple_Eq?-aux ty1 ty2))))
(define (tytuple_Eq?-aux ty1 ty2)
  (if (null? (cdr ty1)) (null? (cdr ty2))
      (if (null? (cdr ty2)) #f
          (if (null? (cddr ty1))
              (if (not-null? (cddr ty2)) #f
                  (equal? (cadr ty1) (cadr ty2)))
              (if (null? (cddr ty2)) #f
                  (and (tytuple_Eq?-aux (cadr ty1)
                         (cadr ty2))
                       (tytuple_Eq?-aux (cddr ty1)
                         (cddr ty2))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DATATYPE vatuple -- a binary tree with nodes labeled by variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define NULL_vatup (cons 'vatuple '()))
(define (var-to-vatuple va)
  (if (not-DIA-var? va)
      (myerror "var-to-vatuple:"
        "variable argument expected" va)
      (cons 'vatuple (cons va '()))))

(define (vatupleSIMP? vatup)
  (if (null? vatup) #f
      (if (not-pair? vatup) #f
          (if (not-eq? (car vatup) 'vatuple) #f
              (if (null? (cdr vatup)) #t
                  (if (not-pair? (cdr vatup)) #f
                      (if (null? (cddr vatup))
                          (var-form? (cadr vatup))
                          (and (vatupleSIMP?
                                 (cadr vatup))
                               (vatupleSIMP?
                                 (cddr vatup))))))))))
(define (nvatupleSIMP? vatup)
  (if (vatupleSIMP? vatup) #f #t))

(define (vatupleDEEP? vatup)
  (if (null? vatup) #f
      (if (not-pair? vatup) #f
          (if (not-eq? (car vatup) 'vatuple) #f
              (if (null? (cdr vatup)) #t
                  (if (not-pair? (cdr vatup)) #f
                      (if (null? (cddr vatup))
                          (var? (cadr vatup))
                          (and (vatupleDEEP?
                                 (cadr vatup))
                               (vatupleDEEP?
                                 (cddr vatup))))))))))
(define (nvatupleDEEP? vatup)
  (if (vatupleDEEP? vatup) #f #t))

(define (vatuple? vatup)
  (if CHECK
      (if PARANOIA
          (vatupleDEEP? vatup)
          (vatupleSIMP? vatup))
      #t))
(define (not-vatuple? vatup)
  (if (vatuple? vatup) #f #t))

(define (vatuple-assoc vatup)
  (if (not-vatuple? vatup)
      (myerror "vatuple-assoc:"
        "argument must be a vatuple" vatup)
      (if (null? (cdr vatup))
          (myerror "vatuple-assoc: argument"
            "cannot be NULL_vatup")
          (if (null? (cddr vatup))
              (myerror
                "vatuple-assoc: argument"
                "cannot be SINGLETON vatuple")
              (let((pair (cadr vatup))
                   (C (cddr vatup)))
                (if (null? (cdr pair))
                    (myerror
                      "vatuple-assoc: left of"
                      "argument cannot be NULL_vatup")
                    (if (null? (cddr pair))
                        (myerror
                          "vatuple-assoc: left of argument"
                          "cannot be SINGLETON vatuple")
                        (let((A (cadr pair))
                             (B (cddr pair)))
                          (vatuple-append A
                            (vatuple-append B C
                              "vatuple-assoc 1")
                            "vatuple-assoc 2")))))))))


(define (vatuple-left vatup)
  (if (not-vatuple? vatup)
      (myerror "vatuple-left: argument"
        "must be a vatuple" vatup)
      (if (null? (cdr vatup))
          (myerror
            "vatuple-left: argument"
            "cannot be NULL_vatup" vatup)
          (if (null? (cddr vatup))
              (myerror
                "vatuple-left: argument"
                "cannot be singleton vatuple"
                vatup)
              (cadr vatup)))))

(define (vatuple-right vatup)
  (if (not-vatuple? vatup)
      (myerror "vatuple-right: argument"
        "must be a vatuple" vatup)
      (if (null? (cdr vatup))
          (myerror
            "vatuple-right: argument"
            "cannot be NULL_vatup" vatup)
          (if (null? (cddr vatup))
              (myerror
                "vatuple-right: argument"
                "cannot be singleton vatuple"
                vatup)
              (cddr vatup)))))


(define (vatuple-append va1 va2 err) 
  (if (not-vatuple? va1)
      (myerror "vatuple-append: first"
        "argument must be a vatuple"
        va1 va2 err)
      (if (not-vatuple? va2)
          (myerror "vatuple-append: second"
            "argument must be a vatuple"
            va1 va2 err)
	  (vatuple-append-SIMP va1 va2))))
(define (vatuple-append-SIMP va1 va2)
  (cons 'vatuple (cons va1 va2)))
; (define (vatuple-append-SIMP va1 va2)
;   (if (null? (cdr va1)) va2
;       (if (null? (cdr va2)) va1
;           (cons 'vatuple (cons va1 va2)))))

(define (vatuple-len vatup)
  (if (not-vatuple? vatup)
      (myerror "vatuple-len:"
        "vatuple argument expected" vatup)
      (vatuple-len-aux vatup)))
(define (vatuple-len-aux vatup)
  (if (null? (cdr vatup)) 0
      (if (null? (cddr vatup)) 1
          (+ (vatuple-len-aux
              (cadr vatup))
            (vatuple-len-aux
              (cddr vatup))))))

(define (tytuple-to-vatuple tytup)
  (if (not-tytuple? tytup)
      (myerror "tytuple-to-vatuple:"
        "tytuple argument expected" tytup)
      (tytuple-to-vatuple-aux tytup)))
(define (tytuple-to-vatuple-aux tytup)
  (if (null? (cdr tytup)) NULL_vatup
      (if (null? (cddr tytup))
          (var-to-vatuple
            (type-to-new-var
              (cadr tytup)))
          (vatuple-append
            (tytuple-to-vatuple-aux
              (cadr tytup))
            (tytuple-to-vatuple-aux
              (cddr tytup))
            "tytuple-to-vatuple"
            ))))

(define (vatuple-to-tytuple vatup)
  (if (not-vatuple? vatup)
      (myerror "vatuple-to-tytuple:"
        "vatuple argument expected" vatup)
      (vatuple-to-tytuple-aux vatup)))
(define (vatuple-to-tytuple-aux vatup)
  (if (null? (cdr vatup)) NULL_tytup
      (if (null? (cddr vatup))
          (type-to-tytuple
            (var-to-type
              (cadr vatup)))
          (tytuple-append
            (vatuple-to-tytuple-aux
              (cadr vatup))
            (vatuple-to-tytuple-aux
              (cddr vatup))
            "vatuple-to-tytuple"
            ))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DATATYPE tmtuple -- a binary tree with nodes labeled by terms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define NULL_tmtup (cons 'tmtuple '()))
(define (term-to-tmtuple tm)
  (if (not-DIA-term? tm)
      (myerror "term-to-tmtuple:"
        "term argument expected" tm)
      (if (NULL-typ? (term-to-type tm)) NULL_tmtup
          (cons 'tmtuple (cons tm '())))))

(define (term-to-zero-tmtuple tm)
  (if (not-DIA-term? tm)
      (myerror "term-to-zero-tmtuple:"
        "term argument expected" tm)
      (if (NULL-typ? (term-to-type tm)) NULL_tmtup
          (cons 'tmtuple
            (cons (term-to-zero tm) '())))))

(define (tmtupleSIMP? tmtup)
  (if (null? tmtup) #f
      (if (not-pair? tmtup) #f
          (if (not-eq? (car tmtup) 'tmtuple) #f
              (if (null? (cdr tmtup)) #t
                  (if (not-pair? (cdr tmtup)) #f
                      (if (null? (cddr tmtup))
                          (term? (cadr tmtup))
                          (and (tmtupleSIMP?
                                 (cadr tmtup))
                               (tmtupleSIMP?
                                 (cddr tmtup))))))))))
(define (ntmtupleSIMP? tmtup)
  (if (tmtupleSIMP? tmtup) #f #t))

(define (tmtupleDEEP? tmtup)
  (if (null? tmtup) #f
      (if (not-pair? tmtup) #f
          (if (not-eq? (car tmtup) 'tmtuple) #f
              (if (null? (cdr tmtup)) #t
                  (if (not-pair? (cdr tmtup)) #f
                      (if (null? (cddr tmtup))
                          (term-DEEP?
                            (cadr tmtup))
                      (and (tmtupleDEEP?
                             (cadr tmtup))
                           (tmtupleDEEP?
                             (cddr tmtup))))))))))
(define (ntmtupleDEEP? tmtup)
  (if (tmtupleDEEP? tmtup) #f #t))

(define (tmtuple? tmtup)
  (if CHECK
      (if PARANOIA
          (tmtupleDEEP? tmtup)
          (tmtupleSIMP? tmtup))
      #t))
(define (not-tmtuple? tmtup)
  (if (tmtuple? tmtup) #f #t))

(define (DIA-tmtuple-assoc tmtup)
  (if (not-tmtuple? tmtup)
      (myerror "DIA-tmtuple-assoc: argument"
        "must be a tmtuple" tmtup)
      (if (null? (cdr tmtup))
          (myerror "DIA-tmtuple-assoc: argument"
            "cannot be NULL_tmtup")
          (if (null? (cddr tmtup))
              (myerror
                "DIA-tmtuple-assoc: argument"
                "cannot be SINGLETON tmtuple")
              (let((pair (cadr tmtup))
                   (C (cddr tmtup)))
                (if (null? (cdr pair))
                    (myerror
                      "DIA-tmtuple-assoc: left of"
                      "argument cannot be NULL_tmtup")
                    (if (null? (cddr pair))
                        (myerror
                          "DIA-tmtuple-assoc: left of argument"
                          "cannot be SINGLETON tmtuple")
                        (let((A (cadr pair))
                             (B (cddr pair)))
                          (tmtuple-append A
                            (tmtuple-append B C
                              "DIA-tmtuple-assoc 1")
                            "DIA-tmtuple-assoc 2")))))))))


(define (tmtuple-left tmtup)
  (if (not-tmtuple? tmtup)
      (myerror "tmtuple-left: argument"
        "must be a tmtuple" tmtup)
      (if (null? (cdr tmtup))
          (myerror
            "tmtuple-left: argument"
            "cannot be NULL_tmtup" tmtup)
          (if (null? (cddr tmtup))
              (myerror
                "tmtuple-left: argument"
                "cannot be singleton tmtuple"
                tmtup)
              (cadr tmtup)))))

(define (tmtuple-right tmtup)
  (if (not-tmtuple? tmtup)
      (myerror "tmtuple-right: argument"
        "must be a tmtuple" tmtup)
      (if (null? (cdr tmtup))
          (myerror
            "tmtuple-right: argument"
            "cannot be NULL_tmtup" tmtup)
          (if (null? (cddr tmtup))
              (myerror
                "tmtuple-right: argument"
                "cannot be singleton tmtuple"
                tmtup)
              (cddr tmtup)))))


; VARIANT of 17 July 2005
; (define (tmtuple-left tmtup)
;   (if (not-tmtuple? tmtup)
;       (myerror "tmtuple-left: argument"
;         "must be a tmtuple" tmtup)
;       (if (null? (cdr tmtup))
;           NULL_tmtup
;           (if (null? (cddr tmtup))
;               (myerror
;                 "tmtuple-left: argument"
;                 "cannot be singleton tmtuple"
;                 tmtup)
;               (cadr tmtup)))))

; (define (tmtuple-right tmtup)
;   (if (not-tmtuple? tmtup)
;       (myerror "tmtuple-right: argument"
;         "must be a tmtuple" tmtup)
;       (if (null? (cdr tmtup))
; 	  NULL_tmtup
;           (if (null? (cddr tmtup))
;               (myerror
;                 "tmtuple-right: argument"
;                 "cannot be singleton tmtuple"
;                 tmtup)
;               (cddr tmtup)))))


(define (tmtuple-to-term tmtup)
  (if (not-tmtuple? tmtup)
      (myerror "tmtuple-to-term: argument"
        "must be a tmtuple" tmtup)
      (if (null? (cdr tmtup))
          (myerror
            "tmtuple-to-term: argument"
            "cannot be NULL_tmtup" tmtup)
          (if (not-null? (cddr tmtup))
              (myerror
                "tmtuple-to-term: argument"
                "must be singleton tmtuple"
                tmtup)
              (cadr tmtup)))))

(define (vatuple-to-var vatup)
  (if (not-vatuple? vatup)
      (myerror "vatuple-to-var: argument"
        "must be a vatuple" vatup)
      (if (null? (cdr vatup))
          (myerror
            "vatuple-to-var: argument"
            "cannot be NULL_vatup" vatup)
          (if (not-null? (cddr vatup))
              (myerror
                "vatuple-to-var: argument"
                "must be singleton vatuple"
                vatup)
              (cadr vatup)))))
 
(define (tmtuple-append tm1 tm2 err) 
  (if (not-tmtuple? tm1)
      (myerror "tmtuple-append:"
        "first argument must be a tmtuple"
        tm1 tm2 err)
      (if (not-tmtuple? tm2)
          (myerror "tmtuple-append:"
            "second argument must be a tmtuple"
            tm1 tm2 err)
	  (tmtuple-append-SIMP tm1 tm2))))
(define (tmtuple-append-SIMP tm1 tm2)
  (cons 'tmtuple (cons tm1 tm2)))
; (define (tmtuple-append-SIMP tm1 tm2)
;   (if (null? (cdr tm1)) tm2
;       (if (null? (cdr tm2)) tm1
;           (cons 'tmtuple (cons tm1 tm2)))))

(define (tytuple-to-tmtuple tytup)
  (if (not-tytuple? tytup)
      (myerror "tytuple-to-tmtuple:"
        "tytuple argument expected" tytup)
      (tytuple-to-tmtuple-aux tytup)))
(define (tytuple-to-tmtuple-aux tytup)
  (if (null? (cdr tytup)) NULL_tmtup
      (if (null? (cddr tytup))
          (term-to-tmtuple
            (make-term-in-var-form
              (type-to-new-var (cadr tytup))))
          (tmtuple-append
            (tytuple-to-tmtuple-aux
              (cadr tytup))
            (tytuple-to-tmtuple-aux
              (cddr tytup))
            "tytuple-to-tmtuple"
            ))))

(define (vatuple-to-tmtuple vatup)
  (if (not-vatuple? vatup)
      (myerror "vatuple-to-tmtuple:"
        "vatuple argument expected" vatup)
      (vatuple-to-tmtuple-aux vatup)))
(define (vatuple-to-tmtuple-aux vatup)
  (if (null? (cdr vatup)) NULL_tmtup
      (if (null? (cddr vatup))
          (term-to-tmtuple
            (make-term-in-var-form
              (cadr vatup)))
          (tmtuple-append
            (vatuple-to-tmtuple-aux
              (cadr vatup))
            (vatuple-to-tmtuple-aux
              (cddr vatup))
            "vatuple-to-tmtuple"
            ))))

(define (vatuple-to-zero-tmtuple vatup)
  (if (not-vatuple? vatup)
      (myerror "vatuple-to-zero-tmtuple:"
        "vatuple argument expected" vatup)
      (vatuple-to-zero-tmtuple-aux vatup)))
(define (vatuple-to-zero-tmtuple-aux vatup)
  (if (null? (cdr vatup)) NULL_tmtup
      (if (null? (cddr vatup))
          (term-to-tmtuple
            (var-to-zero (cadr vatup)))
          (tmtuple-append
            (vatuple-to-zero-tmtuple-aux
              (cadr vatup))
            (vatuple-to-zero-tmtuple-aux
              (cddr vatup))
            "vatuple-to-zero-tmtuple"
            ))))

(define (tytuple-to-ZERO tytup)
  (if (not-tytuple? tytup)
      (myerror "tytuple-to-ZERO:"
        "tytuple argument expected" tytup)
      (tytuple-to-ZERO-aux tytup)))
(define (tytuple-to-ZERO-aux tytup)
  (if (null? (cdr tytup)) NULL_tmtup
      (if (null? (cddr tytup))
          (term-to-tmtuple
            (type-to-zero (cadr tytup)))
          (tmtuple-append
            (tytuple-to-ZERO-aux
              (cadr tytup))
            (tytuple-to-ZERO-aux
              (cddr tytup))
            "tytuple-to-ZERO"
            ))))

(define (tmtuple-to-tytuple tmtup)
  (if (not-tmtuple? tmtup)
      (myerror "tmtuple-to-tytuple:"
        "tmtuple argument expected" tmtup)
      (tmtuple-to-tytuple-aux tmtup)))
(define (tmtuple-to-tytuple-aux tmtup)
  (if (null? (cdr tmtup)) NULL_tytup
      (if (null? (cddr tmtup))
          (type-to-tytuple
            (term-to-type (cadr tmtup)))
          (tytuple-append
            (tmtuple-to-tytuple-aux
              (cadr tmtup))
            (tmtuple-to-tytuple-aux
              (cddr tmtup))
            "tmtuple-to-tytuple"
            ))))

(define (tmtuple-substitute tmtup subst)
  (if (not-tmtuple? tmtup)
      (myerror "tmtuple-substitute:"
        "tmtuple argument expected"
        tmtup  subst)
      (if (null? subst) tmtup
          (tmtuple-substitute-aux
            tmtup subst))))
(define (tmtuple-substitute-aux tmtup subst)
  (if (null? (cdr tmtup)) NULL_tmtup
      (if (null? (cddr tmtup))
          (term-to-tmtuple
            (term-substitute
              (cadr tmtup) subst))
          (tmtuple-append
            (tmtuple-substitute-aux
              (cadr tmtup) subst)
            (tmtuple-substitute-aux
              (cddr tmtup) subst)
            "tmtuple-substitute"
            ))))

(define (DIA-tmtuple-non-simult-subst tmtup alst)
  (if (not-tmtuple? tmtup)
      (myerror "DIA-tmtuple-non-simult-subst:"
        "tmtuple argument expected"
        tmtup alst)
      (if (null? alst) tmtup
          (DIA-tmtuple-non-simult-subst-aux
            tmtup alst))))
(define (DIA-tmtuple-non-simult-subst-aux tmtup alst)
  (if (null? (cdr tmtup)) NULL_tmtup
      (if (null? (cddr tmtup))
          (term-to-tmtuple
            (DIA-term-non-simult-subst
              (cadr tmtup) alst))
          (tmtuple-append
            (DIA-tmtuple-non-simult-subst-aux
              (cadr tmtup) alst)
            (DIA-tmtuple-non-simult-subst-aux
              (cddr tmtup) alst)
            "DIA-tmtuple-non-simult-subst"
            ))))  
  
(define (DIA-term-non-simult-subst tm alst)
  (if (null? alst) tm
      (let*((free (term-to-free tm))
            (new-alst
              (DIA-select-alist free alst)))
        (DIA-term-non-simult-subst-aux tm new-alst))))
(define (DIA-term-non-simult-subst-aux tm alst)
  (if (null? alst) tm
      (make-term-in-app-form
        (make-term-in-abst-form
          (caar alst)
          (DIA-term-non-simult-subst-aux tm
            (cdr alst)))
        (cdar alst))))

(define (DIA-select-alist valst alst)
  (if (null? alst) '()
      (let*((head (car alst))
            (var (car head))
            (rec-alst
              (DIA-select-alist
                valst (cdr alst))))
        (if (or (notelem? var valst)
                (elem-alist? var rec-alst))
            rec-alst
            (cons head rec-alst)))))

(define (DIA-make-ZERO-alist valst)
  (if (not-valist? valst)
      (myerror "DIA-make-ZERO-alist:"
        "argument must be valist" valst)
      (DIA-make-ZERO-alist-aux valst)))
(define (DIA-make-ZERO-alist-aux valst)
  (if (null? valst) '()
      (cons (cons (car valst)
                (var-to-zero (car valst)))
        (DIA-make-ZERO-alist-aux
          (cdr valst)))))

(define (DIA-non-simult-alist-to-string alst)
  (if (null? alst) "[ EMPTY-ALIST ]"
      (string-append " [ " SBK3
        (DIA-non-simult-alist-to-string-aux alst))))
(define (DIA-non-simult-alist-to-string-aux alst)
  (if (null? alst) " ]"
      (string-append " , "
        (var-to-string (caar alst))
        " -> "
        (term-to-string (cdar alst))
        (DIA-non-simult-alist-to-string-aux
          (cdr alst)))))

(define (tmtuple-to-free tmtup)
  (if (not-tmtuple? tmtup)
      (myerror "tmtuple-to-free:"
        "tmtuple argument expected" tmtup)
      (tmtuple-to-free-aux tmtup)))
(define (tmtuple-to-free-aux tmtup)
  (if (null? (cdr tmtup)) '()
      (if (null? (cddr tmtup))
          (term-to-free (cadr tmtup))
          (union
            (tmtuple-to-free-aux
              (cadr tmtup))
            (tmtuple-to-free-aux
              (cddr tmtup))))))

(define (DIA-star-to-tmtuple tm tytup)
  (if (not-DIA-term? tm)
      (myerror "DIA-star-to-tmtuple:"
        "1st argument must be term " tm)
      (if (not-tytuple? tytup)
          (myerror "DIA-star-to-tmtuple:"
            "2nd argument must be tytuple"
            tytup)
          (let((LEGDUM
                 (if DEBUG-STAR
                     (DIA-comment-forced
                       "DIA-star-to-tmtuple BEGIN :"
                       'CNL (term-to-string tm) 'CNL
                       (tytuple-to-string tytup))))
               (rv (DIA-star-to-tmtuple-aux
                     tm tytup)))
            (begin
              (if DEBUG-STAR
                  (DIA-comment-forced
                    "DIA-star-to-tmtuple RESULT is"
                    'CNL (tmtuple-to-string rv)))
              rv)))))
               
(define (DIA-star-to-tmtuple-aux tm tytup)
  (if (NULL-tytup? tytup)
      (if (NULL-tm? tm)
          (tytuple-to-tmtuple tytup)
          (myerror
            "DIA-star-to-tmtuple:"
            "NULL_tm expected"))
      (if (null? (cddr tytup))
          (if (equal? (cadr tytup)
                (term-to-type tm))
              (term-to-tmtuple tm)
              (myerror
                "DIA-star-to-tmtuple:"
                "type of term"
                (term-to-string tm)
                "should be the type in"
                (tytuple-to-string tytup)))
          (let*((left-tm
                 (DIA-star-to-left tm tytup))
               (LEGDUM
                 (if DEBUG-STAR
                     (DIA-comment-forced
                       "DIA-star-to-tmtuple:"
                       "left-tm is " 'CNL
                       (term-to-string left-tm))))
               (right-tm
                 (DIA-star-to-right tm tytup))
               (LEGDUM
                 (if DEBUG-STAR
                     (DIA-comment-forced
                       "DIA-star-to-tmtuple:"
                       "right-tm is " 'CNL
                       (term-to-string right-tm)))))               
          (tmtuple-append
            (DIA-star-to-tmtuple-aux
              left-tm (cadr tytup))
            (DIA-star-to-tmtuple-aux
              right-tm (cddr tytup))
            "DIA-star-to-tmtuple")))))

(define (DIA-star-to-left tm tytup)
  (begin
    (if DEBUG-STAR
        (DIA-comment-forced
          "DIA-star-to-left:" 'CNL
          (term-to-string tm) 'CNL
          (tytuple-to-string tytup)))
    (if (NULL-tytup? (cadr tytup)) NULL_tm
        (if (NULL-tytup? (cddr tytup)) tm
            (if (star-form? (term-to-type tm))
                (if (term-in-pair-form? tm)
                    (term-in-pair-form-to-left tm)
                    (make-term-in-lcomp-form tm))
                (myerror
                  "DIA-star-to-left: star-form"
                  "required for type of "
                  (term-to-string tm)))))))
(define (DIA-star-to-right tm tytup)
  (begin
    (if DEBUG-STAR
        (DIA-comment-forced
          "DIA-star-to-right:" 'CNL
          (term-to-string tm) 'CNL
          (tytuple-to-string tytup)))
    (if (NULL-tytup? (cddr tytup)) NULL_tm
        (if (NULL-tytup? (cadr tytup)) tm
            (if (star-form? (term-to-type tm))
                (if (term-in-pair-form? tm)
                    (term-in-pair-form-to-right tm)
                    (make-term-in-rcomp-form tm))
                (myerror
                  "DIA-star-to-right: star-form"
                  "required for type of "
                  (term-to-string tm)))))))

(define (DIA-tmtuple-to-star tmtup)
  (if (not-tmtuple? tmtup)
      (myerror "DIA-tmtuple-to-star:"
        "tmtuple argument expected" tmtup)
      (DIA-tmtuple-to-star-aux tmtup)))
(define (DIA-tmtuple-to-star-aux tmtup)
  (if (null? (cdr tmtup)) NULL_tm
      (if (null? (cddr tmtup)) (cadr tmtup)
          (DIA-make-term-in-star-form
            (DIA-tmtuple-to-star-aux
              (cadr tmtup))
            (DIA-tmtuple-to-star-aux
              (cddr tmtup))))))
(define (DIA-make-term-in-star-form tm1 tm2)
  (if (NULL-tm? tm1) tm2
      (if (NULL-tm? tm2) tm1
          (make-term-in-pair-form tm1 tm2))))
      

(define (make-tmtuple-in-abst-form vatup tmtup)
  (if (not-vatuple? vatup)
      (myerror "make-tmtuple-in-abst-form:"
        "first argument must be a vatuple"
        vatup tmtup)
      (if (not-tmtuple? tmtup)
          (myerror "make-tmtuple-in-abst-form:"
            "second argument must be a tmtuple"
            vatup tmtup)
          (make-tmtuple-in-abst-form-aux vatup tmtup))))
(define (make-tmtuple-in-abst-form-aux vatup tmtup)
  (if (null? (cdr tmtup)) NULL_tmtup
      (if (null? (cddr tmtup))
          (term-to-tmtuple
            (make-tmtuple-in-abst-form-aux-aux
              vatup (cadr tmtup)))
          (tmtuple-append
            (make-tmtuple-in-abst-form-aux
              vatup (cadr tmtup))
            (make-tmtuple-in-abst-form-aux
              vatup (cddr tmtup))
            "make-tmtuple-in-abst-form"
            ))))

(define (make-tmtuple-in-abst-form-aux-aux vatup tm)
  (if (null? (cdr vatup)) tm
      (if (null? (cddr vatup))
          (make-term-in-abst-form
            (cadr vatup) tm)
          (make-tmtuple-in-abst-form-aux-aux
            (cadr vatup)
            (make-tmtuple-in-abst-form-aux-aux
              (cddr vatup) tm)))))

(define (make-tmtuple-in-paral-app-form
          tmtupOP tmtupARG)
  (if (not-tmtuple? tmtupOP)
      (myerror "make-tmtuple-in-paral-app-form:"
        "first argument must be a tmtuple"
        tmtupOP tmtupARG)
      (if (not-tmtuple? tmtupARG)
          (myerror "make-tmtuple-in-paral-app-form:"
            "second argument must be a tmtuple"
            tmtupOP tmtupARG)
          (make-tmtuple-in-paral-app-form-aux
            tmtupOP tmtupARG))))

(define (make-tmtuple-in-paral-app-form-aux
          tmtupOP tmtupARG)
  (if (null? (cdr tmtupOP)) NULL_tmtup
      (if (null? (cddr tmtupOP))
          (term-to-tmtuple
            (make-term-in-app-form
              (cadr tmtupOP) (cadr tmtupARG)))
          (tmtuple-append
            (make-tmtuple-in-paral-app-form-aux
              (cadr tmtupOP) (cadr tmtupARG))
            (make-tmtuple-in-paral-app-form-aux
              (cddr tmtupOP) (cddr tmtupARG))
            "make-tmtuple-in-paral-app-form"
            ))))

(define (make-tmtuple-in-app-form
          tmtupOP tmtupARG)
  (if (not-tmtuple? tmtupOP)
      (myerror "make-tmtuple-in-app-form:"
        "first argument must be a tmtuple"
        tmtupOP tmtupARG)
      (if (not-tmtuple? tmtupARG)
          (myerror "make-tmtuple-in-app-form:"
            "second argument must be a tmtuple"
            tmtupOP tmtupARG)
          (make-tmtuple-in-app-form-aux
            tmtupOP tmtupARG))))

(define (make-tmtuple-in-app-form-aux
          tmtupOP tmtupARG)
  (if (null? (cdr tmtupOP)) NULL_tmtup
      (if (null? (cddr tmtupOP))
          (term-to-tmtuple
            (make-tmtuple-in-app-form-aux-aux
              (cadr tmtupOP) tmtupARG))
          (tmtuple-append
            (make-tmtuple-in-app-form-aux
              (cadr tmtupOP) tmtupARG)
            (make-tmtuple-in-app-form-aux
              (cddr tmtupOP) tmtupARG)
            "make-tmtuple-in-app-form"
            ))))

(define (make-tmtuple-in-app-form-aux-aux
          tm tmtup)
  (if (null? (cdr tmtup)) tm
      (if (null? (cddr tmtup))
          (make-term-in-app-form
            tm (cadr tmtup))
          (make-tmtuple-in-app-form-aux-aux 
            (make-tmtuple-in-app-form-aux-aux
              tm (cadr tmtup))
            (cddr tmtup)))))

(define (nbe-normalize-tmtuple tmtup)
  (if (not-tmtuple? tmtup)
      (myerror "nbe-normalize-tmtuple:"
        "tmtuple argument expected" tmtup)
      (nbe-normalize-tmtuple-aux tmtup)))
(define (nbe-normalize-tmtuple-aux tmtup)
  (if (null? (cdr tmtup)) NULL_tmtup
      (if (null? (cddr tmtup))
          (term-to-tmtuple
            (nbe-normalize-term
              (cadr tmtup)))
          (tmtuple-append
            (nbe-normalize-tmtuple-aux
              (cadr tmtup))
            (nbe-normalize-tmtuple-aux
              (cddr tmtup))
            "nbe-normalize-tmtuple"
            ))))

(define (make-tmtuple-in-if-form tm
          tmtup1 tmtup2)
  (begin
    (if PARANOIA
        (if (not-DIA-term? tm)
            (myerror
              "make-tmtuple-in-if-form:"
              "1st argument must be term" tm)
            (if (not (alg-form?
                       (term-to-type tm)))
                (myerror
                  "make-tmtuple-in-if-form:"
                  "1st argument must be"
                  "boolean term" tm)
                (if (not
                      (string=? "boole"
                        (alg-form-to-name
                          (term-to-type tm))))
                    (myerror
                      "make-tmtuple-in-if-form:"
                      "1st argument must be"
                      "boolean term" tm)
                    (if (not-tmtuple? tmtup1)
                        (myerror
                          "make-tmtuple-in-if-form:"
                          "2nd argument must be tmtuple"
                          tmtup1)
                        (if (not-tmtuple? tmtup2)
                            (myerror
                              "make-tmtuple-in-if-form:"
                              "3rd argument must be tmtuple"
                              tmtup2)))))))
    (make-tmtuple-in-if-form-aux tm
      tmtup1 tmtup2)))
(define (make-tmtuple-in-if-form-aux tm
          tmtup1 tmtup2)
  (if (null? (cdr tmtup1))
      (if (not-null? (cdr tmtup2))
          (myerror
            "make-tmtuple-in-if-form: 2nd and"
            "3rd argument must be isomorphic"
            tmtup1 tmtup2)
          NULL_tmtup)
      (if (null? (cddr tmtup1))
          (if (null? (cdr tmtup2))
              (myerror
                "make-tmtuple-in-if-form: 2nd and"
                "3rd argument must be isomorphic"
                tmtup1 tmtup2)
              (if (not-null? (cddr tmtup2))
                  (myerror
                    "make-tmtuple-in-if-form: 2nd and"
                    "3rd argument must be isomorphic"
                    tmtup1 tmtup2)
                  (term-to-tmtuple
                    (make-term-in-if-form tm
                      (list (cadr tmtup1)
                        (cadr tmtup2))))))
          (tmtuple-append
            (make-tmtuple-in-if-form-aux tm
              (cadr tmtup1) (cadr tmtup2))
            (make-tmtuple-in-if-form-aux tm
              (cddr tmtup1) (cddr tmtup2))
            "make-tmtuple-in-if-form"))))            

;; The following procedure creates substitutions from isomorphic
;; vatuple and tmtuple arguments

(define (DIA-make-substitution vatup tmtup err)
  (if (not-vatuple? vatup)
      (myerror err "DIA-make-substitution:"
        "1st argument must be vatuple" vatup)
      (if (not-tmtuple? tmtup)
          (myerror err
            "DIA-make-substitution:"
            "2nd argument must be tmtuple" tmtup)
          (DIA-make-substitution-aux vatup tmtup err))))
(define (DIA-make-substitution-aux vatup tmtup err)
  (if (null? (cdr vatup))
      (if (not-null? (cdr tmtup))
          (myerror err
            "DIA-make-substitution-aux:"
            "1st and 2nd argument must be isomorphic")
          empty-subst)
      (if (null? (cddr vatup))
          (if (not-null? (cddr tmtup))
              (myerror err
                "DIA-make-substitution-aux:"
                "1st and 2nd argument must be isomorphic")
              (make-subst (cadr vatup) (cadr tmtup)))
          (append
            (DIA-make-substitution-aux
                    (cadr vatup) (cadr tmtup) err)
            (DIA-make-substitution-aux
              (cddr vatup) (cddr tmtup) err)))))

;; The following procedure creates alists of associations of
;; terms to vars to be used for non-simultaneous substitutions
;; The arguments must be isomorphic vatuple and tmtuple

(define (DIA-make-alist vatup tmtup err)
  (if (not-vatuple? vatup)
      (myerror err "DIA-make-alist:"
        "1st argument must be vatuple" vatup)
      (if (not-tmtuple? tmtup)
          (myerror err
            "DIA-make-alist:"
            "2nd argument must be tmtuple" tmtup)
          (DIA-make-alist-aux vatup tmtup err))))
(define (DIA-make-alist-aux vatup tmtup err)
  (if (null? (cdr vatup))
      (if (not-null? (cdr tmtup))
          (myerror err
            "DIA-make-alist-aux: 1st and 2nd"
            "argument must be isomorphic")
          '())
      (if (null? (cddr vatup))
          (if (not-null? (cddr tmtup))
              (myerror err
                "DIA-make-alist-aux: 1st and 2nd"
                "argument must be isomorphic")
              (list (cons (cadr vatup) (cadr tmtup))))
          (append
            (DIA-make-alist-aux
              (cadr vatup) (cadr tmtup) err)
            (DIA-make-alist-aux
              (cddr vatup) (cddr tmtup) err)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DATATYPE tmtuplist == a simple list of tmtuples 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (tmtuplist? tupli)
  (if CHECK
      (if (not-list? tupli) #f
          (tmtuplist-aux? tupli))
      #t))
(define (tmtuplist-aux? tupli) 
  (if (null? tupli) #t 
      (if (not-tmtuple? (car tupli)) #f
          (tmtuplist-aux? (cdr tupli)))))
(define (not-tmtuplist? tupli)
  (if (tmtuplist? tupli) #f #t))

(define (make-tmtuplist-in-app-form
          tmtuplst tmtup)
  (if (not-tmtuple? tmtup)
      (myerror "make-tmtuplist-in-app-form:"
        "2nd argument must be tmtuple"
        tmtup)
      (if (not-tmtuplist? tmtuplst)
          (myerror "make-tmtuplist-in-app-form:"
            "1st argument must be tmtuplist"
            tmtuplst)
          (make-tmtuplist-in-app-form-aux
            tmtuplst tmtup))))
(define (make-tmtuplist-in-app-form-aux
          tmtuplst tmtup)
  (if (null? tmtuplst) (list)
      (cons (make-tmtuple-in-app-form-aux
              (car tmtuplst) tmtup)
        (make-tmtuplist-in-app-form-aux
          (cdr tmtuplst) tmtup))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DATATYPE tmtuplealist == a list of associations
;;;      of tmtuples to assumption variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (tmtuplealist? tmtupali)
  (if CHECK 
      (if (not-list? tmtupali) #f
          (tmtuplealist-aux? tmtupali))
      #t))
(define (tmtuplealist-aux? tmtupali) 
  (if (null? tmtupali) #t 
      (if (not-tmtuple?
            (cdar tmtupali)) #f
          (if (not-avar?
                (caar tmtupali)) #f 
              (tmtuplealist-aux?
                (cdr tmtupali))))))
(define (ntmtuplealist? tmtupali)
  (if (tmtuplealist? tmtupali) #f #t))

(define NULL_tmtupalst (list))

(define (make-tmtuplealist-in-abst-form
          vatpl tmtplalst)
  (if (not-vatuple? vatpl)
      (myerror "make-tmtuplealist-in-abst-form:"
        "1st argument must be vatuple")
      (if (ntmtuplealist? tmtplalst)
	  (myerror
	   "make-tmtuplealist-in-abst-form: 2nd"
           "argument must be tmtuple-alist")
          (make-tmtuplealist-in-abst-form-aux
            vatpl tmtplalst))))
(define (make-tmtuplealist-in-abst-form-aux
          vatpl tmtplalst)
  (if (null? tmtplalst) tmtplalst
      (cons
        (cons (caar tmtplalst) 
          (make-tmtuple-in-abst-form vatpl
            (cdar tmtplalst)))
        (make-tmtuplealist-in-abst-form-aux
          vatpl (cdr tmtplalst)))))

(define (make-tmtuplealist-in-app-form
          tmtplalst tmtpl)
  (if (not-tmtuple? tmtpl)
      (myerror "make-tmtuplealist-in-app-form:"
        "2nd argument must be tmtuple")
      (if (ntmtuplealist? tmtplalst)
	  (myerror
	   "make-tmtuplealist-in-app-form: 1st"
           "argument must be tmtuple-alist")
          (make-tmtuplealist-in-app-form-aux
            tmtplalst tmtpl))))
(define (make-tmtuplealist-in-app-form-aux
          tmtplalst tmtpl)          
  (if (null? tmtplalst) tmtplalst
      (cons
        (cons (caar tmtplalst) 
          (make-tmtuple-in-app-form
            (cdar tmtplalst) tmtpl))
        (make-tmtuplealist-in-app-form-aux
          (cdr tmtplalst) tmtpl))))

(define (alist-to-formula-free tmtplalst)
  (if (null? tmtplalst) (list)
      (union (formula-to-free
               (avar-to-formula
                 (caar tmtplalst)))
	     (alist-to-formula-free
               (cdr tmtplalst)))))

(define (alist-to-tmtuple-free tmtplalst)
  (if (null? tmtplalst) (list)
      (union
        (tmtuple-to-free
          (cdar tmtplalst))
        (alist-to-tmtuple-free
          (cdr tmtplalst)))))

(define (tmtuplealist-substitute
          tmtplalst subst)
  (if (ntmtuplealist? tmtplalst)
      (myerror "tmtuplealist-substitute:"
        "1st argument must be tmtuplealist")
      (tmtuplealist-substitute-aux
        tmtplalst subst)))
(define (tmtuplealist-substitute-aux
          tmtplalst subst)
  (if (null? subst) tmtplalst
      (if (null? tmtplalst) tmtplalst
          (cons (cons (caar tmtplalst) 
                  (tmtuple-substitute
                    (cdar tmtplalst) subst))
            (tmtuplealist-substitute-aux
              (cdr tmtplalst) subst)))))

(define (tmtuplealist-non-simult-subst
          tmtplalst subst)
  (if (ntmtuplealist? tmtplalst)
      (myerror "tmtuplealist-substitute:"
        "1st argument must be tmtuplealist")
      (tmtuplealist-non-simult-subst-aux
        tmtplalst subst)))
(define (tmtuplealist-non-simult-subst-aux
          tmtplalst subst)
  (if (null? subst) tmtplalst
      (if (null? tmtplalst) tmtplalst
          (cons (cons (caar tmtplalst) 
                  (DIA-tmtuple-non-simult-subst
                    (cdar tmtplalst) subst))
            (tmtuplealist-non-simult-subst-aux
              (cdr tmtplalst) subst)))))


; DATATYPE typair == pair of tytuples

(define (typair-left typair) (cadr typair))
(define (typair-right typair) (caddr typair))
(define (typair? t)
  (if (not-eq? 'typair (car t)) #f
      (if (not-tytuple? (cadr t)) #f
          (tytuple? (caddr t)))))
(define (ntypair? t)
  (if (typair? t) #f #t))

(define (make-typair tytpl1 tytpl2)
  (begin
    (if PARANOIA
        (if (not-tytuple? tytpl1)
            (myerror "make-typair: 1st"
              "argument not a tytuple" tytpl1)
            (if (not-tytuple? tytpl2)
                (myerror "make-typair: 2nd"
                  "argument not a tytuple" tytpl2))))
    (list 'typair tytpl1 tytpl2)))

(define NULL_typr
  (make-typair NULL_tytup NULL_tytup))

; DATATYPE vapair == pair of vatuples

(define (vapair-left vapr) (cadr vapr))
(define (vapair-right vapr)(caddr vapr))
(define (vapair? vapr) 
  (if (not-eq? 'vapair (car vapr)) #f
      (if (not-vatuple? (cadr vapr)) #f 
          (vatuple? (caddr vapr)))))
(define (nvapair? t)
  (if (vapair? t) #f #t))

(define (make-vapair vatpl1 vatpl2) 
  (begin
    (if PARANOIA
        (if (not-vatuple? vatpl1)
            (myerror "make-vapair: 1st"
              "argument not a vatuple" vatpl1)
            (if (not-vatuple? vatpl2)
                (myerror "make-vapair: 2nd"
                  "argument not a vatuple" vatpl2))))
    (list 'vapair vatpl1 vatpl2)))

(define NULL_vapr
  (make-vapair NULL_vatup NULL_vatup))

(define (typair-to-vapair typr)
  (begin
    (if PARANOIA
        (if (ntypair? typr)
            (myerror "typair-to-vapair:"
              "argument not a typair" typr)))
    (let*((vatup-le
            (tytuple-to-vatuple
              (typair-left typr)))
           (vatup-ri
            (tytuple-to-vatuple
              (typair-right typr))))
      (make-vapair
        vatup-le vatup-ri))))

; DATATYPE tmpair == pair with left component tmtuple and
;                    right component a tmtuple alist

(define (tmpair-to-tuple tmpair)
  (cadr tmpair))
(define (tmpair-to-alist tmpair)
  (caddr tmpair))
(define (tmpair? t) 
  (if (not-eq? 'tmpair (car t)) #f
      (if (not-tmtuple? (cadr t)) #f
          (tmtuplealist? (caddr t)))))
(define (ntmpair? t)
  (if (tmpair? t) #f #t))

(define (make-tmpair tmtpl tmtplalst) 
  (if (not-tmtuple? tmtpl)
      (myerror "make-tmpair: 1st"
        "argument must be tmtuple" tmtpl)
      (if (ntmtuplealist? tmtplalst)
          (myerror "make-tmpair: 2nd"
            "argument must be tmtuplealist")
          (list 'tmpair tmtpl tmtplalst))))

; DATATYPE vatmpair == 
; pair of first component vapair and second component tmpair

(define (make-vatmpair vapr tmpair)
  (list 'vatmpair vapr tmpair))
(define (vatmpair-to-vapair vatmpr)
  (cadr vatmpr))
(define (vatmpair-to-tmpair vatmpr)
  (caddr vatmpr))
(define NULLvatmpair
  (make-vatmpair
    (make-vapair NULL_vatup  NULL_vatup) 
    (make-tmpair NULL_tmtup NULL_tmtupalst)))

(define (vatmpair? vmp)
  (if (not-eq? 'vatmpair (car t)) #f
      (if (nvapair? (cadr t)) #f
          (tmpair? (caddr t)))))
(define (nvatmpair? t)
  (if (vatmpair? t) #f #t))

; In DIA-pvar-to-tvarp we assign a pair of tytuples to the predicate
; variables.  For to be able to later refer to this assignment, we use a
; global variable DIA-PVAR-TO-TVARP-ALIST, which memorizes the assigment done
; so far.  Later reference is necessary, because such tvars will appear
; in extracted programs of theorems involving pvars, and in a given
; development there may be many auxiliary lemmata containing the same
; pvar.  A fixed DIA-pvar-to-tvarp refers to and updates DIA-PVAR-TO-TVARP-ALIST.

(define DIA-PVAR-TO-TVARP-ALIST '())
(define DIA-INIT-PVAR-TO-TVARP-ALIST DIA-PVAR-TO-TVARP-ALIST)

(define (DIA-pvar-to-tvarp pvar)
  (let ((info (assoc pvar DIA-PVAR-TO-TVARP-ALIST)))
    (if info
	(cadr info)
	(let ((DIA-newtvarp (make-typair
			    (type-to-tytuple (new-tvar)) 
			    (type-to-tytuple (new-tvar)))))
	  (set! DIA-PVAR-TO-TVARP-ALIST
		   (cons (list pvar DIA-newtvarp)
			 DIA-PVAR-TO-TVARP-ALIST))
	  DIA-newtvarp))))


; In DIA-formula-to-typair KIND we assign a typair (i.e., a pair of tytuples)
; to any formula passed as argument such that a new pair of type variables is 
; assigned to the predicate variables occuring in the argument formulas 
; - assignment carried on via DIA-pvar-to-tvarp. Here as well the assigments
; already done are remembered. The assignments are memorized in the global
; variable DIA-PVAR-TO-TVARP-ALIST. 

(define (DIA-formula-to-typair KIND fmla)
  (case (tag fmla)
    ((atom) NULL_typr)
    ((predicate)
     (if (formula=? falsity-log fmla)
         NULL_typr
        (let((pred (predicate-form-to-predicate fmla)))
	  (if (predconst-form? pred) NULL_typr
	      (if (pvar-form? pred) 
		  (if (= 0 (pvar-to-h-deg pred))
		      (DIA-pvar-to-tvarp pred)  NULL_typr)
		  (if (idpredconst-form? pred)
		      (myerror "DIA-formula-to-typair:"
			       "inductive predicates not supported yet" pred)
		      (myerror "DIA-formula-to-typair:"
			       "predicate expected" (formula-to-string fmla) pred)))))))
    ((imp)
     (make-arrow-fiet
       (DIA-formula-to-typair KIND
         (imp-form-to-premise fmla))
       (DIA-formula-to-typair KIND
         (imp-form-to-conclusion fmla))))
    ((and)
     (make-star-fiet
       (DIA-formula-to-typair KIND
         (and-form-to-left fmla))
       (DIA-formula-to-typair KIND
         (and-form-to-right fmla))))
    ((all)
     (make-all-fiet
       (type-to-tytuple
         (var-to-type (all-form-to-var fmla)))
       (DIA-formula-to-typair KIND
         (all-form-to-kernel fmla))))
    ((allnc)
       (case KIND
	 ((light monot) (DIA-formula-to-typair KIND
			(allnc-form-to-kernel fmla)))
	 ((pure)  
	     (make-all-fiet
	        (type-to-tytuple (var-to-type (allnc-form-to-var fmla)))
		(DIA-formula-to-typair KIND
				       (allnc-form-to-kernel fmla))))
	 (else (myerror "DIA-formula-to-typair:" "unknown KIND" KIND))))
    ((ex)
     (make-ex-fiet
       (type-to-tytuple
         (var-to-type (ex-form-to-var fmla)))
       (DIA-formula-to-typair KIND
         (ex-form-to-kernel fmla))))
    ((exca excl)
     (DIA-formula-to-typair KIND
       (unfold-formula fmla)))
    ((exnc)
     (myerror "DIA-formula-to-typair:"
       "exnc not implemented"))
    ((tensor)
     (myerror "DIA-formula-to-typair:"
       "tensor not allowed here"
       (formula-to-string fmla)))
;      (make-star-fiet
;        (DIA-formula-to-typair KIND
;          (tensor-form-to-left fmla))
;        (DIA-formula-to-typair KIND
;          (tensor-form-to-right fmla))))
    (else (myerror "DIA-formula-to-typair:"
            "formula expected" fmla))))


(define (make-arrow-fiet typairA typairB)
  (if (ntypair? typairA)
      (myerror "make-arrow-fiet:"
        "1st argument must be typair"
        typairA typairB)
      (if (ntypair? typairB)
          (myerror "make-arrow-fiet:"
            "2nd argument must be typair"
            typairA typairB)
          (make-arrow-fiet-aux typairA typairB))))
(define (make-arrow-fiet-aux typairA typairB)        
  (let*((x (typair-left typairA)) 
	(y (typair-right typairA))
	(u (typair-left typairB)) 
	(v (typair-right typairB))
	(xv (tytuple-append x v
              "make-arrow-fiet 1"))  
	(bigY (make-tytuple-arrow xv y))
	(bigU (make-tytuple-arrow x u)) 
	(YU (tytuple-append bigY bigU
              "make-arrow-fiet 2")))
    (make-typair YU xv)))

(define (make-star-fiet typairA typairB)
  (if (ntypair? typairA)
      (myerror "make-star-fiet:"
        "1st argument must be typair"
        typairA typairB)
      (if (ntypair? typairB)
          (myerror "make-star-fiet:"
            "2nd argument must be typair"
            typairA typairB)
          (make-star-fiet-aux typairA typairB))))
(define (make-star-fiet-aux typairA typairB)
  (let*((x (typair-left typairA)) 
	(y (typair-right typairA))
	(u (typair-left typairB)) 
	(v (typair-right typairB))
	(xu (tytuple-append x u
              "make-star-fiet 1"))  
	(yv (tytuple-append y v
              "make-star-fiet 2")))
    (make-typair xu yv)))

(define (make-all-fiet z typairA)
  (if (not-tytuple? z)
      (myerror "make-all-fiet:"
        "1st argument must be tytuple"
        z typairA)
      (if (ntypair? typairA)
          (myerror "make-all-fiet:"
            "2nd argument must be typair"
            z typairA)
          (make-all-fiet-aux z typairA))))
(define (make-all-fiet-aux z typairA)          
  (let*((x (typair-left typairA)) 
	(y (typair-right typairA))
	(bigX (make-tytuple-arrow z x)) 
	(zy (tytuple-append z y
              "make-all-fiet")))
    (make-typair bigX zy)))

(define (make-ex-fiet z typairA)
  (if (not-tytuple? z)
      (myerror "make-ex-fiet:"
        "1st argument must be tytuple"
        z typairA)
      (if (ntypair? typairA)
          (myerror "make-ex-fiet:"
            "2nd argument must be typair"
            z typairA)
          (make-ex-fiet-aux z typairA))))
(define (make-ex-fiet-aux z typairA)
  (make-typair
    (tytuple-append z
      (typair-left typairA)
      "make-ex-fiet") 
    (typair-right typairA)))

; In DIA-pvar-to-bool-term we assign a  boolean term of type
; a1->a2->...->aN->bool to each pvar given as argument, 
; where (a1,...,aN) is the arity of the predicate variable argument.  
; This assignment is memorized for each pvar in the global variable 
; DIA-PVAR-TO-BT-ALIST at the first-time call of DIA-pvar-to-bool-term 
; on that pvar argument and is later referenced at the subsequent 
; calls of  DIA-pvar-to-bool-term on the same pvar argument

(define DIA-PVAR-TO-BT-ALIST '())
(define DIA-INIT-PVAR-TO-BT-ALIST DIA-PVAR-TO-BT-ALIST)

(define (DIA-pvar-to-bool-term pvar)
  (let ((info (assoc pvar DIA-PVAR-TO-BT-ALIST)))
    (if info
	(cadr info)
	(let ((DIA-newBT (pvar-to-new-bool-term pvar)))
	  (set! DIA-PVAR-TO-BT-ALIST
		   (cons (list pvar DIA-newBT)
			 DIA-PVAR-TO-BT-ALIST))
	  DIA-newBT))))

(define (dyn-mk-arrow x)
  (if (list? x)
       (dyn-mk-arrow-aux x)
       (myerror "dyn-mk-arrow: list argument expected" x)))
(define (dyn-mk-arrow-aux x)
  (if (null? x)
      (myerror "dyn-mk-arrow: non-empty list argument expected" x)
      (dyn-mk-arrow-aux-aux x)))
(define (dyn-mk-arrow-aux-aux x)
      (if (null? (cdr x)) (car x)
	  (make-arrow (car x) (dyn-mk-arrow-aux-aux (cdr x)))))

(define (dyn-mk-term-in-app-form tm tmlst)
  (if (list? tmlst)
       (dyn-mk-term-in-app-form-aux tm tmlst)
       (myerror "dyn-mk-term-in-app-form: list argument expected" tmlst)))
(define (dyn-mk-term-in-app-form-aux tm tmlst)
  (if (null? tmlst)
      (myerror "dyn-mk-term-in-app-form: non-empty list argument expected" tmlst)
      (dyn-mk-term-in-app-form-aux-aux tm tmlst)))
(define (dyn-mk-term-in-app-form-aux-aux tm tmlst)
      (if (null? (cdr tmlst)) (make-term-in-app-form tm (car tmlst))
	 (dyn-mk-term-in-app-form-aux-aux 
	   (make-term-in-app-form tm  (car tmlst))
	   (cdr tmlst))))

(define (dyn-mk-term-in-abst-form tm valst)
  (if (list? valst)
       (dyn-mk-term-in-abst-form-aux tm valst)
       (myerror "dyn-mk-term-in-abst-form: list argument expected" valst)))
(define (dyn-mk-term-in-abst-form-aux tm valst)
  (if (null? valst)
      (myerror "dyn-mk-term-in-abst-form:"  
	                  "non-empty list argument expected" valst)
      (dyn-mk-term-in-abst-form-aux-aux tm valst)))
(define (dyn-mk-term-in-abst-form-aux-aux tm valst)
      (if (null? (cdr valst)) (make-term-in-abst-form (car valst) tm)
	  (make-term-in-abst-form (car valst) 
			(dyn-mk-term-in-abst-form-aux-aux tm (cdr valst)))))

(define (pvar-to-new-bool-term pvar)
  (let* ((name (string-append "pc" (pvar-to-name pvar)))
	 (arity (pvar-to-arity pvar))
	 (types (arity-to-types arity))
	 (pcnst 
	  (let((info (assoc name PROGRAM-CONSTANTS)))
	     (if info (cadr info)
		(let*((new-types (append types (list (py "boole"))))
		      (typ (dyn-mk-arrow new-types)))
		  (begin
		    (add-program-constant name typ)
		    (pconst-name-to-pconst name))))))
	 (tm-pcnst (make-term-in-const-form pcnst))
	 (vars (map type-to-new-var types))
	 (varterms (map make-term-in-var-form vars))
	 (appterm (dyn-mk-term-in-app-form tm-pcnst varterms))
	 (rv  (dyn-mk-term-in-abst-form appterm vars))
	 (LEGDUM (nldisplay "bool-term for pvar" 
	      (pvar-to-name pvar)   "is"  (term-to-string rv))))
    rv))

(define (dyn-union x)
  (if (list? x)
       (dyn-union-aux x)
       (myerror "dyn-union: list argument expected" x)))
(define (dyn-union-aux x)
  (if (null? x)
      (myerror "dyn-union: non-empty list argument expected" x)
      (dyn-union-aux-aux x)))
(define (dyn-union-aux-aux x)
  (cond ((null? x) '())
	((list? (car x))
	 (remove-duplicates (append (car x) (dyn-union-aux-aux (cdr x)))))
	(else (myerror "union: list expected" (car x)))))

;; (DIA-Data KIND A) returns a 4-elements list
;; (<x,y>,t_A,<ty-x,ty-y>.free-var-list) with
;; 1st component - a vapair of existential and
;;                 universal vatuples
;; which correspond to the vatuples of the 2nd component
;; 2nd component - a boolean term t_A built from the free 
;; variables of A which are enumerated in the "free-var-list",
;; x and y (i.e., the existential and universal variables)
;; such that:  A_D(x;y;a) <-> atom(t_A[x;y;a])
;; 3rd component - a typair of existential and
;;                 universal tytuples

(define (DIA-Data KIND fmla)
  (begin
    (if DEBUG-DIDA
        (DIA-comment-forced "DIA-Data applied on"
          'CNL (formula-to-string fmla)))
  (case (tag fmla)
    ((atom)
     (let*((tA0 (atom-form-to-kernel fmla))
           (freeA0 (term-to-free tA0))
           (rv
             (cons NULL_vapr
               (cons tA0
                 (cons NULL_typr
                   freeA0)))))
       rv))
    ((predicate)
     (if (formula=? falsity-log fmla)
         (let((rv
                (cons NULL_vapr
                  (cons FALSE_tm
                    (cons NULL_typr
                      '())))))
             rv)
     (let ((pred (predicate-form-to-predicate fmla)))
       (if (predconst-form? pred) NULL_typr
	(if (pvar-form? pred) 
	    (if (= 0 (pvar-to-h-deg pred))
		(myerror "DIA-Data:" 
			 "Not yet implemented  for predicates with h-deg zero")
		(let*((args (predicate-form-to-args fmla))
		      (bool-tm (DIA-pvar-to-bool-term pred))
		      (tm (dyn-mk-term-in-app-form bool-tm args))
		      (fvars (dyn-union (map term-to-free args)))
		      (rv (cons NULL_vapr
			    (cons tm (cons NULL_typr fvars)))))
		  rv))
	    (if (idpredconst-form? pred)
		(myerror "DIA-Data" 
			       "inductive predicates not supported yet" pred)
		(myerror "DIA-Data:" "predicate expected" pred)))))))
    ((imp)
     (let*((A (DIA-Data KIND (imp-form-to-premise fmla)))
           (LEGDUM
             (if DEBUG-DIDA
                 (DIA-comment-forced "DIA-Data "
                   "imp - A finished")))
             (typr_A (caddr A)) 
            (vapr_A (car A))
            (tm_A (cadr A))
            (fv_A (cdddr A))
	    (typ_x (typair-left typr_A)) 
	    (typ_y (typair-right typr_A))           
	    (var_x (vapair-left vapr_A)) 
	    (var_y (vapair-right vapr_A))
	    (B
              (DIA-Data KIND 
                (imp-form-to-conclusion
                  fmla)))
           (LEGDUM
             (if DEBUG-DIDA
                 (DIA-comment-forced "DIA-Data "
                   "imp - B finished")))
	    (typr_B (caddr B)) 
	    (vapr_B (car B))
            (tm_B (cadr B))
            (fv_B (cdddr B))
	    (typ_u (typair-left typr_B)) 
	    (typ_v (typair-right typr_B))           
	    (var_u (vapair-left vapr_B)) 
	    (var_v (vapair-right vapr_B))
	    (typ_xv
              (tytuple-append typ_x typ_v
                "DIA-Data KIND imp 1"))
            (typ_BigY
              (make-tytuple-arrow
                typ_xv typ_y))
	    (typ_BigU
              (make-tytuple-arrow
                typ_x typ_u))
            (typ_YU
              (tytuple-append typ_bigY typ_bigU
                "DIA-Data imp 2"))
            (var_BigY
              (tytuple-to-vatuple typ_BigY))
            (var_BigU
              (tytuple-to-vatuple typ_BigU))
            (var_xv
              (vatuple-append var_x var_v
                "DIA-Data imp 3"))
            (var_YU
              (vatuple-append var_BigY var_BigU
                "DIA-Data imp 4"))            
	    (Yxv
              (make-tmtuple-in-app-form
                (vatuple-to-tmtuple var_BigY) 
                (vatuple-to-tmtuple var_xv)))
	    (Ux
              (make-tmtuple-in-app-form
                (vatuple-to-tmtuple var_BigU) 
                (vatuple-to-tmtuple var_x)))
	    (new_tm_A
              (DIA-term-non-simult-subst tm_A
                (DIA-make-alist var_y Yxv
                  "DIA-Data (imp) y Yxv :")))
	    (new_tm_B
              (DIA-term-non-simult-subst tm_B
                (DIA-make-alist var_u Ux
                  "DIA-Data (imp) u Ux :")))
	    (tm_AimpB
              (mk-term-in-if-form  
                new_tm_A (list new_tm_B TRUE_tm)))
	    (fv_AimpB
              (union fv_A fv_B))
            (rv
              (cons
                (make-vapair var_YU var_xv)
                (cons tm_AimpB 
                  (cons
                    (make-typair typ_YU typ_xv)
                    fv_AimpB)))))
       (begin
         (if DEBUG-DIDA
             (DIA-comment-forced "DIA-Data "
               "IMP finished "
               (term-to-string tm_AimpB)))
         rv)))
     ((and)
     (let*((A
             (DIA-Data KIND 
               (and-form-to-left 
                 fmla)))
           (LEGDUM
             (if DEBUG-DIDA
                 (DIA-comment-forced "DIA-Data "
                   "and - A finished")))
           (typr_A (caddr A)) 
           (vapr_A (car A))
           (tm_A (cadr A))
           (fv_A (cdddr A))
           (typ_x (typair-left typr_A)) 
           (typ_y (typair-right typr_A))           
           (var_x (vapair-left vapr_A)) 
           (var_y (vapair-right vapr_A))
           (B
             (DIA-Data KIND 
               (and-form-to-right
                 fmla)))
           (LEGDUM
             (if DEBUG-DIDA
                 (DIA-comment-forced "DIA-Data "
                   "and - B finished")))
           (typr_B (caddr B)) 
           (vapr_B (car B))
           (tm_B (cadr B))
           (fv_B (cdddr B))
           (typ_u (typair-left typr_B)) 
           (typ_v (typair-right typr_B))           
           (var_u (vapair-left vapr_B)) 
           (var_v (vapair-right vapr_B))
           (typ_xu
             (tytuple-append typ_x typ_u
               "DIA-Data and 1"))
           (typ_yv
             (tytuple-append typ_y typ_v
               "DIA-Data and 2"))
           (var_xu
             (vatuple-append var_x var_u
               "DIA-Data and 3"))
           (var_yv
             (vatuple-append var_y var_v
               "DIA-Data and 4"))
           (tm_AandB
             (mk-term-in-if-form  
               tm_A (list tm_B FALSE_tm)))
           (fv_AandB
             (union fv_A fv_B))
           (rv 
             (cons
               (make-vapair var_xu var_yv)
               (cons tm_AandB 
                 (cons
                   (make-typair typ_xu typ_yv)
                   fv_AandB)))))
       (begin
         (if DEBUG-DIDA
             (DIA-comment-forced "DIA-Data "
               "AND finished "
               (term-to-string tm_AandB)))
         rv)))
     ((all)
     (let*((A
             (DIA-Data KIND 
               (all-form-to-kernel fmla)))
           (LEGDUM
             (if DEBUG-DIDA
                 (DIA-comment-forced "DIA-Data "
                   "all - A finished")))
           (typr_A (caddr A)) 
           (vapr_A (car A))
           (tm_A (cadr A))
           (fv_A (cdddr A))
           (typ_x (typair-left typr_A)) 
           (typ_y (typair-right typr_A))           
           (var_x (vapair-left vapr_A)) 
           (var_y (vapair-right vapr_A))
           (var_z
             (var-to-vatuple
               (all-form-to-var fmla)))
           (typ_z
             (vatuple-to-tytuple var_z))
           (new_z
             (tytuple-to-vatuple typ_z))
           (typ_zy
             (tytuple-append typ_z typ_y
               "DIA-Data all 1")) 
           (var_zy
             (vatuple-append new_z var_y
               "DIA-Data all 2")) 
           (typ_BigX
             (make-tytuple-arrow typ_z typ_x))
           (var_BigX
             (tytuple-to-vatuple typ_BigX))
           (Xz
             (make-tmtuple-in-app-form
               (vatuple-to-tmtuple var_BigX)  
               (vatuple-to-tmtuple new_z)))
           (alst
             (DIA-make-alist
               (vatuple-append var_x var_z
                 "DIA-Data all 3")
               (tmtuple-append Xz
                 (vatuple-to-tmtuple new_z)
                 "DIA-Data all 4")
               "DIA-Data (all): "))
           (new_tm
             (DIA-term-non-simult-subst
               tm_A alst))
           (new_fv
             (set-minus fv_A var_z))
           (rv
             (cons
               (make-vapair var_BigX var_zy)
               (cons new_tm 
                 (cons
                   (make-typair typ_BigX typ_zy)
                   new_fv)))))
       (begin
         (if DEBUG-DIDA
             (DIA-comment-forced "DIA-Data "
               "ALL finished "
               (term-to-string new_tm)))
         rv)))
    ((allnc)
           (case KIND
	 ((light monot) (DIA-Data KIND 
			    (allnc-form-to-kernel fmla)))
	 ((pure)      
	     (let*((A (DIA-Data KIND
				(allnc-form-to-kernel fmla)))
		   (LEGDUM
		    (if DEBUG-DIDA
			(DIA-comment-forced "DIA-Data" "allnc - A finished")))
		   (typr_A (caddr A)) 
		   (vapr_A (car A))
		   (tm_A (cadr A))
		   (fv_A (cdddr A))
		   (typ_x (typair-left typr_A)) 
		   (typ_y (typair-right typr_A))           
		   (var_x (vapair-left vapr_A)) 
		   (var_y (vapair-right vapr_A))
		   (var_z
		    (var-to-vatuple
		     (allnc-form-to-var fmla)))
		   (typ_z
		    (vatuple-to-tytuple var_z))
		   (new_z
		    (tytuple-to-vatuple typ_z))
		   (typ_zy
		    (tytuple-append typ_z typ_y
				    "DIA-Data PDI allnc 1")) 
		   (var_zy
		    (vatuple-append new_z var_y
				    "DIA-Data PDI allnc 2")) 
		   (typ_BigX
		    (make-tytuple-arrow typ_z typ_x))
		   (var_BigX
		    (tytuple-to-vatuple typ_BigX))
		   (Xz
		    (make-tmtuple-in-app-form
		     (vatuple-to-tmtuple var_bigX)  
		     (vatuple-to-tmtuple new_z)))
		   (new_tm
		    (DIA-term-non-simult-subst tm_A
				       (DIA-make-alist
					(vatuple-append var_x var_z
							"DIA-Data PDI allnc 3")
					(tmtuple-append Xz
							(vatuple-to-tmtuple new_z)
							"DIA-Data PDI allnc 4")
					"DIA-Data PDI (allnc): ")))
		   (new_fv
		    (set-minus fv_A var_z))
		   (rv
		    (cons
		     (make-vapair var_BigX var_zy)
		     (cons new_tm 
			   (cons
			    (make-typair typ_BigX typ_zy)
			    new_fv)))))
	       (begin
		 (if DEBUG-DIDA
		     (DIA-comment-forced "DIA-Data PDI" "ALLNC finished "
				  (term-to-string new_tm)))
		 rv)))
	 (else (myerror "DIA-Data: unknown KIND" KIND))))
    ((ex)
     (let*((A
             (DIA-Data KIND 
               (ex-form-to-kernel fmla)))
           (LEGDUM
             (if DEBUG-DIDA
                 (DIA-comment-forced "DIA-Data "
                   "ex - A finished")))
           (typr_A (caddr A)) 
           (vapr_A (car A))
           (tm_A (cadr A))
           (fv_A (cdddr A))
           (typ_x (typair-left typr_A)) 
           (typ_y (typair-right typr_A))           
           (var_x (vapair-left vapr_A)) 
           (var_y (vapair-right vapr_A))
           (var_z
             (var-to-vatuple
               (ex-form-to-var fmla)))
           (typ_z
             (vatuple-to-tytuple var_z))
           (new_z
             (tytuple-to-vatuple typ_z))
           (typ_zx
             (tytuple-append typ_z typ_x
               "DIA-Data ex 1")) 
           (var_zx
             (vatuple-append new_z var_x
               "DIA-Data ex 2")) 
           (new_tm
             (DIA-term-non-simult-subst tm_A
               (DIA-make-alist var_z
                 (vatuple-to-tmtuple new_z)
                 "DIA-Data (ex): ")))
           (new_fv
             (set-minus fv_A var_z))
           (rv
             (cons
               (make-vapair var_zx var_y)
               (cons new_tm 
                 (cons
                   (make-typair typ_zx typ_y)
                   new_fv)))))
       (begin
         (if DEBUG-DIDA
             (DIA-comment-forced "DIA-Data "
               "EX finished "
               (term-to-string new_tm)))
         rv)))
    ((exca excl)
     (DIA-Data KIND 
       (unfold-formula fmla)))
    ((exnc)
     (myerror "DIA-Data:" 
	      "exnc not implemented"
	      (formula-to-string fmla)))
    ((tensor)
     (myerror "DIA-Data:"
       "tensor not allowed here"
       (formula-to-string fmla)))
    (else
      (myerror "DIA-Data:"
        "syntactic error in formula"
        fmla)))))

(define (avar-table-count avr alist)
  (if (null? alist)
      (list (cons avr 1))
      (if (avar=? avr (caar alist))
          (cons
            (cons avr (+ (cdar alist) 1))
              (cdr alist))
          (cons (car alist)
            (avar-table-count avr (cdr alist))))))
(define (avar-table avr alist)
  (cond ((null? alist) #f)
        ((avar=? avr (caar alist)) (cdar alist))
        (else (avar-table avr (cdr alist)))))

(define (DIA-Occur-table-to-string alst)
  (DIA-avar-table-to-string alst number->string))
(define (DIA-avar-table-to-string alst to_string_proc)
  (if (null? alst) "[ EMPTY-ALIST ]"
      (string-append " [ " SBK3
        (DIA-avar-table-to-string-aux alst
          to_string_proc))))
(define (DIA-avar-table-to-string-aux alst
          to_string_proc)
  (if (null? alst) " ]"
      (string-append " , "
        (avar-to-string (caar alst))
        " -> " (to_string_proc (cdar alst))
        (DIA-avar-table-to-string-aux
          (cdr alst) to_string_proc))))
  

; (DIA-make-avar-to-Data KIND) creates a new list of associations
; of Data to assumption variables. Data is a list with 1st
; element the number of occurences of that assumption variable
; in the argument proof - this is determined in the first
; "optimization" pass (when y is #t). The 2nd element of Data
; is a vapair thus uniquely associated to the assumption var.
; If the assumption var A occurs at least twice in the proof
; then the list contains also an associated term t_A such that
; A_D(x;y;a) <--> t_A(x;y;a), a typair corresponding to the
; vapair and in the end the list of free variables of the
; formula A

(define (DIA-make-avar-to-Data KIND)
  (let((avar-Occur-list '())
       (avar-Vapr-list '())
       (avar-Data-list '()))
    (lambda (avr flg)
      (begin
        (if (not-avar? avr)
            (myerror "DIA-make-avar-to-Data: "
              "avar argument expected"))
        (if DEBUG-MAVD
            (nldisplay "DIA-make-avar-to-Data:"
              "invoked with flag " flg
              "for avar " (avar-to-string avr)))
        (if flg
            (let((new-Occur-list
                   (avar-table-count avr
                     avar-Occur-list)))
              (begin
                (set! avar-Occur-list
                  new-Occur-list)
                new-Occur-list))
            (let((LEGDUM
                   (if DEBUG-MAVD
                       (nldisplay "Occur list: "
                         (DIA-Occur-table-to-string
                           avar-Occur-list))))
                 (info
                   (avar-table avr
                     avar-Occur-list))
                 (fmla (avar-to-formula avr)))
              (case info
                ((#f)
                 (begin
                   (if DEBUG-MAVD
                       (nldisplay "Avar-to-Data:"
                         "detected assumption variable"
                         (avar-to-string avr)
                         "with no occurence in proof."
                         "Formula is \n"
                         (formula-to-string fmla)))
                   (list 0 #f)))
                ((1)
                 (begin
                   (if DEBUG-MAVD
                       (nldisplay "Avar-to-Data:"
                         "OK, assumption variable"
                         (avar-to-string avr)
                         "with 1 occurence will"
                         "be added to VAPR list." 
                         "Formula is \n"
                         (formula-to-string fmla)))                 
                   (let((vapr
                          (avar-table avr
                            avar-Vapr-list)))
                     (if vapr (list info vapr)
                         (let((new-vapr
                                (typair-to-vapair
                                  (DIA-formula-to-typair KIND
                                    fmla))))
                           (begin
                             (set! avar-Vapr-list
                               (cons (cons avr new-vapr)
                                 avar-Vapr-list))
                             (list info new-vapr)))))))
                (else
                  (let((data
                         (avar-table avr
                           avar-Data-list)))
                    (if data (cons info data)
                        (let((new-data
                               (DIA-Data KIND fmla)))
                          (begin
                            (if DEBUG-MAVD
                                (nldisplay "Avar-to-Data:"
                                  "OK, assumption variable"
                                  (avar-to-string avr)
                                  "with " info "occurences will"
                                  "be added to DATA list." 
                                  "Formula is \n"
                                  (formula-to-string fmla)))                                  
                            (set! avar-Data-list
                              (cons (cons avr new-data)
                                avar-Data-list))
                            (cons info new-data)))))))))))))

;; DIA-OPTone-preproc is a preprocessing phase to the
;; program-extraction in which also the Stab
;; and Stab-Log not containing strong ex are
;; replaced by their proofs, i.e. a Stab
;; elimination procedure is comprised in the
;; DIA-OPTone-preproc phase

(define (DIA-OPTone-preproc prf)
  (DIA-OPTone-preproc-aux prf))
(define (DIA-OPTone-preproc-aux prf)
  (case (tag prf)
    ((proof-in-avar-form) prf)
    ((proof-in-aconst-form)
     (let*((aconst
             (proof-in-aconst-form-to-aconst prf))
           (name
             (aconst-to-name aconst)))
       (cond
         ((string=? name "Stab")
          (let*((fmla
                  (proof-to-formula prf))
                (vars-and-final-kernel
                  (allnc-form-to-vars-and-final-kernel
                    fmla))
                (vars (car vars-and-final-kernel))
                (kernel (cadr vars-and-final-kernel))
                (concl
                  (unfold-formula
                    (imp-form-to-conclusion kernel))))
            (DIA-OPTone-preproc-aux 
              (apply mk-proof-in-nc-intro-form
                (append vars
                  (list (proof-of-stab-at concl))))
             )))
         ((string=? name "Stab-Log")
          (let*((fmla
                  (proof-to-formula prf))
                (vars-and-final-kernel
                  (allnc-form-to-vars-and-final-kernel
                    fmla))
                (vars (car vars-and-final-kernel))
                (kernel (cadr vars-and-final-kernel))
                (concl
                  (unfold-formula
                    (imp-form-to-conclusion kernel))))
            (DIA-OPTone-preproc-aux 
              (apply mk-proof-in-nc-intro-form
                (append vars
                  (list (proof-of-stab-log-at concl))))
             ))) 
          (else prf))))
    ((proof-in-imp-elim-form)
     (let((op (proof-in-imp-elim-form-to-op prf))
          (arg (proof-in-imp-elim-form-to-arg prf)))
       (make-proof-in-imp-elim-form
         (DIA-OPTone-preproc-aux op)
         (DIA-OPTone-preproc-aux arg))))
    ((proof-in-imp-intro-form)
     (let((avar
            (proof-in-imp-intro-form-to-avar prf))
          (kernel
            (proof-in-imp-intro-form-to-kernel prf)))
       (make-proof-in-imp-intro-form
	avar (DIA-OPTone-preproc-aux kernel))))
    ((proof-in-and-intro-form)
     (let((left
            (proof-in-and-intro-form-to-left prf))
          (right
            (proof-in-and-intro-form-to-right prf)))
       (make-proof-in-and-intro-form
	(DIA-OPTone-preproc-aux left)
	(DIA-OPTone-preproc-aux right))))
    ((proof-in-and-elim-left-form)
     (let((kernel
            (proof-in-and-elim-left-form-to-kernel
              prf)))
       (make-proof-in-and-elim-left-form ;inserted M.S.
	(DIA-OPTone-preproc-aux kernel))))
    ((proof-in-and-elim-right-form)
     (let((kernel
            (proof-in-and-elim-right-form-to-kernel
              prf)))
       (make-proof-in-and-elim-right-form ;inserted M.S.
	(DIA-OPTone-preproc-aux kernel))))
    ((proof-in-tensor-intro-form)
     (let((left
            (proof-in-tensor-intro-form-to-left
              prf))
	   (right
             (proof-in-tensor-intro-form-to-right
               prf)))
       (make-proof-in-tensor-intro-form
	(DIA-OPTone-preproc-aux left)
	(DIA-OPTone-preproc-aux right))))
    ((proof-in-tensor-elim-left-form)
     (let((kernel
            (proof-in-tensor-elim-left-form-to-kernel
              prf)))
       (make-proof-in-tensor-elim-left-form
	(DIA-OPTone-preproc-aux kernel))))
    ((proof-in-tensor-elim-right-form)
     (let((kernel
            (proof-in-tensor-elim-right-form-to-kernel
              prf)))
       (make-proof-in-tensor-elim-right-form
	(DIA-OPTone-preproc-aux kernel))))
    ((proof-in-all-intro-form)
     (let((var
            (proof-in-all-intro-form-to-var prf))
           (kernel
             (DIA-OPTone-preproc-aux
               (proof-in-all-intro-form-to-kernel prf)
              )))
       (if (proof-in-all-elim-form? kernel)
           (let*((tm (proof-in-all-elim-form-to-arg kernel))
                (LEGDUM
                  (if DEBUG
                      (nldisplay
                        "all-intro follows an all-elim "
                         " var = " (var-to-string var)
                         " tm = " (term-to-string tm)))))                 
             (if (term-in-var-form? tm)
                 (if (equal? var (term-in-var-form-to-var tm))
                     (begin (if DEBUG (nldisplay "OK, optimized"))
                            (proof-in-all-elim-form-to-op kernel))
                     (make-proof-in-all-intro-form var  kernel))
                 (make-proof-in-all-intro-form var  kernel)))
           (make-proof-in-all-intro-form var  kernel))))
    ((proof-in-all-elim-form)
     (let((op (DIA-OPTone-preproc-aux
                (proof-in-all-elim-form-to-op prf)
               ))
          (arg (proof-in-all-elim-form-to-arg prf)))
       (if (term-in-var-form? arg)
           (if (proof-in-all-intro-form? op)
               (let*((var (proof-in-all-intro-form-to-var op))
                     (LEGDUM
                       (if DEBUG
                           (nldisplay
                             "all-elim follows an all-intro "
                             " var = " (var-to-string var)
                             " tm = " (term-to-string arg)))))
                 (if (equal? var (term-in-var-form-to-var arg))
                     (begin (if DEBUG (nldisplay "OK, optimized"))
                            (proof-in-all-intro-form-to-kernel op))
                     (make-proof-in-all-elim-form op arg)))
               (make-proof-in-all-elim-form op arg))
           (make-proof-in-all-elim-form op arg))))
    ((proof-in-allnc-intro-form)
     (let((var
            (proof-in-allnc-intro-form-to-var prf))
           (kernel
             (DIA-OPTone-preproc-aux
               (proof-in-allnc-intro-form-to-kernel
                 prf))))
       (if (proof-in-allnc-elim-form? kernel)
           (let*((tm (proof-in-allnc-elim-form-to-arg kernel))
                (LEGDUM
                  (if DEBUG
                      (nldisplay
                        "allnc-intro follows an allnc-elim "
                         " var = " (var-to-string var)
                         " tm = " (term-to-string tm)))))
             (if (term-in-var-form? tm)
                 (if (equal? var
                       (term-in-var-form-to-var tm))
                     (begin (if DEBUG (nldisplay "OK, optimized"))
                            (proof-in-allnc-elim-form-to-op kernel))
                     (make-proof-in-allnc-intro-form var  kernel))
                 (make-proof-in-allnc-intro-form var  kernel)))
           (make-proof-in-allnc-intro-form var  kernel))))
    ((proof-in-allnc-elim-form)
     (let((op
            (DIA-OPTone-preproc-aux
              (proof-in-allnc-elim-form-to-op
                prf)))
          (arg
            (proof-in-allnc-elim-form-to-arg prf)))
       (if (term-in-var-form? arg)
           (if (proof-in-allnc-intro-form? op)
               (let*((var (proof-in-allnc-intro-form-to-var op))
                     (LEGDUM
                       (if DEBUG
                           (nldisplay
                             "allnc-elim follows an allnc-intro "
                             " var = " (var-to-string var)
                             " tm = " (term-to-string arg)))))
                 (if (equal? var (term-in-var-form-to-var arg))
                     (begin (if DEBUG (nldisplay "OK, optimized"))
                            (proof-in-allnc-intro-form-to-kernel op))
                     (make-proof-in-allnc-elim-form op arg)))
               (make-proof-in-allnc-elim-form op arg))
           (make-proof-in-allnc-elim-form op arg))))
(else (myerror "DIA-OPTone-preproc-aux: proof tag expected"
        (tag prf)))))

;; DIA-Data-preproc is a pre-processing phase
;; where an evidence of the number of occurences
;; of each assumption in the proof is created

(define (DIA-Data-preproc prf avar-to-Data)
  (case (tag prf)
    ((proof-in-avar-form)
     (begin
       (avar-to-Data
         (proof-in-avar-form-to-avar prf))
       1))
    ((proof-in-imp-elim-form)
     (+ (DIA-Data-preproc
          (proof-in-imp-elim-form-to-op prf)
          avar-to-Data)
       (DIA-Data-preproc
         (proof-in-imp-elim-form-to-arg prf)
         avar-to-Data)))
    ((proof-in-imp-intro-form)
     (- (DIA-Data-preproc
          (proof-in-imp-intro-form-to-kernel prf)
          avar-to-Data)
       1))
    ((proof-in-and-intro-form)
     (+ (DIA-Data-preproc
          (proof-in-and-intro-form-to-left prf)
          avar-to-Data)
       (DIA-Data-preproc
         (proof-in-and-intro-form-to-right prf)
         avar-to-Data)))
    ((proof-in-and-elim-left-form)
     (DIA-Data-preproc
       (proof-in-and-elim-left-form-to-kernel prf)
       avar-to-Data))
    ((proof-in-and-elim-right-form)
     (DIA-Data-preproc
       (proof-in-and-elim-right-form-to-kernel prf)
       avar-to-Data))
    ((proof-in-tensor-intro-form)
     (+ (DIA-Data-preproc
          (proof-in-tensor-intro-form-to-left prf)
          avar-to-Data)
       (DIA-Data-preproc
         (proof-in-tensor-intro-form-to-right prf)
         avar-to-Data)))
    ((proof-in-tensor-elim-left-form)
     (DIA-Data-preproc
       (proof-in-tensor-elim-left-form-to-kernel prf)
       avar-to-Data))
    ((proof-in-tensor-elim-right-form)
     (DIA-Data-preproc
       (proof-in-tensor-elim-right-form-to-kernel prf)
       avar-to-Data))
    ((proof-in-all-intro-form)
     (DIA-Data-preproc
       (proof-in-all-intro-form-to-kernel prf)
       avar-to-Data))
    ((proof-in-all-elim-form)
     (DIA-Data-preproc
       (proof-in-all-elim-form-to-op prf)
       avar-to-Data))
    ((proof-in-allnc-intro-form)
     (DIA-Data-preproc
       (proof-in-allnc-intro-form-to-kernel prf)
       avar-to-Data))
    ((proof-in-allnc-elim-form)
     (DIA-Data-preproc
       (proof-in-allnc-elim-form-to-op prf)
       avar-to-Data))
    (else 0)))


(define (DIA-display-NC-Prf prf) 
 (begin 
    (DIA-comment "NonComp-Conclusion: " 'CNL
	(formula-to-string (nf (proof-to-formula prf))))
    (DIA-display-NC-Hyps? (proof-to-free-avars prf))))

(define (DIA-display-NC-Hyps? avar-list)
  (if (null? avar-list) (DIA-comment "END of NonComp-Assumptions")
      (begin 
	(DIA-display-NC-Hyp (car avar-list))
	 (DIA-display-NC-Hyps? (cdr avar-list)))))

(define (DIA-display-NC-Hyp avr)
  (DIA-comment (avar-to-string avr) " ==> " 
	       (formula-to-string (nf (avar-to-formula avr)))))

(define (DIA-NonComp? KIND prf) 
(if (proof-in-avar-form? prf) #f
;   (if (proof-in-aconst-form? prf) 
;       (case (aconst-to-kind (proof-in-aconst-form-to-aconst prf))
; 	((theorem) 
; 	   (begin
; 	       (nldisplay "DIA-NonComp? KIND theorem" 
; 		          (formula-to-string (proof-to-formula prf)))
; 	       (DIA-NonComp-Conc? KIND (proof-to-formula prf))))
; 	((axiom) #f)
; 	(else 
; 	  (begin
; 	     (nldisplay "DIA-NonComp? KIND theorem" 
; 		          (formula-to-string (proof-to-formula prf)))
; 	    (DIA-NonComp-Conc? KIND (proof-to-formula prf)))))
 (and (DIA-NonComp-Conc? KIND (proof-to-formula prf))
          (DIA-NonComp-Hyps? KIND (proof-to-free-avars prf)))))

(define (DIA-NonComp-Conc? KIND fmla)
  (let((vatup (vapair-left (car (DIA-Data KIND fmla)))))
   (if (NULL-vatuple? vatup) vatup #f)))

(define (DIA-NonComp-Hyps? KIND avar-list)
  (if (null? avar-list) #t
      (and (DIA-NonComp-Hyp? KIND (car avar-list))
	 (DIA-NonComp-Hyps? KIND (cdr avar-list)))))

(define (DIA-NonComp-Hyp? KIND avr)
  (let((vatup (vapair-right (car (DIA-Data KIND (avar-to-formula avr))))))
   (if (NULL-vatuple? vatup) vatup #f)))

(define (DIA-NonComp-proof-to-ux KIND prf free-avars)
(begin
  (case (tag prf)
    ((proof-in-avar-form) 
       (let*((avr (proof-in-avar-form-to-avar prf))
	   (fmla (avar-to-formula avr))
	  (tv (if (member-wrt avar=? avr free-avars) #t #f))
          (rv (if tv  
                    (vapair-left (car (DIA-Data KIND fmla)))
	NULL_vatup)))
      (begin  rv)))
    ((proof-in-aconst-form) NULL_vatup)
    ((proof-in-imp-intro-form)
     (DIA-NonComp-proof-to-ux KIND 
         (proof-in-imp-intro-form-to-kernel prf) free-avars))
    ((proof-in-imp-elim-form)
       (vatuple-append  
           (DIA-NonComp-proof-to-ux KIND 
	   (proof-in-imp-elim-form-to-op prf) free-avars)
          (DIA-NonComp-proof-to-ux KIND 
	   (proof-in-imp-elim-form-to-arg prf) free-avars)
          "DIA-NonComp-proof-to-ux :  imp-elim"))
    ((proof-in-and-intro-form)
     (vatuple-append  
      (DIA-NonComp-proof-to-ux KIND 
       (proof-in-and-intro-form-to-left prf) free-avars)
      (DIA-NonComp-proof-to-ux KIND 
       (proof-in-and-intro-form-to-right prf) free-avars)
      "DIA-NonComp-proof-to-ux :  and-intro"))
    ((proof-in-and-elim-left-form)
     (DIA-NonComp-proof-to-ux KIND 
      (proof-in-and-elim-left-form-to-kernel prf) free-avars))
    ((proof-in-and-elim-right-form)
     (DIA-NonComp-proof-to-ux KIND 
      (proof-in-and-elim-right-form-to-kernel prf) free-avars))
    ((proof-in-tensor-intro-form)
     (vatuple-append
      (DIA-NonComp-proof-to-ux KIND 
       (proof-in-tensor-intro-form-to-left prf) free-avars)
      (DIA-NonComp-proof-to-ux KIND 
       (proof-in-tensor-intro-form-to-right prf) free-avars)
      "DIA-NonComp-proof-to-ux :  tensor-intro"))
    ((proof-in-tensor-elim-left-form)
     (DIA-NonComp-proof-to-ux KIND 
      (proof-in-tensor-elim-left-form-to-kernel prf) free-avars))
    ((proof-in-tensor-elim-right-form)
     (DIA-NonComp-proof-to-ux KIND 
      (proof-in-tensor-elim-right-form-to-kernel prf) free-avars))
    ((proof-in-all-intro-form)
     (DIA-NonComp-proof-to-ux KIND 
      (proof-in-all-intro-form-to-kernel prf) free-avars))
    ((proof-in-all-elim-form)
     (DIA-NonComp-proof-to-ux KIND 
      (proof-in-all-elim-form-to-op prf) free-avars))
    ((proof-in-allnc-intro-form)
     (DIA-NonComp-proof-to-ux KIND 
      (proof-in-allnc-intro-form-to-kernel prf) free-avars))
    ((proof-in-allnc-elim-form)
     (DIA-NonComp-proof-to-ux KIND 
      (proof-in-allnc-elim-form-to-op prf) free-avars))
    (else (myerror "DIA-NonComp-proof-to-ux: proof expected" prf)))))

(define (DIA-NonComp-tmtupalist KIND avar-list)
  (if (null? avar-list) NULL_tmtupalst
      (let((avr (car avar-list)))
      (cons (cons avr (vatuple-to-tmtuple (DIA-NonComp-Hyp? KIND avr)))
           (DIA-NonComp-tmtupalist KIND (cdr avar-list))))))

(define (DIA-NonComp-vatmp KIND prf) 
  (let*((conc (proof-to-formula prf))
            (hyps (proof-to-free-avars prf))
            (y (vapair-right (car (DIA-Data KIND conc))))
            (ux (DIA-NonComp-proof-to-ux KIND prf hyps))
            (vapr (make-vapair y ux))
            (tmpr (make-tmpair (vatuple-to-tmtuple (DIA-NonComp-Conc? KIND conc))
		 (DIA-NonComp-tmtupalist KIND hyps)))
            (rv  (make-vatmpair vapr tmpr)))
    (begin rv)))

 
;;  For the two proofs built by the DIA-extraction system
;; during the treatment of Induction also a dedicated
;; extraction procedure is more useful
(define (Ind-extracted-vatmpair KIND prf)
  (let*((old-debug DEBUG)
	(LEGDUM (set! DEBUG DEBUG-IND-AX))
	(avar-to-Data
          (DIA-make-avar-to-Data KIND))
        (avar-to-Data-ONE
          (lambda (x) (avar-to-Data x #t)))
        (LEGDUM
          (DIA-Data-preproc prf avar-to-Data-ONE))
        (avar-to-Data-TWO
          (lambda (x) (avar-to-Data x #f)))
        (vatmpr
          (DIA-extr-vatmpair-aux KIND 
            prf avar-to-Data-TWO))
	(LEGDUM (set! DEBUG old-debug)))
    vatmpr))

(define (DIA-extract KIND prf)
  (case KIND
    ((pure light monot)
     (DIA-reset-counters)
     (let ((rv (DIA-extr-vatmpair KIND prf)))
       (DIA-display-counters) rv))
    (else
     (myerror "DIA-extract: unknown KIND" KIND))))

(define (DIA-extr-vatmpair KIND prf)
(case KIND
  ((pure light monot)
   (if (DIA-NonComp? KIND prf) 
       (begin
	 (if EXTRACT-VERBOSE (DIA-comment-forced "DIA-extr-vatmpair:"  
		"Non-Computational Sub-Proof detected"))
	 (if DEBUG (DIA-display-NC-Prf prf))
	 (DIA-NonComp-vatmp KIND prf))
       (let*((str-fmla (formula-to-string (nf (proof-to-formula prf))))
	     (LEGDUM (if EXTRACT-VERBOSE (DIA-comment-forced 
		"DIA-extr-vatmpair: NEW EXTRACTION STARTS")))			  
	     (LEGDUM (if DEBUG (DIA-comment
	       "Extraction from a proof of formula" 'CNL str-fmla)))
	     (pre-prf (DIA-OPTone-preproc prf))
	     (LEGDUM (if EXTRACT-VERBOSE (DIA-comment-forced 
	       "OK pre-processing phase ONE ended")))
	     (nrm-prf
	      (if NORMALIZE-PROOF
		  (let*((norm-prf (DIA-time (np pre-prf))))
		    (begin (if EXTRACT-VERBOSE 
		      (DIA-comment-forced 
		       "OK normalization of proof ENDED"))
		      norm-prf))
		  pre-prf))
	     (avar-to-Data
	      (DIA-make-avar-to-Data KIND))
	     (avar-to-Data-ONE
	      (lambda (x) (avar-to-Data x #t)))
	     (LEGDUM
	      (DIA-Data-preproc nrm-prf
				avar-to-Data-ONE))
	     (avar-to-Data-TWO
	      (lambda (x) (avar-to-Data x #f)))
	     (vatmpr
	      (DIA-time 
	       (DIA-extr-vatmpair-aux KIND 
				      nrm-prf avar-to-Data-TWO)))
	     (LEGDUM
	      (begin
		(if EXTRACT-VERBOSE (DIA-comment-forced 
		  	      "DIA-extr-vatmpair: EXTRACTION ENDED"))			  
		(if DEBUG (DIA-comment
		      "Extraction from a proof of formula" 'CNL str-fmla))))
	     (fmla (proof-to-formula nrm-prf))
	     (tmpr (vatmpair-to-tmpair vatmpr))
	     (tmtup (tmpair-to-tuple tmpr))
	     ;;; (extra-free-vars '())
	     (extra-free-vars
	      (set-minus
	       (tmtuple-to-free tmtup)
	       (formula-to-free fmla)))
	     (LEGDUM (if (not (null? extra-free-vars)) 
			   (nldisplay "WARNING: in DIA-extr-vatmpair, "
				      "after the return from DIA-extr-vatmpair-aux," 
				      "extracted terms have not NULL extra-free-vars !!!")))
	     (new-vatmpr
	      (if (null? extra-free-vars) vatmpr
		  (let*((alst
			 (DIA-make-ZERO-alist
			  extra-free-vars))
			(new-tmtup
			 (DIA-tmtuple-non-simult-subst
			  tmtup alst)))
		    (begin
		      (if EXTRACT-VERBOSE (DIA-comment-forced 
		       "Some extra free vars" "of the extracted terms"
		       "are substituted with ZEROs" 'CNL
		       (DIA-non-simult-alist-to-string alst)
		       'CNL "The list of uncanceled assumptions is" 'CNL
		       (tmtuplealist-to-string (tmpair-to-alist tmpr)))
		      (make-vatmpair
		       (vatmpair-to-vapair vatmpr)
		       (make-tmpair new-tmtup
				    (tmpair-to-alist tmpr))))))))
	     (norm-vatmpr
	      (nbe-normalize-vatmpair-of THEOREM-NORMALIZE
					 new-vatmpr)))
	 norm-vatmpr)))
  (else (myerror "DIA-extr-vatmpair:" "unknown KIND" KIND))))

(define (DIA-extr-vatmpair-aux KIND prf avar-to-Data)
(if (DIA-NonComp? KIND prf) 
    (begin
       (if EXTRACT-VERBOSE (DIA-comment-forced "DIA-extr-vatmpair-aux:"  
	    "Non-Computational Sub-Proof detected"))
       (if DEBUG (DIA-display-NC-Prf prf))
       (DIA-NonComp-vatmp KIND prf))
  (case (tag prf)
    ((proof-in-avar-form)
     (let*((avar
             (proof-in-avar-form-to-avar prf))
           (data (avar-to-Data avar))
           (LEGDUM (if DEBUG (begin
                 (nldisplay
                   "PROOF-IN-AVAR-FORM:"
                   (avar-to-string avar)
                   "occuring "
                   (car data)
                   "times in the proof.")
	   (DIA-comment "Formula is "
                   (formula-to-string
                     (nf (avar-to-formula avar)))))))
	   (vapr (cadr data))
	   (x (vapair-left vapr))
	   (y (vapair-right vapr))
	   (xy (vatuple-append x y
                 "proof-in-avar-form"))
	   (tm-x (vatuple-to-tmtuple x))
	   (tm-y (vatuple-to-tmtuple y))
	   (T-lst
             (list
               (cons avar
                 (make-tmtuple-in-abst-form
                   xy tm-y))))
	   (T (make-tmtuple-in-abst-form x tm-x))
	   (rv (make-vatmpair
                 (make-vapair y x)
                 (make-tmpair T T-lst)))
 	   (LEGDUM
             (DIA-tyva-check KIND prf 
               (proof-to-formula prf) rv
               "proof-in-avar-form")))
       rv))
    ((proof-in-aconst-form)
     (let*((aconst (proof-in-aconst-form-to-aconst prf)) 
                (name (aconst-to-name aconst))
           (LEGDUM
             (if DEBUG
                 (nldisplay
                   "PROOF-IN-aconst-FORM:" name ))))
       (case (aconst-to-kind aconst)
	 ((axiom) 
	  (cond
            ((string=? "Ind" name)
	  ;;; (DIA-IndAx-extract KIND aconst) ;;; MDH -- 071117 uncomment this
                ;;; after having loaded the code from IndAxSrc.scm if you really want ...
	 (myerror "DIA-extr-vatmpair: " "we strongly discourage the treatement"
		  " of the Induction Axiom, since it should only be used as part"
		  " of the Induction Rule" "We therefore moved the specific code"
		  " into a separate procedure DIA-IndAx-extract in IndAxSrc.scm"
		  " This is meant to be used for a few experimental IndAx samples"
		  " where the induction formula has low logical complexity,"
		  "basically quantifier-free and purely-existential" 
		  "This message is normally a sign of error in the proof at input."
		  "Otherwise, if you really want, you can re-include the code"
		  "as indicated at the right place in extraction module newfiets.scm"))
            ((string=? "Cases" name)
             (myerror
             "DIA-extr-vatmpair: "
             "Cases not implemented"))
            ((string=? "Ex-Intro" name)
             (let*((ex-fmla
                     (aconst-to-repro-formula1
                       aconst))
                   (LEGDUM
                     (if DEBUG
                         (nldisplay
                           "PROOF-IN-Ex-Intro-FORM"
                           (formula-to-string
                             ex-fmla))))
                   (z (var-to-vatuple
                        (ex-form-to-var ex-fmla)))
                   (kernel
                     (ex-form-to-kernel ex-fmla))
                   (typr
                     (DIA-formula-to-typair KIND kernel))
                   (x (tytuple-to-vatuple
                        (typair-left typr))) 
                   (y (tytuple-to-vatuple
                        (typair-right typr)))
                   (zx (vatuple-append z x
                         "Ex-Intro 1")) 
                   (zxy (vatuple-append zx y
                          "Ex-Intro 2"))
                   (tm-Y
                     (make-tmtuple-in-abst-form zxy
                       (vatuple-to-tmtuple y)))
                   (tm-ZU
                     (make-tmtuple-in-abst-form 
                       zx (vatuple-to-tmtuple
                            (tuple-append z x))))
                   (tm-YZU
                     (tmtuple-append tm-Y tm-ZU
                       "Ex-Intro"))
                   (rv (make-vatmpair
                         (make-vapair zxy
                           NULL_vatup) 
                         (make-tmpair tm-YZU
                           NULL_tmtupalst)))
                     (LEGDUM
                       (if DEBUG
                           (nldisplay      
                             rv "FINISHED Ex-Intro"))))
               rv))
            ((string=? "Ex-Elim" name) 
             (let*((ex-fmla
                     (aconst-to-repro-formula1
                       aconst))
                   (concl
                     (aconst-to-repro-formula2
                       aconst))
                   (LEGDUM
                     (if DEBUG
                         (nldisplay
                           "PROOF-IN-Ex-Elim-FORM"
                           "ex-form = "
                           (formula-to-string
                             ex-fmla)
                           "concl"
                           (formula-to-string
                             concl))))
                   (z (var-to-vatuple
                        (ex-form-to-var ex-fmla)))
                   (kernel
                     (ex-form-to-kernel ex-fmla))
                   (kernel-typr
                     (DIA-formula-to-typair KIND kernel))
                   (x (tytuple-to-vatuple
                        (typair-left kernel-typr))) 
                   (yp (tytuple-to-vatuple
                         (typair-right kernel-typr)))
                   (concl-typr
                     (DIA-formula-to-typair KIND concl))
                   (up (tytuple-to-vatuple
                         (typair-left concl-typr)))
                   (v (tytuple-to-vatuple
                        (typair-right concl-typr)))
                   (zx (vatuple-append z x
                         "Ex-Elim 1")) 
                   (zxv (vatuple-append zx v
                          "Ex-Elim 2"))
                   (typ_y
                     (make-tytuple-arrow
                       (vatuple-to-tytuple zxv) 
                       (vatuple-to-tytuple yp)))
                   (y
                     (tytuple-to-vatuple typ_y))
                   (typ_u
                     (make-tytuple-arrow
                       (vatuple-to-tytuple zx) 
                       (vatuple-to-tytuple up)))
                   (u (tytuple-to-vatuple typ_u))  
                   (zxy (vatuple-append zx y
                          "Ex-Elim 3"))
                   (zxyu
                     (vatuple-append zxy u
                       "Ex-Elim 4"))   
                   (zxyuv
                     (vatuple-append zxyu v
                       "Ex-Elim 5"))
                   (tm-yp
                     (make-tmtuple-in-app-form
                       (vatuple-to-tmtuple y)
                       (vatuple-to-tmtuple zxv)))
                   (tm-ypz
                     (tmtuple-append
                       tm-yp (vatuple-to-tmtuple z)
                       "Ex-Elim 1"))
                   (tm-xv
                     (tmtuple-append
                       (vatuple-to-tmtuple x)
                       (vatuple-to-tmtuple v)
                       "Ex-Elim 2"))
                   (tm-YZXV
                     (make-tmtuple-in-abst-form zxyuv
                       (tmtuple-append tm-ypz tm-xv
                         "Ex-Elim 3")))
                   (tm-U
                     (make-tmtuple-in-abst-form zxyu
                       (make-tmtuple-in-app-form
                         (vatuple-to-tmtuple u)
                         (vatuple-to-tmtuple zx))))
                   (tm-YZXVU
                     (tmtuple-append tm-YZXV tm-U
                       "Ex-Elim 4"))
                   (rv (make-vatmpair
                         (make-vapair
                           zxyuv NULL_vatup) 
                         (make-tmpair
                           tm-YZXVU NULL_tmtupalst)))
                   (LEGDUM
                     (if DEBUG
                         (nldisplay "FINISHED Ex-Elim"))))
               rv))
            ((string=? "Exnc-Elim" name)
             (myerror
               "DIA-extr-vatmpair: "
               "Exnc-Elim not implemented"))
            ((string=? "Exnc-Intro" name)
             (myerror
               "DIA-extr-vatmpair: "
               "Exnc-Intro not implemented"))
            ((or (string=? "Intro" name)
                 (string=? "Elim" name))
             (myerror
               "DIA-extr-vatmpair: "
               "Inductive Definitions not implemented"))
            ((string=? "Eq-Compat" name)
             (let*((LEGDUM
                     (if DEBUG
                         (nldisplay
                           "PROOF-IN-Eq-Compat-FORM")))
                   (fmla
                     (aconst-to-inst-formula aconst))
                   (kernel
                     (imp-form-to-conclusion
                       (imp-form-to-conclusion fmla)))
                   (typr (DIA-formula-to-typair KIND kernel))
                   (u (tytuple-to-vatuple
                        (typair-left typr)))
                   (v (tytuple-to-vatuple
                        (typair-right typr)))
                   (uv (vatuple-append u v "Eq-Compat"))
                   (Tv (make-tmtuple-in-abst-form uv
                         (vatuple-to-tmtuple v)))
                   (Tu (make-tmtuple-in-abst-form u
                         (vatuple-to-tmtuple u)))
                   (Tvu (tmtuple-append Tv Tu "Eq-Compat"))
                   (rv (make-vatmpair
                         (make-vapair uv NULL_vatup) 
                         (make-tmpair Tvu NULL_tmtupalst)))
                   (LEGDUM
                     (if DEBUG
                         (nldisplay "FINISHED Eq-Compat"))))
               rv))
            ((string=? "Truth-Axiom" name)
             (begin (if DEBUG (nldisplay "TRUTH-AXIOM"))
                    (make-vatmpair
                      (make-vapair
                        NULL_vatup  NULL_vatup) 
                      (make-tmpair
                        NULL_tmtup NULL_tmtupalst))))
            (else (myerror
                    "DIA-extr-vatmpair-aux : "
                    "axiom expected" name))))
       ((theorem)
           (let*((LEGDUM (if EXTRACT-VERBOSE (DIA-comment-forced
                           "BEGINS treatment of THEOREM "
			   (aconst-to-string aconst))))
                      (rv (DIA-extr-vatmpair KIND 
			(theorem-aconst-to-inst-proof aconst)))
                    (LEGDUM (if EXTRACT-VERBOSE (DIA-comment-forced
		  "ENDED treatment of THEOREM "
		  (aconst-to-string aconst)))))
                  rv))
         ((global-assumption) 
          (cond
            ((string=? "Stab-Log" name)
             (myerror
               "DIA-extr-vatmpair: "
               "Stab and Stab-Log not allowed here;"
               "you must eliminate them either via reduce-stab,"
               "if the kernel contains no strong Exists or otherwise"
               "you must use a Negative Translation"
               "from classical to intuitionistic proofs"))
            ((string=? "Stab" name)
             (myerror
               "DIA-extr-vatmpair: "
               "Stab and Stab-Log not allowed here;"
               "you must eliminate them either via reduce-stab,"
               "if the kernel contains no strong Exists or otherwise"
               "you must use a Negative Translation"
               "from classical to intuitionistic proofs"))
            ((string=? "Efq-Log" name)
             (let*((LEGDUM
                     (if DEBUG
                         (nldisplay
                           "PROOF-IN-Efq-Log-FORM")))
                   (fmla
                     (aconst-to-inst-formula aconst))
		   (typr
                     (DIA-formula-to-typair KIND fmla))
		   (Tx
                     (tytuple-to-ZERO
                       (typair-left typr)))
		   (y
                     (tytuple-to-vatuple
                       (typair-right typr)))
		   (rv
                     (make-vatmpair
                       (make-vapair y NULL_vatup) 
                       (make-tmpair Tx NULL_tmtupalst)))
		   (LEGDUM
                     (if DEBUG
                         (nldisplay "FINISHED Efq-Log"))))
               rv))
            ((string=? "Efq" name)
	    (let*((LEGDUM
                    (if DEBUG
                        (nldisplay "PROOF-IN-Efq-FORM")))
                  (fmla
                    (aconst-to-inst-formula aconst))
		   (typr
                     (DIA-formula-to-typair KIND fmla))  
                  (Tx
                    (tytuple-to-ZERO
                        (typair-left typr)))
                  (y
                    (tytuple-to-vatuple
                      (typair-right typr)))
                  (rv
                    (make-vatmpair
                        (make-vapair y NULL_vatup)
                        (make-tmpair Tx NULL_tmtupalst)))
                  (LEGDUM
                    (if DEBUG
                        (nldisplay "FINISHED Efq"))))
	      rv))
            ((or
               (and (<= (string-length
                          "Eq-Compat-Rev")
                      (string-length name))
                    (string=?
                      (substring name 0
                        (string-length
                          "Eq-Compat-Rev"))
                      "Eq-Compat-Rev"))
               (and (<= (string-length
                          "Compat-Rev")
                      (string-length name))
                    (string=?
                      (substring name 0
                        (string-length
                          "Compat-Rev"))
                      "Compat-Rev")))
             (let*((LEGDUM
                     (if DEBUG
                         (nldisplay
                           "PROOF-IN-(Eq-)Compat-Rev-FORM")))
                   (fmla
                     (aconst-to-inst-formula aconst))
                   (kernel
                     (imp-form-to-conclusion
                       (imp-form-to-conclusion fmla)))
                   (typr
                     (DIA-formula-to-typair KIND kernel))
                   (u
                     (tytuple-to-vatuple
                       (typair-left typr)))
                   (v
                     (tytuple-to-vatuple
                       (typair-right typr)))
                   (uv
                     (vatuple-append u v
                       "(Eq-)Compat-Rev"))
                   (Tv
                     (make-tmtuple-in-abst-form uv
                       (vatuple-to-tmtuple v)))
                   (Tu
                     (make-tmtuple-in-abst-form u
                       (vatuple-to-tmtuple u)))
                   (Tvu
                     (tmtuple-append Tv Tu
                       "(Eq-)Compat-Rev"))
                   (rv
                     (make-vatmpair
                       (make-vapair uv
                         NULL_vatup)
                       (make-tmpair Tvu
                         NULL_tmtupalst)))
                   (LEGDUM
                     (if DEBUG
                         (nldisplay
                           "FINISHED (Eq-)Compat-Rev"))))
               rv))
            (else
              (let*((rv (DIA-uga-to-vatmpair KIND aconst))
;                     (LEGDUM
;                       (DIA-tyva-check KIND prf (proof-to-formula prf)
;                         rv "UserGlobalAssumption"))
                    )
                rv))))
	 (else
           (myerror
             "DIA-extr-vatmpair: "
             "unknown kind of aconst"
             (aconst-to-kind aconst))))))
    ((proof-in-imp-intro-form)
     (let*((avar (proof-in-imp-intro-form-to-avar prf))
           (LEGDUM
             (if DEBUG
                 (nldisplay
                   "PROOF-IN-IMP_INTRO-FORM of avar"
                   (avar-to-string avar))))
            (data (avar-to-Data avar))
             (av-occur (car data))
             (LEGDUM (if DEBUG (nldisplay  "Imp-Intro: the avar "
                   (avar-to-string avar) "occurs " av-occur " times.")))
             (kernel (proof-in-imp-intro-form-to-kernel prf))
              (vatmpr (DIA-extr-vatmpair-aux KIND kernel avar-to-Data))
	(LEGDUM  (if DEBUG (nldisplay
			       "Imp-Intro: OK, kernel processed.")))
              (ke-vapr (vatmpair-to-vapair vatmpr))
	(y (vapair-left ke-vapr))
	(xpx (vapair-right ke-vapr)) 
	(ke-tmpr (vatmpair-to-tmpair vatmpr))
	(T (tmpair-to-tuple ke-tmpr))
	(ke-alst (tmpair-to-alist ke-tmpr)))
       (case av-occur
         ((0)
            (if EXTRACT-VERBOSE (DIA-comment-forced
              "Imp-Intro with DUMMY assumption "
              (avar-to-string avar) " detected."))
            (if DEBUG  (DIA-comment "INTRO formula is" 
	  'CNL (formula-to-string (nf (avar-to-formula avar))) 
                'CNL "and CONCLUSION formula is" 'CNL
              (formula-to-string (nf (proof-to-formula kernel)))))
            (let*((typr
                    (DIA-formula-to-typair KIND
                      (avar-to-formula avar)))
                  (ex-tytup (typair-left typr))
                  (all-tytup (typair-right typr))
                  (z (tytuple-to-vatuple ex-tytup))
                  (zero-tmtup
                    (tytuple-to-ZERO all-tytup))
                  (tmtup-xpx
                    (vatuple-to-tmtuple xpx))
                  (xz
                    (vatuple-append xpx z
                      "Imp-Intro dummy assum 1"))
                  (xzy
                    (vatuple-append xz y
                      "Imp-Intro dummy assum 2"))
                  (zy
                    (vatuple-append z y
                      "Imp-Intro dummy assum 3"))                
                  (St
                    (make-tmtuple-in-abst-form xzy
                      zero-tmtup))
                  (Ss
                    (make-tmtuple-in-abst-form xz
                      (make-tmtuple-in-app-form  T
                        tmtup-xpx)))
                  (S
                    (tmtuple-append St Ss
                      "Imp-Intro dummy assum 4"))
                  (uS
                    (make-tmtuplealist-in-abst-form xz
                      (make-tmtuplealist-in-app-form 
                        ke-alst tmtup-xpx)))
                  (rv (make-vatmpair
                        (make-vapair zy xpx)
                        (make-tmpair S uS)))
                  (LEGDUM
                    (DIA-tyva-check KIND prf
                      (proof-to-formula prf) rv
                      "proof-in-imp-intro-form")))
              rv))
         (else
           (let*((av-vapr (cadr data))
                 (z (vapair-left av-vapr))
                 (vatup-tmtupalst-tmtuplst 
                   (Imp-Intro-split avar ke-alst
                     avar-to-Data))
                 (x (caar
                      vatup-tmtupalst-tmtuplst)) 
                 (new-alst
                   (cdar
                     vatup-tmtupalst-tmtuplst))
                 (tmtuplst
                   (cdr vatup-tmtupalst-tmtuplst))
                 (LEGDUM
                   (if CHECK
                       (let((l1 (length tmtuplst))
                            (l2 (length new-alst))
                            (l3 (length ke-alst))
                            (l4 (vatuple-len xpx))
                            (l5 (vatuple-len x))
                            (l6 (vatuple-len z)))
                         (begin
                           (if (not (= l1 av-occur))
                               (myerror
                                 "DIA-extr-vatmpair: "
                                 "internal error 1 at" 
                                 "imp-intro of assumption "
                                 (avar-to-string avar)
                                 ": l1 is != av-occur "
                                 "l1=" l1 "av-occur=" av-occur
                                 ".\n Assumption formula is: "
                                 (formula-to-string
                                   (avar-to-formula avar))
                                 ".\n Kernel formula is: "
                                 (formula-to-string
                                   (proof-to-formula
                                     kernel))))
                           (if (not (= l3 (+ l1 l2)))
                               (myerror
                                 "DIA-extr-vatmpair: "
                                 "internal error 2 at" 
                                 "imp-intro of assumption "
                                 (avar-to-string avar)
                                 ": l3 is != (+ l1 l2) "
                                 ".\n Assumption formula is: "
                                 (formula-to-string
                                   (avar-to-formula avar))
                                 ".\n Kernel formula is: "
                                 (formula-to-string
                                   (proof-to-formula
                                     kernel))))
                           (if (not (= l4 (+ l5 (* l1 l6))))
                               (myerror
                                 "DIA-extr-vatmpair: "
                                 "internal error 3 at" 
                                 "imp-intro of assumption "
                                 (avar-to-string avar)
                                 ": l4 is != (+ l5 (* l1 l6)) "
                                 ".\n Assumption formula is: "
                                 (formula-to-string
                                   (avar-to-formula avar))
                                 ".\n Kernel formula is: "
                                 (formula-to-string
                                   (proof-to-formula
                                     kernel))))))))                     
                 (xz
                   (vatuple-append x z
                     "proof-in-imp-intro-form 1"))
                 (zy
                   (vatuple-append z y
                     "proof-in-imp-intro-form 2"))
                 (xzy
                   (vatuple-append x zy
                     "proof-in-imp-intro-form 3"))
                 (xpxy
                   (vatuple-to-tmtuple
                     (vatuple-append xpx y
                       "proof-in-imp-intro-form 4")))           
                 (tmtup
                   (if (null? (cdr tmtuplst))
                       (begin
                         (if CONTR-VERBOSE (DIA-comment-forced
                               "Imp-Intro WITHOUT Contraction"
                               (avar-to-string avar) " detected."))
	           (if DEBUG (DIA-comment "Intro formula is" 'CNL
                               (formula-to-string (nf (avar-to-formula avar))) 
                               'CNL "and conclusion formula is" 'CNL
                               (formula-to-string (nf (proof-to-formula kernel)))))
                         (make-tmtuple-in-app-form
                           (car tmtuplst) xpxy))
                       (begin
		   (if (NULL-tmtuple? (car tmtuplst))
		       (begin
			 (set! CIRC-COUNT (+ CIRC-COUNT 1))
			 (if CONTR-VERBOSE (DIA-comment-forced
			         "Imp-Intro WITH Logical Contraction"
			         (avar-to-string avar) " detected."))
			 (if DEBUG (DIA-comment "Intro formula is" 
			          'CNL (formula-to-string (nf (avar-to-formula avar))) 
			          'CNL "which occurs " av-occur " times. "			  
			          "Conclusion formula is" 'CNL
			           (formula-to-string (nf (proof-to-formula kernel)))))
		       (make-tmtuple-in-app-form (car tmtuplst) xpxy))
		       (begin 
			 (set! CRLC-COUNT (+ CRLC-COUNT 1))
			 (if CONTR-VERBOSE (DIA-comment-forced
			       "Imp-Intro WITH Computational Contraction"
			       (avar-to-string avar) " detected."))
			  (if DEBUG (DIA-comment "Intro formula is" 'CNL
			       (formula-to-string (nf (avar-to-formula avar))) 
			       'CNL "which occurs " av-occur " times. "			  
			       "Conclusion formula is" 'CNL
			       (formula-to-string (nf (proof-to-formula kernel)))))
			 (case KIND
			    ((light pure)
			     (if CONTR-VERBOSE (DIA-comment-forced 
				"Application of Imp-Intro-CondN ... " 'CNL 
				"The associated B-term is" (term-to-string (nt (caddr data)))))
			     (Imp-Intro-CondN 
			      (make-tmtuplist-in-app-form
			       tmtuplst xpxy)
			      (vapair-right av-vapr)
			      (caddr data)))
			   ((monot)
			        (if CONTR-VERBOSE (DIA-comment-forced 
				  "Application of Imp-Intro-MonN ... " 'CNL 
				  "The associated B-term is" (term-to-string (nt (caddr data)))))
			     (Imp-Intro-MonN 
			       (make-tmtuplist-in-app-form tmtuplst xpxy)))
			   (else (myerror "DIA-extr-vatmpair-aux: Relevant Contraction:"
					   "unknown KIND " KIND))))))))
                 (St (make-tmtuple-in-abst-form
                       xzy tmtup))
                 (Ss (make-tmtuple-in-abst-form xz
                       (make-tmtuple-in-app-form  T
                         (vatuple-to-tmtuple xpx))))
                 (S (tmtuple-append St Ss
                      "proof-in-imp-intro-form"))
                 (uS (make-tmtuplealist-in-abst-form 
                       xzy
                       (make-tmtuplealist-in-app-form 
                         new-alst xpxy)))
                 (rv (make-vatmpair
                       (make-vapair zy x)
                       (make-tmpair S uS)))
                 (LEGDUM
                   (DIA-tyva-check KIND prf
                     (proof-to-formula prf) rv
                     "proof-in-imp-intro-form")))
             (nbe-normalize-vatmpair-of
               IMP-INTRO-NORMALIZE rv))))))
    ((proof-in-imp-elim-form)
     (let((all-elim-tm (DIA-Ind-Rule? prf)))
     (if all-elim-tm
         (let*((LEGDUM
                 (if (or DEBUG DEBUG-IND-RL)
                     (nldisplay
                       "PROOF-IN-IndRule-??? Begin")))
               (step-prf
                 (proof-in-imp-elim-form-to-arg
                   prf))
               (step-avars
                 (proof-to-free-avars step-prf))
               (LEGDUM
                 (if DEBUG-IND-RL
                     (nldisplay
                       "Ind-Rule: Step has"
                       (length step-avars)
                       "assumptions" SNL
                       (DIA-avars-to-string
                         step-avars))))
               (base-prf
                 (proof-in-imp-elim-form-to-arg
                   (proof-in-imp-elim-form-to-op prf)))
               (base-avars
                 (proof-to-free-avars base-prf))               
               (LEGDUM
                 (if DEBUG-IND-RL
                     (nldisplay
                       "Ind-Rule: Base has"
                       (length base-avars)
                       "assumptions" SNL
                       (DIA-avars-to-string
                         base-avars)))))
           (if (and (null? base-avars)
                    (null? step-avars))
               (let*((LEGDUM
		(begin
		      (set! IndRlZeCOUNTER (+ IndRlZeCOUNTER 1))
		 (if (or DEBUG EXTRACT-VERBOSE) 
		          (nldisplay "PROOF-IN-IndRule-Zero-FORM" 
				             IndRlZeCOUNTER  "BEGIN"))))
	    (LocalIndRlZeCOUNTER IndRlZeCOUNTER)	     
	    (step-vatmpr (DIA-extr-vatmpair KIND step-prf))
	      (LEGDUM  (if (or DEBUG EXTRACT-VERBOSE) 
	           (nldisplay "PROOF-IN-IndRule-Zero-FORM" 
			    LocalIndRlZeCOUNTER  "Step Mined")))
                     (step-tmpr (vatmpair-to-tmpair step-vatmpr))
                     (step-alist (tmpair-to-alist step-tmpr))
                     (LEGDUM
                       (if (not-null? step-alist)
                           (myerror  "Ind-Rule IR0: Step has"
                             (length step-alist) "assumptions")))
                     (step-tmtup
                       (tmtuple-right
                         (tmpair-to-tuple step-tmpr)))
                     (base-vatmpr
                       (DIA-extr-vatmpair KIND 
                         base-prf))
	      (LEGDUM  (if (or DEBUG EXTRACT-VERBOSE) 
		 (nldisplay "PROOF-IN-IndRule-Zero-FORM" 
			    LocalIndRlZeCOUNTER  "Base Mined"))) 
                     (base-vapr
                       (vatmpair-to-vapair base-vatmpr))
                     (y (vapair-left base-vapr))
                     (base-tmpr
                       (vatmpair-to-tmpair base-vatmpr))
                     (base-alist
                       (tmpair-to-alist base-tmpr))
                     (LEGDUM
                       (if (not-null? base-alist)
                           (myerror  "Ind-Rule IR0: Base has"
                             (length base-alist) "assumptions")))
                     (base-tmtup
                       (tmpair-to-tuple base-tmpr))
                     (star-tytup
                       (tmtuple-to-tytuple base-tmtup))
                     (base-tm
                       (DIA-tmtuple-to-star base-tmtup))
                     (star_typ
                       (term-to-type base-tm))
                     (fld-ys (type-to-new-var star_typ))
                     (tm-fld-ys
                       (make-term-in-var-form fld-ys)) 
                     (unfld-ys
                       (DIA-star-to-tmtuple
                         tm-fld-ys star-tytup))
                     (typ_z (py "nat"))
                     (va-z (type-to-new-var typ_z))
                     (tm-z (make-term-in-var-form va-z))
                     (z (var-to-vatuple va-z))
                     (tmtup-z (vatuple-to-tmtuple z))
                     (tmtup-zys
                       (tmtuple-append
                         tmtup-z unfld-ys "Ind-Rule"))
                     (tmtup-step
                       (make-tmtuple-in-app-form
                         step-tmtup tmtup-zys))
                     (tm-step
                       (make-term-in-abst-form va-z
                         (make-term-in-abst-form fld-ys
                           (DIA-tmtuple-to-star tmtup-step))))           
                     (Rec (case KIND
		       ((light pure)   
			(DIA-type-to-rec-term typ_z star_typ))
		       ((monot)
			(type-to-mon-rec-tm typ_z star_typ))
		       (else (myerror "DIA-extr-vatmpair: "  
				      "Ind - Rec ZERO:" "unknown KIND" KIND))))
                     (tm-T
                       (make-term-in-app-form
                         (make-term-in-app-form Rec base-tm)
                         tm-step))
                     (tmtup-T
                       (DIA-star-to-tmtuple
                         (make-term-in-app-form tm-T tm-z)
                         star-tytup))
                     (real-T
	          (make-tmtuple-in-app-form 
		   (make-tmtuple-in-abst-form
		    z tmtup-T) (term-to-tmtuple all-elim-tm)))
                     ;;; (zy (vatuple-append z y "Ind-Rule"))
                     (rv (make-vatmpair
                           (make-vapair y NULL_vatup) 
                           (make-tmpair real-T
                             NULL_tmtupalst)))
	      (LEGDUM (nldisplay "PROOF-IN-IndRule-Zero-FORM" 
			    LocalIndRlZeCOUNTER "END"))
                     (LEGDUM
                       (DIA-tyva-check KIND prf 
                         (proof-to-formula prf)
                         rv "Ind-Rule IR0")))
                 rv) 
               (let*((LEGDUM
		(begin
		      (set! IndRuleCOUNTER (+ IndRuleCOUNTER 1))
		      (if (or DEBUG EXTRACT-VERBOSE) 
			  (nldisplay "PROOF-IN-IndRule-FORM" 
				     IndRuleCOUNTER  "BEGIN"))))
	      (LocalIndRuleCOUNTER IndRuleCOUNTER)	     
	      (step-fmla (proof-to-formula step-prf))
                     (step-var (all-form-to-var step-fmla))
                     (step-ker (all-form-to-kernel step-fmla))
                     (Az (imp-form-to-premise step-ker))
                     (LEGDUM (if DEBUG-IND-RL
                           (nldisplay  "Ind-Rule IR: KERNEL"
                             "formula is:" SNL(formula-to-string Az))))
                     (CimpAz-fmla
                       (DIA-IR-mk-imp-formula
                         base-avars
                         (DIA-IR-mk-imp-formula
                           step-avars Az)))
                     (LEGDUM (if DEBUG-IND-RL  
		(DIA-comment-forced 
		    "Ind-Rule IR: CimpAz is"
		    (formula-to-string (nf CimpAz-fmla)))))
                     (CimpAz-avr
                       (formula-to-new-avar CimpAz-fmla))
                     (CimpAz-prf
                       (make-proof-in-avar-form CimpAz-avr))
                     (Az-prf
                       (DIA-IR-mk-elim-proof
                         (DIA-IR-mk-elim-proof
                           CimpAz-prf base-avars) step-avars))
                     (tm-step-var
                       (make-term-in-var-form step-var))               
                     (ASz-prf
                       (make-proof-in-imp-elim-form
                         (make-proof-in-all-elim-form
                           step-prf tm-step-var) Az-prf))
                     (CimpASz-prf
                       (DIA-IR-mk-intro-proof base-avars
                         (DIA-IR-mk-intro-proof step-avars
                           ASz-prf)))
                     (new-step-prf
                       (make-proof-in-all-intro-form
                         step-var
                         (make-proof-in-imp-intro-form
                           CimpAz-avr CimpASz-prf)))
                     (LEGDUM
	           (if (or DEBUG EXTRACT-VERBOSE)	      
	             (nldisplay "PROOF-IN-IndRule-FORM" 
		    LocalIndRuleCOUNTER  "new-step-prf BUILT")))
                     (step-vatmpr
                       (DIA-extr-vatmpair KIND 
                         new-step-prf))
                     (LEGDUM
	           (if (or DEBUG  EXTRACT-VERBOSE)	      
	             (nldisplay "PROOF-IN-IndRule-FORM" 
		     LocalIndRuleCOUNTER  "new-step-prf MINED")))
                     (step-tmpr
                       (vatmpair-to-tmpair step-vatmpr))
                     (step-alist
                       (tmpair-to-alist step-tmpr))
                     (LEGDUM
                       (if PARANOIA
                           (if (not-null? step-alist)
                                 (myerror
                                   "Ind-Rule IR: assumptions"
                                   "for new-step-prf"))))
                     (step-tmtup
                       (tmtuple-right
                         (tmpair-to-tuple step-tmpr)))
                     (new-base-prf
                       (DIA-IR-mk-intro-proof base-avars
                         (DIA-IR-mk-intro-proof step-avars
                         base-prf)))
                     (LEGDUM
	           (if (or DEBUG  EXTRACT-VERBOSE)	      
	             (nldisplay "PROOF-IN-IndRule-FORM" 
		    LocalIndRuleCOUNTER "new-base-prf BUILT")))
                      (base-vatmpr
                       (DIA-extr-vatmpair KIND 
                         new-base-prf))
                     (LEGDUM
	           (if (or DEBUG  EXTRACT-VERBOSE)	      
	             (nldisplay "PROOF-IN-IndRule-FORM" 
		    LocalIndRuleCOUNTER "new-base-prf MINED")))
                     (base-vapr
                       (vatmpair-to-vapair base-vatmpr))
                     (y (vapair-left base-vapr))
                     (base-tmpr
                       (vatmpair-to-tmpair base-vatmpr))
                     (base-alist
                       (tmpair-to-alist base-tmpr))
                     (LEGDUM
                       (if PARANOIA
                           (if (not-null? base-alist)
                               (myerror
                                 "Ind-Rule IR: Assumptions"
                                 "for new-base-prf"))))
                     (base-tmtup
                       (tmpair-to-tuple base-tmpr))
                     (star-tytup
                       (tmtuple-to-tytuple base-tmtup))
                     (base-tm
                       (DIA-tmtuple-to-star base-tmtup))
                     (star_typ
                       (term-to-type base-tm))
                     (fld-ys (type-to-new-var star_typ))
                     (tm-fld-ys
                       (make-term-in-var-form fld-ys)) 
                     (unfld-ys
                       (DIA-star-to-tmtuple
                         tm-fld-ys star-tytup))
                     (typ_z (py "nat"))
                     (va-z (type-to-new-var typ_z))
                     (tm-z (make-term-in-var-form va-z))
                     (z (var-to-vatuple va-z))
                     (tmtup-z (vatuple-to-tmtuple z))
                     (tmtup-zys
                       (tmtuple-append
                         tmtup-z unfld-ys "Ind-Rule"))
                     (tmtup-step
                       (make-tmtuple-in-app-form
                         step-tmtup tmtup-zys))
                     (tm-step
                       (make-term-in-abst-form va-z
                         (make-term-in-abst-form fld-ys
                           (DIA-tmtuple-to-star tmtup-step))))          
                     (Rec (case KIND
		       ((light pure)   
		          (DIA-type-to-rec-term typ_z star_typ))
		       ((monot)
			(type-to-mon-rec-tm typ_z star_typ))
		       (else (myerror "DIA-extr-vatmpair: "  
			   "Ind - Rec:" "unknown KIND" KIND))))
                     (tm-T
                       (make-term-in-app-form
                         (make-term-in-app-form Rec base-tm)
                         tm-step))
                     (tmtup-T
                       (DIA-star-to-tmtuple
                         (make-term-in-app-form tm-T tm-z)
                         star-tytup))
                     (real-T
	          (make-tmtuple-in-app-form 
		   (make-tmtuple-in-abst-form
		    z tmtup-T) (term-to-tmtuple all-elim-tm)))
                     ;;; (zy (vatuple-append z y "Ind-Rule"))
                     (rv (make-vatmpair
                           (make-vapair y NULL_vatup) 
                           (make-tmpair real-T
                             NULL_tmtupalst)))
                     (IR-fmla (DIA-IR-mk-imp-formula base-avars
		     (DIA-IR-mk-imp-formula step-avars 
			(proof-to-formula prf))))
                     (IR-acnst
                       (make-aconst "Ind-Rule" 'global-assumption
                         IR-fmla empty-subst))
                     (LEGDUM
                       (set! DIA-UGA-ALIST
                         (cons (cons IR-acnst rv)
                           DIA-UGA-ALIST)))
                     (IR-acnst-prf
                       (list 'proof-in-aconst-form
                          IR-fmla IR-acnst))
                     (IR-prf IR-acnst-prf)
                     (fin-prf
                         (DIA-IR-mk-elim-proof
                           (DIA-IR-mk-elim-proof IR-prf
                             base-avars) step-avars))
                    (LEGDUM
	            (if (or DEBUG  EXTRACT-VERBOSE)
		       (nldisplay "PROOF-IN-IndRule-FORM" 
			     LocalIndRuleCOUNTER "fin-prf BUILT")))
                     (fin-rv
                       (DIA-extr-vatmpair-aux KIND fin-prf avar-to-Data))
                     (LEGDUM
	            (if (or DEBUG  EXTRACT-VERBOSE)
	             (nldisplay "PROOF-IN-IndRule-FORM" 
		    LocalIndRuleCOUNTER "fin-prf MINED")))
                     (LEGDUM
                       (DIA-tyva-check KIND prf 
                         (proof-to-formula prf)
                         fin-rv "Ind-Rule IR"))
                     (LEGDUM
                       (set! DIA-UGA-ALIST
                         (cdr DIA-UGA-ALIST))))
                 (nbe-normalize-vatmpair-of
                   IND-RL-NORMALIZE fin-rv))))
	 (let*((LEGDUM
		 (if DEBUG
		     (nldisplay
		       "PROOF-IN-IMP_ELIM-FORM")))
	       (op
		 (proof-in-imp-elim-form-to-op prf))
	       (op-vatmpr
		 (DIA-extr-vatmpair-aux KIND 
		   op  avar-to-Data))
	       (AimpB
		 (proof-to-formula op))
	       (LEGDUM
		 (if PARANOIA
		     (if (not (imp-form? AimpB))
			 (myerror
			   "PROOF-IN-imp-elim-FORM: "
			   "formula in imp form expected"
			   (formula-to-string AimpB)))))
	       (LEGDUM (if DEBUG (begin
		     (nldisplay
		       "PROOF-IN-imp-elim-FORM:"
		       "A -> B was processed OK")
		     (DIA-comment "Formula was" 'CNL
		       (formula-to-string AimpB)))))
	       (A (imp-form-to-premise AimpB))
	       (B (imp-form-to-conclusion AimpB))
	       (extra-free-vars-ini 
		(set-minus (formula-to-free A) 
			   (formula-to-free B)))
	       (op-vapr
		 (vatmpair-to-vapair op-vatmpr))
	       (op-tmpair
		 (vatmpair-to-tmpair op-vatmpr))
	      (op-tmtupalst
		 (tmpair-to-alist op-tmpair))
	      (extra-free-vars-bis
	       (DIA-set-minus extra-free-vars-ini op-tmtupalst))
	       (arg (proof-in-imp-elim-form-to-arg prf))
	       (old-arg-vatmpr
		 (DIA-extr-vatmpair-aux KIND 
		                               arg  avar-to-Data))
	       (arg-vatmpr 
		(nbe-normalize-vatmpair-of 
		          IMP-ARG-NORMALIZE  old-arg-vatmpr))
	       (prem (imp-form-to-premise AimpB))
	       (LEGDUM (if DEBUG (begin
		     (nldisplay
		       "PROOF-IN-imp-elim-FORM:"
		       "Premise was processed OK")
		     (DIA-comment "Formula was"
		         'CNL (formula-to-string prem)))))
	       (arg-vapr
		 (vatmpair-to-vapair arg-vatmpr))
	       (arg-tmpair
		 (vatmpair-to-tmpair arg-vatmpr))
	       (arg-tmtupalst
		 (tmpair-to-alist arg-tmpair))
	      (extra-free-vars
	                (DIA-set-minus extra-free-vars-bis arg-tmtupalst))
	      (xp (vapair-right arg-vapr)) 
	       (xs (vapair-right op-vapr)) 
	       (x (vatuple-append xp xs
		    "proof-in-imp-elim-form 1"))
	       (ysy (vapair-left op-vapr))  
	       (yp (vapair-left arg-vapr))
	       (conc-free
		 (formula-to-free
		   (proof-to-formula prf)))
	       (subst (DIA-make-ZERO-alist extra-free-vars))
	       (Tp (DIA-tmtuple-non-simult-subst
		 (tmpair-to-tuple arg-tmpair) subst))
	       (TsT (DIA-tmtuple-non-simult-subst
		 (tmpair-to-tuple op-tmpair) subst))
	       (xsTpxp
		 (tmtuple-append
		   (vatuple-to-tmtuple xs)
		   (make-tmtuple-in-app-form Tp
		     (vatuple-to-tmtuple xp))
		   "proof-in-imp-elim-form 1"))
	       (ys (vatuple-left ysy)) 
	       (y (vatuple-right ysy)) 
	       (xy (vatuple-append x y
		   "proof-in-imp-elim-form 2"))
	       (Ts (tmtuple-left TsT))
	       (T (tmtuple-right TsT)) 
	       (xsTpxpy
		 (tmtuple-append xsTpxp
		   (vatuple-to-tmtuple y)
		   "proof-in-imp-elim-form 2"))
	       (xpTsxsTpxpy
		 (tmtuple-append
		   (vatuple-to-tmtuple xp) 
		   (make-tmtuple-in-app-form
		     Ts xsTpxpy)
		   "proof-in-imp-elim-form 3"))
	       (S (make-tmtuple-in-abst-form x
		    (make-tmtuple-in-app-form
		      T xsTpxp)))
	       (uSarg
		 (make-tmtuplealist-in-abst-form xy 
		   (make-tmtuplealist-in-app-form
		     (tmtuplealist-non-simult-subst
		       arg-tmtupalst subst)
		     xpTsxsTpxpy)))
	       (uSop
		 (make-tmtuplealist-in-abst-form x 
		   (make-tmtuplealist-in-app-form
		     (tmtuplealist-non-simult-subst
		       op-tmtupalst subst)
		     xsTpxp)))
	       (uS (append uSarg uSop))
	       (rv (make-vatmpair
		     (make-vapair y x)
		     (make-tmpair S uS)))
	       (LEGDUM
		 (DIA-tyva-check KIND prf 
		   (proof-to-formula prf)
		   rv "proof-in-imp-elim-form")))
	   (nbe-normalize-vatmpair-of
	     IMP-ELIM-NORMALIZE rv)))))
	((proof-in-and-intro-form)
	 (let*((LEGDUM
		 (if DEBUG
		     (nldisplay
		       "PROOF-IN-AND_INTRO-FORM")))
	       (left
		 (proof-in-and-intro-form-to-left
		   prf))
	       (right
		 (proof-in-and-intro-form-to-right
		   prf))
	       (left-vatmpr
		 (DIA-extr-vatmpair-aux KIND 
		   left  avar-to-Data))
	       (left-vapr
		 (vatmpair-to-vapair left-vatmpr)) 
	       (yp (vapair-left left-vapr))
	       (xp (vapair-right left-vapr))
	       (left-tmpair
		 (vatmpair-to-tmpair left-vatmpr))
	       (Tp (tmpair-to-tuple left-tmpair))
	       (uTp (tmpair-to-alist left-tmpair))
	       (right-vatmpr
		 (DIA-extr-vatmpair-aux KIND 
		   right  avar-to-Data))
	       (right-vapr
		 (vatmpair-to-vapair right-vatmpr))
	       (ys (vapair-left right-vapr))
	       (xs (vapair-right right-vapr))
	       (right-tmpair
		 (vatmpair-to-tmpair right-vatmpr))
	       (Ts (tmpair-to-tuple right-tmpair))
	       (uTs (tmpair-to-alist right-tmpair))
	       (x (vatuple-append xp xs
		    "proof-in-and-intro-form 1"))
	       (y (vatuple-append yp ys
		    "proof-in-and-intro-form 2"))
	       (xy (vatuple-append x y
		     "proof-in-and-intro-form 3"))
	       (xpyp (vatuple-append xp yp
		       "proof-in-and-intro-form 4"))
	       (xsys (vatuple-append xs ys
		       "proof-in-and-intro-form 5"))
	       (uSA
		 (make-tmtuplealist-in-app-form
		   uTp (vatuple-to-tmtuple xpyp)))
	       (uSB
		 (make-tmtuplealist-in-app-form
		   uTs (vatuple-to-tmtuple xsys)))
	       (uS
		 (make-tmtuplealist-in-abst-form
		   xy (append uSA uSB)))
	       (SA
		 (make-tmtuple-in-abst-form x 
		   (make-tmtuple-in-app-form Tp
		     (vatuple-to-tmtuple xp))))
	       (SB
		 (make-tmtuple-in-abst-form x 
		   (make-tmtuple-in-app-form Ts
		     (vatuple-to-tmtuple xs))))
	       (S
		 (tmtuple-append SA SB
		   "proof-in-and-intro-form"))
	       (rv (make-vatmpair
		     (make-vapair y x)
		     (make-tmpair S uS)))
	       (LEGDUM
		 (DIA-tyva-check KIND prf (proof-to-formula prf)
		   rv "proof-in-and-intro-form")))
	   rv))
	((proof-in-and-elim-left-form)
	     (let*((LEGDUM
		    (if DEBUG
			(nldisplay "PROOF-IN-AND_ELIM_LEFT-FORM")))
		   (kernel
		    (proof-in-and-elim-left-form-to-kernel prf))
		   (fmla (proof-to-formula kernel))
		   (A (and-form-to-left fmla))
		   (B (and-form-to-right fmla))
		   (extra-free-vars-ini 
		    (set-minus
		     (formula-to-free B)
		     (formula-to-free A)))
		   (vatmpr
		    (DIA-extr-vatmpair-aux KIND 
		     kernel avar-to-Data))
		   (tmpair (vatmpair-to-tmpair vatmpr))
		   (tmtupalst (tmpair-to-alist tmpair))
		   (extra-free-vars  
		    (DIA-set-minus extra-free-vars-ini tmtupalst))
		   (subst (DIA-make-ZERO-alist extra-free-vars))
		   (Tp (DIA-tmtuple-non-simult-subst
		     (tmtuple-left
		       (tmpair-to-tuple tmpair)) subst))
		   (new-tmtupalst 
		    (tmtuplealist-non-simult-subst
		     tmtupalst subst))
		   (vapr (vatmpair-to-vapair vatmpr))
		   (x (vapair-right vapr))
		   (vatp (vapair-left vapr))
		   (yp (vatuple-left vatp)) 
		   (xyp (vatuple-append x yp
			  "proof-in-and-elim-left-form"))
		   (xypZERO
		     (tmtuple-append
		       (vatuple-to-tmtuple xyp)
		       (vatuple-to-zero-tmtuple
			 (vatuple-right vatp))
		       "proof-in-and-elim-left-form"))
		   (uS (make-tmtuplealist-in-abst-form xyp
			 (make-tmtuplealist-in-app-form
			   new-tmtupalst xypZERO)))
		   (rv (make-vatmpair
			 (make-vapair yp x)
			 (make-tmpair Tp uS)))
		   (LEGDUM
		     (DIA-tyva-check KIND prf (proof-to-formula prf)
		       rv "proof-in-and-elim-left-form")))
	       (nbe-normalize-vatmpair-of AND-NORMALIZE rv)))
	((proof-in-and-elim-right-form)
	 (let*((LEGDUM
		(if DEBUG
		    (nldisplay "PROOF-IN-AND_ELIM_RIGHT-FORM")))
	       (kernel
		(proof-in-and-elim-right-form-to-kernel prf))
	       (fmla (proof-to-formula kernel))
	       (A (and-form-to-left fmla))
	       (B (and-form-to-right fmla))
	       (extra-free-vars-ini  
		  (set-minus
		       (formula-to-free A)
		       (formula-to-free B)))
	       (vatmpr
		(DIA-extr-vatmpair-aux KIND 
		 kernel  avar-to-Data))
	       (tmpair (vatmpair-to-tmpair vatmpr))
	       (tmtupalst (tmpair-to-alist tmpair))
	       (extra-free-vars  
		(DIA-set-minus extra-free-vars-ini tmtupalst))
	       (subst (DIA-make-ZERO-alist extra-free-vars))
	       (Ts (DIA-tmtuple-non-simult-subst
		    (tmtuple-right
		     (tmpair-to-tuple tmpair)) subst))
	       (new-tmtupalst
		(tmtuplealist-non-simult-subst
		 tmtupalst subst))
	       (vapr (vatmpair-to-vapair vatmpr))
	       (x (vapair-right vapr))
	       (vatp (vapair-left vapr))
	       (ys (vatuple-right vatp)) 
	       (xys (vatuple-append x ys
		       "proof-in-and-elim-right-form"))
	       (xZEROys
		 (tmtuple-append
		   (vatuple-to-tmtuple x) 
		   (tmtuple-append
		     (vatuple-to-zero-tmtuple
		       (vatuple-left vatp))
		     (vatuple-to-tmtuple ys)
		     "proof-in-and-elim-right-form 1")
		   "proof-in-and-elim-right-form 2"))
	       (uS
		 (make-tmtuplealist-in-abst-form xys
		   (make-tmtuplealist-in-app-form
		     tmtupalst xZEROys)))
	       (rv (make-vatmpair
		     (make-vapair ys x)
		     (make-tmpair Ts uS)))
	       (LEGDUM
		 (DIA-tyva-check KIND prf (proof-to-formula prf)
		   rv "proof-in-and-elim-right-form")))
	   (nbe-normalize-vatmpair-of
	     AND-NORMALIZE rv)))
    ((proof-in-all-intro-form)
     (let*((LEGDUM
             (if DEBUG
                 (nldisplay
                   "PROOF-IN-ALL_INTRO-FORM")))
           (z
             (var-to-vatuple
               (proof-in-all-intro-form-to-var
                 prf)))
           (kernel
             (proof-in-all-intro-form-to-kernel
               prf))
           (vatmpr
             (DIA-extr-vatmpair-aux KIND  
               kernel  avar-to-Data))
           (tmpair
             (vatmpair-to-tmpair vatmpr)) 
	   (vapr
             (vatmpair-to-vapair vatmpr))
           (x (vapair-right vapr)) 
           (T (tmpair-to-tuple tmpair)) 
	   (uT (tmpair-to-alist tmpair))
           (xz
             (vatuple-append x z
               "proof-in-all-intro-form 1")) 
	   (zy
             (vatuple-append z
               (vapair-left vapr)
               "proof-in-all-intro-form 2"))
           (S
             (make-tmtuple-in-abst-form xz 
	       (make-tmtuple-in-app-form T
                 (vatuple-to-tmtuple x))))
           (uS
             (make-tmtuplealist-in-abst-form xz
               (make-tmtuplealist-in-app-form uT
                 (vatuple-to-tmtuple x))))
           (rv (make-vatmpair
                 (make-vapair zy x)
                 (make-tmpair S uS)))
	   (LEGDUM
             (DIA-tyva-check KIND prf (proof-to-formula prf)
               rv "proof-in-all-intro-form")))
       rv))
    ((proof-in-all-elim-form)
     (let*((LEGDUM
             (if DEBUG
                 (nldisplay "PROOF-IN-ALL_ELIM-FORM")))
           (op (proof-in-all-elim-form-to-op prf))
           (all-fmla (proof-to-formula op))
           (LEGDUM
             (if PARANOIA
                 (if (not (all-form? all-fmla))
                     (myerror
                       "PROOF-IN-all-elim-FORM: "
                       "all-formula expected "
                       (formula-to-string all-fmla)))))
           (all-var (all-form-to-var all-fmla))
           (ker-fmla (all-form-to-kernel all-fmla))
           (arg (proof-in-all-elim-form-to-arg prf))
           (tmtup-arg
;              (if (notelem? all-var
;                    (formula-to-free ker-fmla))
;                  (begin
;                    (DIA-comment
;                      "PROOF-IN-all-elim-FORM:"
;                      "DUMMY substitution detected"
;                      "for formula" 'CNL
;                      (formula-to-string all-fmla)
;                      'CNL "The variable "
;                      (var-to-string all-var)
;                      " does not occur free"
;                      "in the kernel" 'CNL
;                      (formula-to-string ker-fmla))
;                  (term-to-zero-tmtuple arg))
                 (term-to-tmtuple arg))
           (vatmpr
             (DIA-extr-vatmpair-aux KIND 
		      op  avar-to-Data))
           (tmpr (vatmpair-to-tmpair vatmpr)) 
	   (vapr (vatmpair-to-vapair vatmpr))
           (zy (vapair-left vapr)) 
	   (x (vapair-right vapr))
           (S (tmpair-to-tuple tmpr))  
           (uS (tmpair-to-alist tmpr))
           (y (vatuple-right zy)) 
           (xt (tmtuple-append
                 (vatuple-to-tmtuple x)
                 tmtup-arg
                 "proof-in-all-elim-form"))
           (T (make-tmtuple-in-abst-form x
                (make-tmtuple-in-app-form
                  S xt)))
           (uT (make-tmtuplealist-in-abst-form 
		x (make-tmtuplealist-in-app-form
                    uS xt))) 
           (rv (make-vatmpair (make-vapair y x)
                 (make-tmpair T uT)))
	   (LEGDUM
             (DIA-tyva-check KIND prf (proof-to-formula prf)
               rv "proof-in-all-elim-form")))
       (nbe-normalize-vatmpair-of
         ALL-NORMALIZE rv)))
    ((proof-in-allnc-intro-form)
        (case KIND
              ((light monot)  (DIA-extr-vatmpair-aux KIND  
		       (proof-in-allnc-intro-form-to-kernel prf) avar-to-Data))
	((pure)      
	     (let*((LEGDUM
		    (if DEBUG
			(nldisplay "PDI PROOF-IN-ALLNC_INTRO-FORM")))
		   (z (var-to-vatuple
		            (proof-in-allnc-intro-form-to-var prf)))
		   (kernel
 		            (proof-in-allnc-intro-form-to-kernel prf))
		   (vatmpr
		       (DIA-extr-vatmpair-aux KIND kernel  avar-to-Data))
		   (tmpair (vatmpair-to-tmpair vatmpr)) 
		   (vapr (vatmpair-to-vapair vatmpr))
		   (x (vapair-right vapr)) 
		   (T (tmpair-to-tuple tmpair)) 
		   (uT (tmpair-to-alist tmpair))
		   (xz (vatuple-append x z
			   "proof-in-allnc-intro-form 1")) 
		   (zy (vatuple-append z (vapair-left vapr)
			   "proof-in-allnc-intro-form 2"))
		   (S (make-tmtuple-in-abst-form xz 
			(make-tmtuple-in-app-form T (vatuple-to-tmtuple x))))
		   (uS (make-tmtuplealist-in-abst-form xz
			(make-tmtuplealist-in-app-form uT
				    (vatuple-to-tmtuple x))))
		   (rv (make-vatmpair
			(make-vapair zy x)
			(make-tmpair S uS)))
		   (LEGDUM (DIA-tyva-check KIND prf (proof-to-formula prf)
					   rv "proof-in-allnc-intro-form")))
	       rv))
	(else (myerror "DIA-extr-vatmpair-aux, proof-in-allnc-intro-form:" 
		       "unknown KIND"))))
    ((proof-in-allnc-elim-form)
     (let((LEGDUM
            (if DEBUG
                (nldisplay
                  "PROOF-IN-allnc-elim-FORM")))
          (final-op
            (DIA-allnc-form-to-final prf))
          (rv #f))
       (begin
         (if (proof-in-aconst-form? final-op)
             (let*((acnst
                     (proof-in-aconst-form-to-aconst
                       final-op))
                   (name (aconst-to-name acnst))
                   (cstknd (aconst-to-kind acnst))
                   (LEGDUM
                     (if DEBUG
                         (nldisplay
                           "MULTIPLE allnc-elim"
                           name " of " cstknd " kind "
                           (formula-to-string
                             (proof-to-formula prf)) SNL
                             (formula-to-string
                               (proof-to-formula
                                 final-op))))))
;      (if (string<? "nc-" 
; 	(aconst-to-name (proof-in-aconst-form-to-aconst final-op)))
; 	 (begin (nldisplay "NonComp ACONST detected " name)
; 		(set! rv NULLvatmpair))
               (cond
                 ((eq? 'theorem cstknd)
                  (let*((inst-prf
                          (theorem-aconst-to-inst-proof
                            acnst))
                        (free
                          (formula-to-free
                            (proof-to-formula inst-prf)))
                        (nc-prf
                          (apply mk-proof-in-nc-intro-form
                            (append free (list inst-prf))))
                        (new-prf
                          (DIA-allnc-form-set-final
                            prf nc-prf)))
                    (begin
                      (if EXTRACT-VERBOSE (DIA-comment-forced
			 "ALLNC treatment of THEOREM "
			 (aconst-to-string acnst)))
                       (if DEBUG (DIA-comment " with formula" 'CNL
                        (formula-to-string (nf (aconst-to-formula acnst)))))
                      (set! rv
                        (DIA-extr-vatmpair KIND new-prf)))))
                 ((string=? "Ind" name))
                 (else
                   (begin
                     (set! rv
                       (DIA-extr-vatmpair-aux KIND 
                         final-op  avar-to-Data))
                     (DIA-tyva-check KIND prf (proof-to-formula prf)
                       rv "MULTIPLE allnc-elim"))))))
         (if rv  rv
	     (case KIND
	         ((light monot)   
		  (DIA-extr-vatmpair-aux KIND  
		          (proof-in-allnc-elim-form-to-op prf) avar-to-Data))
	         ((pure)
		   (let*((LEGDUM
			  (if DEBUG
			      (nldisplay
			       "PDI PROOF-IN-ALLNC_ELIM-FORM")))
			 (op (proof-in-allnc-elim-form-to-op prf))
			 (allnc-fmla (proof-to-formula op))
			 (LEGDUM
			  (if PARANOIA
			      (if (not (allnc-form? allnc-fmla))
				  (myerror
				   "PROOF-IN-allnc-elim-FORM: "
				   "allnc-formula expected "
				   (formula-to-string
				    allnc-fmla)))))
			 (allnc-var (allnc-form-to-var allnc-fmla))
			 (ker-fmla (allnc-form-to-kernel allnc-fmla))
			 (arg (proof-in-allnc-elim-form-to-arg prf))
			 (tmtup-arg
;                      (if (notelem? allnc-var
;                            (formula-to-free ker-fmla))
;                          (begin
;                            (DIA-comment
;                              "PROOF-IN-allnc-elim-FORM:"
;                              "DUMMY substitution detected"
;                              "for formula" 'CNL
;                              (formula-to-string allnc-fmla)
;                              'CNL "The variable "
;                              (var-to-string allnc-var)
;                              " does not occur free"
;                              "in the kernel" 'CNL
;                              (formula-to-string ker-fmla))
;                            (term-to-zero-tmtuple arg))
			  (term-to-tmtuple arg))
			 (vatmpr (dia-extr-vatmpair-aux KIND
					 op  avar-to-Data))
			 (tmpr (vatmpair-to-tmpair vatmpr)) 
			 (vapr (vatmpair-to-vapair vatmpr))
			 (zy (vapair-left vapr)) 
			 (x (vapair-right vapr))
			 (S (tmpair-to-tuple tmpr))  
			 (uS (tmpair-to-alist tmpr))
			 (y (vatuple-right zy)) 
			 (xt (tmtuple-append
			      (vatuple-to-tmtuple x)
			      tmtup-arg
			      "proof-in-allnc-elim-form"))
			 (T (make-tmtuple-in-abst-form x
				(make-tmtuple-in-app-form S xt)))
			 (uT (make-tmtuplealist-in-abst-form 
			      x (make-tmtuplealist-in-app-form
				 uS xt))) 
			 (new-rv
			  (make-vatmpair (make-vapair y x)
					 (make-tmpair T uT)))
			 (LEGDUM
			  (DIA-tyva-check KIND prf (proof-to-formula prf)
					  new-rv "proof-in-allnc-elim-form")))
		     (nbe-normalize-vatmpair-of
		      ALL-NORMALIZE  new-rv)))
		 (else (myerror "DIA-extr-vatmpair-aux, proof-in-allnc-elim-form:"
				"unknown KIND")))))))
    (else (myerror "DIA-extr-vatmpair: "  "proof expected" prf)))))


(define (DIA-type-to-rec-term typ_z a_typ)
  (let*((init-rec-const (type-info-to-rec-const
			          (make-arrow typ_z a_typ)))
             (init-rec-term (make-term-in-const-form init-rec-const))
             (new_typ (mk-arrow typ_z a_typ a_typ))
             (va-y (type-to-new-var new_typ))
             (va-z (type-to-new-var  typ_z))
             (va-x (type-to-new-var a_typ))
             (tm-y (make-term-in-var-form va-y))     
             (tm-z (make-term-in-var-form va-z))     
             (tm-x (make-term-in-var-form va-x))
             (root-tm (mk-term-in-app-form init-rec-term tm-z tm-x tm-y)))
    (mk-term-in-abst-form va-x va-y va-z root-tm)))

;; Some auxiliary code for the "allnc-elim" 
;; case of dia-extr-vatmpair


(define (DIA-allnc-form-to-final prf)
  (cond
    ((proof-in-allnc-elim-form? prf)
     (DIA-allnc-form-to-final
       (proof-in-allnc-elim-form-to-op prf)))
    ((proof-in-allnc-intro-form? prf)
     (DIA-allnc-form-to-final
       (proof-in-allnc-intro-form-to-kernel prf)))
    (else prf)))

(define (DIA-allnc-form-set-final prf fin-prf)
  (cond
    ((proof-in-allnc-elim-form? prf)
     (make-proof-in-allnc-elim-form
       (DIA-allnc-form-set-final
         (proof-in-allnc-elim-form-to-op prf)
         fin-prf)
     (proof-in-allnc-elim-form-to-arg
       prf)))
    ((proof-in-allnc-intro-form? prf)
     (make-proof-in-allnc-intro-form
       (proof-in-allnc-intro-form-to-var prf)
       (DIA-allnc-form-set-final
         (proof-in-allnc-intro-form-to-kernel prf)
         fin-prf)))
    (else fin-prf)))

(define (DIA-all-allnc-form-to-final prf)
  (cond
    ((proof-in-all-elim-form? prf)
     (DIA-all-allnc-form-to-final
       (proof-in-all-elim-form-to-op prf)))
    ((proof-in-all-intro-form? prf)
     (DIA-all-allnc-form-to-final
       (proof-in-all-intro-form-to-kernel prf)))
    ((proof-in-allnc-elim-form? prf)
     (DIA-all-allnc-form-to-final
       (proof-in-allnc-elim-form-to-op prf)))
    ((proof-in-allnc-intro-form? prf)
     (DIA-all-allnc-form-to-final
       (proof-in-allnc-intro-form-to-kernel prf)))
    (else prf)))

(define (DIA-all-allnc-form-set-final prf fin-prf)
  (cond
    ((proof-in-all-elim-form? prf)
     (make-proof-in-all-elim-form
       (DIA-all-allnc-form-set-final
         (proof-in-all-elim-form-to-op prf)
         fin-prf)
     (proof-in-all-elim-form-to-arg
       prf)))
    ((proof-in-all-intro-form? prf)
     (make-proof-in-all-intro-form
       (proof-in-all-intro-form-to-var prf)
       (DIA-all-allnc-form-set-final
         (proof-in-all-intro-form-to-kernel prf)
         fin-prf)))
    ((proof-in-allnc-elim-form? prf)
     (make-proof-in-allnc-elim-form
       (DIA-all-allnc-form-set-final
         (proof-in-allnc-elim-form-to-op prf)
         fin-prf)
     (proof-in-allnc-elim-form-to-arg
       prf)))
    ((proof-in-allnc-intro-form? prf)
     (make-proof-in-allnc-intro-form
       (proof-in-allnc-intro-form-to-var prf)
       (DIA-all-allnc-form-set-final
         (proof-in-allnc-intro-form-to-kernel prf)
         fin-prf)))
    (else fin-prf)))


;; Some auxiliary code for the "UserGlobalAssumption" 
;; sub-case of dia-extr-vatmpair

(define (user-global-assumption? x)
  (and (aconst? x) 
       (Eq? (aconst-to-kind x) 'global-assumption)
       (let((name (aconst-to-name x)))
	 (and (or (assoc name GLOBAL-ASSUMPTIONS)
                  (string=? "Ind-Rule" name))
	      (not (string=? "Stab-Log" name))
	      (not (string=? "Stab" name))
	      (not (string=? "Efq-Log" name))
	      (not (string=? "Efq" name))
	      (or (> (string-length "Eq-Compat-Rev")
                    (string-length name))
		  (not (string=?
                         (substring name 0
                           (string-length "Eq-Compat-Rev"))
                         "Eq-Compat-Rev")))
	      (or (> (string-length "Compat-Rev")
                    (string-length name))
		  (not (string=?
                         (substring name 0
                           (string-length "Compat-Rev"))
                         "Compat-Rev")))))))
(define (not-user-global-assumption? x)
  (cond
    ((not (aconst? x)) #t)
     ((not (Eq? (aconst-to-kind x)
             'global-assumption)) #t)
     (else
       (let((name (aconst-to-name x)))
         (cond
           ((string=? "Stab-Log" name) #t)
           ((string=? "Stab" name) #t)
           ((string=? "Efq-Log" name) #t)
           ((string=? "Efq" name) #t)
           ((and (<= (string-length "Eq-Compat-Rev")
                   (string-length name))
                 (string=? "Eq-Compat-Rev"
                   (substring name 0
                     (string-length "Eq-Compat-Rev"))))
            #t)
           ((and (<= (string-length "Compat-Rev")
                   (string-length name))
               (string=? "Compat-Rev"
                      (substring name 0
                        (string-length "Compat-Rev"))))
            #t)
           (else
             (and
               (not
                 (assoc name GLOBAL-ASSUMPTIONS))
               (not (string=? "Ind-Rule" name)))))))))

(define uga? user-global-assumption?)
(define (not-uga? x)
  (begin
    (if DEBUG (DIA-comment "not-uga? INVOKED"))
    (not-user-global-assumption? x)))
(define (uga=? acst1 acst2)
  (cond
    ((not-eq? 'global-assumption
       (aconst-to-kind acst1))
     (myerror
       "uga=?: 1st argument not a"
       "global assumption" acst1))
    ((not-eq? 'global-assumption
       (aconst-to-kind acst2))
     (myerror
       "uga=?: 2nd argument not a"
       "global assumption" acst2))
    ((string=? (aconst-to-name acst1)
         (aconst-to-name acst2)) #t)
    (else #f)))


(define (DIA-UGA-ALIST-to-string)
  (string-append "{UGA-BEGIN:"
    (DIA-UGA-ALIST-to-string-aux DIA-UGA-ALIST)))
(define (DIA-UGA-ALIST-to-string-aux alist)
  (if (null? alist) ":UGA-END}"
      (string-append ": "
        (aconst-to-string (caar alist))
        " => "
        (formula-to-string
          (aconst-to-formula (caar alist)))
        " :" (DIA-UGA-ALIST-to-string-aux
               (cdr alist)))))

(define (DIA-assoc-UGA acst)
  (begin
    (if PARANOIA
        (if (not-uga? acst)
            (myerror
              "DIA-assoc-UGA: user global"
              "assumption expected" acst)))
    (DIA-assoc-UGA-aux acst DIA-UGA-ALIST)))
     
(define (DIA-assoc-UGA-aux acst galst)
  (if (null? galst) #f
      (if (uga=? acst (caar galst))
          (car galst)
          (DIA-assoc-UGA-aux acst (cdr galst)))))
  
(define DIA-UGA-ALIST '())
(define (DIA-uga-to-vatmpair KIND x)
  (begin
    (if CHECK
        (if (not-uga? x)
            (myerror "DIA-uga-to-vatmpair:  User"
              "Global Assumption argument expected")))
    (let*((name (aconst-to-name x))
          (LEGDUM
            (if DEBUG
                (nldisplay
                  "UserGlobalAssumption: "
                  name)))
          (info (DIA-assoc-UGA x))
          (LEGDUM
            (if DEBUG-UGA
                (nldisplay "DIA-uga-to-vatmpair : "
                  "info determined")))
          (rv
            (if info (cdr info)
                (let*((fmla
                        (aconst-to-inst-formula x))
                      (new-typr
                        (DIA-formula-to-typair KIND fmla))
                      (ex-tytup (typair-left new-typr))
                      (fa-tytup (typair-right new-typr))
                      (LEGDUM
                        (if DEBUG-UGA
                            (nldisplay
                              "User Global Assumption detected: "
                              name
                              "of shape: \n "
                              (formula-to-string fmla)
                              "\nwhich produces universally"
                              "quantified variables of types: \n" 
                              (tytuple-to-string fa-tytup)
                              "\nand requires user-defined realizers"
                              "for the existential part of types: \n"
                              (tytuple-to-string ex-tytup))))
                      (tmtup
                        (DIA-uga-user-defined-realizers
                          ex-tytup name))
                      (new-rv
                        (make-vatmpair
                          (make-vapair
                            (tytuple-to-vatuple fa-tytup)
                            NULL_vatup)
                          (make-tmpair tmtup NULL_tmtupalst))))
                  (begin (set! DIA-UGA-ALIST
                           (cons (cons x new-rv)
                             DIA-UGA-ALIST))
                         new-rv)))))
      rv)))


(define (DIA-uga-user-defined-realizers tytup name)
  (if (NULL-tytup? tytup) 
      (begin
        (if DEBUG-UGA
            (nldisplay
              "OK, existential part of UGA" name
              "is empty,"
              "no user-defined realizer needed!"))
        (tytuple-to-tmtuple tytup))
      (begin
        (myerror
          "Here the user should provide a realizing tmtuple."
          "NOT YET IMPLEMENTED"))))

(define (DIA-IR-mk-imp-formula avars fmla)
  (if (null? avars) fmla
      (make-imp
        (avar-to-formula (car avars))
        (DIA-IR-mk-imp-formula (cdr avars) fmla))))

(define (DIA-IR-mk-elim-proof prf avars)
  (if (null? avars) prf
      (DIA-IR-mk-elim-proof 
        (make-proof-in-imp-elim-form prf
          (make-proof-in-avar-form (car avars)))
        (cdr avars))))

(define (DIA-IR-mk-intro-proof avars prf)        
  (if (null? avars) prf
      (make-proof-in-imp-intro-form (car avars)
        (DIA-IR-mk-intro-proof (cdr avars) prf))))

(define (DIA-Ind-Rule? prf)
 (begin
   (if DEBUG-IND-RL (begin
	(nldisplay "DIA-Ind-Rule?: Begin")
	(cdp prf)))
   (let((op (proof-in-imp-elim-form-to-op prf)))
      (if (not (proof-in-imp-elim-form? op))
	  (begin
	         (if DEBUG-IND-RL 
		     (nldisplay "DIA-Ind-Rule?: End" "op is not imp-elim"))
	         #f)
        (let((arg-fmla
	      (proof-to-formula
	         (proof-in-imp-elim-form-to-arg prf))))
            (if (not (all-form? arg-fmla))
	       (begin
	          (if DEBUG-IND-RL 
		   (nldisplay "DIA-Ind-Rule?: End" "arg-fmla is not all-form"))
	         #f)
        (let((fin-op
                       (DIA-all-allnc-form-to-final
                            (proof-in-imp-elim-form-to-op op))))
	  (if (not (proof-in-aconst-form? fin-op))
	          (begin
	             (if DEBUG-IND-RL 
		   (nldisplay "DIA-Ind-Rule?: End" "fin-op is not aconst"))
	         #f)
           (let((name (aconst-to-name
                        (proof-in-aconst-form-to-aconst fin-op))))
	     (if (not (string=? "Ind" name))
	              (begin
	                (if DEBUG-IND-RL 
		     (nldisplay "DIA-Ind-Rule?: End" "fin-op is not an Ind"))
	         #f)
	         (let*((op-op (proof-in-imp-elim-form-to-op op)))
		   (if (not (proof-in-all-elim-form? op-op))
		       (begin
			 (if DEBUG-IND-RL 
			     (nldisplay "DIA-Ind-Rule?: End" 
					"op-op is not all-elim"))
			 #f)
		       (proof-in-all-elim-form-to-arg op-op)))))))))))))


;; Some auxiliary code for the "imp-intro" case of DIA-extr-vatmpair  

(define (Imp-Intro-split avar
          tmtupalst avar-to-Data)
  (begin
    (if PARANOIA
        (if (not-avar? avar)
            (myerror "Imp-Intro-split:"
              "1st argument must be avar")
            (if (ntmtuplealist? tmtupalst)
                (myerror
                  "Imp-Intro-split: 2nd argument"
                  "must be tmtuplealist"))))
    (Imp-Intro-split-aux avar
      tmtupalst avar-to-Data)))
(define (Imp-Intro-split-aux avar
          tmtupalst avar-to-Data)
  (if (null? tmtupalst)
      (cons
        (cons NULL_vatup (list))
        (list))
      (let((recval
             (Imp-Intro-split-aux avar
               (cdr tmtupalst) avar-to-Data)))
        (if (avar=? avar (caar tmtupalst))
            (cons (car recval)
              (cons
                (cdar tmtupalst)
                (cdr recval)))
            (cons
              (cons
                (vatuple-append
                  (vapair-left
                    (cadr
                      (avar-to-Data
                        (caar tmtupalst))))
                  (caar recval)
                  "Imp-Intro-split")
                (cons
                  (car tmtupalst)
                  (cdar recval)))
              (cdr recval))))))

(define (Imp-Intro-CondN tmtuplst vatup tm)
  (begin 
    (if PARANOIA
        (if (not-tmtuplist? tmtuplst)
            (myerror "Imp-Intro-CondN: 1st"
              "argument must be a tmtuplist")
            (if (null? tmtuplst)
                (myerror "Imp-Intro-CondN:"
                  "Non-NULL tmtuplist expected")
                (if (null? (cdr tmtuplst))
                    (myerror "Imp-Intro-CondN:"
                      "Non-SINGLETON tmtuplist"
                      "expected")))))
    (if PARANOIA
        (if (not-vatuple? vatup)
            (myerror "Imp-Intro-CondN: 2nd"
              "argument must be a vatuple" vatup)
            (if (not-DIA-term? tm)
                (myerror "Imp-Intro-CondN: 3rd"
                  "argument must be a term" tm))))
    (let((nrm-tm
           (if CONDN-NORMALIZE (DIA-time (nt tm)) tm)))
      (Imp-Intro-CondN-aux tmtuplst 
	(DIA-mk-subst vatup nrm-tm tmtuplst)))))

(define (DIA-mk-subst vatup tm tmtuplst)
  (if (null? (cdr tmtuplst)) (list)
      (cons  
       (term-substitute tm (DIA-make-substitution 
	vatup (car tmtuplst) "Imp-Intro-CondN"))
	     (DIA-mk-subst vatup tm (cdr tmtuplst)))))

(define (Imp-Intro-CondN-aux tmtuplst boolest)
  (if (null? (cdr tmtuplst)) (car tmtuplst)
      (make-tmtuple-in-if-form (car boolest)
         (Imp-Intro-CondN-aux (cdr tmtuplst) (cdr boolest))          
	 (car tmtuplst))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; NEW Mon Begin
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define (Imp-Intro-MonN tmtuplst)
  (begin 
    (if PARANOIA
        (if (not-tmtuplist? tmtuplst)
            (myerror "Imp-Intro-MonN: 1st"
              "argument must be a tmtuplist")
            (if (null? tmtuplst)
                (myerror "Imp-Intro-MonN:"
                  "Non-NULL tmtuplist expected")
                (if (null? (cdr tmtuplst))
                    (myerror "Imp-Intro-MonN:"
                      "Non-SINGLETON tmtuplist"
                      "expected")))))
      (let*((tmtup (car tmtuplst))
	    (tytup (tmtuple-to-tytuple tmtup))
	    (maxtup (tytuple-to-max tytup)))
      (begin
	(Imp-Intro-MonN-aux tmtuplst maxtup)))))

(define (Imp-Intro-MonN-aux tmtuplst maxtup)
 (begin
  (if (null? (cdr tmtuplst)) (car tmtuplst)
      (make-tmtuple-in-paral-app-form 
       (make-tmtuple-in-paral-app-form maxtup (car tmtuplst))
         (Imp-Intro-MonN-aux (cdr tmtuplst) maxtup)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; NEW Mon End
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; A simple and NOT complete check that a "vatmpair" realizes
;; a given proof. Used to check the extracted vatmpair in
;; dia-extr-vatmpair

(define (va-check fmla vatmpr)
  (let*((tmpair (vatmpair-to-tmpair vatmpr))
	(tmtpl (tmpair-to-tuple tmpair))
	(alst (tmpair-to-alist tmpair))
	(tmtpl-free
          (union (tmtuple-to-free tmtpl) 
            (alist-to-tmtuple-free alst)))
	(fmla-free
          (union (formula-to-free fmla)
            (alist-to-formula-free alst))))
    (if (notsubset? tmtpl-free fmla-free) 
	(set-minus tmtpl-free fmla-free) #f)))

(define (notelem? var lst)
  (if (null? lst) #t
      (if (equal? var (car lst)) #f
	  (notelem? var (cdr lst)))))

(define (elem-alist? var alst)
  (if (null? alst) #f
      (if (equal? var (caar alst)) #t
	  (elem-alist? var (cdr alst)))))

(define (notsubset? lstA lstB)
  (if (null? lstA) #f
      (if (notelem? (car lstA) lstB) #t
	  (notsubset? (cdr lstA) lstB))))

(define (nDIA-tyva-check KIND prf fmla vatmpr err)
  (if (DIA-tyva-check KIND prf fmla vatmpr err) #f #t))
(define (DIA-tyva-check KIND prf fmla vatmpr err) 
  (if (or CHECK PARANOIA DEBUG)
      (begin
        (if DEBUG
            (nldisplay "DIA-TYVA-CHECK: " err 
              ;;; (formula-to-string (nf fmla))
	      ))
        (if (not (DIA-ty-check KIND fmla vatmpr))
           (begin
            (nldisplay "DIA-TYVA-CHECK: " err 
              "ERROR at type checking")
            (cdp prf)
            (DIA-comment (normalize-vatmpair-to-string vatmpr))
            (myerror "SERIOUS DIA-extraction ERROR")))
          (let((valst (va-check fmla vatmpr)))
              (if valst 
	   (begin	
	     (nldisplay "DIA-TYVA-CHECK: " err 
			"ERROR at free-var checking."
			"Variables "
			(valist-to-string valst)
			"are free in the realizing terms"
			"and not among the free vars of "
			(formula-to-string (nf fmla)))
	     (cdp prf)
                    (DIA-comment (normalize-vatmpair-to-string vatmpr))
	    (myerror "SERIOUS DIA-extraction ERROR"))))
	#t)
      #t))

(define (DIA-ty-check KIND fmla vatmpr)
  (let*((vapr (vatmpair-to-vapair vatmpr))
        (vatup-y (vapair-left vapr))
        (tytup-y (vatuple-to-tytuple vatup-y))
        (vatup-x (vapair-right vapr))
        (tytup-x (vatuple-to-tytuple vatup-x))
        (tmpr (vatmpair-to-tmpair vatmpr))
        (tmtup-T (tmpair-to-tuple tmpr))
        (tmtup-Tx (make-tmtuple-in-app-form 
            tmtup-T (vatuple-to-tmtuple vatup-x)))
        (tytup-Tx (tmtuple-to-tytuple tmtup-Tx))
        (typr (DIA-formula-to-typair KIND fmla))
        (concl-univ (typair-right typr))
        (concl-exis (typair-left typr))
        (universal
          (if (tytuple_Eq? tytup-y concl-univ) #t
              (begin
                (nldisplay "DIA-ty-check:"
                  "unequal universal tytuples"
                  SNL (tytuple-to-string tytup-y) SNL
                  "while the following was expected"
                  SNL (tytuple-to-string concl-univ)) #f)))
        (existential
          (if (tytuple_Eq? tytup-Tx concl-exis) #t
              (begin (nldisplay "DIA-ty-check:"
                       "unequal existential tytuples"
                     SNL (tytuple-to-string tytup-Tx) SNL
                     "while the following was expected"
                     SNL (tytuple-to-string concl-exis)) #f)))
        (test-one
          (and universal existential)))
    test-one))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; NEW Mon Begin
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define load-nat-if-unloaded
  (if (not (assoc "NatPlus" PROGRAM-CONSTANTS))
      (libload "nat.scm")))

(define (make-Max)
  (begin
    (add-program-constant "Max" (py "nat=>nat=>nat") 1)
    (add-computation-rule (pt "Max (Succ m) (Succ n)") (pt "Succ (Max m n)"))
    (add-rewrite-rule (pt "Max nat 0") (pt "nat"))
    (add-rewrite-rule (pt "Max 0 nat") (pt "nat"))
    (add-rewrite-rule (pt "Max nat (Max nat n)") (pt "Max nat n"))
    (add-rewrite-rule (pt "Max nat (Max n nat)") (pt "Max nat n"))
    (add-rewrite-rule (pt "Max (Max nat n) nat") (pt "Max nat n"))
    (add-rewrite-rule (pt "Max (Max n nat) nat") (pt "Max nat n"))
    ))

(define make-Max-once
   (if (assoc "Max" PROGRAM-CONSTANTS)
       (comment "WARNING: Max is already a program constant. Default to existent, no new addition !!!")
       (make-max)))

(define (type-to-max typ)
  (cond
   ((star-form? typ) 
      (let*((var_x (type-to-new-var typ))
	   (tm_x (make-term-in-var-form var_x))
	   (var_y (type-to-new-var typ))
	   (tm_y (make-term-in-var-form var_y))
	   (max_l (type-to-max (star-form-to-left-type typ)))
	   (max_r (type-to-max (star-form-to-right-type typ))))
	(make-term-in-abst-form var_x
	   (make-term-in-abst-form var_y			
	      (make-term-in-pair-form
	       (make-term-in-app-form
		(make-term-in-app-form
		   max_l (make-term-in-lcomp-form tm_x))
		(make-term-in-lcomp-form tm_y))
	       (make-term-in-app-form
		(make-term-in-app-form
		   max_r (make-term-in-rcomp-form tm_x))
		(make-term-in-rcomp-form tm_y)))))))		
   ((arrow-form? typ)
      (let*((var_x (type-to-new-var typ))
	   (tm_x (make-term-in-var-form var_x))
	   (var_y (type-to-new-var typ))
	   (tm_y (make-term-in-var-form var_y))
	   (var_z (type-to-new-var (arrow-form-to-arg-type typ)))
	   (tm_z (make-term-in-var-form var_z))
	   (max_val (type-to-max (arrow-form-to-val-type typ))))
	(make-term-in-abst-form var_x
	   (make-term-in-abst-form var_y			
	      (make-term-in-abst-form var_z
	       (make-term-in-app-form
		(make-term-in-app-form
		   max_val (make-term-in-app-form tm_x tm_z))
		(make-term-in-app-form tm_y tm_z)))))))
   ((alg-form? typ)
      (if (string=? "nat" (alg-form-to-name typ)) (pt "Max")
	  (myerror "type-to-max: only nat algebra allowed as ground type")))
   (else
     (myerror "type-to-max: type argument expected" typ))))

(define (tytuple-to-max tytup)
  (if (not-tytuple? tytup)
      (myerror "tytuple-to-max:"
        "tytuple argument expected" tytup)
      (tytuple-to-max-aux tytup)))
(define (tytuple-to-max-aux tytup)
  (if (null? (cdr tytup)) NULL_tmtup
      (if (null? (cddr tytup))
           (term-to-tmtuple (type-to-max (cadr tytup)))
           (tmtuple-append
	   (tytuple-to-max-aux  (cadr tytup))
	   (tytuple-to-max-aux  (cddr tytup))
            "tytuple-to-max"
            ))))

(define (mk-term-in-max-form tmlst)
  (if (null? tmlst) 
      (begin (nldisplay "WARNING: mk-term-in-max-form:" 
			"unexpected NULL argument") tmlst)
      (mk-term-in-max-form-aux (car tmlst) (cdr tmlst))))
(define (mk-term-in-max-form-aux tm tmlst)
  (if (null? tmlst) tm
      (let((Max (type-to-max (term-to-type tm)))
	   (max_tmlst (mk-term-in-max-form-aux tmlst)))
	(mk-term-in-app-form Max tm max_tmlst))))

(define (type-to-mon-rec-tm typ_z star_typ)
  (begin
    (let((rv
  (let*((Rec (DIA-type-to-rec-term typ_z star_typ))
	(var_n (type-to-new-var typ_z))
	(tm_n (make-term-in-var-form var_n))
	(var_y (type-to-new-var star_typ))
	(tm_y (make-term-in-var-form var_y))
	(var_z (type-to-new-var (make-arrow typ_z 
			  (make-arrow star_typ star_typ))))
	(tm_z (make-term-in-var-form var_z))
	(Max (type-to-max star_typ))
	(mon_tm_z 
	 (mk-term-in-abst-form var_n var_y 
		(mk-term-in-app-form Max
			tm_y  (mk-term-in-app-form tm_z tm_n tm_y)))))
    (mk-term-in-abst-form var_y var_z var_n
       (mk-term-in-app-form Rec tm_y mon_tm_z tm_n)))))
      (begin rv))))


(define (nat-DIA-type-to-Rec-MonTm Rec_typ)
   (let*((nat_typ (py "nat"))
              (rv (DIA-type-to-Rec-MonTm  nat_typ Rec_typ)))
     rv))

(define DIA-type-to-Rec-MonTm DIA-type-to-Rec-Term)

(define (type-to-XMaj typ)
  (let*((Rec_tm (nat-DIA-type-to-Rec-MonTm typ))
             (arr_typ (make-arrow (py "nat") typ))
             (va_x (type-to-new-var arr_typ))
             (tm_x (make-term-in-var-form va_x))
             (Base_Tm (pt "0"))
             (Max_tm (type-to-max typ))
             (va_z (type-to-new-var typ))
             (tm_z (make-term-in-var-form va_z))
             (va_k (type-to-new-var (py "nat")))
             (tm_k (make-term-in-var-form va_k))
             (tm_xk (make-term-in-app-form tm_x tm_k))
             (Step_Tm (mk-term-in-abst-form va_k va_z
	      (mk-term-in-app-form  Max_tm tm_z tm_xk)))
            (XMaj_tm (mk-term-in-app-form 
		      Rec_tm Base_Tm Step_Tm))
            (Succ_Tm (pt "Succ"))
            (rv (mk-term-in-abst-form va_x va_k 
		      (make-term-in-app-form XMaj_tm 
			(make-term-in-app-form  Succ_Tm tm_k)))))
    (begin  (pp rv) rv)))

(define (make-nat-XMaj) 
    (let*((nat_typ (py "nat")))
        (type-to-XMaj nat_typ)))

(define nat-XMaj (make-nat-XMaj))

(define (term-to-maj tm)
 (begin
   (let((rv
  (case (tag tm)
    ((term-in-const-form)
       (if (string=? "Rec" (const-to-name (term-in-const-form-to-const tm)))
	   (let((typ (arrow-form-to-arg-type (term-to-type tm))))
	     (type-to-mon-rec-tm (py "nat") typ))
	   tm))
    ((term-in-var-form) 
          (let((typ (term-to-type tm)))
	       (cond 
		((nat-type? typ) tm)
		((nat-nat-type? typ) 
		      (make-term-in-app-form nat-XMaj tm))
		((nat-rho-type? typ) 
		     (let*((rho-typ (give-rho-type typ))
			 (rho-XMaj (type-to-XMaj rho-typ)))
		       (make-term-in-app-form rho-XMaj tm)))
		(else
		    (myerror 
		        "term-to-maj: " "term variable is " (term-to-string tm) 
		        "which has type " (type-to-string typ) " but variables must "
		        "have type of form _nat_ OR _nat=>rho_ in input term")))))
    ((term-in-abst-form) 
       (make-term-in-abst-form (term-in-abst-form-to-var tm)
          (term-to-maj (term-in-abst-form-to-kernel tm))))
    ((term-in-app-form)
        (make-term-in-app-form 
	   (term-to-maj (term-in-app-form-to-op tm))
	   (term-to-maj (term-in-app-form-to-arg tm))))
    ((term-in-pair-form)
        (make-term-in-pair-form
	   (term-to-maj (term-in-pair-form-to-left tm))
	   (term-to-maj (term-in-pair-form-to-right tm))))
    ((term-in-lcomp-form)
        (make-term-in-lcomp-form
	    (term-to-maj (term-in-lcomp-form-to-kernel tm))))
    ((term-in-rcomp-form)
        (make-term-in-rcomp-form
	    (term-to-maj (term-in-rcomp-form-to-kernel tm))))
    ((term-in-if-form)
          (myerror "term-to-maj: not wanted for If-terms ... see the code ... "))
; ;        MDH ==> discarded 19 Mai 2006 
; ;        (mk-term-in-max-form (map term-to-maj (term-in-if-form-to-alts tm))))
    (else
       (myerror "term-to-maj: term expected" tm)))))
     (begin rv)))) 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Further bureaucratic procedures for the MON case
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (nat-type? typ)
    (string=? "nat" (type-to-string typ)))

(define (nat-nat-type? typ)
    (string=? "nat=>nat" (type-to-string typ)))

(define (nat-rho-type? typ)
  (if (arrow-form? typ)
             (let*((arg_typ (arrow-form-to-arg-type typ))
                        (val_typ (arrow-form-to-val-type typ)))
	       (nat-type? arg_typ))
             #f))

(define (give-rho-type typ)
  (if (arrow-form? typ)
             (let*((arg_typ (arrow-form-to-arg-type typ))
                        (val_typ (arrow-form-to-val-type typ)))
	       val_typ)
             (myerror "give-rho-type:" 
		      "Arrow type argument expected ... " typ)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; The procedures below create the formula of inequality between
;;;;; two given terms/variables of the same type -- MDH 071117
;;;;; Kept here since they might get useful some day ... not now
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ; ; (define (make-leq-va typ var_x var_y)
; ; ;   (if (not (equal? typ (var-to-type var_x)))
; ; ;       (myerror "make-leq: 1st var must have type typ")
; ; ;       (if (not (equal? typ (var-to-type var_y)))
; ; ; 	  (myerror "make-leq: 2nd var must have type typ")
; ; ; 	  (let*((tm_x (make-term-in-var-form var_x))
; ; ; 		(tm_y (make-term-in-var-form var_y)))
; ; ; 	  (make-leq-aux typ tm_x tm_y)))))

; ; ; (define (make-leq typ tm_x tm_y)
; ; ;   (if (not (equal? typ (term-to-type tm_x)))
; ; ;       (myerror "make-leq: 1st var must have type typ")
; ; ;       (if (not (equal? typ (term-to-type tm_y)))
; ; ; 	  (myerror "make-leq: 2nd var must have type typ")
; ; ; 	  (make-leq-aux typ tm_x tm_y))))

; ; ; (define (make-leq-aux typ tm_x tm_y)
; ; ;   (cond
; ; ;    ((star-form? typ) 
; ; ;       (let*((leq_l (make-leq 
; ; ; 		    (star-form-to-left-type typ)
; ; ; 		    (make-term-in-lcomp-form tm_x)
; ; ; 		    (make-term-in-lcomp-form tm_y)))
; ; ; 	   (leq_r (make-leq 
; ; ; 		    (star-form-to-right-type typ)
; ; ; 		    (make-term-in-rcomp-form tm_x)
; ; ; 		    (make-term-in-rcomp-form tm_y))))
; ; ; 	(make-and leq_l leq_r)))
; ; ;    ((arrow-form? typ)
; ; ;       (let*((va_z (type-to-new-var (arrow-form-to-arg-type typ)))
; ; ; 	   (tm_z (make-term-in-var-form va_z)))
; ; ; 	   (make-allnc va_z 
; ; ; 		     (make-leq (arrow-form-to-val-type typ)
; ; ; 				 (make-term-in-app-form tm_x tm_z)
; ; ; 				 (make-term-in-app-form tm_y tm_z)))))
; ; ;    ((alg-form? typ)
; ; ;       (if (string=? "nat" (alg-form-to-name typ)) 
; ; ; 	    (make-atomic-formula
; ; ; 	       (mk-term-in-app-form (pt "NatLeq") tm_x tm_y))
; ; ; 	  (myerror "make-leq: only nat algebra allowed as ground type")))
; ; ;    (else
; ; ;      (myerror "make-leq: type argument expected" typ))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; NEW Mon End
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; These are a few useful depth/size measuring functions for proofs/terms
;; SHOULD BE included in the standard libraries --- there were some procedures
;; in the standard libraries already, but I was not happy with them --- here
;; I propose just an alternative --- MDH 25 October 2007 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (proof-to-depth prf)
  (case (tag prf)
    ((proof-in-avar-form proof-in-aconst-form) 0)
    ((proof-in-imp-intro-form)
     (let ((kernel (proof-in-imp-intro-form-to-kernel prf)))
       (+ 1 (proof-to-depth kernel))))
    ((proof-in-imp-elim-form)
     (let ((op (proof-in-imp-elim-form-to-op prf))
	   (arg (proof-in-imp-elim-form-to-arg prf)))
       (+ 1 (max (proof-to-depth op) (proof-to-depth arg)))))
    ((proof-in-and-intro-form)
     (let ((left (proof-in-and-intro-form-to-left prf))
	   (right (proof-in-and-intro-form-to-right prf)))
       (+ 1 (max (proof-to-depth left) (proof-to-depth right)))))
    ((proof-in-and-elim-left-form)
     (let ((kernel (proof-in-and-elim-left-form-to-kernel prf)))
       (+ 1 (proof-to-depth kernel))))
    ((proof-in-and-elim-right-form)
     (let ((kernel (proof-in-and-elim-right-form-to-kernel prf)))
       (+ 1 (proof-to-depth kernel))))
    ((proof-in-tensor-intro-form)
     (let ((left (proof-in-tensor-intro-form-to-left prf))
	   (right (proof-in-tensor-intro-form-to-right prf)))
       (+ 1 (max (proof-to-depth left) (proof-to-depth right)))))
    ((proof-in-tensor-elim-left-form)
     (let ((kernel (proof-in-tensor-elim-left-form-to-kernel prf)))
       (+ 1 (proof-to-depth kernel))))
    ((proof-in-tensor-elim-right-form)
     (let ((kernel (proof-in-tensor-elim-right-form-to-kernel prf)))
       (+ 1 (proof-to-depth kernel))))
    ((proof-in-all-intro-form)
     (let ((kernel (proof-in-all-intro-form-to-kernel prf)))
       (+ 1 (proof-to-depth kernel))))
    ((proof-in-all-elim-form)
     (let ((op (proof-in-all-elim-form-to-op prf)))
       (+ 1 (proof-to-depth op))))
    ((proof-in-allnc-intro-form)
     (let ((kernel (proof-in-allnc-intro-form-to-kernel prf)))
       (+ 1 (proof-to-depth kernel))))
    ((proof-in-allnc-elim-form)
     (let ((op (proof-in-allnc-elim-form-to-op prf)))
       (+ 1 (proof-to-depth op))))
    (else (myerror "proof-to-depth: proof tag expected" (tag prf)))))


(define (proof-to-size prf)
  (case (tag prf)
    ((proof-in-avar-form proof-in-aconst-form) 1)
    ((proof-in-imp-intro-form)
     (let ((kernel (proof-in-imp-intro-form-to-kernel prf)))
       (+ 1 (proof-to-size kernel))))
    ((proof-in-imp-elim-form)
     (let ((op (proof-in-imp-elim-form-to-op prf))
	   (arg (proof-in-imp-elim-form-to-arg prf)))
       (+ 1 (+ (proof-to-size op) (proof-to-size arg)))))
    ((proof-in-and-intro-form)
     (let ((left (proof-in-and-intro-form-to-left prf))
	   (right (proof-in-and-intro-form-to-right prf)))
       (+ 1 (+ (proof-to-size left) (proof-to-size right)))))
    ((proof-in-and-elim-left-form)
     (let ((kernel (proof-in-and-elim-left-form-to-kernel prf)))
       (+ 1 (proof-to-size kernel))))
    ((proof-in-and-elim-right-form)
     (let ((kernel (proof-in-and-elim-right-form-to-kernel prf)))
       (+ 1 (proof-to-size kernel))))
    ((proof-in-tensor-intro-form)
     (let ((left (proof-in-tensor-intro-form-to-left prf))
	   (right (proof-in-tensor-intro-form-to-right prf)))
       (+ 1 (+ (proof-to-size left) (proof-to-size right)))))
    ((proof-in-tensor-elim-left-form)
     (let ((kernel (proof-in-tensor-elim-left-form-to-kernel prf)))
       (+ 1 (proof-to-size kernel))))
    ((proof-in-tensor-elim-right-form)
     (let ((kernel (proof-in-tensor-elim-right-form-to-kernel prf)))
       (+ 1 (proof-to-size kernel))))
    ((proof-in-all-intro-form)
     (let ((kernel (proof-in-all-intro-form-to-kernel prf)))
       (+ 1 (proof-to-size kernel))))
    ((proof-in-all-elim-form)
     (let ((op (proof-in-all-elim-form-to-op prf)))
       (+ 1 (proof-to-size op))))
    ((proof-in-allnc-intro-form)
     (let ((kernel (proof-in-allnc-intro-form-to-kernel prf)))
       (+ 1 (proof-to-size kernel))))
    ((proof-in-allnc-elim-form)
     (let ((op (proof-in-allnc-elim-form-to-op prf)))
       (+ 1 (proof-to-size op))))
    (else (myerror "proof-to-size: proof tag expected" (tag prf)))))

(define (size-and-depth tm)
    (begin
               (newline)
	 (display "***********************************************")
	 (newline)
	 (display "Depth of term is ") 
	 (display (term-to-depth tm))
	 (newline)
	 (display "Size of term is ") 
	 (display (term-to-size tm))
	 (newline)
	 (display "***********************************************")
	 (newline)
	 ))

(define (term-to-depth tm)
  (case (tag tm)
    ((term-in-var-form term-in-const-form) 0)
    ((term-in-abst-form)
       (+ 1 (term-to-depth (term-in-abst-form-to-kernel tm))))
    ((term-in-app-form)
     (+ 1 (max 
	    (term-to-depth (term-in-app-form-to-op tm))
	    (term-to-depth (term-in-app-form-to-arg tm)))))
    ((term-in-pair-form)
     (+ 1 (max 
	   (term-to-depth (term-in-pair-form-to-left tm))
	   (term-to-depth (term-in-pair-form-to-right tm)))))
    ((term-in-lcomp-form)
     (+ 1
	(term-to-depth (term-in-lcomp-form-to-kernel tm))))
    ((term-in-rcomp-form)
     (+ 1
      (term-to-depth (term-in-rcomp-form-to-kernel tm))))
    ((term-in-if-form)
     (begin
       ; (nldisplay "ATTENTION: term-to-depth: if-form detected")
     (+ 1 (max (term-to-depth (term-in-if-form-to-test tm))
	       (apply max (map term-to-depth
			       (term-in-if-form-to-alts tm)))))))
    (else (myerror "default-term-to-depth: term expected" tm))))


(define (term-to-size tm)
  (case (tag tm)
    ((term-in-var-form term-in-const-form) 1)
    ((term-in-abst-form)
       (+ 1 (term-to-size (term-in-abst-form-to-kernel tm))))
    ((term-in-app-form)
     (+ 1 (+ 
	    (term-to-size (term-in-app-form-to-op tm))
	    (term-to-size (term-in-app-form-to-arg tm)))))
    ((term-in-pair-form)
     (+ 1 (+ 
	   (term-to-size (term-in-pair-form-to-left tm))
	   (term-to-size (term-in-pair-form-to-right tm)))))
    ((term-in-lcomp-form)
     (+ 1
	(term-to-size (term-in-lcomp-form-to-kernel tm))))
    ((term-in-rcomp-form)
     (+ 1
      (term-to-size (term-in-rcomp-form-to-kernel tm))))
    ((term-in-if-form)
     (begin
       ; (nldisplay "ATTENTION: term-to-size: if-form detected")
     (+ 1 (+ (term-to-size (term-in-if-form-to-test tm))
	       (apply + (map term-to-size
			       (term-in-if-form-to-alts tm)))))))
    (else (myerror "default-term-to-size: term expected" tm))))

(define (term-to-sad tm)
  (case (tag tm)
    ((term-in-var-form term-in-const-form) (cons 1 0))
    ((term-in-abst-form)
       (let*((ker (term-in-abst-form-to-kernel tm))
	     (sad (term-to-sad ker))
	     (s (+ 1 (car sad)))
	     (d (+ 1 (cdr sad))))
	 (cons s d)))
    ((term-in-app-form)
       (let*((op (term-in-app-form-to-op tm))
	     (sad_op (term-to-sad op))
	     (s_op (car sad_op))
	     (d_op (cdr sad_op))
	     (arg (term-in-app-form-to-arg tm))
	     (sad_arg (term-to-sad arg))
	     (s_arg (car sad_arg))
	     (d_arg (cdr sad_arg))
	     (s (+ 1 (+ s_op s_arg)))
	     (d (+ 1 (max d_op d_arg))))
	 (cons s d)))
    ((term-in-pair-form)
       (let*((op (term-in-pair-form-to-right tm))
	     (sad_op (term-to-sad op))
	     (s_op (car sad_op))
	     (d_op (cdr sad_op))
	     (arg (term-in-pair-form-to-left tm))
	     (sad_arg (term-to-sad arg))
	     (s_arg (car sad_arg))
	     (d_arg (cdr sad_arg))
	     (s (+ 1 (+ s_op s_arg)))
	     (d (+ 1 (max d_op d_arg))))
	 (cons s d)))
    ((term-in-lcomp-form)
       (let*((ker (term-in-lcomp-form-to-kernel tm))
	     (sad (term-to-sad ker))
	     (s (+ 1 (car sad)))
	     (d (+ 1 (cdr sad))))
	 (cons s d)))
    ((term-in-rcomp-form)
        (let*((ker (term-in-rcomp-form-to-kernel tm))
	     (sad (term-to-sad ker))
	     (s (+ 1 (car sad)))
	     (d (+ 1 (cdr sad))))
	 (cons s d)))
    ((term-in-if-form)
       (myerror "term-to-sad: if-form detected"))
;      (begin
;        (nldisplay "ATTENTION: term-to-sad: if-form detected")
;      (+ 1 (+ (term-to-sad (term-in-if-form-to-test tm))
; 	       (apply + (map term-to-sad
; 			       (term-in-if-form-to-alts tm)))))))
    (else (myerror "default-term-to-sad: term expected" tm))))
   
(newline)
(display "******************************************************")
(newline)
(display "*****    DIALECTICA Interpretations extraction module LOADED !!!")
(newline)
(display "******************************************************")
(newline)


