; $Id: pigeonhole.scm,v 1.2 2009-12-29 23:05:25 logik Exp $

; Problem:
;       Given: An infinite tape containing at most r different colors
;              i.e.,    all n. fn < r
;       Show: On every such tape there are n cells with the same content,
;              i.e.,    all n. excl l, m. Lh l = n ! 
;                        (all k. Succ k < n -> (Succ k thof l) < (k thof l)) !
;                        (all k. k < n -> f (k thof l) = m)

; Lemma (Infinite Pigeonhole Principle):
; If a sequence contains at most r different colors, then there is a color appearing infinitely often in the sequence.
; i.e.,       all r, f. all n (f n < r) -> 
;                       excl m. m < r ! all n excl k. n <= k ! f k = m

(set! COMMENT-FLAG #f)
(libload "nat.scm")
(libload "list.scm")
(set! COMMENT-FLAG #t)
; load the needed libraries
 
(add-var-name "f" (py "nat=>nat")) 
; the infinite coloured sequence
(add-var-name "l" (py "list nat"))  
; a list of lenght n consisting of the indexes where the sequence has the same value
(add-var-name "r" (py "nat")) 
; the number of colours

; The element at the position (length of list) is last element in the list
(set-goal (pf "Equal (Lh (list alpha) thof (list alpha):+:alpha:) alpha"))
(ind) ; on (list alpha)
; Base case
(ng)
(assume "alpha")
(use "Eq-Refl")
; Step case
(assume "alpha" "list alpha" "IHl")
(assume "alpha_1")
(ng)
(use "IHl")
; Proof finished.

(add-rewrite-rule (pt "(Lh (list alpha)) thof ((list alpha):+:alpha:)") 
		  (pt "alpha"))


; Infinite Pigeonhole Principle
(set-goal
 (pf "all r,f(
       all n((f n<r -> bot) -> bot) -> 
       excl m(m<r ! all n excl k(n<=k ! f k=m)))"))

(ind) ; on the number of colors

; Base case. 
(assume "f" "H" "negG") 
(use "H" (pt "0")) 
(ng)
(use "Efq")

; Induction step
(assume "r" "IH" "f" "StepH" "negG")

(use "negG" (pt "r")) 
(prop)
(assume "n" "negfkr")
(use "IH" (pt "[m] f (n max m)")) 
(ng)
(assume "n1" "negfLer")
(use "StepH" (pt "n max n1"))
(assume "fLtSk")
(use "NatLeCases" (pt "r") (pt "f (n max n1)"))
(use "NatLtSuccToLe") 
(use "fLtSk")
(use "negfLer") 
(use "negfkr") 
(use "NatMaxUB1")
(ng) 
(assume "m" "mr" "negH")
(use "negG" (pt "m"))
(use "NatLtTrans" (pt "r")) 
(use "mr") 
(use "Truth-Axiom")
(assume "n1" "nG")
(use "negH" (pt "n1"))
(assume "k" "n1k" "fm") 
(use "nG" (pt "n max k")) 
(use "NatLeTrans" (pt "k")) 
(use "n1k")
(use "NatMaxUB2")
(use "fm")
(save "IPH")


; If r occurs infinitely many often, we select a given number of occcurences
; Inf(r) -> G 
(set-goal 
 (pf "all f,r(
       all n excl k(n<=k ! f k=r) -> 
       all n 
       excl l(
         Lh l=n ! 
         (all m(Succ m<n -> (Succ m thof l)<(m thof l)) ! 
          all m(m<n -> f(m thof l)=r))))"))
; Note: we have length Succ n as a technical detail, in order to avoid having too many conditions (guards) on m

(assume "f" "r" "inf(r)")

(cases) ; on n

; Case n=0
(assume "negG")
(use "negG" (pt "(Nil nat)"))
(use "Truth-Axiom")
(assume "m") 
(ng) 
(use "Efq")
(assume "m") 
(ng) 
(use "Efq")

; Case Succ n
(ind) ; on n, n>0

; Base case: first elem. in the list
(assume "negG") 
(use "inf(r)" (pt "0")) (assume "k" "T" "fkr")
(use "negG" (pt "k:"))
(use "Truth-Axiom")
(assume "m") 
(ng) 
(use "Efq") 
(assume "m" "m<1") 
(use "NatLtSuccCases" (pt "0") (pt "m")) 
(use "m<1") 
(ng) 
(use "Efq") 
(assume "m0") 
(simp-with "m0") 
(ng) 
(use "fkr")

; Step
(assume "n" "IH" "negG") 
(use "IH") 
(ng)

(cases) ; on l: empty or not

; Case empty list. Cannot be, 0<n
(ng) 
(use "Efq")

; Step: nat:+:l
(assume "nat1" "l" "Lhl" "H1" "H2")
(use "inf(r)" (pt "Succ nat1")) 
(assume "nat2" "H3" "fr")
(use "negG" (pt "nat2::nat1::l"))
(use "Lhl")
(cases)  ; on m
; m=0
(ng) 
(assume "T")
(use "NatSuccLeToLt") 
(use "H3")
; Succ m
(assume "m" "m<n") 
(use "H1") 
(use "m<n")

(cases)  ; on m
(assume "T") 
(use "fr")
(assume "m" "m<Sn") 
(use "H2") 
(use "m<Sn")
(save "Inf(r)Gn")


(add-var-name "q" (py "nat")) ; q < r a colour
; Corollary of IPH, using "Inf(r)Gn"
(set-goal 
 (pf " all f,r,n(
       all m((f m<r -> bot) -> bot) -> 
       excl l,q(Lh l=n ! all m(m<n -> f(m thof l)=q)))"))

(assume "f" "r" "n" "A" "negG") ; r colors, n the length of the subsequence

(use "IPH" (pt "r") (pt "f"))
(use "A")
(assume "q" "qr" "infb")
(use "Inf(r)Gn" (pt "f") (pt "q") (pt "n")) 
(use "infb")
(assume "l" "ln" "fnT" "nC") 
(use "negG" (pt "l") (pt "q"))
(use "ln") 
(use "nC") 
(save "IPHCor")

;------------------------------
; A-translation
;------------------------------

;(cdp)
(define class-tape-proof 
  (np (atr-expand-theorems (theorem-name-to-proof "IPHCor"))))
(define class-tape-proof 
  (np (expand-thm class-tape-proof "NatLeCases")))
;(cdp class-tape-proof)
(define extr_term 
   (atr-min-excl-proof-to-structured-extracted-term  
      class-tape-proof))
; var names for types
; nt together with np ?
(pp (nt
     (proof-to-extracted-term
      (np 
       (expand-theorems (theorem-name-to-proof "IPH"))))))

(pp (nt
     (proof-to-extracted-term
      (np
       (expand-theorems (theorem-name-to-proof "Inf(r)Gn"))))))

(pp (nt
     (proof-to-extracted-term
      (np
       (theorem-name-to-proof "IPHCor")))))

(pp extr_term) ; 86 lines
(define nterm (nt extr_term))
(pp nterm) ;50


(add-var-name "x" (py "(list nat=>list nat@@nat)=>list nat@@nat"))
(add-var-name "y" (py "list nat=>list nat@@nat"))
(add-var-name "z" (py "nat=>(nat=>(nat=>list nat@@nat)=>list nat@@nat)=>list nat@@nat"))
(add-var-name "t" (py "nat=>list nat@@nat=>list nat@@nat"))
(add-var-name "u" (py "list nat@@nat"))
(add-var-name "v" (py "nat=>list nat@@nat=>list nat@@nat=>list nat@@nat"))
(add-var-name "w" (py "(nat=>nat)=>(nat=>list nat@@nat=>list nat@@nat)=>(nat=>(nat=>(nat=>list nat@@nat)=>list nat@@nat)=>list nat@@nat)=>list nat@@nat"))

;------------------------------
; Dialectica
;------------------------------

; personal rewrite rules for simplifying Dialectica
(add-rewrite-rule (pt "NegConst (NegConst boole^)") 
		  (pt "boole^"))
(add-rewrite-rule (pt "ImpConst boole^ False") 
		  (pt "NegConst boole^"))

(set! ETSD-LET-ENABLED #t) 
(define extr_term-d
  (proof-to-extracted-d-term class-tape-proof))
(pp (term-to-type extr_term-d))

(pp extr_term-d)
; 663 lines

(define nterm-d (nt extr_term-d))
(pp nterm-d)
; 367 lines

;------------------------------
; Modular Dialectica
;------------------------------

(set! ETSD-LET-ENABLED #t)
(define extr_term-iph
  (proof-to-extracted-d-term (np
			      (expand-theorems
			       (theorem-name-to-proof "IPH")))))
(add-program-constant "dIPH" (term-to-type extr_term-iph))

(pp extr_term-iph)
; 161 lines

(define nterm-iph (nt extr_term-iph))
(pp nterm-iph)
; 117 lines

(define (animate-iph)
  (add-computation-rule "dIPH k f" (nt
				    (mk-term-in-app-form
				     extr_term-iph (pt "k") (pt "f")))))
(define (deanimate-iph)
 (remove-computation-rules-for (pt "dIPH k f")))

(set! ETSD-LET-ENABLED #t)
(define extr_term-g
  (proof-to-extracted-d-term (np
			      (expand-theorems
			       (theorem-name-to-proof "Inf(r)Gn")))))

(add-program-constant "dInfYyryYGn" (term-to-type extr_term-g))

(pp extr_term-g)
; 337 lines

(define nterm-g (nt extr_term-g))
(pp nterm-g)
; 77 lines

(define (animate-goal)
  (add-computation-rule "dInfYyryYGn f k" (nt
					   (mk-term-in-app-form
					    extr_term-g
					    (pt "f") (pt "k")))))
(define (deanimate-goal)
  (remove-computation-rules-for (pt "dInfYyryYGn f k")))

(set! ETSD-LET-ENABLED #t)
(define extr_term-dm
  (proof-to-extracted-d-term (theorem-name-to-proof "IPHCorr")))

(pp extr_term-dm)
; 29 lines

(define nterm-dm (nt extr_term-dm))
(pp nterm-dm)
; 28 lines

;------------------------------
; Tests
;------------------------------

; generate a list of 2^n infinite sequences
; starting with all possible variations of n booleans
; and continuing with #f
(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)))))

; return a list of (f 0),(f 1),...,(f n-1)
(define (first f n)
  (if (= n 0)
      '()
       (cons (f 0)
	     (first (lambda (n) (f (+ n 1))) (- n 1)))))

(for-each (lambda (x) (display (first x 7)) (newline)) (generate-seq 4))

; 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*)

; Definitions needed for term-to-expr

(define (|ListAppend| l1)
  (lambda (l2)
    (append l1 l2)))

(define (|listrec| l)
  (lambda (base)
    (lambda (step)
      (if (null? l)
	  base
	  (((step (car l)) (cdr l))
	   (((|listrec| (cdr l)) base) step))))))

(define (|NatMax| n1)
  (lambda (n2)
    (max n1 n2)))

(define (|ListProj| n)
  (lambda (l)
    (if (< n (length l))
	(list-ref l n)
	0)))

; prepare a Scheme program for A-translation
(define (prepare-a term k n)
  (lambda (seq)
    (let ((prog (ev (term-to-expr term))))
      (((prog seq) k) n))))

; prepare a Scheme program for Dialectica
; (dummy argument (lambda (l) (cons 0 0)) needed)
(define (prepare-d term k n)
  (let ((prog (ev (term-to-expr term))))
    (lambda (seq)
      ((car (((prog seq) k) n)) (lambda (l) (cons 0 0))))))

; test A-translation
(define (ev x) (eval x (interaction-environment)))
(test-bseq (prepare-a extr_term 2 2))

;(cdp class-tape-proof)
(define extr_term 
   (atr-min-excl-proof-to-structured-extracted-term  
      class-tape-proof))
(test-bseq (prepare-a extr_term 2 2))

; test Dialectica
(define prog-d (prepare-d extr_term-d 2 2))
(test-bseq prog-d)

; animate subprograms for modular Dialectica
(define |dInfYyryYGn| (ev (term-to-expr extr_term-g)))
(define |dIPH|  (ev (term-to-expr extr_term-iph)))

; test modular Dialectica
(define prog-dm (prepare-d extr_term-dm 2 2))
(test-bseq prog-dm)
