; $Id: dc-first.scm,v 1.8 2008/01/25 13:30:25 logik Exp $

; dc-first.scm 

; demofile for the example - Every infinite subsequence of 0 and 1s
; has a subsequence which is constant 0 or 1 - (plus corollary)
; discussed in Seisenberger, On the constructive content of proofs, 
; 2003, section 3.3. 

; This is an example for program extraction from classical
; proofs using the axiom of classical dependent choice;
; A-translation is done by adding a realizer for the A-translated
; axiom;  demonstrates that using `strong axioms', here DC, not 
; necessarily leads to bad programs.

; The example was first suggested by Stolzenberg as an example
; for program extraction from classical proofs; here we do
; slightly different proof, using DC.

; update 08-2006: uses now the existing modules lib/nat.scm and 
; lib/listrev.scm

; (load "~/minlog/init.scm")

(set! COMMENT-FLAG #f)
(libload "nat.scm")
(libload "listrev.scm")
(set! COMMENT-FLAG #t)
(set! DOT-NOTATION #f)

; 1. Declarations

(av "a" "b" "c" (py "boole"))
(av "i" "j" (py "nat"))
(av "e"  (py "nat=>nat")) 
(av "h"  (py "nat=>boole"))

(add-global-assumption "<-lemma" (pf "all n,m. n < m + n + 1"))
(add-global-assumption "=-lemma" (pf "all a,b,c. a=b -> c=b -> a=c"))

; "OnlyTwo"
(set-goal (pf "all a((a=False -> bot) -> (a=True -> bot) -> bot)"))
(ind)
(ng)
(assume 1 2)
(use 2)
(use "Truth-Axiom")
(ng)
(assume 1 2)
(use 1)
(use "Truth-Axiom")
; Proof finished.
(save "OnlyTwo")

(define dc-inst
  (pf "all h(
       all n excl m((n<m -> h m=False -> bot) -> bot) -> 
       excl e(e 0=0 ! all k((e k<e(k+1) -> h(e(k+1))=False -> bot) -> bot)))"))

; 2. Interactive proofs

; Using DC we prove the lemma saying that every function h:nat->boole has 
; an infinite constant subsequence 

(set-goal
 (mk-imp
  dc-inst 
  (pf "all h excl a,e all k((e k<e(k+1) -> h(e(k+1))=a -> bot) -> bot)")))
(assume "dc-inst" "h" 2)
(use-with "dc-inst" (pt "h") "?" "?")

; all n excl m((n<m -> h m=False -> bot) -> bot)
(assume "n" 3)
(use-with 2 (pt "True") (pt "[m]m+n") "?")
(assume "k")
(ng)
(strip)
(drop "dc-inst" 2)

(use-with "OnlyTwo" (pt "h(Succ(k+n))") "?" "?")

(assume 5)
(use-with 3 (pt "Succ(k+n)") "?")
(strip)
(use 6)
(use "<-lemma")
(use 5)

(use 4)
(use "Truth-Axiom")

; all e(e 0=0 -> excl k(e k<e(k+1) -> h(e(k+1))=False -> bot))
(assume "e" 3)
(use 2)
; Proof finished.
(save "ConstantSubSequence")

; Finally, we apply A-translation to the corollary

; "Cor"
(set-goal (mk-all (pv "h")
                  (mk-imp dc-inst 
                          (pf "excl i,j(i<j ! h i=h j)"))))
(assume  "h" "dc-inst" 2)
(use-with "ConstantSubSequence" "dc-inst" (pt "h") "?")
(assume "a" "e" 3)
(use-with 3 (pt "0") "?")
(strip)
(use-with 3 (pt "1") "?")
(strip)
(use 2 (pt "e 1") (pt "e 2"))
; e 1<e 2
(use 6)
; h(e 1)=h(e 2)
(use "=-lemma" (pt "a"))
(use 5)
(use 7)
; Proof finished.
(save "Cor")

(define min-excl-proof (np (expand-theorems (theorem-name-to-proof "Cor"))))

(min-excl-proof? min-excl-proof)

; 3. Realizing classical dependent choice:

; The following definitions and notations refer to section 3.2
(define rho (py "nat"))
(define nu (py "nat@@nat"))
(define sigma (mk-arrow nu nu))
(define type-of-G (mk-arrow rho (mk-arrow rho sigma nu) nu))
(define type-of-Y (mk-arrow (mk-arrow (py "nat") rho)
			    (mk-arrow (py "nat") sigma)
			    nu))
(av "x" rho)
(av "z" sigma)
(av "G" type-of-G)
(av "Y" type-of-Y)
(define type-of-list (py "list (nat@@(nat@@nat=>nat@@nat))"))
(av "t" type-of-list)

; [G,Y]Psi G Y Lin is a realizer for DC^X:
(add-program-constant "Psi" (mk-arrow type-of-G type-of-Y type-of-list nu))

; 4. A-translation:

(define program (atr-min-excl-proof-to-structured-extracted-term
		 min-excl-proof
		 (pt "[h,G,Y]Psi G Y (Nil (nat@@(nat@@nat=>nat@@nat)))")))

; For a better display we add some additional variable names:

(av "f" (py "nat=>(nat@@nat=>nat@@nat)=>nat@@nat"))
(av "g" (py "nat=>nat@@nat=>nat@@nat"))
(av "p"(py "nat@@nat"))

(define nprogram (nt program))
(term-to-expr nprogram) 

; (lambda (h0)
;   (((|Psi|
;       (lambda (n1)
;         (lambda (f2)
;           (if (h0 (+ n1 1))
;               (if (h0 (+ (+ n1 1) 1))
;                   (cons (+ n1 1) (+ (+ n1 1) 1))
;                   ((f2 (+ (+ n1 1) 1)) (lambda (p3) p3)))
;               ((f2 (+ n1 1)) (lambda (p3) p3))))))
;      (lambda (e1)
;        (lambda (g2) ((g2 0) ((g2 1) (cons (e1 1) (e1 2)))))))
;     '()))

; note depends on Psi as it is not animated yet.

; 5. Animation of Psi

; in tsil.scm: Lh: tsil alpha -> nat and
; Proj: tsil alpha -> nat ->alpha, displayed, infix, as __.
; projection: if t=[t_0,...,t_{n-1}] (t__i) yields t_i

(define type-of-beta (mk-arrow (py " nat") (make-star rho sigma)))
(av "beta" type-of-beta)

(define type-of-Tilde (mk-arrow type-of-Y type-of-beta nu))
(add-program-constant "Tilde" type-of-Tilde)
(add-computation-rule (pt "Tilde Y beta")
                      (pt "Y 
                           ([n][if (n=0) 0 (left (beta (Pred n)))])
                           ([n] right (beta n))")) 

; H is a realizer for an instance of the efq-axiom 
; here the instance is bot -> (bot -> bot)

(add-program-constant "H" (mk-arrow nu nu nu))
(add-computation-rule (pt "H p1 p2") (pt "p1"))

(add-computation-rule (pt "Psi G Y t")
                      (pt "Tilde 
                           Y
                           ([n][if (n < (Lh t))
                                  (t__n)
                                  (0@
                                    H (G 
                                       [if (Lh t = 0)
                                           0
                                           (left (t__(Pred (Lh t))))]  
                                       ([x,z] (Psi G Y (t::(x@z))))))])"))


(define nprogram (nt program))
(term-to-expr nprogram)

; (lambda (h0)
;   (if (h0 1)
;       (if (h0 2)
;           (cons 1 2)
;           (if (h0 3) (if (h0 4) (cons 3 4) (cons 2 4)) (cons 2 3)))
;       (if (h0 2) (if (h0 3) (cons 2 3) (cons 1 3)) (cons 1 2))))

; 6. Running the extracted program

(add-program-constant "Constsequence" (py "nat=>boole"))
(add-rewrite-rule (pt "Constsequence n")(pt "F"))
(term-to-string (nt (mk-term-in-app-form nprogram (pt "Constsequence"))))
; ==> "1@2"

; Note that the 0th element is not found 
; the reason being h \circ e is only constant for inputs n>0.

(add-program-constant "Sequence" (mk-arrow (py "nat")(py "boole")))
(add-computation-rule (pt "Sequence 0")(pt "T"))
(add-computation-rule (pt "Sequence 1")(pt "T"))
(add-computation-rule (pt "Sequence 2")(pt "F"))
(add-computation-rule (pt "Sequence 3")(pt "T"))
(add-computation-rule (pt "Sequence 4")(pt "F"))
(term-to-string (nt (mk-term-in-app-form nprogram (pt "Sequence"))))
; ==> "2@4"

(add-program-constant "Dualsequence" (mk-arrow (py "nat")(py "boole")))
(add-computation-rule (pt "Dualsequence 0")(pt "F"))
(add-computation-rule (pt "Dualsequence 1")(pt "F"))
(add-computation-rule (pt "Dualsequence 2")(pt "T"))
(add-computation-rule (pt "Dualsequence 3")(pt "F"))
(add-computation-rule (pt "Dualsequence 4")(pt "T"))
(term-to-string (nt (mk-term-in-app-form nprogram (pt "Dualsequence"))))
; ==> "1@3"

(add-program-constant "Interesting" (mk-arrow (py "nat")(py "boole")))
(add-computation-rule (pt "Interesting 0")(pt "F"))
(add-computation-rule (pt "Interesting 1")(pt "T"))
(add-computation-rule (pt "Interesting 2")(pt "F"))
(add-computation-rule (pt "Interesting 3")(pt "T"))
(add-computation-rule (pt "Interesting 4")(pt "T"))
(term-to-string (nt (mk-term-in-app-form nprogram (pt "Interesting"))))
; ==> "3@4"

