; normtest.scm, Berger, 14.9.93

; Effizienz der Normalisierung
; ============================

; In dieser Datei werden drei Algorithmen zur Normalisierung
; von einfach getypten Lambda-Termen bez"uglich Effizienz
; verglichen:

; 1. Normalisierung durch Auswertung (Schwichtenberg), wie sie im
;    Beweissystem MINLOG verwendet wird

; 2. Normalisierung durch einen herk"ommlichen rekursiven Algorithmus.

; 3. Eine Variante von 2., die einer Call by name Strategie entspricht.

; Als Testbeispiele wurden aufeinander angewandte Iteratoren gew"ahlt,
; die exponentiell wachsende Reduktionsl"angen haben. 
; Es stellt sich heraus, dass die Normalisierung durch Auswertung
; den anderen beiden Algorithmen deutlich "uberlegen ist.


; Inhalt

; 1 Normalisierung durch Auswertung
; 1.1 Lange Nf
; 1.2 Kurze Nf
; 2 Rekursive Normalisierung
; 2.1 Call by value
; 2.2 Call by name
; 3 Hilfsfunktionen
; 4 Beispielsmaterial
; 5 Laufzeiten

(define (ev x)
  (eval x (the-environment)))


; 1. Normalisierung durch Auswertung (Schwichtenberg)
; ===================================================

; Normalisierungsalgorithmen extrahiert aus dem Tait/Troelstra
; Beweis der starken Normalisierung 

; die folgenden Versionen funktionieren nur fuer geschlossene Terme

; 1.1 Lange Normalform

(define (norm r rho)
  (((phi rho) (ev r)) 0))

(define (phi type)
  (if (ground-type? type)
      (lambda (u) u)
           (let ((psi-rho (psi (arg-type type)))
                 (phi-sigma (phi (val-type type))))
             (lambda (u)
               (lambda (k)
                 (let ((xk (mvar k)))
                   (nabst xk ((phi-sigma (u (psi-rho (lambda (l) xk)))) 
                             (+ k 1)))))))))

(define (psi type)
  (if (ground-type? type)
      (lambda (g) g)
      (let ((phi-rho (phi (arg-type type)))
            (psi-sigma (psi (val-type type))))
          (lambda (g)
             (lambda (v)
                (psi-sigma
                 (lambda (k)
                   (app (g k) ((phi-rho v) k)))))))))


; 1.2 Kurze (eta) Normalform. 

; Nach (set! nabst cabst) berechnet (norm r)
; die eta Normalform von r. Zur"uck mit (set! nabst abst)

(define (cabst x r)
  (if (application? r)
      (let ((s (operator r))
            (y (argument r)))
        (if (and (equal? x y) (not (free? x s)))
            s
            (list 'lambda (list x) r)))
      (list 'lambda (list x) r)))



; 2 Rekursive (gewoehnliche Normalisierung)
; =========================================

; 2.1 Call by value

; Vollstaendige Normalisierung, also in etwa call by value

(define (recnorm r)
  (cond ((variable? r) r)
	((application? r)
	 (let ((op (recnorm (operator r)))
	       (arg (recnorm (argument r))))
	   (if (abstraction? op)
	       (let ((x (abstvar op))
		     (s (kernel op)))
		 (recnorm (substitute s x arg)))
	       (app op arg))))
	((abstraction? r) (abst (abstvar r) (recnorm (kernel r))))))


; 2.2 Call by name

; Head Normalform, also in etwa call by name. Nur geschlossene Terme vom
; Grundtyp werden vollstaendig normalisiert.

(define (hnorm r)
  (cond ((variable? r) r)
	((application? r)
	 (let ((op (hnorm (operator r)))
	       (arg (argument r)))
	   (if (abstraction? op)
	       (let ((x (abstvar op))
		     (s (kernel op)))
		 (hnorm (substitute s x arg)))
	       (app op (hnorm arg)))))
	((abstraction? r) r)))



; 3 Hilfsfunktionen
; =================

(define (make-var x k)
  (string->symbol (string-append (symbol->string x) (number->string k))))
(define (mvar k)
  (string->symbol (string-append "X" (number->string k))))
(define (abst x r)
  (list 'lambda (list x) r))
(define app list)

(define nabst abst)

(define ground-type? symbol?)
(define arg-type car)
(define val-type cadr)
(define arrow list)

(define operator car)
(define argument cadr)

(define abstvar caadr)
(define kernel caddr)

(define variable? symbol?)
(define (application? r) (and (list? r) (equal? (length r) 2)))
(define (abstraction? r)
  (and (list? r) (equal? (length r) 3) (equal? (car r) 'lambda)))



(define (fvar r)
  (cond ((variable? r) (list r))
        ((application? r) (append (fvar (operator r))
                                  (fvar (argument r))))
        ((abstraction? r) (erase (abstvar r) (fvar (kernel r))))))

(define (bvar r)
  (cond ((variable? r) '())
        ((application? r) (append (bvar (operator r))
                                  (bvar (argument r))))
        ((abstraction? r) (cons (abstvar r) (bvar (kernel r))))))

(define (free? x r) (memq x (fvar r)))

(define (erase x l)
  (if (null? l)
      '()
      (if (equal? x (car l))
          (erase x (cdr l))
          (cons (car l) (erase x (cdr l))))))

(define (replace s x r)
  (cond ((variable? s) (if (equal? s x)
			   r
			   s))
	((application? s) (app (replace (operator s) x r)
			       (replace (argument s) x r)))
	((abstraction? s)
         (let ((y (abstvar s))
	       (t (kernel s)))
	   (if (equal? x y)
	       s
	       (abst y (replace t x r)))))))
	   
	    
(define (substitute s x r)
  (cond ((variable? s) (if (equal? s x)
			   r
			   s))
	((application? s) (app (substitute (operator s) x r)
			       (substitute (argument s) x r)))
	((abstraction? s)
         (let ((y (abstvar s))
	       (t (kernel s)))
	   (if (equal? x y)
	       s
	       (if (not (member y (fvar r)))
	           (abst y (substitute t x r))
	           (let* ((new-y (fresh y (append (bvar t) (fvar r))))
		          (new-t (replace t y new-y)))
	              (abst new-y (substitute new-t x r)))))))))
	    
					   
(define (fresh y l)  ; berechnet ein yk, das nicht in der Liste l vorkommt,
  (do ((k 0 (+ k 1)) ; mit minimalem k
       (yk (make-var y 0) (make-var y k)))
      ((not (member yk l)) yk)))
      

; 4 Beispielmaterial

(define (int-type n)
  (if (zero? n)
      'nat
      (let ((rho (int-type (- n 1))))
        (list rho rho))))


(define (it n)
  (letrec ((iterator-kernel (lambda (n)
                               (if (zero? n)
                                   'x
                                   (app 'f (iterator-kernel (- n 1)))))))
     (abst 'f (abst 'x (iterator-kernel n)))))

(define (rnm n m)
  (app (app (it n) (it m)) (abst 'x 'x)))

(define (rnmx n m) (app (rnm n m) 'x))



; 5 Laufzeit
; ==========

; rnm := (rnm n m)

;      norm  recnorm        hnorm (hier rnmx, da sonst keine Vollst. Norm.)

;  r44  1s    3s             20s   
;  r55  2s   20s             7 min
;  r56  3s    2min
;  r66  4s   out of memory
;  r76 14s
;  r86 85s
;  r77 35s
;  r87  4min
;  r88 32min