; Problem:
;  Given: An infinite tape containing 0s and 1s: 
;                 A: all x. fx = 0 \/ fx = 1
;  To show: There exist two cells with the same content:
;                 G: exc n,m. n<m ! fn = fm
; Aditional information:
;                 inf0: all n exc k. n <= k ! fk = 0
;                 inf1: all n exc k. n <= k ! fk = 1

; In our classical setting:
;            A: all n. (fn = 0 -> bot) -> (fn = 1 -> bot) -> bot  

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

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

(add-var-name "f" (py "nat=>nat")) 
; the infinite 0/1 tape 

; We will first show two additional lemmas

; Lemma 1 (stolzenberg's Principle): 
; The infinite boolean tape contains either infinitely many 0s or infinitely many 1s. ; Formally,   A -> inf0 \/ inf1
; I.e.,       A -> (inf0 -> bot) -> (inf1 -> bot) -> bot   (or variants thereof)

; Lemma(s) 2:
; If either inf0 or from inf1, then G (the desired property of the tape).
;             inf0 -> G  and  inf1 -> G


; *********************************   1st Variant   **********************************

; We formulate Lemma 1 ("Inf0orInf1") as:   
;       A -> (inf0 -> bot) -> inf1

(set-goal
 (pf "all f(
       all n((f n=0 -> bot) -> (f n=1 -> bot) -> bot) -> 
       excl n all k(n<=k -> f k=0 -> bot) -> all n excl k(n<=k ! f k=1))"))
(assume "f" "A" "not_inf0" "n" "notinf1")
(use "not_inf0")
(assume "m" "notinf0")
(drop "not_inf0")
(use "A" (pt "m max n"))
(use "notinf0")
(use "NatMaxUB1")
(use "notinf1" (pt "m max n"))
(use "NatMaxUB2")
(save "Inf0orInf1")


; The 2nd pair of Lemmas is "frominf0G": inf0 -> G and "frominf1G": inf1 -> G

; "frominf0G"
(set-goal 
 (pf "all f(all n excl k(n<=k ! f k=0) -> excl n,m(n<m ! f n=f m))"))
(assume "f" "inf0" "negG")
(use "inf0" (pt "0"))
(assume "k" "T" "fk0")
(drop "T")
(use "inf0" (pt "Succ k"))
(assume "n" "SkLen" "fn0") 
(use "negG" (pt "k") (pt "n"))
(use "NatSuccLeToLt")
(use "SkLen")
(use "Nat=Trans" (pt "0"))
(use "fk0")
(use "Nat=Symm")
(use "fn0")
(save "frominf0G")

; "frominf1G"
(set-goal 
 (pf "all f(all n excl k(n<=k ! f k=1) -> excl n,m(n<m ! f n=f m))"))
(assume "f" "inf0" "negG")
(use "inf0" (pt "0"))
(assume "k" "T" "fk1")
(drop "T")
(use "inf0" (pt "Succ k"))
(assume "n" "SkLen" "fn1") 
; n is the successor of k
(use "negG" (pt "k") (pt "n"))
(use "NatSuccLeToLt")
(use "SkLen")
(use "Nat=Trans" (pt "1"))
(use "fk1")
(use "Nat=Symm")
(use "fn1")
(save "frominf1G")


; Corollary of Stolzenberg's Principle: 
; If there are either 0s or 1s on an infinite tape then there are 2 distinct positions
; at which the value is the same. 

(set-goal 
 (pf "all f(
       all n((f n=0 -> bot) -> (f n=1 -> bot) -> bot) -> 
       excl n,m(n<m ! f n=f m))"))
(assume "f" "A")
; The excluded middle, as we need it
(assert (pf "(all n excl k(n<=k ! f k=0) -> excl n,m(n<m ! f n=f m)) -> 
             ((all n excl k(n<=k ! f k=0) -> bot) -> excl n,m.(n<m ! f n=f m)) ->
             excl n,m(n<m ! f n=f m)"))
(prop)
;(proof-to-expr-with-formulas (current-proof))
(assume "ExclMiddle")
(use "ExclMiddle")
(use "frominf0G")
(assume "notInf0")
(use "frominf1G")
(use "Inf0orInf1" (pt "f") (pt "n"))
(use "A")
(use "notInf0")
(save "tapeTheorem1")

(proof-to-expr-with-formulas (theorem-name-to-proof "tapeTheorem1"))
(cdp)


; Prepare the proof term for A-Translation
(define class-tape-proof1 
  (theorem-name-to-proof "tapeTheorem1"))
(define class-tape-proof-exp-atr
  (np (atr-expand-theorems class-tape-proof1)))
;(proof-to-expr-with-formulas class-tape-proof-exp-atr)


; A-Translation, followed by program extraction by modified realizability
(define extr_term1 
   (atr-min-excl-proof-to-structured-extracted-term class-tape-proof-exp-atr))
(pp (nt extr_term1)) 
;; [f0]
;;  [if (f0 0=1)
;;    [if (f0 1=1)
;;     (0@1)
;;     [if (f0 1=0) [if (f0 2=1) (0@2) [if (f0 2=0) (1@2) (0@0)]] (0@0)]]
;;    [if (f0 0=0)
;;     [if (f0 1=1)
;;      [if (f0 2=1)
;;       (1@2)
;;       [if (f0 2=0) [if (f0 3=1) (1@3) [if (f0 3=0) (2@3) (0@0)]] (0@0)]]
;;      (0@[if (f0 1=0) 1 0])]
;;     (0@0)]]



; ----------------------------------     TESTS     -----------------------------------

; We generate a list of 2^n infinite sequences starting with all possible variations of n booleans and continuing with 0 and then take its first "n" elements.
(define (generate-seq n)
  (if (= n 0)
      (list (lambda (n) 0))
      (foldr (lambda (x l)
	       (cons (lambda (n) (if (= n 0) 0 (x (- n 1))))
		     (cons (lambda (n) (if (= n 0) 1 (x (- n 1))))
			   l)))
	     '()
	     (generate-seq (- n 1)))))
(define (first f n)
  (if (= n 0)
      '()
       (cons (f 0)
	     (first (lambda (n) (f (+ n 1))) (- n 1)))))


; Test a Scheme program on a list of infinite binary sequences
(define (test-bseq program . l)
  (let ((len (if (null? l) 4 (car l))))
    (map (lambda (seq)
	   (display "Testing on: ")
	   (display (first seq len))
	   (newline)
	   (display "Result: ")
	   (display (program seq))
	   (newline))
	 (generate-seq len)))
  *the-non-printing-object*)

; The Scheme program for the extracted term
(define (program term)
  (lambda (seq)
    (let ((prog (ev (term-to-expr term))))
      (prog seq))))

; Test the scheme program associated to the extracted term
(define (ev x) (eval x (interaction-environment)))
(test-bseq (program extr_term1) 4)



; *********************************   2nd Variant   **********************************

; Lemma 1: We consider the variant in which 0 and 1 are swapped
;    A -> (inf1 -> bot) -> inf0
(set-goal
 (pf "all f(
       all n((f n=0 -> bot) -> (f n=1 -> bot) -> bot) -> 
       excl n all k(n<=k -> f k=1 -> bot) -> all n excl k(n<=k ! f k=0))"))
(assume "f" "A" "not_inf1" "n" "notinf0")
(use "not_inf1")
(assume "m" "notinf1")
(use "A" (pt "m max n"))
(use "notinf0")
(use "NatMaxUB2")
(use "notinf1" (pt "n max m"))
(use "NatMaxUB1")
(save "Inf1orInf0")

; Lemma(s) 2:  unchanged

; Stolzenberg's Corollary needs to be addapted to the change in Lemma 1
(set-goal 
 (pf "all f(
       all n((f n=0 -> bot) -> (f n=1 -> bot) -> bot) -> 
       excl n,m(n<m ! f n=f m))"))
(assume "f" "A")
; For the excluded middle, we need to replace 0 by 1
(assert (pf "(all n excl k(n<=k ! f k=1) -> excl n,m(n<m ! f n=f m)) -> 
             ((all n excl k(n<=k ! f k=1) -> bot) -> excl n,m.(n<m ! f n=f m)) ->
             excl n,m(n<m ! f n=f m)"))
(prop)
(assume "ExclMiddle")
(use "ExclMiddle")
(use "frominf1G") ; use first "frominf1G" and then "frominf0G"
(assume "notInf1")
(use "frominf0G")
(use "Inf1orInf0" (pt "f") (pt "n"))
(use "A")
(use "notInf1")
(save "tapeTheorem2")
;(proof-to-expr-with-formulas (theorem-name-to-proof "tapeTheorem"))


; Prepare the proof term for A-Translation
(define class-tape-proof2 
  (theorem-name-to-proof "tapeTheorem2"))
(define class-tape-proof-exp-atr
  (np (atr-expand-theorems class-tape-proof2)))


; A-Translation, followed by program extraction by modified realizability
(define extr_term2 
   (atr-min-excl-proof-to-structured-extracted-term  
    class-tape-proof-exp-atr))
(pp (nt extr_term2)) 
;; [f0]
;;  [if (f0 0=1)
;;    [if (f0 1=1)
;;     (0@1)
;;     [if (f0 1=0)
;;      [if (f0 2=1)
;;       [if (f0 3=1) (2@3) [if (f0 3=0) (1@3) (0@0)]]
;;       [if (f0 2=0) (1@2) (0@0)]]
;;      (0@0)]]
;;    [if (f0 0=0)
;;     [if (f0 1=1) [if (f0 2=1) (1@2) (0@[if (f0 2=0) 2 0])] (0@[if (f0 1=0) 1 0])]
;;     (0@0)]]



; ----------------------------------     TESTS     -----------------------------------
(test-bseq (program extr_term2) 4)



; *********************************   3rd Variant   **********************************

; We take the symmetrical variant of
;              A:    all n. (fn = 0 -> bot) -> (fn = 1 -> bot) -> bot
; namely
;              A:    all n. (fn = 1 -> bot) -> (fn = 0 -> bot) -> bot


; Lemma 1: the assumption A is as above

(set-goal
 (pf "all f(
       all n((f n=1 -> bot) -> (f n=0 -> bot) -> bot) -> 
       excl n all k(n<=k -> f k=0 -> bot) -> all n excl k(n<=k ! f k=1))"))
(assume "f" "A" "not_inf0" "n" "notinf1")
(use "not_inf0")
(assume "m" "notinf0")
(use "A" (pt "m max n"))
(use "notinf1")
(use "NatMaxUB2")
(use "notinf0" (pt "m max n"))
(use "NatMaxUB1")
(save "Inf0orInf1Asym")

; Lemma(s) 2: unchanged

; Stolzenberg's Corollary
(set-goal 
 (pf "all f(
       all n((f n=1 -> bot) -> (f n=0 -> bot) -> bot) -> 
       excl n,m(n<m ! f n=f m))"))
(assume "f" "A")
(assert (pf "((all n excl k. n <= k ! f k = 0) -> excl n,m. n < m ! f n = f m) ->
              (((all n excl k. n <= k ! f k = 0) -> bot ) -> excl n,m. n < m ! f n = f m) ->
              excl n,m. n < m ! f n = f m"))
(prop)
(assume "ExclMiddle")
(use "ExclMiddle")
(use "frominf0G")
(assume "notInf0")
(use "frominf1G")
(use "Inf0orInf1Asym" (pt "f") (pt "n"))
(use "A")
(use "notInf0")
(save "tapeTheorem3")


; Prepare the proof term for A-Translation
(define class-tape-proof 
  (theorem-name-to-proof "tapeTheorem3"))
(define class-tape-proof-exp-atr
  (np (atr-expand-theorems class-tape-proof)))

; A-Translation, followed by program extraction by modified realizability
(define extr_term3 
   (atr-min-excl-proof-to-structured-extracted-term  
    class-tape-proof-exp-atr))
(pp (nt extr_term3)) 
;; [f0]
;;  [if (f0 0=0)
;;    [if (f0 1=0)
;;     (0@1)
;;     [if (f0 1=1)
;;      [if (f0 2=0)
;;       [if (f0 3=0) (2@3) [if (f0 3=1) (1@3) (0@0)]]
;;       [if (f0 2=1) (1@2) (0@0)]]
;;      (0@0)]]
;;    [if (f0 0=1)
;;     [if (f0 1=0) [if (f0 2=0) (1@2) (0@[if (f0 2=1) 2 0])] (0@[if (f0 1=1) 1 0])]
;;     (0@0)]]


; ----------------------------------     TESTS     -----------------------------------
(test-bseq (program extr_term3) 4)



; *********************************   4th Variant   **********************************

; We leave it as exercise for the use to write the proof for the fourth variant,
; combining the hypothesis in the 3rd Variant with 
;           the change of Lemma 1 from the 2nd Variant




; Remark: We can formulate A as all n f n < 2
; Gain: we don't need explicit negations, because they can be inferred (see below)
; Loss: we lose the flexibility in manipulating the symmetry.
(set-goal
 (pf "all f(all n f n<2 -> all n((f n=0 -> bot) -> (f n=1 -> bot) -> bot))"))
(assume "f" "H")
(assume "n" "not0" "not1") 
(use "NatLtSuccCases" (pt "1") (pt "f n"))
(use "H")
(assume "less1")
(use "NatLtSuccCases" (pt "0") (pt "f n"))
(use "less1")
(ng)
(use "Efq")
(use "not0")
(use "not1")
(save "PosToNeg")

; The proof of tapeTheorem1 is now immediate
(set-goal 
 (pf "all f(all n f n<2 -> excl n,m(n<m ! f n=f m))"))
(assume "f" "A")
(use "tapeTheorem1")
(use "PosToNeg")
(use "A")
; Proof finished.

