;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  MDH -- First DiaTup example, created in Spring  2003
;;;  MDH -- Last updated 071118, i.e., 18 November 2007
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(load "~/minlog/init.scm")
(set! COMMENT-FLAG #f)
(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")
(define hsh-proof (theorem-name-to-proof "hsh-Theorem"))

(mload "../modules/diatup.scm")
(define vatmp (time (DIA-extract 'light hsh-proof)))
(define FI-tmtup (tmpair-to-tuple (vatmpair-to-tmpair vatmp)))
(define FI-tmlst (tmtuple-to-tmlist FI-tmtup))
(length FI-tmlst)
(define n1 (car  FI-tmlst))
(define n2 (cadr  FI-tmlst))
(set! UNFOLDING-FLAG #t)
(set! COMMENT-FLAG #t)
(define n-n1 (time (nt n1)))
(define n-n2 (time (nt n2)))
; ; ; With renaming (f0 -> s and f1 -> h) and indentation
(pp n-n1)
; ; ; [s,h] h(h 0)
(pp n-n2)
; ; ; [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)]

