;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  MDH - updated 071118; created very long time ago ...
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(newline)
(display "**********************************************************")
(newline)
(display "******  Begin loading DIALECTICA special module for Induction AXIOM  ...")
(newline)
(display "**********************************************************")
(newline)

;; The "DEBUG-IND-AX" flag decides whether a debug-level
;; of messages is active or not in connection with
;; the treatment of the Induction Axiom IA. 
(define DEBUG-IND-AX #f)
(comment "*** DEBUG-IND-AX flag set to FALSE ***")

(define (DIA-IndAx-extract KIND aconst)
    (begin
               (if CHECK
                   (if (not-null? (cdr 
		   (aconst-to-repro-formulas aconst)))
                       (myerror
                         "DIA-extr-vatmpair:  Ind - only" 
                         "one universal formula allowed")))
               (let*((Ind-fmla (aconst-to-inst-formula aconst))
                          (variab (all-form-to-var Ind-fmla))		     
                     (typ (var-to-type variab))
                     (LEGDUM
                       (if CHECK
                           (begin
                             (if (not (alg-form? typ))
                                 (myerror
                                   "DIA-extr-vatmpair:  Ind " 
                                   "- only nat algebra allowed"))
                             (if (not (string=? "nat"
                                        (alg-form-to-name typ)))
                                 (myerror
                                   "DIA-extr-vatmpair:  Ind - " 
                                   "only nat algebra allowed")))))
                     (LEGDUM
                       (if DEBUG
                           (nldisplay
                             "PROOF-IN-IND-FORM")))
                     (kernel (imp-form-to-conclusion
		           (imp-form-to-conclusion
			 (all-form-to-kernel Ind-fmla))))
                     (tvariab
                       (make-term-in-var-form variab))
                     (base
                       (formula-subst
                         kernel variab (pt "0")))
                     (step
                       (make-imp kernel
                         (formula-subst kernel variab
                           (make-term-in-app-form
                             (pt "Succ") tvariab))))
                     (assumpt
                       (make-and base
                         (make-all variab step)))
                     (P1
                       (let((avar
                              (formula-to-new-avar assumpt)))  
                         (make-proof-in-imp-intro-form avar 
                           (make-proof-in-and-elim-left-form
                             (make-proof-in-avar-form avar)))))
                     (LEGDUM
                       (if DEBUG
                           (nldisplay
                             "IND - P1 is now treated")))
                     (vatmpr1
                       (Ind-extracted-vatmpair KIND P1))
                     (LEGDUM
                       (if DEBUG
                           (nldisplay
                             "IND - P1 treatment finished")))
                     (Q
                       (let((avar
                              (formula-to-new-avar assumpt)))  
                         (make-proof-in-imp-intro-form avar
                           (make-proof-in-all-elim-form 
                             (make-proof-in-and-elim-right-form
                               (make-proof-in-avar-form avar))
                             tvariab))))
                     (P2
                       (let((avarC
                              (formula-to-new-avar assumpt)) 
                            (avarCAz
                              (formula-to-new-avar 
                                (make-imp assumpt kernel))))
                         (make-proof-in-all-intro-form
                           variab  
                           (make-proof-in-imp-intro-form
                             avarCAz 
                             (make-proof-in-imp-intro-form
                               avarC  
                               (make-proof-in-imp-elim-form
                                 (make-proof-in-imp-elim-form
                                   Q  
                                   (make-proof-in-avar-form
                                     avarC))
                                 (make-proof-in-imp-elim-form 
                                   (make-proof-in-avar-form
                                     avarCAz)
                                   (make-proof-in-avar-form
                                     avarC))))))))
                     (LEGDUM
                       (if DEBUG
                           (nldisplay
                             "IND - P2 is now treated")))
                     (vatmpr2
                       (Ind-extracted-vatmpair KIND P2))
                     (LEGDUM
                       (if DEBUG
                           (nldisplay
                             "IND - P2 treatment finished")))
                     (yp
                       (vapair-left
                         (vatmpair-to-vapair vatmpr1)))
                     (Tp
                       (tmpair-to-tuple
                         (vatmpair-to-tmpair vatmpr1)))
                    (Tp-List (tmtuple-to-tmlist Tp))
                     (star-tytup
                       (tmtuple-to-tytuple Tp))
                     (tm-Tp (DIA-tmtuple-to-star Tp))
                     (star_typ (term-to-type tm-Tp))
                     (Ts
                       (tmtuple-right
                         (tmpair-to-tuple
                           (vatmpair-to-tmpair vatmpr2))))
                    (Ts-List (tmtuple-to-tmlist (tmpair-to-tuple
                           (vatmpair-to-tmpair vatmpr2))))
                     (vapa
                       (vapair-left
                         (vatmpair-to-vapair vatmpr2)))
                     (z (vatuple-left vapa))
                     (va-z (vatuple-to-var z))
                     (tmtup-z (vatuple-to-tmtuple z))
                     (tm-z (tmtuple-to-term tmtup-z))
                     (typ_z (term-to-type tm-z))
                     (LEGDUM
                       (if PARANOIA
                           (if (not (alg-form? typ_z))
                               (myerror
                                 "DIA-extr-vatmpair: " 
                                 "Ind - nat type expected"))))
                     (LEGDUM
                       (if PARANOIA
                           (if (not (string=? "nat"
                                      (alg-form-to-name typ_z)))
                               (myerror
                                 "DIA-extr-vatmpair: " 
                                 "Ind - nat type expected"))))
                     (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))
                     (tmtup-zys
                       (tmtuple-append
                         tmtup-z unfld-ys "Ind"))
                     (tmtup-Ts
                       (make-tmtuple-in-app-form
                         Ts tmtup-zys))
                    (tm-Ts
                       (make-term-in-abst-form va-z
                         (make-term-in-abst-form fld-ys
                           (DIA-tmtuple-to-star tmtup-Ts))))
                     (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 tm-Tp)
                         tm-Ts))
                     (tmtup-T
                       (DIA-star-to-tmtuple
                         (make-term-in-app-form tm-T tm-z)
                         star-tytup))
                    (x
                       (tytuple-to-vatuple
                         (typair-left
                           (DIA-formula-to-typair KIND assumpt))))
                     (y
                       (tytuple-to-vatuple
                         (typair-right
                           (DIA-formula-to-typair KIND kernel))))
                     (tmtup-x (vatuple-to-tmtuple x))
                     (xz (vatuple-append x z "Ind 1"))
                     (real-T
                       (DIA-tmtuple-assoc
                         (make-tmtuple-in-abst-form xz 
                           (make-tmtuple-in-app-form tmtup-T
                             tmtup-x))))
                     (zy (vatuple-append z y "Ind 2"))
                     (xzy
                       (vatuple-assoc
                         (vatuple-append x zy "Ind 3")))
; ; ;                      (dp (Ind-NC (proof-to-formula prf)
; ; ;                            xzy real-T))
; ; ;                      (LEGDUM
; ; ;                        (if PARANOIA
; ; ;                            (let((freeT
; ; ;                                   (tmtuple-to-free (cdr dp))))
; ; ;                              (if (not-null? freeT)
; ; ;                                  (myerror
; ; ;                                    "DIA-extr-vatmpair: "
; ; ;                                    "realizing terms for Ind"
; ; ;                                    "must be closed"
; ; ;                                    (formula-to-string
; ; ;                                      (proof-to-formula prf))
; ; ;                                    "Illegal free variables: "
; ; ;                                    (valist-to-string freeT)
; ; ;                                    "Kernel formula is"
; ; ;                                    (formula-to-string kernel))))))
                     (rv (make-vatmpair
                           (make-vapair xzy
                             NULL_vatup) 
                           (make-tmpair real-T
                             NULL_tmtupalst))))
; ; ;                      (LEGDUM
; ; ;                        (DIA-tyva-check KIND prf
; ; ;                          (proof-to-formula prf) 
; ; ;                          rv "Ind")))
                 rv)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; The code below is needed for closing the IA extracted term
;;;; relative to the free variables of the induction formula, which
;;;; were closed by allnc instead of all -- MDH 071117
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ; ; (define (Ind-NC fmla vatup tmtup)
; ; ;   (if (not-DIA-formula? fmla)
; ; ;       (myerror "Ind-NC: first argument"
; ; ;         "must be a formula" fmla)
; ; ;       (if (not-vatuple? vatup)
; ; ;           (myerror "Ind-NC: 2nd argument"
; ; ;             "must be a vatuple" vatup)
; ; ;           (if (not-tmtuple? tmtup)
; ; ;               (myerror "Ind-NC: 2nd argument"
; ; ;                 "must be a tmtuple" tmtup)
; ; ;               (Ind-NC-aux fmla vatup tmtup)))))
; ; ; (define (Ind-NC-aux fmla vatup tmtup)              
; ; ;   (if (allnc-form? fmla)
; ; ;       (let*((dp (Ind-NC-aux
; ; ;                   (allnc-form-to-kernel fmla)
; ; ;                   vatup tmtup))
; ; ;             (vat (car dp))
; ; ;             (tmt (cdr dp))
; ; ;             (var (var-to-vatuple
; ; ;                    (allnc-form-to-var fmla)))
; ; ;             (new-vat
; ; ;               (vatuple-append var vat "Ind-NC"))
; ; ;             (new-tmt
; ; ;               (make-tmtuple-in-abst-form
; ; ;                 var tmt)))
; ; ;         (cons new-vat new-tmt))
; ; ;       (cons vatup tmtup)))

(newline)
(display "******************************************************")
(newline)
(display "*****    DIALECTICA special module for Induction Axiom LOADED !!!")
(newline)
(display "******************************************************")
(newline)