; $Id: taitRun.scm 2156 2008-01-25 13:25:12Z schimans $
; 16-6-05
; Running the programs extracted from the proofs in taitPartial.scm

(begin

(load "~/research/nbe/adtType.scm")
(load "~/research/nbe/adtTerm.scm")

; 1. Implement the `administrative' functions
;    |Hat|, |ModL|, |Mod| as well as the
;    realizers of the choice axioms as the identity 

; 2. Replace in the extracte program the binary equality
;    function = by a curried version (occurs in LemmaThree
;    only). The extraction procedure should be changed
;    in order to avoid this complication.

; 3. For simplicitly normalize closed terms only, so
;    a dummy variable environment can be used.


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Types and terms need curried constructors

(define |BaseType| basetype)
(define |ArrowType| (lambda (rho) (lambda (sigma) (arrow rho sigma))))

(define |Var| variable)
(define |Abs| (lambda (x) (lambda (r) (abstraction x r))))
(define |App| (lambda (r) (lambda (s) (application r s))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; D = (N->Term)+(D->D)

(define id (lambda (x) x))

(define |Hat| id)
(define |ModL| id)
(define |Mod| id)
(define |cLemmaSCIotaFold| id)
(define |cAC| id)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; The following programs are literally as extracted from the proofs 
; in taitPartial.scm except that in |cLemmaThree| the expression
; ((= n8) n2) had to be replaced by ((myeq n8) n2) where
; myeq is the curried version of scheme function =.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LemmaOne (reify, reflect)


(define |cLemmaOne|
((typerec (cons |ModL| |cLemmaSCIotaFold|))
 (lambda (rho3)
   (lambda (rho4)
     (lambda (p5)
       (lambda (p6)
         (cons (lambda (a7)
                 (lambda (n8)
                   ((|Abs| n8)
                    (((car p6)
                      ((|Mod| a7) ((cdr p5) (lambda (n9) (|Var| n8)))))
                     (+ n8 1)))))
               (lambda (rs7)
                 (|Hat|
                   (|cAC|
                     (lambda (a9)
                       ((cdr p6)
                        (lambda (n10)
                          ((|App| (rs7 n10))
                           (((car p5) a9) n10))))))))))))))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LemmaThree (eval)

(define myeq (lambda (x) (lambda (y) (equal? x y))))

(define |cLemmaThree|
(((termrec (lambda (n2) (lambda (as3) (as3 n2))))
  (lambda (r2)
    (lambda (r3)
      (lambda (q4)
        (lambda (q5) (lambda (as6) ((|Mod| (q4 as6)) (q5 as6))))))))
 (lambda (n2)
   (lambda (r3)
     (lambda (q4)
       (lambda (as5)
         (|Hat|
           (|cAC|
             (lambda (a7)
               (q4 (lambda (n8) (if ((myeq n8) n2) a7 (as5 n8))))))))))))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SNTheorem (nbe)

(define nbe
(lambda (r0)
  (lambda (rhos1)
    (lambda (rho2)
      ((car (|cLemmaOne| rho2))
       ((|cLemmaThree| r0)
        (lambda (n4)
          ((cdr (|cLemmaOne| (rhos1 n4)))
           (lambda (n5) (|Var| n4)))))))))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Normalization by Evaluation for closed terms

(define dummy-env (lambda (x) '()))

(define (norm r rho) ((((nbe r) dummy-env) rho) 0))

;; Sample runs

; (norm (application (cn 7) (cn 4)) (inttype 2))

; (begin (norm (application (cn 11) (cn 4)) (inttype 2)) (display "norm done"))

;; Comparison with naive normalization

; (recnorm (application (cn 7) (cn 4)))

; (begin (recnorm (application (cn 11) (cn 4))) (display "recnorm done"))

(define (recnorm r)
  (cond ((var? r) r)
	((app? r)
	 (let ((op (recnorm (appop r)))
	       (arg (recnorm (apparg r))))
	   (if (abs? op)
	       (let ((x (absvar op))
		     (s (abskernel op)))
		 (recnorm (substitute s x arg)))
	       (application op arg))))
	((abs? r) (abstraction (absvar r) (recnorm (abskernel r))))))


; nbe with Scheme evaluation for LemmaThree

(define (nbe-scheme r rho)
  (((car (|cLemmaOne| rho))
   (eval r))
   0))

; (nbe-scheme (application (cn 7) (cn 4)) (inttype 2))
; (begin (nbe-scheme (application (cn 11) (cn 4)) (inttype 2)) (display "nbe-scheme done"))
; only slightly faster than norm

)
