; $Id: fibconstr.scm,v 1.11 2008/01/25 13:30:23 logik Exp $

; Extraction of the Fibonacci algorithm from a constructive proof

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

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

(add-var-name "l" (py "nat"))
(add-var-name "p" (py "nat@@nat"))

; The graph of the Fibonacci function:

(add-predconst-name "G" (make-arity (make-alg "nat") (make-alg "nat")))

; "Fib"
(set-goal (pf "G 0 0 -> G 1 1 ->
               (all n,k,l.G n k -> G (n+1) l -> G (n+2) (k+l)) ->
               all n ex k,l. G n k & G (n+1) l"))
(assume "Init-Zero" "Init-One" "Step")
(ind)

; Base
(ex-intro (pt "0"))
(ex-intro (pt "1"))
(prop)

; Step
(assume "n" "IH")
(by-assume-with "IH" "k" "IH-k")
(by-assume-with "IH-k" "l" "IH-l")
(ex-intro (pt "l"))
(ex-intro (pt "k+l"))
(search)
(save "Fib")

(define Fib-neterm
  (nt (proof-to-extracted-term (theorem-name-to-proof "Fib"))))

(term-to-string Fib-neterm)
; "(Rec nat=>nat@@nat)(0@1)([n1,p2]right p2@left p2+right p2)"

(term-to-string (nt (make-term-in-app-form Fib-neterm (pt "0")))) ;"0@1"
(term-to-string (nt (make-term-in-app-form Fib-neterm (pt "1")))) ;"1@1"
(term-to-string (nt (make-term-in-app-form Fib-neterm (pt "2")))) ;"1@2"
(term-to-string (nt (make-term-in-app-form Fib-neterm (pt "3")))) ;"2@3"
(term-to-string (nt (make-term-in-app-form Fib-neterm (pt "5")))) ;"5@8"
(term-to-string (nt (make-term-in-app-form Fib-neterm (pt "9")))) ;"34@55"
(term-to-string (nt (make-term-in-app-form Fib-neterm (pt "13")))) ;"233@377"

(term-to-expr Fib-neterm)

; ((natrec (cons 0 1))
;  (lambda (n1)
;    (lambda (p2) (cons (cdr p2) (+ (car p2) (cdr p2))))))

(define (natrec init) 
  (lambda (step)
    (lambda (n)
      (if (= 0 n)
	  init
	  ((step n) (((natrec init) step) (- n 1)))))))
		  
(time (cdr ((ev (term-to-expr Fib-neterm)) 3000)))

;Local Variables:
;mode: scheme
;End:
