; $Id: hsh.scm,v 1.3 2008/01/25 13:30:17 logik Exp $

; We show classically the existence of an n such that h(s(h n)) \ne n
; and extract a (somewhat unexpected) program from it (due to U.Berger)

(libload "nat.scm")
(add-var-name "f" "g" "h" "s" (py "nat=>nat"))

(add-program-constant "c" (py "(nat=>nat)=>(nat=>nat)=>nat=>nat") 1)
(add-computation-rule (pt "c g f n") (pt "g(f n)"))

(add-global-assumption "Compat" (pf "allnc f,n,m.n=m -> f n=f m"))

(set-goal (pf "all f,g.all m excl n g(f n)=m -> all m excl n g n=m"))
(search)
(save "Surj-Lemma")

(set-goal (pf "all f,g.(all n,m.g(f n)=g(f m) -> n=m) ->
                        all n,m.f n=f m -> n=m"))
(strip)
(use 1)
(use "Compat")
(use 2)
(save "Inj-Lemma")

(set-goal (pf "all f,g.(all m excl n g(f n)=m) ->
                       (all n,m.g n=g m -> n=m) ->
                        all m excl n f n=m"))
(search)
(save "Surj-Inj-Lemma")

; We now prove the hsh-Theorem

(set-goal (pf "all s,h.(all n.s n=0 -> bot) -> all n h(s(h n))=n -> bot"))
(assume "s" "h" "s-not-0" "hsh-is-id")
(cut (pf "all m excl n.h(s(h n))=m"))
(assume "hsh-surj")
(cut (pf "all m excl n.h(s n)=m"))
(assume "hs-surj")
(cut (pf "all n,m.h(s(h n))=h(s(h m)) -> n=m"))
(assume "hsh-inj")
(cut (pf "all n,m.s(h n)=s(h m) -> n=m"))
(assume "sh-inj")
(cut (pf "all n,m.h n=h m -> n=m"))
(assume "h-inj")
(cut (pf "all m excl n s n=m"))
(assume "s-surj")
(use-with "s-surj" (pt "0") "s-not-0")
(use "Surj-Inj-Lemma" (pt "h"))
(use "hs-surj")
(use "h-inj")
(use "Inj-Lemma" (pt "s"))
(use "sh-inj")
(use-with "Inj-Lemma" (pt "c s h") (pt "h") "?")
(use "hsh-inj")
(assume "n" "m")
(inst-with-to "hsh-is-id" (pt "n") "hshn-is-n")
(simp "hshn-is-n")
(inst-with-to "hsh-is-id" (pt "m") "hshn-is-m")
(simp "hshn-is-m")
(prop)
(use-with "Surj-Lemma" (pt "h") (pt "c h s") "?")
(use "hsh-surj")
(assume "m" "m-not-hsh-value")
(use "m-not-hsh-value" (pt "m"))
(use "hsh-is-id")

(save "hsh-Theorem")

; (dnpe)
; (lambda (s)
;   (lambda (h)
;     (lambda (|105|)
;       (lambda (|106|)
;         ((((((|Surj-Inj-Lemma| s) h)
;             (((|Surj-Lemma| h) (lambda (n118) (h (s n118))))
;              (lambda (m127)
;                (lambda (|108|) ((|108| m127) (|106| m127))))))
;            (((|Inj-Lemma| h) s)
;             (((|Inj-Lemma| (lambda (n122) (s (h n122)))) h)
;              (lambda (n130)
;                (lambda (m131)
;                  ((((((((|Compat-Rev-nat| h) s) m131) n130)
;                      (h (s (h n130))))
;                     n130)
;                    (|106| n130))
;                   ((((((|Compat-Rev-nat| n130) m131) (h (s (h m131))))
;                      m131)
;                     (|106| m131))
;                    (lambda (|114|) |114|))))))))
;           "0")
;          |105|)))))

; Tests

(define hsh-proof (theorem-name-to-proof "hsh-Theorem"))
; (formula-to-string (proof-to-formula hsh-proof))
; (proof-to-expr hsh-proof)
(define nhsh-proof (np hsh-proof))
; (proof-to-expr nhsh-proof)
(define ggnhsh-proof (proof-to-goedel-gentzen-translation nhsh-proof))
; (cdp ggnhsh-proof)
; (proof-to-expr ggnhsh-proof)
(define nggnhsh-proof (np ggnhsh-proof))
; (proof-to-expr nggnhsh-proof)
; (cdp nggnhsh-proof)
(define rggnhsh-proof (proof-to-reduced-goedel-gentzen-translation nhsh-proof))
; (cdp rggnhsh-proof)
; (proof-to-expr rggnhsh-proof)
(define nrggnhsh-proof (np rggnhsh-proof))
(define enrggnhsh-proof (expand-thm nrggnhsh-proof "Surj-Lemma"))
(define nenrggnhsh-proof (np enrggnhsh-proof))
; (proof-to-expr nenrggnhsh-proof)

; (lambda (s)
;   (lambda (h)
;     (lambda (|474|)
;       (lambda (|475|)
;         ((|475| (h "0"))
;          (lambda (|476|)
;            ((|475| (s (h (h "0"))))
;             (lambda (|477|)
;               ((((((((((|Compat-Rev-nat| h) s) "0") (s (h (h "0"))))
;                     (h (s (h (s (h (h "0")))))))
;                    (s (h (h "0"))))
;                   |477|)
;                  (lambda (|478|)
;                    (lambda (|479|)
;                      ((|475| "0")
;                       (lambda (|480|)
;                         ((((((((|Compat-Rev-nat| (s (h (h "0")))) "0")
;                               (h (s (h "0"))))
;                              "0")
;                             |480|)
;                            (lambda (|481|) |481|))
;                           |478|)
;                          |479|))))))
;                 (lambda (|487|)
;                   (|487|
;                     ((((|Compat| h) (s (h (s (h (h "0")))))) (s (h "0")))
;                      ((((|Compat| s) (h (s (h (h "0"))))) (h "0"))
;                       |476|)))))
;                (|474| (h (h "0"))))))))))))

(define min-excl-proof nenrggnhsh-proof)
; (formula-to-string (fold-formula (proof-to-formula min-excl-proof)))
; "all s,h.(all n.0=s n -> bot) -> excl n.n=h(s(h n)) -> bot"

(mload "../modules/atr.scm")

(define et (atr-min-excl-proof-to-structured-extracted-term min-excl-proof))

; (term-to-string (nt et))
; "[f0,f1][if (f1(f0(f1(f1 0)))=f1 0) [if (f1(f0(f1(f0(f1(f1 0)))))=f0(f1(f1 0))) 0 (f0(f1(f1 0)))] (f1 0)]"

; With renaming (f0 -> s and f1 -> h) and indentation

; [s,h][if (h(s(h(h 0)))=h 0)
; 	   [if (h(s(h(s(h(h 0)))))=s(h(h 0)))
; 	       0
; 	       (s(h(h 0)))]
; 	   (h 0)]

