; $Id: gcd-gind.scm 2156 2008-01-25 13:25:12Z schimans $

; GCD with general induction, and correspondingly general recursion in
; the extracted terms.  Both A-translation and Dialectica
; interpretation are employed, on the same proof.  All this is based
; on work of Trifon Trifonov and Simon Huber.

; We begin with the Dialectica interpretation, closely following the
; hand formalization of the gcd-proof in conmat07/find07.  Extending
; previous treatments we use a proper definition of Quot and Rem and
; also provide totality proofs.

; (load "~/minlog/init.scm")
(set! DOT-NOTATION #f)
(set! COMMENT-FLAG #f)
(libload "nat.scm")
(set! COMMENT-FLAG #t)

(add-var-name "a" "b" "c" "q" "r" "l" (py "nat"))
(add-var-name "p" (py "nat@@nat"))

; Quot and Rem are quotient and remainder for natural numbers.  Step
; is an auxiliary function such that

;    Step a1 a2 k1 k2 q = q*k1-1 if k2*a2<k1*a1 and 0<q
;                         q*k1+1 otherwise

; Lin a1 a2 k1 k2 means |k1*a1 - k2*a2|


(add-program-constant "Quot" (py "nat=>nat=>nat") t-deg-zero)
(add-program-constant "Rem" (py "nat=>nat=>nat") t-deg-zero)
(add-program-constant "QuotRem" (py "nat=>nat=>nat@@nat") t-deg-zero)
(add-program-constant "QuotRemAux" (py "nat=>nat@@nat=>nat@@nat") t-deg-zero)

(add-computation-rule
 (pt "QuotRemAux n p")
 (pt "[if (Succ right p<n) (left p@Succ right p) (Succ left p@0)]"))

; "QuotRemAuxTotal"
(set-goal (pf "Total QuotRemAux"))
(use "Total")
(use "All-AllPartial")
(assume "n")
(use "Total" 'right)
(use "All-AllPartial")
(assume "p")
(ng)
(cases (pt "Succ right p<n"))
(assume "u1")
(drop "u1")
(ng)
(use "Total-Pair")
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "Truth-Axiom")
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "Truth-Axiom")
(assume "u1")
(drop "u1")
(ng)
(use "Total-Pair")
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "Truth-Axiom")
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "Truth-Axiom")
; Proof finished.
(save "QuotRemAuxTotal")

(add-computation-rule  (pt "QuotRem 0 n") (pt "0@0"))
(add-computation-rule (pt "QuotRem(Succ m)n")
		      (pt "QuotRemAux n(QuotRem m n)")) 

; "QuotRemTotal"
(set-goal (pf "Total QuotRem"))
(use "Total")
(use "All-AllPartial")
(assume "m")
(use "Total" 'right)
(use "All-AllPartial")
(assume "n")
(ind (pt "m"))
; Base
(ng)
(use "Total-Pair")
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "Truth-Axiom")
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "Truth-Axiom")
; Step
(assume "m1" "IH")
(ng)
(cases (pt "(Succ right(QuotRem m1 n)<n)"))
; first case
(assert (pf "Total(right(QuotRem m1 n))"))
  (use "Total-Proj")
  (use "IH")
(assume "u1")
(assert (pf "E right(QuotRem m1 n)"))
  (use (make-proof-in-aconst-form (finalg-to-total-to-e-aconst (py "nat"))))
  (use "u1")
  (drop "u1")
(assume "u2")
(assert (pf "E(Succ right(QuotRem m1 n))"))
  (use "u2")
  (drop "u2")
(assume "u3")
(use (make-proof-in-aconst-form (finalg-to-total-to-e-aconst (py "boole"))))
(use "Total")
(use "Total")
(use "NatLtTotal")
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "u3")
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "Truth-Axiom")
(ng)
(assume "u1")
(use "Total-Pair")
(use "Total-Proj")
(use "IH")
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(ng)
(use (make-proof-in-aconst-form (finalg-to-total-to-e-aconst (py "nat"))))
(use "Total-Proj")
(use "IH")

; second case
(assume "u1")
(ng)
(assert (pf "Total(left(QuotRem m1 n))"))
  (use "Total-Proj")
  (use "IH")
(assume "u")
(use "Total-Pair")
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(ng)
(use (make-proof-in-aconst-form (finalg-to-total-to-e-aconst (py "nat"))))
(use "u")
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "Truth-Axiom")
; Proof finished.
(save "QuotRemTotal")

(add-computation-rule (pt "Quot m n") (pt "left(QuotRem m n)"))

; QuotTotal
(set-goal (pf "Total Quot"))
(use "Total")
(use "All-AllPartial")
(assume "m")
(use "Total" 'right)
(use "All-AllPartial")
(assume "n")
(ng)
(use "Total-Proj")
(use "Total")
(use "Total")
(use "QuotRemTotal")
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "Truth-Axiom")
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "Truth-Axiom")
; Proof finished.
(save "QuotTotal")

(add-computation-rule (pt "Rem m n") (pt "right(QuotRem m n)"))

; RemTotal
(set-goal (pf "Total Rem"))
(use "Total")
(use "All-AllPartial")
(assume "m")
(use "Total" 'right)
(use "All-AllPartial")
(assume "n")
(ng)
(use "Total-Proj")
(use "Total")
(use "Total")
(use "QuotRemTotal")
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "Truth-Axiom")
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "Truth-Axiom")
; Proof finished.
(save "RemTotal")

; (pp (nt (pt "QuotRem 777 13")))

; "QuotRemCorrect"
(set-goal (pf "all m,n(0<m -> n=m*(left(QuotRem n m))+right(QuotRem n m) &
                              right(QuotRem n m)<m)"))
(assume "m")
(ind)
(ng)
(assume "u")
(split)
(use "Truth-Axiom")
(use "u")
(assume "n" "IH")
(assume "0<m")
(use "NatLeCases" (pt "m") (pt "Succ right(QuotRem n m)"))
(use "NatLtToSuccLe")
(use "IH")
(use "0<m")
(assume "Sr<m")
(split)
(ng)
(simp "Sr<m")
(ng)
(use-with "IH" "0<m" 'left)
(ng)
(simp "Sr<m")
(ng)
(use "Sr<m")
(assume "Sr=m")
(split)
(ng)
(simp "Sr=m")
(ng)
(assert (pf "Succ n=m*left(QuotRem n m)+Succ right(QuotRem n m)"))
  (use "IH")
  (use "0<m")
(simp "Sr=m")
(assume "u")
(use "u")
(ng)
(simp "Sr=m")
(use "0<m")
; Proof finished.
(save "QuotRemCorrect")

(add-program-constant "Lin" (py "nat=>nat=>nat=>nat=>nat") t-deg-zero)
(add-computation-rule (pt "Lin a1 a2 0 k2") (pt "k2*a2"))
(add-computation-rule
 (pt "Lin a1 a2(Succ k1)k2")
 (pt "[if (k2*a2<(k1+1)*a1) ((k1+1)*a1--k2*a2) (k2*a2--(k1+1)*a1)]"))


; "LinTotal"
(set-goal (pf "Total Lin"))
(use "Total")
(use "All-AllPartial")
(assume "a1")
(use "Total" 'right)
(use "All-AllPartial")
(assume "a2")
(use "Total" 'right)
(use "All-AllPartial")
(assume "k1")
(use "Total" 'right)
(use "All-AllPartial")
(assume "k2")
(cases (pt "k1"))
(assume "u1")
(drop "u1")
(ng)
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "Truth-Axiom")
(assume "k" "k1=Sk")
(drop "k1=Sk")
(ng)
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "Truth-Axiom")
; Proof finished.
(save "LinTotal")


(add-program-constant "Step" (py "nat=>nat=>nat=>nat=>nat=>nat") t-deg-zero)
(add-computation-rule (pt "Step a1 a2 k1 k2 0") (pt "1"))

(add-computation-rule
 (pt "Step a1 a2 k1 k2(Succ q)")
 (pt "[if (k2*a2<k1*a1) ((q+1)*k1--1) ((q+1)*k1+1)]"))


; "StepTotal"
(set-goal (pf "Total Step"))
(use "Total")
(use "All-AllPartial")
(assume "a1")
(use "Total" 'right)
(use "All-AllPartial")
(assume "a2")
(use "Total" 'right)
(use "All-AllPartial")
(assume "k1")
(use "Total" 'right)
(use "All-AllPartial")
(assume "k2")
(use "Total" 'right)
(use "All-AllPartial")
(assume "q")
(cases (pt "q"))
(assume "u1")
(drop "u1")
(ng)
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "Truth-Axiom")
(assume "q1" "u2")
(drop "u2")
(ng)
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "nat"))))
(use "Truth-Axiom")
; Proof finished.
(save "StepTotal")


; "StepLemma"
(set-goal
 (pf "all a1,a2,k1,k2,q,r(
      a1=q*Lin a1 a2 k1 k2+r -> Lin a1 a2(Step a1 a2 k1 k2 q)(q*k2)=r)"))
(assume "a1" "a2" "k1" "k2" "q" "r" "u1")
(cases (pt "q"))
; Case q=0
(assume "q=0")
(ng)
(simphyp "u1" "q=0")
(ng)
(simp 3)
(cases (pt "r"))
(assume "Trivial")
(use "Truth-Axiom")
(assume "r1" "u2")
(use "Truth-Axiom")
; Case q=Sq1
(assume "q1" "q=Sq1")
(ng)
(cases (pt "k2*a2<k1*a1"))
(assume "k2*a2<k1*a1")
(ng)
(admit)
(assume "k2*a2<k1*a1 -> F")
(ng)
(admit)
; "Proof" finished.


; "LS1" or "StepLemma1"
(add-global-assumption
 "LS1"
 (pf "all a1,a2,k1,k2,q,r(
       a1=q*Lin a1 a2 k1 k2+r -> r=Lin a1 a2(Step a1 a2 k1 k2q)(q*k2))"))

; "LS2" or "StepLemma2"
(add-global-assumption
 "LS2"
 (pf "all a1,a2,k1,k2,q,r(
       a2=q*Lin a1 a2 k1 k2+r -> r=Lin a1 a2(q*k1)(Step a2 a1 k2 k1 q))"))

(add-global-assumption "L1" (pf "all r,l(r=l -> (0<l -> F) -> r=0)"))
(add-global-assumption "L2" (pf "all r,l,k(r=l -> r<k -> l<k)"))

; "QuotRemCorr"
(set-goal (pf "all a,b(0<b -> a=Quot a b*b+Rem a b & Rem a b<b)"))
(assume "a" "b" "0<b")
(ind (pt "a"))
(ng)
(split)
(use "Truth-Axiom")
(use "0<b")
(assume "a1" "IH")
(use "NatLeCases" (pt "b") (pt "Succ right(QuotRem a1 b)"))
(use "NatLtToSuccLe")
(use "IH")
(assume "Sr<b")
(split)
(ng)
(simp "Sr<b")
(ng)
(use-with "IH" 'left)
(ng)
(simp "Sr<b")
(ng)
(use "Sr<b")
(assume "Sr=b")
(split)
(ng)
(simp "Sr=b")
(ng)
(assert (pf "Succ a1=left(QuotRem a1 b)*b+Succ right(QuotRem a1 b)"))
  (use "IH")
(simp "Sr=b")
(assume "u")
(use "u")
(ng)
(simp "Sr=b")
(use "0<b")
; Proof finished.
(save "QuotRemCorr")


; "LQ" or "QuotRemCor"
(set-goal (pf "all a,b(0<b -> a=Quot a b*b+Rem a b)"))
(assume "a" "b" "0<b")
(use "QuotRemCorr")
(use "0<b")
; Proof finished.
(save "LQ")

; "LR" or "RemCor"
(set-goal (pf "all a,b(0<b -> Rem a b<b)"))
(assume "a" "b" "0<b")
(use "QuotRemCorr")
(use "0<b")
; Proof finished.
(save "LR")


; Now the Gcd proof with &, following the hand implementation.
(set-goal
 (pf "all a1,a2(0<a2 -> 
                exca k1,k2(
                 0<Lin a1 a2 k1 k2 ! 
                 Rem a1(Lin a1 a2 k1 k2)=0 &
                 Rem a2(Lin a1 a2 k1 k2)=0))"))
(assume "a1" "a2" "v0" "u")
(use-with "u" (pt "0") (pt "1") "v0" "?")
(use-with (make-proof-in-aconst-form
	   (all-formula-to-gind-aconst
	    (pf "all k1,k2(
                 0<Lin a1 a2 k1 k2 -> 
                 Rem a1(Lin a1 a2 k1 k2)=0 & Rem a2(Lin a1 a2 k1 k2)=0)")
	    2))
	  (pt "a1") (pt "a2")
	  (pt "[k1,k2]Lin a1 a2 k1 k2") (pt "0") (pt "1")
	  "?" ;for progressiveness
	  (pt "True") (make-proof-in-aconst-form truth-aconst) ;for the guard
	  "v0")
(ng)
(assume "k1" "k2" "u1" "u2")	  
(split)

; We first show Rem a1(Lin a1 a2 k1 k2)=0
(use-with
 "L1" (pt "Rem a1(Lin a1 a2 k1 k2)")
 (pt "Lin a1 a2
 (Step a1 a2 k1 k2(Quot a1(Lin a1 a2 k1 k2)))(Quot a1(Lin a1 a2 k1 k2)*k2)")
 "?" "?")
(use-with
 "LS1" (pt "a1") (pt "a2") (pt "k1") (pt "k2")
 (pt "Quot a1(Lin a1 a2 k1 k2)") (pt "Rem a1(Lin a1 a2 k1 k2)") "?")
(use-with "LQ" (pt "a1") (pt "Lin a1 a2 k1 k2") "u2")

(assume "w")
(use-with "u" (pt "Step a1 a2 k1 k2(Quot a1(Lin a1 a2 k1 k2))")
	  (pt "Quot a1(Lin a1 a2 k1 k2)*k2") "w" "?")
(use-with "u1" (pt "Step a1 a2 k1 k2(Quot a1(Lin a1 a2 k1 k2))")
	  (pt "Quot a1(Lin a1 a2 k1 k2)*k2") "?" "w")
(use-with
 "L2" (pt "Rem a1(Lin a1 a2 k1 k2)")
 (pt "Lin a1 a2
 (Step a1 a2 k1 k2(Quot a1(Lin a1 a2 k1 k2)))(Quot a1(Lin a1 a2 k1 k2)*k2)")
 (pt "Lin a1 a2 k1 k2")
 "?" "?")
(use-with
 "LS1" (pt "a1") (pt "a2") (pt "k1") (pt "k2")
 (pt "Quot a1(Lin a1 a2 k1 k2)") (pt "Rem a1(Lin a1 a2 k1 k2)") "?")
(use-with "LQ" (pt "a1") (pt "Lin a1 a2 k1 k2") "u2")

(use-with "LR" (pt "a1") (pt "Lin a1 a2 k1 k2") "u2")

; We now show Rem a2(Lin a1 a2 k1 k2)=0
(use-with
 "L1" (pt "Rem a2(Lin a1 a2 k1 k2)")
 (pt "Lin a1 a2
 (Quot a2(Lin a1 a2 k1 k2)*k1)(Step a2 a1 k2 k1(Quot a2(Lin a1 a2 k1 k2)))")
 "?" "?")
(use-with
 "LS2" (pt "a1") (pt "a2") (pt "k1") (pt "k2")
 (pt "Quot a2(Lin a1 a2 k1 k2)") (pt "Rem a2(Lin a1 a2 k1 k2)") "?")
(use-with "LQ" (pt "a2") (pt "Lin a1 a2 k1 k2") "u2")

(assume "w")
(use-with "u" (pt "Quot a2(Lin a1 a2 k1 k2)*k1")
	  (pt "Step a2 a1 k2 k1(Quot a2(Lin a1 a2 k1 k2))") "w" "?")

(use-with "u1" (pt "Quot a2(Lin a1 a2 k1 k2)*k1")
	  (pt "Step a2 a1 k2 k1(Quot a2(Lin a1 a2 k1 k2))") "?" "w")

(use-with
 "L2" (pt "Rem a2(Lin a1 a2 k1 k2)")
 (pt "Lin a1 a2
 (Quot a2(Lin a1 a2 k1 k2)*k1)(Step a2 a1 k2 k1(Quot a2(Lin a1 a2 k1 k2)))")
 (pt "Lin a1 a2 k1 k2")
 "?" "?")

(use-with
 "LS2" (pt "a1") (pt "a2") (pt "k1") (pt "k2")
 (pt "Quot a2(Lin a1 a2 k1 k2)") (pt "Rem a2(Lin a1 a2 k1 k2)") "?")
(use-with "LQ" (pt "a2") (pt "Lin a1 a2 k1 k2") "u2")

(use-with "LR" (pt "a2") (pt "Lin a1 a2 k1 k2") "u2")
; Proof finished.
(save "GcdAnd")

(proof-to-expr-with-aconsts (theorem-name-to-proof "GcdAnd"))

; Assumption constants:
; GInd: allnc a1,a2 
;    all (nat=>nat=>nat)_2296,n2297,n2298(
;     all n2297,n2298(
;      all n2299,n2300(
;       (nat=>nat=>nat)_2296 n2299 n2300<(nat=>nat=>nat)_2296 n2297 n2298 -> 
;       0<Lin a1 a2 n2299 n2300 -> 
;       Rem a1(Lin a1 a2 n2299 n2300)=0 & Rem a2(Lin a1 a2 n2299 n2300)=0) -> 
;      0<Lin a1 a2 n2297 n2298 -> 
;      Rem a1(Lin a1 a2 n2297 n2298)=0 & Rem a2(Lin a1 a2 n2297 n2298)=0) -> 
;     allnc boole(
;      boole -> 
;      0<Lin a1 a2 n2297 n2298 -> 
;      Rem a1(Lin a1 a2 n2297 n2298)=0 & Rem a2(Lin a1 a2 n2297 n2298)=0))
; L1: all r,l(r=l -> (0<l -> F) -> r=0)
; LS1: all a1,a2,k1,k2,q,r(
;    a1=q*Lin a1 a2 k1 k2+r -> r=Lin a1 a2(Step a1 a2 k1 k2 q)(q*k2))
; LQ: all a,b(0<b -> a=Quot a b*b+Rem a b)
; L2: all r,l,k(r=l -> r<k -> l<k)
; LR: all a,b(0<b -> Rem a b<b)
; LS2: all a1,a2,k1,k2,q,r(
;    a2=q*Lin a1 a2 k1 k2+r -> r=Lin a1 a2(q*k1)(Step a2 a1 k2 k1 q))
; Truth-Axiom: T

#|
(lambda (a1)
  (lambda (a2)
    (lambda (v0995)
      (lambda (u996)
        ((((u996 0) 1) v0995)
          (((((((((|GInd| a1) a2)
                  (lambda (k1) (lambda (k2) ((((|Lin| a1) a2) k1) k2))))
                 0)
                1)
               (lambda (k1)
                 (lambda (k2)
                   (lambda (u1999)
                     (lambda (u21000)
                       (cons
                         ((((|L1|
                              (cdr ((|QuotRem| a1)
                                     ((((|Lin| a1) a2) k1) k2))))
                             ((((|Lin| a1) a2)
                                (((((|Step| a1) a2) k1) k2)
                                  (quotient a1 ((((|Lin| a1) a2) k1) k2))))
                               (* (quotient a1 ((((|Lin| a1) a2) k1) k2))
                                  k2)))
                            (((((((|LS1| a1) a2) k1) k2)
                                (quotient a1 ((((|Lin| a1) a2) k1) k2)))
                               (modulo a1 ((((|Lin| a1) a2) k1) k2)))
                              (((|LQ| a1) ((((|Lin| a1) a2) k1) k2))
                                u21000)))
                           (lambda (w1006)
                             ((((u996
                                  (((((|Step| a1) a2) k1) k2)
                                    (quotient
                                      a1
                                      ((((|Lin| a1) a2) k1) k2))))
                                 (* (quotient a1 ((((|Lin| a1) a2) k1) k2))
                                    k2))
                                w1006)
                               ((((u1999
                                    (((((|Step| a1) a2) k1) k2)
                                      (quotient
                                        a1
                                        ((((|Lin| a1) a2) k1) k2))))
                                   (* (quotient
                                        a1
                                        ((((|Lin| a1) a2) k1) k2))
                                      k2))
                                  (((((|L2|
                                        (modulo
                                          a1
                                          ((((|Lin| a1) a2) k1) k2)))
                                       ((((|Lin| a1) a2)
                                          (((((|Step| a1) a2) k1) k2)
                                            (quotient
                                              a1
                                              ((((|Lin| a1) a2) k1) k2))))
                                         (* (quotient
                                              a1
                                              ((((|Lin| a1) a2) k1) k2))
                                            k2)))
                                      ((((|Lin| a1) a2) k1) k2))
                                     (((((((|LS1| a1) a2) k1) k2)
                                         (quotient
                                           a1
                                           ((((|Lin| a1) a2) k1) k2)))
                                        (modulo
                                          a1
                                          ((((|Lin| a1) a2) k1) k2)))
                                       (((|LQ| a1)
                                          ((((|Lin| a1) a2) k1) k2))
                                         u21000)))
                                    (((|LR| a1) ((((|Lin| a1) a2) k1) k2))
                                      u21000)))
                                 w1006))))
                         ((((|L1| (modulo a2 ((((|Lin| a1) a2) k1) k2)))
                             ((((|Lin| a1) a2)
                                (* (quotient a2 ((((|Lin| a1) a2) k1) k2))
                                   k1))
                               (((((|Step| a2) a1) k2) k1)
                                 (quotient a2 ((((|Lin| a1) a2) k1) k2)))))
                            (((((((|LS2| a1) a2) k1) k2)
                                (quotient a2 ((((|Lin| a1) a2) k1) k2)))
                               (modulo a2 ((((|Lin| a1) a2) k1) k2)))
                              (((|LQ| a2) ((((|Lin| a1) a2) k1) k2))
                                u21000)))
                           (lambda (w1015)
                             ((((u996
                                  (* (quotient
                                       a2
                                       ((((|Lin| a1) a2) k1) k2))
                                     k1))
                                 (((((|Step| a2) a1) k2) k1)
                                   (quotient
                                     a2
                                     ((((|Lin| a1) a2) k1) k2))))
                                w1015)
                               ((((u1999
                                    (* (quotient
                                         a2
                                         ((((|Lin| a1) a2) k1) k2))
                                       k1))
                                   (((((|Step| a2) a1) k2) k1)
                                     (quotient
                                       a2
                                       ((((|Lin| a1) a2) k1) k2))))
                                  (((((|L2|
                                        (modulo
                                          a2
                                          ((((|Lin| a1) a2) k1) k2)))
                                       ((((|Lin| a1) a2)
                                          (* (quotient
                                               a2
                                               ((((|Lin| a1) a2) k1) k2))
                                             k1))
                                         (((((|Step| a2) a1) k2) k1)
                                           (quotient
                                             a2
                                             ((((|Lin| a1) a2) k1) k2)))))
                                      ((((|Lin| a1) a2) k1) k2))
                                     (((((((|LS2| a1) a2) k1) k2)
                                         (quotient
                                           a2
                                           ((((|Lin| a1) a2) k1) k2)))
                                        (modulo
                                          a2
                                          ((((|Lin| a1) a2) k1) k2)))
                                       (((|LQ| a2)
                                          ((((|Lin| a1) a2) k1) k2))
                                         u21000)))
                                    (((|LR| a2) ((((|Lin| a1) a2) k1) k2))
                                      u21000)))
                                 w1015))))))))))
              #t)
             |Truth-Axiom|)
            v0995))))))
|#

(define eterm-d-and
  (proof-to-extracted-d-term (theorem-name-to-proof "GcdAnd")))

; We need to block unfolding of GRecGuard (whose last argument will be
; True) to obtain a readable term:

(set! GRECGUARD-UNFOLDING-FLAG #f)
(define neterm-d-and (nt eterm-d-and))
(pp neterm-d-and)

#|
[n0,n1]
 [if (0<n1 impb 
       right(QuotRem n0 n1)=0 andb right(QuotRem n1 n1)=0 impb False)
   ((GRecGuard nat nat nat@@nat)(Lin n0 n1)0 1
   ([n2,n3,(nat=>nat=>nat@@nat)_4]
     [let p5
       [let p5
        (Step n0 n1 n2 n3 left(QuotRem n0(Lin n0 n1 n2 n3))@
        left(QuotRem n0(Lin n0 n1 n2 n3))*n3)
        [if (0<Lin n0 n1 left p5 right p5 impb 
             right(QuotRem n0(Lin n0 n1 left p5 right p5))=0 andb 
             right(QuotRem n1(Lin n0 n1 left p5 right p5))=0 impb 
             False)
         (left(QuotRem n1(Lin n0 n1 n2 n3))*n2@
         Step n1 n0 n3 n2 left(QuotRem n1(Lin n0 n1 n2 n3)))
         p5]]
       [if (0<Lin n0 n1 left p5 right p5 impb 
            right(QuotRem n0(Lin n0 n1 left p5 right p5))=0 andb 
            right(QuotRem n1(Lin n0 n1 left p5 right p5))=0 impb 
            False)
        [let p6
         [let p6
          (Step n0 n1 n2 n3 left(QuotRem n0(Lin n0 n1 n2 n3))@
          left(QuotRem n0(Lin n0 n1 n2 n3))*n3)
          [if (Lin n0 n1 left p6 right p6<Lin n0 n1 n2 n3 impb 
               0<Lin n0 n1 left p6 right p6 impb 
               right(QuotRem n0(Lin n0 n1 left p6 right p6))=0 andb 
               right(QuotRem n1(Lin n0 n1 left p6 right p6))=0)
           (left(QuotRem n1(Lin n0 n1 n2 n3))*n2@
           Step n1 n0 n3 n2 left(QuotRem n1(Lin n0 n1 n2 n3)))
           p6]]
         ((nat=>nat=>nat@@nat)_4 left p6 right p6)]
        p5]])
   True)
   (0@1)]
|#

(term-to-expr neterm-d-and)

#|
(lambda (n0)
  (lambda (n1)
    (if ((|ImpConst| (< 0 n1))
          ((|ImpConst|
             ((|AndConst| (= (cdr ((|QuotRem| n0) n1)) 0))
               (= (cdr ((|QuotRem| n1) n1)) 0)))
            #f))
        (((((natnatgrecguard ((|Lin| n0) n1)) 0) 1)
           (lambda (n2)
             (lambda (n3)
               (lambda (|(nat=>nat=>nat@@nat)_4|)
                 (let ([p5 (let ([p5 (cons
                                       (((((|Step| n0) n1) n2) n3)
                                         (car ((|QuotRem| n0)
                                                ((((|Lin| n0) n1) n2)
                                                  n3))))
                                       (* (car ((|QuotRem| n0)
                                                 ((((|Lin| n0) n1) n2)
                                                   n3)))
                                          n3))])
                             (if ((|ImpConst|
                                    (< 0
                                       ((((|Lin| n0) n1) (car p5))
                                         (cdr p5))))
                                   ((|ImpConst|
                                      ((|AndConst|
                                         (= (cdr ((|QuotRem| n0)
                                                   ((((|Lin| n0) n1)
                                                      (car p5))
                                                     (cdr p5))))
                                            0))
                                        (= (cdr ((|QuotRem| n1)
                                                  ((((|Lin| n0) n1)
                                                     (car p5))
                                                    (cdr p5))))
                                           0)))
                                     #f))
                                 (cons
                                   (* (car ((|QuotRem| n1)
                                             ((((|Lin| n0) n1) n2) n3)))
                                      n2)
                                   (((((|Step| n1) n0) n3) n2)
                                     (car ((|QuotRem| n1)
                                            ((((|Lin| n0) n1) n2) n3)))))
                                 p5))])
                   (if ((|ImpConst|
                          (< 0 ((((|Lin| n0) n1) (car p5)) (cdr p5))))
                         ((|ImpConst|
                            ((|AndConst|
                               (= (cdr ((|QuotRem| n0)
                                         ((((|Lin| n0) n1) (car p5))
                                           (cdr p5))))
                                  0))
                              (= (cdr ((|QuotRem| n1)
                                        ((((|Lin| n0) n1) (car p5))
                                          (cdr p5))))
                                 0)))
                           #f))
                       (let ([p6 (let ([p6 (cons
                                             (((((|Step| n0) n1) n2) n3)
                                               (car ((|QuotRem| n0)
                                                      ((((|Lin| n0) n1) n2)
                                                        n3))))
                                             (* (car ((|QuotRem| n0)
                                                       ((((|Lin| n0) n1)
                                                          n2)
                                                         n3)))
                                                n3))])
                                   (if ((|ImpConst|
                                          (< ((((|Lin| n0) n1) (car p6))
                                               (cdr p6))
                                             ((((|Lin| n0) n1) n2) n3)))
                                         ((|ImpConst|
                                            (< 0
                                               ((((|Lin| n0) n1) (car p6))
                                                 (cdr p6))))
                                           ((|AndConst|
                                              (= (cdr ((|QuotRem| n0)
                                                        ((((|Lin| n0) n1)
                                                           (car p6))
                                                          (cdr p6))))
                                                 0))
                                             (= (cdr ((|QuotRem| n1)
                                                       ((((|Lin| n0) n1)
                                                          (car p6))
                                                         (cdr p6))))
                                                0))))
                                       (cons
                                         (* (car ((|QuotRem| n1)
                                                   ((((|Lin| n0) n1) n2)
                                                     n3)))
                                            n2)
                                         (((((|Step| n1) n0) n3) n2)
                                           (car ((|QuotRem| n1)
                                                  ((((|Lin| n0) n1) n2)
                                                    n3)))))
                                       p6))])
                         ((|(nat=>nat=>nat@@nat)_4| (car p6)) (cdr p6)))
                       p5))))))
          #t)
        (cons 0 1))))
|#

(define (modulo-safe x y)
  (if (= y 0)
      0
      (modulo x y)))

(define (quotient-safe x y)
  (if (= y 0)
      0
      (quotient x y)))

(define (|QuotRem| x)
  (lambda (y)
    (cons (quotient-safe x y) (modulo-safe x y))))

(define (|Lin| a1)
  (lambda (a2)
    (lambda (k1)
      (lambda (k2)
	(abs (- (* k1 a1) (* k2 a2)))))))

;    Step(a1 a2 k1 k2 q) = q*k1-1 if k2*a2<k1*a1 and 0<q
;                          q*k1+1 otherwise

(define (|Step| a1)
  (lambda (a2)
    (lambda (k1)
      (lambda (k2)
	(lambda (q)
	  (if (and (< (* k2 a2) (* k1 a1)) (> q 0))
	      (- (* q k1) 1)
	      (+ (* q k1) 1)))))))
	      
(define (display-gcd gcd-term a1 a2)

  (define (h k)
    (abs (- (* a1 (car k)) (* a2 (cdr k)))))

  (display "GCD of ")
  (display a1)
  (display " and ")
  (display a2)
  (display " is ")
  (display (time (h (((ev (term-to-expr gcd-term)) a1) a2))))
  (newline))
	
; Tests

(display-gcd neterm-d-and 66 27)
(display-gcd neterm-d-and (* 1428 1151412) (* 1428 103723))
(display-gcd neterm-d-and (* 176478618764 12074918274841)
	     (* 176478618764 34974982375987))


; An attempt to do the same proof with A-translation breaks down
; because it does not cover conjunctions.  However, we can redo the
; proof without conjunctions.  Here we closely follow Trifon
; Trifonov's proposal.  The & in the goal is replaced by !.  Instead
; of conjunction introduction we use

; "AndIntroAux" or "L3"
(set-goal
 (pf "all r1,r2(
      ((r1=0 -> bot) -> bot) -> 
      ((r2=0 -> bot) -> bot) -> (r1=0 -> r2=0 -> bot) -> bot)"))
(assume "r1" "r2" "u1" "u2" "u")
(use "u1")
(assume "v1")
(use "u2")
(assume "v2")
(use "u")
(use "v1")
(use "v2")
; Proof finished.
(save "L3")

; Moreover we need
; "L1bot"
(set-goal (pf "all r,l(r=l -> (0<l -> bot) -> (r=0 -> bot) -> bot)"))
(assume "r")
(cases)
(assume "u1" "u2" "u3")
(use "u3")
(use "u1")
(assume "r1" "u1" "u2" "u3")
(use "u2")
(use "Truth-Axiom")
(save "L1bot")

; "Gcd"
(set-goal
 (pf "all a1,a2(
      0<a2 -> 
      excl k1,k2(
       0<Lin a1 a2 k1 k2 ! 
       (Rem a1(Lin a1 a2 k1 k2)=0 ! Rem a2(Lin a1 a2 k1 k2)=0)))"))
(assume "a1" "a2" "v0" "u")
(cut (pf "all k1,k2(
   0<Lin a1 a2 k1 k2 -> 
   (Rem a1(Lin a1 a2 k1 k2)=0 -> Rem a2(Lin a1 a2 k1 k2)=0 -> bot) -> bot)"))
(assume "u1")
(use "u1" (pt "0") (pt "1"))
(use "v0")
(use "u")
(use "v0")

(gind (mk-term-in-abst-form (pv "k1") (pv "k2") (pt "Lin a1 a2 k1 k2")))

(assume "k1" "k2" "u1" "u2")
(use "L3")

; Now we must show Rem a1(Lin a1 a2 k1 k2)=0.

(use "L1bot"
     (pt "Lin a1 a2(Step a1 a2 k1 k2(Quot a1(Lin a1 a2 k1 k2)))
                   (Quot a1(Lin a1 a2 k1 k2)*k2)"))
(use-with "LS1" (pt "a1") (pt "a2") (pt "k1") (pt "k2")
	  (pt "(Quot a1(Lin a1 a2 k1 k2))") (pt "Rem a1(Lin a1 a2 k1 k2)") "?")
(use "QuotRemCorr")
(use "u2")
(assume "w")
(use "u1" (pt "(Step a1 a2 k1 k2(Quot a1(Lin a1 a2 k1 k2)))")
     (pt "(Quot a1(Lin a1 a2 k1 k2))*k2"))
(ng)

(use "L2" (pt "Rem a1(Lin a1 a2 k1 k2)"))
(simp-with "LS1" (pt "a1") (pt "a2") (pt "k1") (pt "k2")
	   (pt "Quot a1(Lin a1 a2 k1 k2)") (pt "Rem a1(Lin a1 a2 k1 k2)") "?")
(use "Truth-Axiom")
(use "QuotRemCorr")
(use "u2")
(use "LR")
(use "u2")
(use "w")
(use "u")
(use "w")

; Now we must show Rem a2(Lin a1 a2 k1 k2)=0.
(use "L1bot"
     (pt "Lin a1 a2 ((Quot a2(Lin a1 a2 k1 k2))*k1)
                    (Step a2 a1 k2 k1(Quot a2(Lin a1 a2 k1 k2)))"))
(use-with "LS2" (pt "a1") (pt "a2") (pt "k1") (pt "k2")
	  (pt "Quot a2(Lin a1 a2 k1 k2)") (pt "Rem a2(Lin a1 a2 k1 k2)") "?")
(use "QuotRemCorr")
(use "u2")
(assume "w")
(use "u1" (pt "((Quot a2(Lin a1 a2 k1 k2))*k1)")
     (pt "Step a2 a1  k2 k1(Quot a2(Lin a1 a2 k1 k2))"))
(ng)
(use "L2" (pt "Rem a2(Lin a1 a2 k1 k2)"))
(simp-with "LS2" (pt "a1") (pt "a2") (pt "k1") (pt "k2")
	   (pt "Quot a2(Lin a1 a2 k1 k2)") (pt "Rem a2(Lin a1 a2 k1 k2)") "?")
(use "Truth-Axiom")
(use "QuotRemCorr")
(use "u2")
(use "LR")
(use "u2")
(use "w")
(use "u")
(use "w")
; Proof finished.
(save "Gcd")

(define gcd-proof (theorem-name-to-proof "Gcd"))
; (cdp (np gcd-proof))

(proof-to-expr-with-aconsts gcd-proof)

; Assumption constants:
; GInd: allnc a1,a2 
;    all (nat=>nat=>nat)_2549,n2550,n2551(
;     all n2550,n2551(
;      all n2552,n2553(
;       (nat=>nat=>nat)_2549 n2552 n2553<(nat=>nat=>nat)_2549 n2550 n2551 -> 
;       0<Lin a1 a2 n2552 n2553 -> 
;       (Rem a1(Lin a1 a2 n2552 n2553)=0 -> 
;        Rem a2(Lin a1 a2 n2552 n2553)=0 -> bot) -> 
;       bot) -> 
;      0<Lin a1 a2 n2550 n2551 -> 
;      (Rem a1(Lin a1 a2 n2550 n2551)=0 -> 
;       Rem a2(Lin a1 a2 n2550 n2551)=0 -> bot) -> 
;      bot) -> 
;     allnc boole(
;      boole -> 
;      0<Lin a1 a2 n2550 n2551 -> 
;      (Rem a1(Lin a1 a2 n2550 n2551)=0 -> 
;       Rem a2(Lin a1 a2 n2550 n2551)=0 -> bot) -> 
;      bot))
; L3: all r1,r2(
;    ((r1=0 -> bot) -> bot) -> 
;    ((r2=0 -> bot) -> bot) -> (r1=0 -> r2=0 -> bot) -> bot)
; L1bot: all r,l(r=l -> (0<l -> bot) -> (r=0 -> bot) -> bot)
; LS1: all a1,a2,k1,k2,q,r(
;    a1=q*Lin a1 a2 k1 k2+r -> r=Lin a1 a2(Step a1 a2 k1 k2 q)(q*k2))
; QuotRemCorr: all a,b(0<b -> a=Quot a b*b+Rem a b & Rem a b<b)
; L2: all r,l,k(r=l -> r<k -> l<k)
; Eq-Compat: allnc boole^2690,boole^2691(
;    Equal boole^2690 boole^2691 -> boole^2690 -> boole^2691)
; Eq-Symm: allnc boole^2692,boole^2693(
;    Equal boole^2692 boole^2693 -> Equal boole^2693 boole^2692)
; =-to-Eq-boole: allnc boole^1,boole^2(boole^1=boole^2 -> Equal boole^1 boole^2)
; Atom-True: all boole(boole -> boole=True)
; Truth-Axiom: T
; LR: all a,b(0<b -> Rem a b<b)
; LS2: all a1,a2,k1,k2,q,r(
;    a2=q*Lin a1 a2 k1 k2+r -> r=Lin a1 a2(q*k1)(Step a2 a1 k2 k1 q))
#|
(lambda (a1)
  (lambda (a2)
    (lambda (v01217)
      (lambda (u1218)
        ((lambda (u11221)
           ((((u11221 0) 1) v01217) (((u1218 0) 1) v01217)))
          (lambda (k2548)
            (lambda (k2547)
              ((((((((|GInd| a1) a2)
                     (lambda (k1) (lambda (k2) ((((|Lin| a1) a2) k1) k2))))
                    k2548)
                   k2547)
                  (lambda (k1)
                    (lambda (k2)
                      (lambda (u11226)
                        (lambda (u21227)
                          ((((|L3| (modulo a1 ((((|Lin| a1) a2) k1) k2)))
                              (modulo a2 ((((|Lin| a1) a2) k1) k2)))
                             ((((|L1bot|
                                  (modulo a1 ((((|Lin| a1) a2) k1) k2)))
                                 ((((|Lin| a1) a2)
                                    (((((|Step| a1) a2) k1) k2)
                                      (quotient
                                        a1
                                        ((((|Lin| a1) a2) k1) k2))))
                                   (* (quotient
                                        a1
                                        ((((|Lin| a1) a2) k1) k2))
                                      k2)))
                                (((((((|LS1| a1) a2) k1) k2)
                                    (quotient
                                      a1
                                      ((((|Lin| a1) a2) k1) k2)))
                                   (modulo a1 ((((|Lin| a1) a2) k1) k2)))
                                  (car (((|QuotRemCorr| a1)
                                          ((((|Lin| a1) a2) k1) k2))
                                         u21227))))
                               (lambda (w1235)
                                 (((((u11226
                                       (((((|Step| a1) a2) k1) k2)
                                         (quotient
                                           a1
                                           ((((|Lin| a1) a2) k1) k2))))
                                      (* (quotient
                                           a1
                                           ((((|Lin| a1) a2) k1) k2))
                                         k2))
                                     (((((|L2|
                                           (modulo
                                             a1
                                             ((((|Lin| a1) a2) k1) k2)))
                                          ((((|Lin| a1) a2)
                                             (((((|Step| a1) a2) k1) k2)
                                               (car ((|QuotRem| a1)
                                                      ((((|Lin| a1) a2) k1)
                                                        k2)))))
                                            (* (car ((|QuotRem| a1)
                                                      ((((|Lin| a1) a2) k1)
                                                        k2)))
                                               k2)))
                                         ((((|Lin| a1) a2) k1) k2))
                                        (((((lambda (boole^2566)
                                              (lambda (boole^2567)
                                                (lambda (u1243)
                                                  (((|Eq-Compat|
                                                      boole^2567)
                                                     boole^2566)
                                                    (((|Eq-Symm|
                                                        boole^2566)
                                                       boole^2567)
                                                      (((|=-to-Eq-boole|
                                                          boole^2566)
                                                         boole^2567)
                                                        u1243))))))
                                             (= (cdr ((|QuotRem| a1)
                                                       ((((|Lin| a1) a2)
                                                          k1)
                                                         k2)))
                                                ((((|Lin| a1) a2)
                                                   (((((|Step| a1) a2) k1)
                                                      k2)
                                                     (car ((|QuotRem| a1)
                                                            ((((|Lin| a1)
                                                                a2)
                                                               k1)
                                                              k2)))))
                                                  (* (car ((|QuotRem| a1)
                                                            ((((|Lin| a1)
                                                                a2)
                                                               k1)
                                                              k2)))
                                                     k2))))
                                            #t)
                                           ((|Atom-True|
                                              (= (cdr ((|QuotRem| a1)
                                                        ((((|Lin| a1) a2)
                                                           k1)
                                                          k2)))
                                                 ((((|Lin| a1) a2)
                                                    (((((|Step| a1) a2) k1)
                                                       k2)
                                                      (car ((|QuotRem| a1)
                                                             ((((|Lin| a1)
                                                                 a2)
                                                                k1)
                                                               k2)))))
                                                   (* (car ((|QuotRem| a1)
                                                             ((((|Lin| a1)
                                                                 a2)
                                                                k1)
                                                               k2)))
                                                      k2))))
                                             (((((((|LS1| a1) a2) k1) k2)
                                                 (quotient
                                                   a1
                                                   ((((|Lin| a1) a2) k1)
                                                     k2)))
                                                (modulo
                                                  a1
                                                  ((((|Lin| a1) a2) k1)
                                                    k2)))
                                               (car (((|QuotRemCorr| a1)
                                                       ((((|Lin| a1) a2)
                                                          k1)
                                                         k2))
                                                      u21227)))))
                                          |Truth-Axiom|))
                                       (((|LR| a1)
                                          ((((|Lin| a1) a2) k1) k2))
                                         u21227)))
                                    w1235)
                                   (((u1218
                                       (((((|Step| a1) a2) k1) k2)
                                         (quotient
                                           a1
                                           ((((|Lin| a1) a2) k1) k2))))
                                      (* (quotient
                                           a1
                                           ((((|Lin| a1) a2) k1) k2))
                                         k2))
                                     w1235)))))
                            ((((|L1bot|
                                 (modulo a2 ((((|Lin| a1) a2) k1) k2)))
                                ((((|Lin| a1) a2)
                                   (* (quotient
                                        a2
                                        ((((|Lin| a1) a2) k1) k2))
                                      k1))
                                  (((((|Step| a2) a1) k2) k1)
                                    (quotient
                                      a2
                                      ((((|Lin| a1) a2) k1) k2)))))
                               (((((((|LS2| a1) a2) k1) k2)
                                   (quotient a2 ((((|Lin| a1) a2) k1) k2)))
                                  (modulo a2 ((((|Lin| a1) a2) k1) k2)))
                                 (car (((|QuotRemCorr| a2)
                                         ((((|Lin| a1) a2) k1) k2))
                                        u21227))))
                              (lambda (w1251)
                                (((((u11226
                                      (* (quotient
                                           a2
                                           ((((|Lin| a1) a2) k1) k2))
                                         k1))
                                     (((((|Step| a2) a1) k2) k1)
                                       (quotient
                                         a2
                                         ((((|Lin| a1) a2) k1) k2))))
                                    (((((|L2|
                                          (modulo
                                            a2
                                            ((((|Lin| a1) a2) k1) k2)))
                                         ((((|Lin| a1) a2)
                                            (* (car ((|QuotRem| a2)
                                                      ((((|Lin| a1) a2) k1)
                                                        k2)))
                                               k1))
                                           (((((|Step| a2) a1) k2) k1)
                                             (car ((|QuotRem| a2)
                                                    ((((|Lin| a1) a2) k1)
                                                      k2))))))
                                        ((((|Lin| a1) a2) k1) k2))
                                       (((((lambda (boole^2589)
                                             (lambda (boole^2590)
                                               (lambda (u1259)
                                                 (((|Eq-Compat| boole^2590)
                                                    boole^2589)
                                                   (((|Eq-Symm| boole^2589)
                                                      boole^2590)
                                                     (((|=-to-Eq-boole|
                                                         boole^2589)
                                                        boole^2590)
                                                       u1259))))))
                                            (= (cdr ((|QuotRem| a2)
                                                      ((((|Lin| a1) a2) k1)
                                                        k2)))
                                               ((((|Lin| a1) a2)
                                                  (* (car ((|QuotRem| a2)
                                                            ((((|Lin| a1)
                                                                a2)
                                                               k1)
                                                              k2)))
                                                     k1))
                                                 (((((|Step| a2) a1) k2)
                                                    k1)
                                                   (car ((|QuotRem| a2)
                                                          ((((|Lin| a1) a2)
                                                             k1)
                                                            k2)))))))
                                           #t)
                                          ((|Atom-True|
                                             (= (cdr ((|QuotRem| a2)
                                                       ((((|Lin| a1) a2)
                                                          k1)
                                                         k2)))
                                                ((((|Lin| a1) a2)
                                                   (* (car ((|QuotRem| a2)
                                                             ((((|Lin| a1)
                                                                 a2)
                                                                k1)
                                                               k2)))
                                                      k1))
                                                  (((((|Step| a2) a1) k2)
                                                     k1)
                                                    (car ((|QuotRem| a2)
                                                           ((((|Lin| a1)
                                                               a2)
                                                              k1)
                                                             k2)))))))
                                            (((((((|LS2| a1) a2) k1) k2)
                                                (quotient
                                                  a2
                                                  ((((|Lin| a1) a2) k1)
                                                    k2)))
                                               (modulo
                                                 a2
                                                 ((((|Lin| a1) a2) k1)
                                                   k2)))
                                              (car (((|QuotRemCorr| a2)
                                                      ((((|Lin| a1) a2) k1)
                                                        k2))
                                                     u21227)))))
                                         |Truth-Axiom|))
                                      (((|LR| a2)
                                         ((((|Lin| a1) a2) k1) k2))
                                        u21227)))
                                   w1251)
                                  (((u1218
                                      (* (quotient
                                           a2
                                           ((((|Lin| a1) a2) k1) k2))
                                         k1))
                                     (((((|Step| a2) a1) k2) k1)
                                       (quotient
                                         a2
                                         ((((|Lin| a1) a2) k1) k2))))
                                    w1251))))))))))
                 #t)
                |Truth-Axiom|))))))))
|#

; A-Translation

(min-excl-proof? gcd-proof)

(define expanded-gcd-proof
  (expand-theorems gcd-proof (lambda (string)
			       (member string '("L3" "L1bot")))))

(proof-to-expr-with-aconsts expanded-gcd-proof)

(define min-excl-proof expanded-gcd-proof)
(define eterm-a
  (atr-min-excl-proof-to-structured-extracted-term min-excl-proof))

; We need to block unfolding of GRecGuard (whose last argument will be
; True) to obtain a readable term:

(set! GRECGUARD-UNFOLDING-FLAG #f)
(define neterm-a (nt eterm-a))
(pp neterm-a)

#|
[n0,n1]
 (GRecGuard 0 nat nat nat@@nat)(Lin n0 n1)0 1
 ([n2,n3,(nat=>nat=>nat@@nat=>nat@@nat)_4,p5]
   [if (Lin n0 n1(Step n0 n1 n2 n3 left(QuotRem n0(Lin n0 n1 n2 n3)))
         (left(QuotRem n0(Lin n0 n1 n2 n3))*n3))
     [if (Lin n0 n1(left(QuotRem n1(Lin n0 n1 n2 n3))*n2)
          (Step n1 n0 n3 n2 left(QuotRem n1(Lin n0 n1 n2 n3))))
      p5
      ([n6]
       (nat=>nat=>nat@@nat=>nat@@nat)_4
       (left(QuotRem n1(Lin n0 n1 n2 n3))*n2)
       (Step n1 n0 n3 n2 left(QuotRem n1(Lin n0 n1 n2 n3)))
       (left(QuotRem n1(Lin n0 n1 n2 n3))*n2@
        Step n1 n0 n3 n2 left(QuotRem n1(Lin n0 n1 n2 n3))))]
     ([n6]
      (nat=>nat=>nat@@nat=>nat@@nat)_4
      (Step n0 n1 n2 n3 left(QuotRem n0(Lin n0 n1 n2 n3)))
      (left(QuotRem n0(Lin n0 n1 n2 n3))*n3)
      (Step n0 n1 n2 n3 left(QuotRem n0(Lin n0 n1 n2 n3))@
       left(QuotRem n0(Lin n0 n1 n2 n3))*n3))])
 True
 (0@1)
|#

(term-to-expr neterm-a)

#|
(lambda (n0)
  (lambda (n1)
    ((((((natnatgrecguard ((|Lin| n0) n1)) 0) 1)
        (lambda (n2)
          (lambda (n3)
            (lambda (|(nat=>nat=>nat@@nat=>nat@@nat)_4|)
              (lambda (p5)
                (cond
                  [(zero?
                     ((((|Lin| n0) n1)
                        (((((|Step| n0) n1) n2) n3)
                          (car ((|QuotRem| n0)
                                 ((((|Lin| n0) n1) n2) n3)))))
                       (* (car ((|QuotRem| n0) ((((|Lin| n0) n1) n2) n3)))
                          n3)))
                   (cond
                     [(zero?
                        ((((|Lin| n0) n1)
                           (* (car ((|QuotRem| n1)
                                     ((((|Lin| n0) n1) n2) n3)))
                              n2))
                          (((((|Step| n1) n0) n3) n2)
                            (car ((|QuotRem| n1)
                                   ((((|Lin| n0) n1) n2) n3))))))
                      p5]
                     [(positive?
                        ((((|Lin| n0) n1)
                           (* (car ((|QuotRem| n1)
                                     ((((|Lin| n0) n1) n2) n3)))
                              n2))
                          (((((|Step| n1) n0) n3) n2)
                            (car ((|QuotRem| n1)
                                   ((((|Lin| n0) n1) n2) n3))))))
                      (((|(nat=>nat=>nat@@nat=>nat@@nat)_4|
                          (* (car ((|QuotRem| n1)
                                    ((((|Lin| n0) n1) n2) n3)))
                             n2))
                         (((((|Step| n1) n0) n3) n2)
                           (car ((|QuotRem| n1)
                                  ((((|Lin| n0) n1) n2) n3)))))
                        (cons
                          (* (car ((|QuotRem| n1)
                                    ((((|Lin| n0) n1) n2) n3)))
                             n2)
                          (((((|Step| n1) n0) n3) n2)
                            (car ((|QuotRem| n1)
                                   ((((|Lin| n0) n1) n2) n3))))))])]
                  [(positive?
                     ((((|Lin| n0) n1)
                        (((((|Step| n0) n1) n2) n3)
                          (car ((|QuotRem| n0)
                                 ((((|Lin| n0) n1) n2) n3)))))
                       (* (car ((|QuotRem| n0) ((((|Lin| n0) n1) n2) n3)))
                          n3)))
                   (((|(nat=>nat=>nat@@nat=>nat@@nat)_4|
                       (((((|Step| n0) n1) n2) n3)
                         (car ((|QuotRem| n0) ((((|Lin| n0) n1) n2) n3)))))
                      (* (car ((|QuotRem| n0) ((((|Lin| n0) n1) n2) n3)))
                         n3))
                     (cons
                       (((((|Step| n0) n1) n2) n3)
                         (car ((|QuotRem| n0) ((((|Lin| n0) n1) n2) n3))))
                       (* (car ((|QuotRem| n0) ((((|Lin| n0) n1) n2) n3)))
                          n3)))]))))))
       #t)
      (cons 0 1))))
|#

; Dialectica

(define goal-proof-d 
  (expand-theorems-with-positive-content
    (theorem-name-to-proof "Gcd")))

(proof-to-expr-with-aconsts goal-proof-d)

(define eterm-d (proof-to-extracted-d-term goal-proof-d))

; We need to block unfolding of GRecGuard (whose last argument will be
; True) to obtain a readable term:

(set! GRECGUARD-UNFOLDING-FLAG #f)
(define neterm-d (nt eterm-d))
; (pp neterm-d)

#|
[n0,n1]
 [if (0<n1 impb 
       right(QuotRem n0 n1)=0 impb right(QuotRem n1 n1)=0 impb False)
   ((GRecGuard nat nat nat@@nat)(Lin n0 n1)0 1
   ([n2,n3,(nat=>nat=>nat@@nat)_4]
     [let p5
       [let p5
        (Step n0 n1 n2 n3 left(QuotRem n0(Lin n0 n1 n2 n3))@
        left(QuotRem n0(Lin n0 n1 n2 n3))*n3)
        [if (0<Lin n0 n1 left p5 right p5 impb 
             right(QuotRem n0(Lin n0 n1 left p5 right p5))=0 impb 
             right(QuotRem n1(Lin n0 n1 left p5 right p5))=0 impb False)
         (left(QuotRem n1(Lin n0 n1 n2 n3))*n2@
         Step n1 n0 n3 n2 left(QuotRem n1(Lin n0 n1 n2 n3)))
         p5]]
       [if (0<Lin n0 n1 left p5 right p5 impb 
            right(QuotRem n0(Lin n0 n1 left p5 right p5))=0 impb 
            right(QuotRem n1(Lin n0 n1 left p5 right p5))=0 impb False)
        [let p6
         [let p6
          (Step n0 n1 n2 n3 left(QuotRem n0(Lin n0 n1 n2 n3))@
          left(QuotRem n0(Lin n0 n1 n2 n3))*n3)
          [if (Lin n0 n1 left p6 right p6<Lin n0 n1 n2 n3 impb 
               0<Lin n0 n1 left p6 right p6 impb
               (right(QuotRem n0(Lin n0 n1 left p6 right p6))=0 impb 
                right(QuotRem n1(Lin n0 n1 left p6 right p6))=0 impb False)impb
               False)
           (left(QuotRem n1(Lin n0 n1 n2 n3))*n2@
           Step n1 n0 n3 n2 left(QuotRem n1(Lin n0 n1 n2 n3)))
           p6]]
         ((nat=>nat=>nat@@nat)_4 left p6 right p6)]
        p5]])
   True)
   (0@1)]
|#

; This is the same term as the one extracted from GcdAnd.

; Tests

(display-gcd neterm-a 66 27)
(display-gcd neterm-d 66 27)
(display-gcd neterm-a (* 1428 1151412) (* 1428 103723))
(display-gcd neterm-d (* 1428 1151412) (* 1428 103723))
(display-gcd neterm-a (* 176478618764 12074918274841)
	     (* 176478618764 34974982375987))
(display-gcd neterm-d (* 176478618764 12074918274841)
	     (* 176478618764 34974982375987))
