; ;  $Id: fib-ATR.scm 2156 2008-01-25 13:25:12Z schimans $
; ;  IN FACT - a slight adaptation due to M.-D. Hernest
; ;  Extraction of the Fibonacci algorithm from a semi-classical proof
; ;  based on the 2002 paper by Berger, Buchholz and Schwichtenberg
; ;  The so-called "BBS Refined A-Translation", a refinement of the
; ; 1978 so-called "A-Translation" due to Friedman/Dragalin, originally 
; ; introduced to establish closure of intuitionistic theories T_i under
; ; the so-called "Markov's Rule": T_i |- ExCl y P(a,y) => T_i |- Ex y P(a,y)

(load "~/minlog/init.scm")
(set! COMMENT-FLAG #f)
(libload "nat.scm")
(add-var-name "l" (py "nat"))
(add-var-name "f" (py "nat=>nat=>nat"))
(add-var-name "H" (py "(nat=>nat=>nat)=>nat"))
; ; We now introduce as predicate constant, The Graph of the Fibonacci function:
(add-predconst-name "G" (make-arity (make-alg "nat") (make-alg "nat")))

(set-goal (pf "all n. G 0 0 -> G 1 1 -> 
                                  (allnc n,k,l. G n k -> G (n+1) l -> G (n+2) (k+l)) -> 
                                       excl k. G n k"))
(assume "n" "Init-Zero" "Init-One" "Step")
(cut (pf "all n excl k,l.G n k ! G (n+1) l"))
(search)
(ind)
(search)
(assume "n1" 4 5)
(search 1)

(mload "../diatup/Examples/fibonacci/newatr.scm")
(define iproof (atr-min-excl-proof-to-intuit-ex-proof (current-proof)))
(nc-violations iproof)
(define et  (proof-to-extracted-term iproof))
(string-length (term-to-string et))
(define net  (nt et))
(pp  net)
;; (type-to-string (term-to-type (pt "(Rec nat=>(nat=>nat=>nat)=>nat)")))
; ; [n] 
; ;  (Rec nat=>(nat=>nat=>nat)=>nat)
; ;     ([f] f 0 1)
; ;     ([m, H, g] H ([p,q] H ([k,l] g l (k + l))))
; ;      n ([k,l] k)

(pp (time (nt (make-term-in-app-form net (pt "12"))))) ; "144"
(pp (time (nt (make-term-in-app-form net (pt "15"))))) ; "610"
(pp (time (nt (make-term-in-app-form net (pt "20"))))) ; "6765" in 1 sec

(define (fibo n)
  (fibo1 n (lambda (k l) k)))

(define (fibo1 n1 f)
  (if (= n1 0)
      (f 1 1)
      (fibo1 (- n1 1) (lambda (k l) (f l (+ k l)))))) 

(time (fibo 80000))

;;; END OF FILE

