; $Id: gcd-d.scm,v 1.2 2008/01/25 13:30:27 logik Exp $
; gcd example, based on gcd_minpr.scm

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

; Proof of the gcd theorem

(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)"))
(add-global-assumption
 "StepLemma"
 (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)"))
(add-global-assumption "GCDAux" (pf "all r,m(m=r -> (0<m -> F) -> r=0)"))

; Step2
(set-goal
 (pf "all a1,a2,k1,k2,q,r(
       a2=q*Lin a1 a2(k1@k2)+r -> Lin a1 a2((q*k1)@(Step a2 a1(k2@k1)q))=r)"))
(strip)
(add-global-assumption
 "LinSymm" (pf "all a1,a2,k1,k2 Lin a1 a2(k1@k2)=Lin a2 a1(k2@k1)"))
(simp "LinSymm")
(use "StepLemma")
(simp "LinSymm")
(use 1)
(save "Step2")		       

(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" "u1")

(by-assume-minimal-wrt
 (pf "exca k1,k2 0<Lin a1 a2(k1@k2)") "k1" "k2"
 (pt "[k1,k2]Lin a1 a2(k1@k2)")
 "MinH" "H")
(assume "u2")
(use "u2" (pt "0") (pt "1"))
(ng)
(use "u1")

; The Minimum Principle has provided the k1, k2 we are searching for:
; the least pair k1, k2 such that 0<Lin a1 a2(k1@k2).

(exc-intro (pt "k1") (pt "k2"))
(use "H")

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

(use "GCDAux"
     (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 "StepLemma")
(use "QuotRemCor")
(use "H")

(use "MinH")
(ng)
(simp "StepLemma" (pt "Rem a1(Lin a1 a2(k1@k2))"))
(use "RemCor")
(use "H")
(use "QuotRemCor")
(use "H")

; Now we must show Rem a2(Lin a1 a2(k1@k2))=0.
(use "GCDAux"
     (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 "Step2")
(use "QuotRemCor")
(use "H")

(use "MinH")
(ng)
(simp "Step2" (pt "Rem a2(Lin a1 a2(k1@k2))"))
(use "RemCor")
(use "H")
(use "QuotRemCor")
(use "H")

(save "Gcd")

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

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

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

(define reduced-gcd (reduce-efq-and-stab gcd-proof))
(define nreduced-gcd (np reduced-gcd))
; (proof-to-expr-with-aconsts nreduced-gcd)
; (cdp nreduced-gcd)

(add-var-name "p" (py "nat@@nat"))
(add-var-name "pf" (py "nat@@nat=>nat@@nat"))
(define term (proof-to-extracted-d-term nreduced-gcd))
(define nterm (nt term))
; (pp nterm)
(define etd (term-to-term-with-let nterm))
; (pp etd)
; (display (pretty-print-string 0 66 etd))

#|
[n0,n1]
 [let pf712
   ((Rec nat=>nat@@nat=>nat@@nat)([p3]0@0)
   ([n3,pf4,p5]
     [if (0<Lin n0 n1 p5 impb 
           Rem n0(Lin n0 n1 p5)=0 impb Rem n1(Lin n0 n1 p5)=0 impb False)
       (pf4
       [let p6
         (Step n0 n1 p5(Quot n0(Lin n0 n1 p5))@Quot n0(Lin n0 n1 p5)*right p5)
         [if (Lin n0 n1 p6<n3 impb 0<Lin n0 n1 p6 impb False)
          (Quot n1(Lin n0 n1 p5)*left p5@
          Step n1 n0(right p5@left p5)(Quot n1(Lin n0 n1 p5)))
          p6]])
       p5])
   n1)
   [let p2
    [if (0<n1 impb Rem n0 n1=0 impb False)
     (pf712(Step n0 n1(0@1)(Quot n0 n1)@Quot n0 n1))
     (0@1)]
    [if (0<Lin n0 n1 p2 impb 
         Rem n0(Lin n0 n1 p2)=0 impb Rem n1(Lin n0 n1 p2)=0 impb False)
     (pf712(0@[if (0<n1) 0 2]))
     p2]]]
|#

; (term-to-expr etd)

(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 etd)) 66) 27))
; (16 . 39)
; (- (* 16 66) (* 39 27))
; 3
; This the gcd of 66 and 27.

; For better readability we can enforce that the extracted expression
; contains views "Lin" and "Step" as functions with 3 and 4 arguments:

; (term-to-expr etd '("Lin" 3) '("Step" 4))

; For evaluation we need to redefine |Lin| and |Step| accordingly:

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

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

(time (((ev (term-to-expr etd '("Lin" 3) '("Step" 4))) 66) 27))
