;; $Id: norm.scm,v 1.2 2008/01/25 13:30:30 logik Exp $
;; This is a ``toy implementation'' of the special reduction strategie
;; of  [1]


;; TODO/BUGS
;; =========
;; * Handle input/output
;; * define constructor functions for every type...


;; ------------------------------------------ 

;; As normalisation only has to care about applications (abstractions and
;; constants *are* normal), the only thing we require at the interface
;; are applications.
;; There are ``free'' applications and special ones. For free applications
;; the require a test function, a constructor and selection functions
;; for left and right part.
;; For special applications we require a moreover a selection function
;; for the kind of application.

(define (make-free-app left right) (list 'freeapp left right))
(define (free-app? obj)
  (cond ((null? obj) #f)
		((list? obj) (equal? (car obj) 'freeapp))
		(#t #f)))
(define (free-app-left obj) (cadr obj))
(define (free-app-right obj) (caddr obj))

(define (make-app type left right) (list 'app type left right))
(define (app? obj)
  (cond ((null? obj) #f)
		((list? obj) (equal? (car obj) 'app))
		(#t #f)))
(define (app-type obj) (cadr obj))
(define (app-left obj) (caddr obj))
(define (app-right obj) (cadddr obj))


;; ------------------------------------------ 

;; For every type we have to define a function returning the ``canonical
;; reduct'' and, to make the interface look nicer also constructor functions


;; Lists
;; -----
;;; constructor symbols: l-cons  l-nil
;;; elimination term: ('l-elim step initial)

(define (list-can-red left right)
  (cond ((not (equal? (car right) 'l-elim)) (error "Illegal list application"))
		((equal? left 'l-nil) (caddr right)) 
		;;
		;;  If it's not nil, than it has to be something of the form:
		;;  (freeapp (freeapp 'l-cons a) l)
		;;
		;; TODO: we don't test it, we just asume it's correct
		(#t 
		 (lambda-apply
		  (lambda-apply (cadr right)(free-app-right (free-app-left left)))
		  (list-can-red (free-app-right left)
						 right)))))


;; Lambda terms
;; ------------
;;; Sytax ('lambda-abs term)
;;;;; Variables as ('lambda-var n)
;;; elimination term: ('lambda-elim s)

(define (lambda-apply left right)
  (make-app 'lambda left (list 'lambda-elim right)))

(define (lambda-can-red left right)
  (cond
   ((not (equal? (car right) 'lambda-elim))
	(error "Illegal lambda application"))
   (#t (lambda-substitute 1 (cadr left) (cadr right)))))
(define (lambda-substitute n left right)
  (cond ((not (list? left)) left)
		((null? left) left)
		((equal? (car left) 'lambda-abs)
		 (map (lambda (left) (lambda-substitute (+ n 1) left right))
			  left))
		((equal? (car left) 'lambda-var)
		 (if (= (cadr left) n)
			 right
			 left))
		(#t (map (lambda (left) (lambda-substitute n left right)) left))))


;; ------------------------------------------ 

;; Finally we collect all these canonical reductions to a single function

(define (can-red type left right)
  (cond ((equal? type 'list)(list-can-red left right))
		((equal? type 'lambda)(lambda-can-red left right))
		(#t (error "Unknown application"))))


;; ------------------------------------------ 

;; And here is the normalisaiton strategie of [1]

(define (normalize term)
  (cond ((free-app? term) (make-free-app (normalize (free-app-left term))
										  (normalize (free-app-right term))))
		((app? term)(normalize (can-red (app-type term)
										(normalize (app-left term))
										(app-right term))))
		(#t term)
		;; everything that is not an application or a free application]
		;; is normal...
))



;; ------------------------------------------ 
;; examples...

 (define list-1 '(freeapp (freeapp l-cons A) 
						  (freeapp (freeapp l-cons B) l-nil)))


 (define lambda-term-1 '(lambda-abs (lambda-abs (freeapp (lambda-var 2)
														 (lambda-var 1)))))
 (define term-1 (list 'app 'list list-1 (list 'l-elim lambda-term-1 '*nil*)))

;(trace normalize)

 (normalize term-1)


;; ------------------------------------------ 

;; References:
;; ===========
;; [1] Aehlig, Schwichtenberg. ``A syntactical analysis of non-sizeincreasing
;; polynomial time computation'', LICS00
