; $Id: gcd.scm,v 1.6 2008/01/25 13:30:27 logik Exp $
; Based on mod99ios.

(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" (py "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-one)
(add-program-constant "Rem" (py "nat=>nat=>nat") t-deg-one)
(add-program-constant "Lin" (py "nat=>nat=>nat@@nat=>nat") t-deg-one)
(add-program-constant "Step" (py "nat=>nat=>nat@@nat=>nat=>nat") t-deg-one)

(add-rewrite-rule (pt "Quot n n") (pt "1"))
(add-rewrite-rule (pt "Rem n n") (pt "0"))

(add-rewrite-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)]"))

(add-rewrite-rule (pt "Lin a1 a2(0@k2)") (pt "k2*a2"))

(add-rewrite-rule (pt "Step a1 a2(k1@k2)0") (pt "1"))

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

(add-global-assumption
 "QuotRemCor" (pf "all a,c(0<c -> a=Quot a c*c+Rem a c)"))

(add-global-assumption "RemCor" (pf "all a,c(0<c -> Rem a c<c)"))

; v0: 0<a2
; v1: all m(m<0 -> bot)
; v2: all a,q,c,r(a=q*c+r -> (0<r -> bot) -> (0=Rem a c -> bot) -> bot)
; v3: all a,c(0<c -> a=Quot a c*c+Rem a c)   "QuotRemCor"
; v4: all a,c(0<c -> Rem a c<c)   "RemCor" 
; v5: 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)))    "StepLemma"
; v6: 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)))     "Step2"

; Abbreviations
; m1(k1,k2) := ((Step a1 a2(k1@k2) q)@(q*k2))
; m2(k1,k2) := ((q*k1)@(Step a2 a1(k2@k1)q))

(add-global-assumption
 "Pos1"
 (pf "all a1,a2,k1,k2,q(
      0<Rem a1(Lin a1 a2(k1@k2)) ->
      all r(a1=q*Lin a1 a2(k1@k2)+r -> 
             r=Lin a1 a2((Step a1 a2(k1@k2) q)@(q*k2))) ->
      all a,c(0<c -> a=Quot a c*c+Rem a c) ->
      0<Lin a1 a2(k1@k2) -> 
      0<Lin a1 a2((Step a1 a2(k1@k2) q)@(q*k2)))"))

(add-global-assumption
 "Pos2"
 (pf "all a1,a2,k1,k2,q(
      0<Rem a2(Lin a1 a2(k1@k2)) ->
      all r(a2=q*Lin a1 a2(k1@k2)+r -> 
             r=Lin a1 a2((q*k1)@(Step a2 a1(k2@k1)q))) ->
      all a,c(0<c -> a=Quot a c*c+Rem a c) ->
      0<Lin a1 a2(k1@k2) -> 
      0<Lin a1 a2(q*k1@Step a2 a1(k2@k1)q))"))

(add-global-assumption
 "Lt1"
 (pf "all a1,a2,k1,k2,q(
      all r(a1=q*Lin a1 a2(k1@k2)+r -> 
             r=Lin a1 a2((Step a1 a2(k1@k2) q)@(q*k2))) -> 
      all a,c(0<c -> a=Quot a c*c+Rem a c) ->
      0<Lin a1 a2(k1@k2) -> 
      all a,c(0<c -> Rem a c<c) ->
      Lin a1 a2((Step a1 a2(k1@k2) q)@(q*k2))<Lin a1 a2(k1@k2))"))

(add-global-assumption
 "Lt2"
 (pf "all a1,a2,k1,k2,q(
      all r(a2=q*Lin a1 a2(k1@k2)+r -> 
             r=Lin a1 a2((q*k1)@(Step a2 a1(k2@k1)q))) -> 
      all a,c(0<c -> a=Quot a c*c+Rem a c) ->
      0<Lin a1 a2(k1@k2) -> 
      all a,c(0<c -> Rem a c<c) ->
      Lin a1 a2((q*k1)@(Step a2 a1(k2@k1)q))<Lin a1 a2(k1@k2))"))

(add-global-assumption
 "v5Lemma"
 (pf "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)))"))

(add-global-assumption
 "v6Lemma"
 (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)))"))


(set-goal
 (pf "all a1,a2(
 0<a2 -> 
 all a,q,c,r(a=q*c+r -> (0<r -> bot) -> (0=Rem a c -> bot) -> bot) -> 
 excl k1,k2(
  0=Rem a1(Lin a1 a2(k1@k2)) ! 
  (0=Rem a2(Lin a1 a2(k1@k2)) ! 0<Lin a1 a2(k1@k2))))"))
(assume "a1" "a2" "v0" "v2" "u")
(by-assume-minimal-wrt
 (pf "excl k1,k2 0<Lin a1 a2(k1@k2)") "k1" "k2"
 (pt "[k1,k2]Lin a1 a2(k1@k2)")
 "u1" "u2")
(exc-intro (pt "0") (pt "1"))
(use "v0")
(ng)

(use "v2" (pt "a2") (pt "Quot a2(Lin a1 a2(k1@k2))")
     (pt "Lin a1 a2(k1@k2)") (pt "Rem a2(Lin a1 a2(k1@k2))"))
(use "QuotRemCor")
(use "u2")
(assume "u32")
(use "u1" (pt "(Quot a2(Lin a1 a2(k1@k2)))*k1")
     (pt "(Step a2 a1(k2@k1)(Quot a2(Lin a1 a2(k1@k2))))"))
(use "Lt2")
(use "v6Lemma")
(use "QuotRemCor")
(use "u2")
(use "RemCor")
(use "Pos2")
(use "u32")
(use "v6Lemma")
(use "QuotRemCor")
(use "u2")
(assume "u3")

(use "v2" (pt "a1") (pt "Quot a1(Lin a1 a2(k1@k2))")
     (pt "Lin a1 a2(k1@k2)") (pt "Rem a1(Lin a1 a2(k1@k2))"))
(use "QuotRemCor")
(use "u2")
(assume "u31")
; (use "u1" (pt "(Step a1 a2(k1@k2) q)") (pt "q*k2")) ';here q is new
(use "u1" (pt "(Step a1 a2(k1@k2)(Quot a1(Lin a1 a2(k1@k2))))")
     (pt "(Quot a1(Lin a1 a2(k1@k2)))*k2"))
(use "Lt1")
(use "v5Lemma")
(use "QuotRemCor")
(use "u2")
(use "RemCor")
(use "Pos1")
(use "u31")
(use "v5Lemma")
(use "QuotRemCor")
(use "u2")
(assume "u4")

(use "u" (pt "k1") (pt "k2"))
(use "u4")
(use "u3")
(use "u2")

(save "Gcd")

(define gcd-proof0 (theorem-name-to-proof "Gcd"))
(define gcd-proof1 (expand-thm gcd-proof0 "ExclIntroOneTwo"))
(define gcd-proof2 (expand-thm gcd-proof1 "ExclElimTwoTwo"))
(define gcd-proof3 (reduce-efq-and-stab gcd-proof2))
(define gcd-proof4 (expand-thm gcd-proof3 "MinPrlOneTwo"))
(define gcd-proof5 (expand-thm gcd-proof4 "CVIndTwo"))
(define gcd-proof6 (reduce-efq-and-stab gcd-proof5))
(define gcd-proof7 (np gcd-proof6))

; (proof-to-expr-with-aconsts gcd-proof7)
; (map var-to-string (proof-to-free (theorem-name-to-proof "Gcd")))

; A-Translation
(mload "../modules/atr.scm")

(define min-excl-proof gcd-proof7)
(define eterm (atr-min-excl-proof-to-structured-extracted-term min-excl-proof))
(define eta (nt eterm))
(pp eta)

#|
[n0,n1]
 [if (0=Rem n0 n1)
   (0@1)
   [if (0<Rem n0 n1)
    ((Rec nat=>nat=>nat=>nat@@nat)([n2,n3]0@0)
    ([n2,(nat=>nat=>nat@@nat)_3,n4,n5]
      [if (0=Rem n1(Lin n0 n1(n4@n5)))
        [if (0=Rem n0(Lin n0 n1(n4@n5)))
         (n4@n5)
         [if (0<Rem n0(Lin n0 n1(n4@n5)))
          ((nat=>nat=>nat@@nat)_3
          (Step n0 n1(n4@n5)(Quot n0(Lin n0 n1(n4@n5))))
          (Quot n0(Lin n0 n1(n4@n5))*n5))
          (0@0)]]
        [if (0<Rem n1(Lin n0 n1(n4@n5)))
         ((nat=>nat=>nat@@nat)_3(Quot n1(Lin n0 n1(n4@n5))*n4)
         (Step n1 n0(n5@n4)(Quot n1(Lin n0 n1(n4@n5)))))
         (0@0)]])
    n1
    (Step n0 n1(0@1)(Quot n0 n1))
    (Quot n0 n1))
    (0@0)]]
|#

(define |Step|
  (lambda (a1)
    (lambda (a2)
      (lambda (p)
	(lambda (q)
	  (if (and (< (* (cdr p) a2) (* (car p) a1)) (< 0 q))
	      (- (* q (car p)) 1)
	      (+ (* q (car p)) 1)))))))

(define |Lin|
  (lambda (a1)
    (lambda (a2)
      (lambda (p)
	(abs (- (* (car p) a1) (* (cdr p) a2)))))))

; (time (((ev (term-to-expr eta)) 66) 27))
; (2 . 5)
; (- (* 5 27) (* 2 66))
; 3
; This the gcd of 66 and 27.
